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: