mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-18 20:31:00 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR ada/5909 (Ada has no test suite.)

Browse Source 
PR ada/5909:
Import ACATS 2.5 for GCC Ada test suite.

From-SVN: r72977
This commit is contained in:
Arnaud Charlet 2003-10-27 12:29:00 +01:00
parent 57b4edef7d
commit 8d39e92bc3
2596 changed files with 438836 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/testsuite/ada/acats/elabd.lst Normal file
View File

@ -0,0 +1,5 @@
c731001
c854002
ca11018
ca11019
ca5006a

2
gcc/testsuite/ada/acats/norun.lst Normal file
View File

@ -0,0 +1,2 @@
templat
# Tests must be sorted in alphabetical order

16
gcc/testsuite/ada/acats/overflow.lst Normal file
View File

@ -0,0 +1,16 @@
c45632a
c45632b
c45632c
c45504a
c45504b
c45504c
c45613a
c45613b
c45613c
c45304a
c45304b
c45304c
c46014a
c460008
c460011
c4a012b

35
gcc/testsuite/ada/acats/run_acats Executable file
View File

@ -0,0 +1,35 @@
#!/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_gnatmake=`which gnatmake`
host_gcc=`which gcc`
ROOT=`pwd`
BASE=`cd $ROOT/../../..; pwd`
PATH=$BASE:$ROOT:$PATH
ADA_INCLUDE_PATH=$BASE/ada/rts
ADA_OBJECTS_PATH=$ADA_INCLUDE_PATH
export PATH ADA_INCLUDE_PATH ADA_OBJECTS_PATH
echo '#!/bin/sh' > gcc
echo exec $BASE/xgcc -B$BASE/ '"$@"' >> gcc
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
echo '#!/bin/sh' > host_gcc
echo PATH=`dirname $host_gcc`:'$PATH' >> host_gcc
echo export PATH >> host_gcc
echo exec $host_gcc '"$@"' >> host_gcc
chmod +x gcc host_gnatmake host_gcc
exec $testdir/run_all.sh "$@"

231
gcc/testsuite/ada/acats/run_all.sh Executable file
View File

@ -0,0 +1,231 @@
#!/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="-q -gnatws"
target_run () {
$*
}
# End of customization section.
dir=`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_gnatmake () {
gnatmake $gnatflags $gccflags $* -largs $EXTERNAL_OBJECTS
}
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.
echo ""
echo ==== CONFIGURATION ==== `date`
type gcc
gcc -v 2>&1
echo host=`host_gcc -dumpmachine`
echo target=`gcc -dumpmachine`
type gnatmake
gnatls -v
echo acats src=$testdir
echo acats obj=$dir
echo ""
echo ==== SUPPORT ==== `date`
printf "Generating support files..."
rm -rf $dir/support
mkdir -p $dir/support
cd $dir/support
cp $testdir/support/{*.ada,*.a,*.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.$$
rm -rf $dir/tests.$$ &
mkdir -p $dir/run
cp -pr $testdir/tests $dir/
for i in $dir/support/{*.ada,*.a}; do
gnatchop $i > /dev/null 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
if [ $? -ne 0 ]; then
echo "**** Failed to compile macrosub"
exit 1
fi
./macrosub > macrosub.out 2>&1
host_gcc -c cd300051.c
host_gnatmake -q -gnatws widechr
if [ $? -ne 0 ]; then
echo "**** Failed to compile widechr"
exit 1
fi
./widechr > widechr.out 2>&1
rm -f $dir/support/{macrosub,widechr,*.ali,*.o}
echo " done."
# From here, all compilations will be made by the target compiler
printf "Compiling support files..."
target_gcc -c *.c
if [ $? -ne 0 ]; then
echo "**** Failed to compile C code"
exit 1
fi
gnatchop *.adt > gnatchop.out 2>&1
target_gnatmake -c -gnato -gnatE *.ads > /dev/null 2>&1
target_gnatmake -c -gnato -gnatE *.adb
echo " done."
echo ""
echo ==== TESTS ==== `date`
if [ $# -eq 0 ]; then
chapters=`cd $dir/tests; echo *`
else
chapters=$*
fi
glob_countn=0
glob_countok=0
for chapter in $chapters; do
echo ==== CHAPTER $chapter ==== `date`
if [ ! -d $dir/tests/$chapter ]; then
echo "**** CHAPTER $chapter does not exist, skipping."
echo ""
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`
countok=0
counti=0
for i in `cat $dir/tests/$chapter/${chapter}.lst`; do
counti=`expr $counti + 1`
echo ""
echo ""
echo ==== $i === `date` === $counti / $countn
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
mkdir $dir/tests/$chapter/$i
cd $dir/tests/$chapter/$i
gnatchop -c -w `ls $dir/tests/${chapter}/${i}*.{a,ada,adt,am,dep} 2> /dev/null` > /dev/null 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"
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
echo "**** SCRIPT-MAIN FAILED $i"
failed="${failed}${i} "
clean_dir
continue
fi
target_gnatmake $extraflags -I$dir/support $main
if [ $? -ne 0 ]; then
echo "**** SCRIPT-BUILD FAILED $i"
failed="${failed}${i} "
clean_dir
continue
fi
echo "RUN $binmain"
cd $dir/run
target_run $dir/tests/$chapter/$i/$binmain | tee $dir/tests/$chapter/$i/${i}.log 2>&1
cd $dir/tests/$chapter/$i
egrep -e '(==== |\+\+\+\+ |\!\!\!\! )' ${i}.log > /dev/null 2>&1
if [ $? -ne 0 ]; then
echo "**** SCRIPT-RUN FAILED $i"
failed="${failed}${i} "
else
countok=`expr $countok + 1`
fi
clean_dir
done
echo ""
echo ==== CHAPTER $chapter results: $countok / $countn
echo ""
glob_countok=`expr $glob_countok + $countok`
glob_countn=`expr $glob_countn + $countn`
done
echo ==== ACATS results: $glob_countok / $glob_countn
if [ $glob_countok -ne $glob_countn ]; then
echo "**** FAILURES: $failed"
fi
echo "#### ACATS done. #### `date`"
exit 0

4308
gcc/testsuite/ada/acats/support/acats25.lst Normal file
View File

File diff suppressed because it is too large Load Diff

197
gcc/testsuite/ada/acats/support/checkfil.ada Normal file
View File

@ -0,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;

65
gcc/testsuite/ada/acats/support/enumchek.ada Normal file
View File

@ -0,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;

149
gcc/testsuite/ada/acats/support/f340a000.a Normal file
View File

@ -0,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;

75
gcc/testsuite/ada/acats/support/f340a001.a Normal file
View File

@ -0,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;

216
gcc/testsuite/ada/acats/support/f341a00.a Normal file
View File

@ -0,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;

94
gcc/testsuite/ada/acats/support/f390a00.a Normal file
View File

@ -0,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;

200
gcc/testsuite/ada/acats/support/f392a00.a Normal file
View File

@ -0,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;

267
gcc/testsuite/ada/acats/support/f392c00.a Normal file
View File

@ -0,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;

103
gcc/testsuite/ada/acats/support/f392d00.a Normal file
View File

@ -0,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;

245
gcc/testsuite/ada/acats/support/f393a00.a Normal file
View File

@ -0,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;

101
gcc/testsuite/ada/acats/support/f393b00.a Normal file
View File

@ -0,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;

81
gcc/testsuite/ada/acats/support/f3a2a00.a Normal file
View File

@ -0,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;

90
gcc/testsuite/ada/acats/support/f460a00.a Normal file
View File

@ -0,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;

107
gcc/testsuite/ada/acats/support/f730a000.a Normal file
View File

@ -0,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;

76
gcc/testsuite/ada/acats/support/f730a001.a Normal file
View File

@ -0,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;

66
gcc/testsuite/ada/acats/support/f731a00.a Normal file
View File

@ -0,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;

97
gcc/testsuite/ada/acats/support/f940a00.a Normal file
View File

@ -0,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

134
gcc/testsuite/ada/acats/support/f954a00.a Normal file
View File

@ -0,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;

73
gcc/testsuite/ada/acats/support/fa11a00.a Normal file
View File

@ -0,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

110
gcc/testsuite/ada/acats/support/fa11b00.a Normal file
View File

@ -0,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

112
gcc/testsuite/ada/acats/support/fa11c00.a Normal file
View File

@ -0,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

78
gcc/testsuite/ada/acats/support/fa11d00.a Normal file
View File

@ -0,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

171
gcc/testsuite/ada/acats/support/fa13a00.a Normal file
View File

@ -0,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;

106
gcc/testsuite/ada/acats/support/fa13b00.a Normal file
View File

@ -0,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;

127
gcc/testsuite/ada/acats/support/fa21a00.a Normal file
View File

@ -0,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;

101
gcc/testsuite/ada/acats/support/fb20a00.a Normal file
View File

@ -0,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;

81
gcc/testsuite/ada/acats/support/fb40a00.a Normal file
View File

@ -0,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;

92
gcc/testsuite/ada/acats/support/fc50a00.a Normal file
View File

@ -0,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;

99
gcc/testsuite/ada/acats/support/fc51a00.a Normal file
View File

@ -0,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;

62
gcc/testsuite/ada/acats/support/fc51b00.a Normal file
View File

@ -0,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;

112
gcc/testsuite/ada/acats/support/fc51c00.a Normal file
View File

@ -0,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;

82
gcc/testsuite/ada/acats/support/fc51d00.a Normal file
View File

@ -0,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;

132
gcc/testsuite/ada/acats/support/fc54a00.a Normal file
View File

@ -0,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;

117
gcc/testsuite/ada/acats/support/fc70a00.a Normal file
View File

@ -0,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;

133
gcc/testsuite/ada/acats/support/fc70b00.a Normal file
View File

@ -0,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;

100
gcc/testsuite/ada/acats/support/fc70c00.a Normal file
View File

@ -0,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;

50
gcc/testsuite/ada/acats/support/fcndecl.ada Normal file
View File

@ -0,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;

84
gcc/testsuite/ada/acats/support/fd72a00.a Normal file
View File

@ -0,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;

144
gcc/testsuite/ada/acats/support/fdb0a00.a Normal file
View File

@ -0,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;

149
gcc/testsuite/ada/acats/support/fdd2a00.a Normal file
View File

@ -0,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;

121
gcc/testsuite/ada/acats/support/fxa5a00.a Normal file
View File

@ -0,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;

144
gcc/testsuite/ada/acats/support/fxaca00.a Normal file
View File

@ -0,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;

107
gcc/testsuite/ada/acats/support/fxacb00.a Normal file
View File

@ -0,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;

115
gcc/testsuite/ada/acats/support/fxacc00.a Normal file
View File

@ -0,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;

162
gcc/testsuite/ada/acats/support/fxc6a00.a Normal file
View File

@ -0,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;

90
gcc/testsuite/ada/acats/support/fxe2a00.a Normal file
View File

@ -0,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;
--====================================================================

96
gcc/testsuite/ada/acats/support/fxf2a00.a Normal file
View File

@ -0,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;

330
gcc/testsuite/ada/acats/support/fxf3a00.a Normal file
View File

@ -0,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'("<CR"),
7 => new String'("<db"),
8 => new String'("<<BBBcr"),
9 => new String'("<<__DB"),
10 => new String'("<<<++++_++-"),
11 => new String'("-999.99>"),
12 => new String'("+++9.99+"),
13 => new String'("++++>>"),
14 => new String'("->"),
15 => new String'("++9-"),
16 => new String'("---999999->"),
17 => new String'("+++-"),
18 => new String'("+++_+++_+.--"),
19 => new String'("--B.BB+>"),
20 => new String'("$$#$"),
21 => new String'("#B$$$$"),
22 => new String'("**Z"),
23 => new String'("ZZZzzz*"),
24 => new String'("9.99DB(2)"),
25 => new String'(A_Picture_String_Too_Long)
);
Edited_Output : Edited_Output_Results_Array_Type
(1..Number_Of_Edited_Output_Strings) :=
-- The following 10 edited output strings result from the first 10
-- valid strings when used with the first 10 Data_With_2DP numeric
-- values.
( 1 => new String'(" $***123,456.78"),
2 => new String'(" $***123,456.78"),
3 => new String'(" "),
4 => new String'(" $.20"),
5 => new String'("+ 123,456.00"),
6 => new String'(" -123,457"),
7 => new String'(" $123,456.78"),
8 => new String'("( $12.34)"),
9 => new String'(" $1.23"),
10 => new String'("$12.34"),
-- The following 10 edited output strings correspond to the 10 foreign
-- currency picture strings (the currency string is supplied at the
-- time of the call to Editing.Image or Editing.Put), when used in
-- conjunction with Data_With_2DP items 11-20
11 => new String'(" FF***123.456,78"),
12 => new String'(" FF***123.456,78"),
13 => new String'(" FF 32,10 "),
14 => new String'("( FF5.432,10)"),
15 => new String'(" (1,234.57DM )"),
16 => new String'(" DM123,456.78"),
17 => new String'("DM 12.34"),
18 => new String'(" DM12.34"),
19 => new String'(" DM1.23"),
20 => new String'(" CHF12,345.67"),
-- The following 12 edited output strings correspond to the 12
-- Data_With_NDP items formatted using Valid_String items 11-22.
-- This combination shows decimal data with no decimal places
-- formatted using picture strings.
21 => new String'(" 1234"),
22 => new String'("51234"),
23 => new String'("($1,234)"),
24 => new String'(" $1,234 "),
25 => new String'(" 1.00"),
26 => new String'(" "),
27 => new String'("( $10)"),
28 => new String'(" 1-"),
29 => new String'("$1234"),
30 => new String'(" $1"),
31 => new String'(" $36 "),
32 => new String'(" $0")
);
-- The following data is used to create exception situations in tests of
-- the Edited Output capabilities of package Ada.Text_IO.Editing. The data
-- are not themselves erroneous, but will produce exceptions based on the
-- data/picture string combination used.
Erroneous_Data : Data_Array_Type_2 (1..Number_Of_Erroneous_Conditions) :=
( 1 => 12.34,
2 => -12.34,
3 => 51234.0
);
Erroneous_Strings : Picture_String_Array_Type
(1..Number_Of_Erroneous_Conditions) :=
( 1 => new String'("9.99"),
2 => new String'("99.99"),
3 => new String'("$$$$9")
);
end FXF3A00;

371
gcc/testsuite/ada/acats/support/impdef.a Normal file
View File

@ -0,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;

153
gcc/testsuite/ada/acats/support/impdefc.a Normal file
View File

@ -0,0 +1,153 @@
-- Version of IMPDEFC.A modified for ACT interrupt support
--
-- IMPDEFC.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 C (Systems Programming).
--
-- APPLICABILITY CRITERIA:
-- This package is only required for implementations validating the
-- Systems Programming Annex.
--
-- CHANGE HISTORY:
-- 29 Jan 96 SAIC Initial version for ACVC 2.1.
--
--!
with Ada.Interrupts.Names;
package ImpDef.Annex_C is
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-- Interrupt_To_Generate should identify a non-reserved interrupt
-- that can be predictably generated within a reasonable time interval
-- (as specified by the constant Wait_For_Interrupt) during testing.
Interrupt_To_Generate: constant Ada.Interrupts.Interrupt_ID :=
Ada.Interrupts.Names.SIGPIPE; -- to allow trivial compilation
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ --- MODIFY HERE AS NEEDED
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-- Wait_For_Interrupt should specify the reasonable time interval during
-- which the interrupt identified by Interrupt_To_Generate can be
-- expected to be generated.
Wait_For_Interrupt : constant := 0.1;
-- ^^^^ --- MODIFY HERE AS NEEDED
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-- The procedure Enable_Interrupts should enable interrupts, if this
-- is required by the implementation. [See additional notes on this
-- procedure in the package body.]
procedure Enable_Interrupts;
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-- The procedure Generate_Interrupt should generate the interrupt
-- identified by Interrupt_To_Generate within the time interval
-- specified by Wait_For_Interrupt. [See additional notes on this
-- procedure in the package body.]
procedure Generate_Interrupt;
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
end ImpDef.Annex_C;
--==================================================================--
package body ImpDef.Annex_C is
-- NOTE: These are example bodies. It is expected that implementors
-- will write their own versions of these routines.
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-- The procedure Enable_Interrupts should enable interrupts, if this
-- is required by the implementation.
--
-- The default body is null, since it is expected that most implementations
-- will not need to perform this step.
--
-- Note that Enable_Interrupts will be called only once per test.
procedure Enable_Interrupts is
begin
null;
-- ^^^^^^^^^^^^^^^^^^^^ MODIFY THIS BODY AS NEEDED ^^^^^^^^^^^^^^^^^^^^
end Enable_Interrupts;
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-- The procedure Generate_Interrupt should generate the interrupt
-- identified by Interrupt_To_Generate within the time interval
-- specified by Wait_For_Interrupt.
--
-- The default body assumes that an interrupt will be generated by some
-- physical act during testing. While this approach is acceptable, the
-- interrupt should ideally be generated by appropriate code in the
-- procedure body.
--
-- Note that Generate_Interrupt may be called multiple times by a single
-- test. The code used to implement this procedure should account for this
-- possibility.
procedure Generate_Interrupt is
procedure c_kill (pid : Integer; sig : in Ada.Interrupts.Interrupt_ID);
pragma Import (C, c_kill, "kill");
function c_getpid return Integer;
pragma Import (C, c_getpid, "getpid");
Pid : integer := c_getpid;
begin
Report.Comment (". >>>>> GENERATE THE INTERRUPT NOW <<<<< " & integer'image (pid) & " " & Ada.Interrupts.Interrupt_ID'image (Interrupt_To_Generate));
c_kill (pid, Interrupt_To_Generate);
-- ^^^^^^^^^^^^^^^^^^^^ MODIFY THIS BODY AS NEEDED ^^^^^^^^^^^^^^^^^^^^
end Generate_Interrupt;
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
end ImpDef.Annex_C;

69
gcc/testsuite/ada/acats/support/impdefd.a Normal file
View File

@ -0,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;

58
gcc/testsuite/ada/acats/support/impdefe.a Normal file
View File

@ -0,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;

83
gcc/testsuite/ada/acats/support/impdefg.a Normal file
View File

@ -0,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;

102
gcc/testsuite/ada/acats/support/impdefh.a Normal file
View File

@ -0,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;

60
gcc/testsuite/ada/acats/support/lencheck.ada Normal file
View File

@ -0,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;

301
gcc/testsuite/ada/acats/support/macro.dfs Normal file
View File

@ -0,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

11
gcc/testsuite/ada/acats/support/macrodef.adb Normal file
View File

@ -0,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;

548
gcc/testsuite/ada/acats/support/macrosub.ada Normal file
View File

@ -0,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 <LETTER>, <NUMBER>, OR <_> IS NOT FOUND. --
-- RETURN PARAMETERS SEND THE BEGINNING POINTER AND LENGTH OF THE --
-- MACRO BACK TO THE MAIN PROGRAM. ALSO RETURNED IS THE MACRO --
-- STRING. --
-----------------------------------------------------------------------
PROCEDURE LOOK_FOR_MACRO (A_LINE : IN STRING;
A_LENGTH : IN INTEGER;
PTR : IN OUT INTEGER;
MACRO : OUT STRING;
MACRO_LEN : IN OUT INTEGER) IS
II, J : INTEGER := INTEGER'LAST;
BEGIN
FOR I IN PTR..A_LENGTH LOOP
IF A_LINE (I) = '$' THEN
II := I+1;
EXIT;
END IF;
II := I;
END LOOP;
IF II < A_LENGTH THEN -- DOLLAR SIGN IS FOUND.
J := II;
WHILE J <= A_LENGTH AND THEN ((A_LINE(J) IN 'A'..'Z') OR
(A_LINE(J) IN '0'..'9') OR
A_LINE(J) = '_') LOOP
J := J+1;
END LOOP;
J := J-1;
MACRO_LEN := (J-II+1);
MACRO (1..MACRO_LEN) := A_LINE (II .. J);
-- DON'T INCLUDE THE DOLLAR SIGN
PTR := J+1;
ELSE
MACRO_LEN := 0;
END IF;
RETURN;
END LOOK_FOR_MACRO;
------------------------------------------------------------------------
-- PROCEDURE WHICH_MACRO COMPARES THE INPUT MACRO STRING TO A --
-- VALUE READ FROM MACRO.DFS AND STORED IN THE SYMBOL TABLE AND --
-- RETURNS THE MACRO SUBSTITUTION STRING BACK TO THE MAIN PROGRAM. --
------------------------------------------------------------------------
PROCEDURE WHICH_MACRO (MACRO : IN STRING;
MACRO_LEN : IN INTEGER;
TEMP_MACRO : OUT STRING;
TEMP_MACRO_LEN : IN OUT INTEGER) IS
BEGIN
FOR INDEX IN 1 .. NUM_MACROS LOOP
IF MACRO (1..MACRO_LEN) =
SYMBOL_TABLE (INDEX).MACRO_NAME
(1..SYMBOL_TABLE (INDEX).NAME_LENGTH) THEN
TEMP_MACRO_LEN :=
SYMBOL_TABLE (INDEX).VALUE_LENGTH;
TEMP_MACRO (1..TEMP_MACRO_LEN) :=
SYMBOL_TABLE (INDEX).MACRO_VALUE
(1..TEMP_MACRO_LEN);
EXIT;
END IF;
IF INDEX = NUM_MACROS THEN
PUT_LINE ("** ERROR: MACRO " & MACRO (1..MACRO_LEN)
& " NOT FOUND. UPDATE PROGRAM.");
TEMP_MACRO_LEN := MACRO_LEN;
TEMP_MACRO (1..TEMP_MACRO_LEN) :=
MACRO (1..MACRO_LEN);
END IF;
END LOOP;
END WHICH_MACRO;
BEGIN
NULL;
END PARSEMAC;
WITH TEXT_IO, GETSUBS, PARSEMAC, DEFS;
USE TEXT_IO, GETSUBS, PARSEMAC, DEFS;
PROCEDURE MACROSUB IS
------------------------------------------------------------------------
-- --
-- MACROSUB IS THE MAIN PROGRAM THAT CALLS PROCEDURES IN TWO --
-- PACKAGES, GETSUBS AND PARSEMAC. THIS PROGRAM IS USED TO MAKE --
-- THE MACRO SUBSTITUTIONS FOR TST TESTS IN THE ACVC TEST SUITE. --
-- --
------------------------------------------------------------------------
INFILE1, INFILE2, OUTFILE1 : FILE_TYPE;
FNAME, MACRO : VAL_STRING;
LENGTH, A_LENGTH, PTR,
TEMP_MACRO_LENGTH, MACRO_LEN, FILE_COUNT : INTEGER := 0;
A_LINE, TEMP_MACRO, TEMP_LINE, NEW_LINE : VAL_STRING;
END_OF_LINE_SEARCH, FLAG : BOOLEAN := FALSE;
TESTS_FILE : CONSTANT STRING := "TSTTESTS.DAT";
TSTTESTS,FILE_CRE : EXCEPTION;
BEGIN
PUT_LINE ("BEGINNING MACRO SUBSTITUTIONS.");
FILL_TABLE;
BEGIN
OPEN (INFILE2, IN_FILE, TESTS_FILE);
EXCEPTION
WHEN NAME_ERROR =>
PUT_LINE ("** ERROR: ERROR DURING OPENING OF " &
"TSTTESTS.DAT");
RAISE TSTTESTS;
END;
WHILE NOT END_OF_FILE (INFILE2) LOOP
GET_LINE (INFILE2, FNAME, LENGTH);
FILE_COUNT := FILE_COUNT + 1;
BEGIN
OPEN (INFILE1, IN_FILE, FNAME(1..LENGTH));
EXCEPTION
WHEN NAME_ERROR =>
PUT_LINE ("** ERROR: ERROR DURING OPENING OF " &
FNAME(1..LENGTH) & ".");
FLAG := TRUE;
END;
IF NOT FLAG THEN
PUT_LINE ("WORKING ON " & FNAME(1..LENGTH));
IF FILE_COUNT = 70 THEN
PUT_LINE ("MACRO SUBSTITUTIONS HALF COMPLETED.");
END IF;
FOR I IN REVERSE 1 .. LENGTH LOOP
IF FNAME(I) = ';' THEN
LENGTH := I - 1;
EXIT;
END IF;
END LOOP;
IF FNAME (LENGTH-2..LENGTH) = "TST" THEN
FNAME (LENGTH-2..LENGTH) := "ADT";
ELSIF FNAME (LENGTH-2..LENGTH) = "tst" THEN
FNAME (LENGTH-2..LENGTH) := "adt";
END IF;
BEGIN
CREATE (OUTFILE1, OUT_FILE, FNAME (1..LENGTH));
EXCEPTION
WHEN OTHERS =>
PUT_LINE ("** ERROR: EXCEPTION RAISED DURING" &
" ATTEMPTED CREATION OF " &
FNAME(1..LENGTH) & ".");
RAISE FILE_CRE;
END;
WHILE NOT END_OF_FILE (INFILE1) LOOP
GET_LINE (INFILE1, A_LINE, A_LENGTH);
IF A_LENGTH > 0 AND A_LINE(1..2) /= "--" THEN
END_OF_LINE_SEARCH := FALSE;
PTR := 1;
WHILE NOT END_OF_LINE_SEARCH LOOP
LOOK_FOR_MACRO (A_LINE, A_LENGTH, PTR,
MACRO, MACRO_LEN);
IF MACRO_LEN = 0 THEN
END_OF_LINE_SEARCH := TRUE;
ELSE -- SEE WHICH MACRO IT IS
WHICH_MACRO (MACRO, MACRO_LEN,
TEMP_MACRO, TEMP_MACRO_LENGTH);
END IF;
IF NOT END_OF_LINE_SEARCH THEN
IF PTR-MACRO_LEN-2 > 0 THEN
-- IF MACRO IS NOT FIRST ON THE LINE
NEW_LINE (1..PTR-MACRO_LEN-2)
:= A_LINE(1..PTR-MACRO_LEN -2);
-- THE OLD LINE UNTIL THE DOLLAR SIGN
END IF;
NEW_LINE(PTR-MACRO_LEN-1 ..
TEMP_MACRO_LENGTH +
(PTR-MACRO_LEN) - 2) :=
TEMP_MACRO(1..TEMP_MACRO_LENGTH);
IF PTR <= A_LENGTH THEN
-- IF MACRO IS NOT LAST ON THE LINE
NEW_LINE (TEMP_MACRO_LENGTH +
PTR-MACRO_LEN - 1 ..
TEMP_MACRO_LENGTH - 1 +
A_LENGTH - MACRO_LEN) :=
A_LINE (PTR..A_LENGTH);
ELSE
END_OF_LINE_SEARCH := TRUE;
END IF;
A_LENGTH := A_LENGTH +
TEMP_MACRO_LENGTH -
MACRO_LEN - 1;
A_LINE (1..A_LENGTH) :=
NEW_LINE (1..A_LENGTH);
PTR := PTR - MACRO_LEN +
TEMP_MACRO_LENGTH - 1;
END IF;
END LOOP;
END IF;
PUT_LINE (OUTFILE1, A_LINE (1..A_LENGTH));
END LOOP;
CLOSE (OUTFILE1);
CLOSE (INFILE1);
ELSE
FLAG := FALSE;
END IF;
END LOOP;
CLOSE (INFILE2);
PUT_LINE ("MACRO SUBSTITUTIONS COMPLETED.");
EXCEPTION
WHEN MAC_FILE | LINE_LEN | TSTTESTS | FILE_CRE =>
NULL;
WHEN OTHERS =>
PUT_LINE ("UNEXPECTED EXCEPTION RAISED");
END MACROSUB;

329
gcc/testsuite/ada/acats/support/repbody.ada Normal file
View File

@ -0,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;

149
gcc/testsuite/ada/acats/support/repspec.ada Normal file
View File

@ -0,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;

67
gcc/testsuite/ada/acats/support/spprt13s.tst Normal file
View File

@ -0,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;

264
gcc/testsuite/ada/acats/support/tctouch.ada Normal file
View File

@ -0,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_<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;

38
gcc/testsuite/ada/acats/support/tsttests.dat Normal file
View File

@ -0,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

294
gcc/testsuite/ada/acats/support/widechr.a Normal file
View File

@ -0,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;

38
gcc/testsuite/ada/acats/tests/a/a22006b.ada Normal file
View File

@ -0,0 +1,38 @@
-- A22006B.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT HORIZONTAL TABULATION CAN BE USED WITHIN AND OUTSIDE OF
-- COMMENTS.
-- JBG 5/26/85
WITH REPORT; USE REPORT;
PROCEDURE A22006B IS
BEGIN
TEST ("A22006B", "CHECK USE OF HT IN AND OUT OF COMMENTS");
-- PRECEDING LINE CONTAINED A LEADING HT
-- NEXT LINE CONTAINS A TAB INSIDE A COMMENT
-- HERE IS HT => <= CHARACTER IN A COMMENT
RESULT; -- TAB PRECEDES THIS COMMENT
END A22006B;

51
gcc/testsuite/ada/acats/tests/a/a22006c.ada Normal file
View File

@ -0,0 +1,51 @@
-- A22006C.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT A COMPILATION MAY BE PRECEDED BY EXTRA LINES
-- (INCLUDING LINES TERMINATED BY FORMAT EFFECTORS OTHER
-- THAN HORIZONTAL TABULATION).
-- NOTE: THIS FILE BEGINS WITH:
-- 1) AN EMPTY LINE
-- 2) A CARRIAGE RETURN CHARACTER (ASCII 13. = 0D HEX)
-- 3) A CARRIAGE RETURN CHARACTER (ASCII 13. = 0D HEX)
-- 4) A VERTICAL TABULATION CHARACTER (ASCII 11. = 0B HEX)
-- 5) A LINE FEED CHARACTER (ASCII 10. = 0A HEX)
-- 6) A LINE FEED CHARACTER (ASCII 10. = 0A HEX)
-- 7) A FORM FEED CHARACTER (ASCII 12. = 0C HEX)
-- PWB 2/13/86
WITH REPORT;
USE REPORT;
PROCEDURE A22006C IS
BEGIN
TEST ("A22006C", "CHECK THAT A COMPILATION CAN BE PRECEDED " &
"BY EXTRA LINES");
RESULT;
END A22006C;

41
gcc/testsuite/ada/acats/tests/a/a22006d.ada Normal file
View File

@ -0,0 +1,41 @@
-- A22006D.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT A COMPILATION CAN BE PRECEDED BY SPACES AND
-- HORIZONTAL TABULATION CHARACTERS.
-- NOTE: THE FIRST LINE OF THIS FILE BEGINS WITH FOUR SPACE
-- CHARACTERS AND A HORIZONTAL TABULATION CHARACTER
-- PWB 2/13/86
WITH REPORT;
USE REPORT;
PROCEDURE A22006D IS
BEGIN
TEST ("A22006D", "CHECK THAT A COMPILATION CAN BE PRECEDED " &
"BY SPACE AND HORIZONTAL TABULATION CHARACTERS");
RESULT;
END A22006D;

48
gcc/testsuite/ada/acats/tests/a/a26007a.tst Normal file
View File

@ -0,0 +1,48 @@
-- A26007A.TST
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT A STRING LITERAL HAVING THE MAXIMUM PERMITTED LINE LENGTH
-- CAN BE GENERATED.
-- TBN 3/5/86
WITH REPORT; USE REPORT;
PROCEDURE A26007A IS
MAX_LEN_STRING_LIT : STRING (1 .. $MAX_IN_LEN - 2);
-- MAX_IN_LEN IS THE MAXIMUM LINE LENGTH PERMITTED.
BEGIN
TEST ("A26007A", "CHECK THAT A STRING LITERAL HAVING THE " &
"MAXIMUM PERMITTED LINE LENGTH CAN BE GENERATED");
MAX_LEN_STRING_LIT :=
$MAX_STRING_LITERAL
;
-- MAX_STRING_LITERAL IS A STRING LITERAL THAT IS MAXIMUM LENGTH.
-- QUOTES ARE COUNTED AS PART OF THE STRING LITERAL.
RESULT;
END A26007A;

51
gcc/testsuite/ada/acats/tests/a/a27003a.ada Normal file
View File

@ -0,0 +1,51 @@
-- A27003A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT IN A STRING LITERAL, CONSECUTIVE HYPHENS
-- ARE PERMITTED WITHOUT INDICATING A COMMENT,
-- AND THAT IN A COMMENT, A SINGLE DOUBLE-QUOTE IS
-- PERMITTED WITHOUT INDICATING A STRING LITERAL.
-- PWB 03/04/86
WITH REPORT; USE REPORT;
PROCEDURE A27003A IS
-- COMMENT : " IS PERMITTED HERE.
STR1 : CONSTANT STRING := "AB--C";
STR2 : STRING (1..10);
BEGIN
TEST ("A27003A", "CONSECUTIVE HYPHENS PERMITTED IN " &
"STRING LITERAL, AND QUOTE PERMITTED " &
"IN COMMENT");
STR2 := STR1 & "--ABC";
-- COMMENT : " IS PERMITTED HERE.
RESULT;
END A27003A;

102
gcc/testsuite/ada/acats/tests/a/a29003a.ada Normal file
View File

@ -0,0 +1,102 @@
-- A29003A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT ALL PREDEFINED ATTRIBUTES EXCEPT DIGITS, DELTA, AND RANGE,
-- AND ALL PREDEFINED TYPE AND PACKAGE NAMES ARE NOT RESERVED WORDS.
-- AH 8/11/86
WITH REPORT; USE REPORT;
PROCEDURE A29003A IS
SUBTYPE INT IS INTEGER;
-- PREDEFINED ATTRIBUTES
ADDRESS : INT := IDENT_INT(0); -- ATTRIBUTE
AFT : INT := IDENT_INT(0); -- ATTRIBUTE
BASE : INT := IDENT_INT(0); -- ATTRIBUTE
CALLABLE : INT := IDENT_INT(0); -- ATTRIBUTE
CONSTRAINED : INT := IDENT_INT(0); -- ATTRIBUTE
COUNT : INT := IDENT_INT(0); -- ATTRIBUTE
EMAX : INT := IDENT_INT(0); -- ATTRIBUTE
EPSILON : INT := IDENT_INT(0); -- ATTRIBUTE
FIRST : INT := IDENT_INT(0); -- ATTRIBUTE
FIRST_BIT : INT := IDENT_INT(0); -- ATTRIBUTE
FORE : INT := IDENT_INT(0); -- ATTRIBUTE
IMAGE : INT := IDENT_INT(0); -- ATTRIBUTE
LARGE : INT := IDENT_INT(0); -- ATTRIBUTE
LAST : INT := IDENT_INT(0); -- ATTRIBUTE
LAST_BIT : INT := IDENT_INT(0); -- ATTRIBUTE
LENGTH : INT := IDENT_INT(0); -- ATTRIBUTE
MACHINE_EMAX : INT := IDENT_INT(0); -- ATTRIBUTE
MACHINE_EMIN : INT := IDENT_INT(0); -- ATTRIBUTE
MACHINE_MANTISSA : INT := IDENT_INT(0); -- ATTRIBUTE
MACHINE_OVERFLOWS : INT := IDENT_INT(0); -- ATTRIBUTE
MACHINE_RADIX : INT := IDENT_INT(0); -- ATTRIBUTE
MACHINE_ROUNDS : INT := IDENT_INT(0); -- ATTRIBUTE
MANTISSA : INT := IDENT_INT(0); -- ATTRIBUTE
POS : INT := IDENT_INT(0); -- ATTRIBUTE
POSITION : INT := IDENT_INT(0); -- ATTRIBUTE
PRED : INT := IDENT_INT(0); -- ATTRIBUTE
SAFE_EMAX : INT := IDENT_INT(0); -- ATTRIBUTE
SAFE_LARGE : INT := IDENT_INT(0); -- ATTRIBUTE
SAFE_SMALL : INT := IDENT_INT(0); -- ATTRIBUTE
SIZE : INT := IDENT_INT(0); -- ATTRIBUTE
SMALL : INT := IDENT_INT(0); -- ATTRIBUTE
STORAGE_SIZE : INT := IDENT_INT(0); -- ATTRIBUTE
SUCC : INT := IDENT_INT(0); -- ATTRIBUTE
TERMINATED : INT := IDENT_INT(0); -- ATTRIBUTE
VAL : INT := IDENT_INT(0); -- ATTRIBUTE
VALUE : INT := IDENT_INT(0); -- ATTRIBUTE
WIDTH : INT := IDENT_INT(0); -- ATTRIBUTE
-- PREDEFINED TYPES
BOOLEAN : INT := IDENT_INT(0); -- TYPE
CHARACTER : INT := IDENT_INT(0); -- TYPE
DURATION : INT := IDENT_INT(0); -- TYPE
FLOAT : INT := IDENT_INT(0); -- TYPE
INTEGER : INT := IDENT_INT(0); -- TYPE
NATURAL : INT := IDENT_INT(0); -- TYPE
POSITIVE : INT := IDENT_INT(0); -- TYPE
STRING : INT := IDENT_INT(0); -- TYPE
-- PREDEFINED PACKAGE NAMES
ASCII : INT := IDENT_INT(0); -- PACKAGE
CALENDAR : INT := IDENT_INT(0); -- PACKAGE
DIRECT_IO : INT := IDENT_INT(0); -- PACKAGE
IO_EXCEPTIONS : INT := IDENT_INT(0); -- PACKAGE
LOW_LEVEL_IO : INT := IDENT_INT(0); -- PACKAGE
MACHINE_CODE : INT := IDENT_INT(0); -- PACKAGE
SEQUENTIAL_IO : INT := IDENT_INT(0); -- PACKAGE
SYSTEM : INT := IDENT_INT(0); -- PACKAGE
TEXT_IO : INT := IDENT_INT(0); -- PACKAGE
UNCHECKED_CONVERSION : INT := IDENT_INT(0); -- PACKAGE
UNCHECKED_DEALLOCATION : INT := IDENT_INT(0); -- PACKAGE
BEGIN
TEST("A29003A", "NO ADDITIONAL RESERVED WORDS");
RESULT;
END A29003A;

72
gcc/testsuite/ada/acats/tests/a/a2a031a.ada Normal file
View File

@ -0,0 +1,72 @@
-- A2A031A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT AN EXCLAMATION MARK CAN REPLACE A VERTICAL BAR WHEN THE
-- VERTICAL BAR IS USED AS A SEPARATOR.
-- CONTEXTS ARE:
-- AS A CHOICE IN A VARIANT PART
-- IN A DISCRIMINANT CONSTRAINT
-- IN A CASE STATEMENT CHOICE
-- IN AN AGGREGATE
-- IN AN EXCEPTION HANDLER.
-- JBG 5/25/85
WITH REPORT; USE REPORT;
PROCEDURE A2A031A IS
TYPE ENUM IS (E1, E2, E3);
TYPE REC (A, B : ENUM) IS
RECORD
C : INTEGER;
CASE A IS
WHEN E1 ! E2 => -- CHOICE OF VARIANT.
D : INTEGER;
WHEN E3 =>
E : FLOAT;
END CASE;
END RECORD;
EX1, EX2, EX3 : EXCEPTION;
VAR : REC (A!B => E2); -- DISCRIMINANT CONSTRAINT.
EVAR : ENUM := E2;
BEGIN
TEST ("A2A031A", "CHECK USE OF ! AS SEPARATOR IN PLACE OF |");
CASE EVAR IS
WHEN E3 => NULL;
WHEN E2!E1 => NULL; -- CASE STATEMENT CHOICE.
END CASE;
VAR := (A!B => E2, C ! D => 0); -- AGGREGATE.
RESULT;
EXCEPTION
WHEN EX1!EX2 ! EX3 => NULL; -- EXCEPTION HANDLER.
END A2A031A;

49
gcc/testsuite/ada/acats/tests/a/a33003a.ada Normal file
View File

@ -0,0 +1,49 @@
-- A33003A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT THE FOLLOWING FORMS OF ALMOST RECURSIVE TYPES CAN BE
-- DECLARED:
-- A) A RECORD HAVING A COMPONENT OF AN ACCESS TYPE WHOSE DESIGNATED
-- TYPE IS THE RECORD TYPE;
-- TBN 10/6/86
-- DTN 11/12/91 DELETED SUBPARTS (B and C).
WITH REPORT; USE REPORT;
PROCEDURE A33003A IS
TYPE REC;
TYPE ACC_REC IS ACCESS REC;
TYPE REC IS
RECORD
A : INTEGER;
B : ACC_REC;
END RECORD;
BEGIN
TEST ("A33003A", "CHECK THAT ALMOST RECURSIVE TYPES CAN BE " &
"DECLARED");
RESULT;
END A33003A;

105
gcc/testsuite/ada/acats/tests/a/a34017c.ada Normal file
View File

@ -0,0 +1,105 @@
-- A34017C.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT IF A DERIVED TYPE DEFINITION IS GIVEN IN THE VISIBLE PART
-- OF A PACKAGE, THE TYPE MAY BE USED AS THE PARENT TYPE IN A DERIVED
-- TYPE DEFINITION IN THE PRIVATE PART OF THE PACKAGE AND IN THE BODY.
-- CHECK THAT IF A TYPE IS DECLARED IN THE VISIBLE PART OF A PACKAGE,
-- AND IS NOT A DERIVED TYPE OR A PRIVATE TYPE, IT MAY BE USED AS THE
-- PARENT TYPE IN A DERIVED TYPE DEFINITION IN THE VISIBLE PART, PRIVATE
-- PART, AND BODY.
-- DSJ 4/27/83
WITH REPORT;
PROCEDURE A34017C IS
USE REPORT;
BEGIN
TEST( "A34017C", "CHECK THAT A DERIVED TYPE MAY BE USED AS A " &
"PARENT TYPE IN THE PRIVATE PART AND BODY. " &
"CHECK THAT OTHER TYPES MAY BE USED AS PARENT " &
"TYPES IN VISIBLE PART ALSO");
DECLARE
TYPE REC IS
RECORD
C : INTEGER;
END RECORD;
PACKAGE PACK1 IS
TYPE T1 IS RANGE 1 .. 10;
TYPE T2 IS NEW REC;
TYPE T3 IS (A,B,C);
TYPE T4 IS ARRAY ( 1 .. 2 ) OF INTEGER;
TYPE T5 IS
RECORD
X : CHARACTER;
END RECORD;
TYPE T6 IS ACCESS INTEGER;
TYPE N1 IS NEW T3;
TYPE N2 IS NEW T4;
TYPE N3 IS NEW T5;
TYPE N4 IS NEW T6;
PRIVATE
TYPE P1 IS NEW T1;
TYPE P2 IS NEW T2;
TYPE P3 IS NEW T3;
TYPE P4 IS NEW T4;
TYPE P5 IS NEW T5;
TYPE P6 IS NEW T6;
END PACK1;
PACKAGE BODY PACK1 IS
TYPE Q1 IS NEW T1;
TYPE Q2 IS NEW T2;
TYPE Q3 IS NEW T3;
TYPE Q4 IS NEW T4;
TYPE Q5 IS NEW T5;
TYPE Q6 IS NEW T6;
END PACK1;
BEGIN
NULL;
END;
RESULT;
END A34017C;

50
gcc/testsuite/ada/acats/tests/a/a35101b.ada Normal file
View File

@ -0,0 +1,50 @@
-- A35101B.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT ONE ENUMERATION LITERAL IS PERMITTED IN AN ENUMERATION
-- TYPE DEFINITION.
-- RJW 2/14/86
WITH REPORT; USE REPORT;
PROCEDURE A35101B IS
BEGIN
TEST ("A35101B", "CHECK THAT ONE ENUMERATION LITERAL IS " &
"PERMITTED IN AN ENUMERATION TYPE " &
"DEFINITION" );
DECLARE
TYPE E1 IS (A); -- OK.
TYPE E2 IS ('1'); -- OK.
BEGIN
NULL;
END;
RESULT;
END A35101B;

63
gcc/testsuite/ada/acats/tests/a/a35402a.ada Normal file
View File

@ -0,0 +1,63 @@
-- A35402A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT THE BOUNDS OF AN INTEGER TYPE DEFINITION NEED NOT
-- HAVE THE SAME INTEGER TYPE.
-- RJW 2/20/86
WITH REPORT; USE REPORT;
PROCEDURE A35402A IS
BEGIN
TEST ( "A35402A", "CHECK THAT THE BOUNDS OF AN INTEGER " &
"TYPE DEFINITION NEED NOT HAVE THE SAME " &
"INTEGER TYPE" );
DECLARE
TYPE INT1 IS RANGE 1 .. 10;
TYPE INT2 IS RANGE 2 .. 8;
TYPE INT3 IS NEW INTEGER;
I : CONSTANT INTEGER := 5;
I1 : CONSTANT INT1 := 5;
I2 : CONSTANT INT2 := 5;
I3 : CONSTANT INT3 := 5;
TYPE INTRANGE1 IS RANGE I .. I1; -- OK.
TYPE INTRANGE2 IS RANGE I1 .. I2; -- OK.
TYPE INTRANGE3 IS RANGE I2 .. I3; -- OK.
TYPE INTRANGE4 IS RANGE I3 .. I; -- OK.
BEGIN
NULL;
END;
RESULT;
END A35402A;

64
gcc/testsuite/ada/acats/tests/a/a35801f.ada Normal file
View File

@ -0,0 +1,64 @@
-- A35801F.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT THE ATTRIBUTES FIRST AND LAST RETURN VALUES HAVING THE
-- SAME BASE TYPE AS THE PREFIX WHEN THE PREFIX IS A FLOATING POINT
-- TYPE.
-- THIS CHECK IS PROVIDED THROUGH THE USE OF THIS TEST IN CONJUNCTION
-- WITH TEST B35801C.
-- R.WILLIAMS 8/21/86
WITH REPORT; USE REPORT;
PROCEDURE A35801F IS
TYPE REAL IS DIGITS 3 RANGE -100.0 .. 100.0;
SUBTYPE SURREAL IS REAL RANGE -50.0 .. 50.0;
TYPE NFLT IS NEW FLOAT;
SUBTYPE UNIT IS NFLT RANGE -1.0 .. 1.0;
SUBTYPE EMPTY IS FLOAT RANGE 1.0 .. -1.0;
R1 : REAL := SURREAL'FIRST; -- OK.
R2 : REAL := SURREAL'LAST; -- OK.
N1 : NFLT := UNIT'FIRST; -- OK.
N2 : NFLT := UNIT'LAST; -- OK.
F1 : FLOAT := FLOAT'FIRST; -- OK.
F2 : FLOAT := FLOAT'LAST; -- OK.
E1 : FLOAT := EMPTY'FIRST; -- OK.
E2 : FLOAT := EMPTY'LAST; -- OK.
BEGIN
TEST ( "A35801F", "CHECK THAT THE ATTRIBUTES FIRST AND LAST " &
"RETURN VALUES HAVING THE SAME BASE TYPE AS " &
"THE PREFIX WHEN THE PREFIX IS A FLOATING " &
"POINT TYPE" );
RESULT;
END A35801F;

51
gcc/testsuite/ada/acats/tests/a/a35902c.ada Normal file
View File

@ -0,0 +1,51 @@
-- A35902C.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT A FIXED POINT TYPE WITH ONLY ONE MODEL NUMBER IS
-- ALLOWED.
-- HISTORY:
-- RJW 02/26/86 CREATED ORIGINAL TEST.
-- DHH 10/15/87 CORRECTED RANGE ERRORS.
WITH REPORT; USE REPORT;
PROCEDURE A35902C IS
BEGIN
TEST ("A35902C", "CHECK THAT A FIXED POINT TYPE WITH ONLY ONE " &
"MODEL NUMBER IS ALLOWED" );
DECLARE
TYPE F IS DELTA 1.0 RANGE -0.5 .. 0.5; -- OK.
F1 : F := 0.0;
BEGIN
NULL;
END;
RESULT;
END A35902C;

99
gcc/testsuite/ada/acats/tests/a/a38106d.ada Normal file
View File

@ -0,0 +1,99 @@
-- A38106D.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT FOR AN ACCESS TYPE WHOSE DESIGNATED TYPE IS AN INCOMPLETE
-- TYPE, ADDITIONAL OPERATIONS FOR THE ACCESS TYPE WHICH DEPEND ON
-- CHARACTERISTICS OF THE FULL DECLARATION OF THE TYPE ARE MADE
-- AVAILABLE AT THE EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE
-- ACCESS TYPE DECLARATION AND AFTER THE FULL DECLARATION OF THE
-- INCOMPLETE TYPE.
-- (1) CHECK FOR COMPONENT SELECTION WITH RECORD TYPES
-- (2) CHECK FOR INDEXED COMPONENTS AND SLICES WITH ARRAY TYPES
-- (3) CHECK FOR USE OF 'FIRST, 'LAST, 'RANGE, AND 'LENGTH WITH ARRAY
-- TYPES
-- PART 1: FULL DECLARATION OF INCOMPLETE TYPE IN PACKAGE SPECIFICATION.
-- DSJ 5/05/83
-- SPS 10/18/83
-- EG 12/19/83
WITH REPORT ;
PROCEDURE A38106D IS
USE REPORT ;
BEGIN
TEST("A38106D", "CHECK THAT ADDITIONAL OPERATIONS OF ACCESS " &
"TYPES OF INCOMPLETE TYPES ARE AVAILABLE AT THE " &
"EARLIEST PLACE IN THE IMMEDIATE SCOPE OF THE " &
"ACCESS TYPE AND AFTER THE FULL DECLARATION " &
"(WHICH IS IN THE PACKAGE SPECIFICATION)") ;
DECLARE
PACKAGE PACK1 IS
TYPE T1 ;
TYPE T2 ;
PACKAGE PACK2 IS
TYPE ACC1 IS ACCESS T1 ;
TYPE ACC2 IS ACCESS T2 ;
END PACK2 ;
TYPE T1 IS ARRAY ( 1 .. 2 ) OF INTEGER ;
TYPE T2 IS
RECORD
C1, C2 : INTEGER ;
END RECORD ;
END PACK1 ;
PACKAGE BODY PACK1 IS
A1 : PACK2.ACC1 := NEW T1'(2,4) ; -- LEGAL
A2 : PACK2.ACC1 := NEW T1'(6,8) ; -- LEGAL
R1 : PACK2.ACC2 := NEW T2'(3,5) ; -- LEGAL
R2 : PACK2.ACC2 := NEW T2'(7,9) ; -- LEGAL
PACKAGE BODY PACK2 IS
X1 : INTEGER := A1(1) ; -- LEGAL
X2 : INTEGER := A1'FIRST ; -- LEGAL
X3 : INTEGER := A1'LAST ; -- LEGAL
X4 : INTEGER := A1'LENGTH ; -- LEGAL
B1 : BOOLEAN := 3 IN A1'RANGE ; -- LEGAL
X5 : INTEGER := R1.C1 ; -- LEGAL
END PACK2 ;
END PACK1 ;
BEGIN
NULL ;
END ;
RESULT ;
END A38106D ;

99
gcc/testsuite/ada/acats/tests/a/a38106e.ada Normal file
View File

@ -0,0 +1,99 @@
-- A38106E.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT FOR AN ACCESS TYPE WHOSE DESIGNATED TYPE IS AN INCOMPLETE
-- TYPE, ADDITIONAL OPERATIONS FOR THE ACCESS TYPE WHICH DEPEND ON
-- CHARACTERISTICS OF THE FULL DECLARATION OF THE TYPE ARE MADE
-- AVAILABLE AT THE EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE
-- ACCESS TYPE DECLARATION AND AFTER THE FULL DECLARATION OF THE
-- INCOMPLETE TYPE.
-- (1) CHECK FOR COMPONENT SELECTION WITH RECORD TYPES
-- (2) CHECK FOR INDEXED COMPONENTS AND SLICES WITH ARRAY TYPES
-- (3) CHECK FOR USE OF 'FIRST, 'LAST, 'RANGE, AND 'LENGTH WITH ARRAY
-- TYPES
-- PART 2 : FULL DECLARATION OF INCOMPLETE TYPE IN PACKAGE BODY
-- DSJ 5/05/83
-- SPS 10/18/83
-- EG 12/19/83
WITH REPORT ;
PROCEDURE A38106E IS
USE REPORT ;
BEGIN
TEST("A38106E", "CHECK THAT ADDITIONAL OPERATIONS OF ACCESS " &
"TYPES OF INCOMPLETE TYPES ARE AVAILABLE AT THE " &
"EARLIEST PLACE IN THE IMMEDIATE SCOPE OF THE " &
"ACCESS TYPE AND AFTER THE FULL DECLARATION " &
"(WHICH IS IN THE PACKAGE BODY)");
DECLARE
PACKAGE PACK1 IS
PRIVATE
TYPE T1 ;
TYPE T2 ;
PACKAGE PACK2 IS
TYPE ACC1 IS ACCESS T1 ;
TYPE ACC2 IS ACCESS T2 ;
END PACK2 ;
END PACK1 ;
PACKAGE BODY PACK1 IS
TYPE T1 IS ARRAY ( 1 .. 2 ) OF INTEGER ;
TYPE T2 IS
RECORD
C1, C2 : INTEGER ;
END RECORD ;
A1 : PACK2.ACC1 := NEW T1'(2,4) ; -- LEGAL
A2 : PACK2.ACC1 := NEW T1'(6,8) ; -- LEGAL
R1 : PACK2.ACC2 := NEW T2'(3,5) ; -- LEGAL
R2 : PACK2.ACC2 := NEW T2'(7,9) ; -- LEGAL
PACKAGE BODY PACK2 IS
X1 : INTEGER := A1(1) ; -- LEGAL
X2 : INTEGER := A1'FIRST ; -- LEGAL
X3 : INTEGER := A1'LAST ; -- LEGAL
X4 : INTEGER := A1'LENGTH ; -- LEGAL
B1 : BOOLEAN := 3 IN A1'RANGE ; -- LEGAL
X5 : INTEGER := R1.C1 ; -- LEGAL
END PACK2 ;
END PACK1 ;
BEGIN
NULL ;
END ;
RESULT ;
END A38106E ;

85
gcc/testsuite/ada/acats/tests/a/a49027a.ada Normal file
View File

@ -0,0 +1,85 @@
-- A49027A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT A SUBTYPE CAN BE NONSTATIC IN A GENERIC TEMPLATE AND
-- STATIC IN THE CORRESPONDING INSTANCE.
-- CHECK THAT FOR A GENERIC INSTANTIATION, IF THE ACTUAL PARAMETER
-- IS A STATIC SUBTYPE, THEN EVERY USE OF THE CORRESPONDING FORMAL
-- PARAMETER WITHIN THE INSTANCE IS CONSIDERED TO DENOTE A STATIC
-- SUBTYPE
--
-- THIS IS A TEST BASED ON AI-00409/05-BI-WJ.
-- HISTORY:
-- EDWARD V. BERARD, 27 AUGUST 1990
-- CJJ 10 OCT 1990 TEST OBJECTIVE CHANGED TO REFLECT AIG
-- OBJECTIVE.
WITH REPORT ;
PROCEDURE A49027A IS
BEGIN -- A49027A
REPORT.TEST ("A49027A", "CHECK THAT A SUBTYPE CAN BE NONSTATIC " &
"IN A GENERIC TEMPLATE AND STATIC IN THE " &
"CORRESPONDING INSTANCE.") ;
LOCAL_BLOCK:
DECLARE
TYPE NUMBER IS RANGE 1 .. 10 ;
GENERIC
TYPE NUMBER_TYPE IS RANGE <> ;
PACKAGE STATIC_TEST IS
TYPE NEW_NUMBER_TYPE IS NEW NUMBER_TYPE ;
SUBTYPE SUB_NUMBER_TYPE IS NUMBER_TYPE ;
END STATIC_TEST ;
PACKAGE NEW_STATIC_TEST IS NEW STATIC_TEST
(NUMBER_TYPE => NUMBER) ;
TYPE ANOTHER_NUMBER IS RANGE
NEW_STATIC_TEST.NEW_NUMBER_TYPE'FIRST ..
NEW_STATIC_TEST.NEW_NUMBER_TYPE'LAST ;
TYPE YET_ANOTHER_NUMBER IS RANGE
NEW_STATIC_TEST.SUB_NUMBER_TYPE'FIRST ..
NEW_STATIC_TEST.SUB_NUMBER_TYPE'LAST ;
BEGIN -- LOCAL_BLOCK
NULL ;
END LOCAL_BLOCK ;
REPORT.RESULT ;
END A49027A ;

159
gcc/testsuite/ada/acats/tests/a/a49027b.ada Normal file
View File

@ -0,0 +1,159 @@
-- A49027B.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT A SUBTYPE CAN BE NONSTATIC IN A GENERIC TEMPLATE
-- AND STATIC IN THE CORRESPONDING INSTANCE.
-- CHECK THAT IF A GENERIC PARAMETER IS A STATIC EXPRESSION AND THE
-- CORRESPONDING (IN) PARAMETER HAS A STATIC SUBTYPE IN THE INSTANCE,
-- THEN EACH USE OF THE FORMAL PARAMETERS IN THE INSTANCE IS SAID TO
-- BE STATIC.
--
-- A NAME DENOTING A CONSTANT DECLARED IN A GENERIC INSTANCE IS
-- ALLOWED AS A PRIMARY IN A STATIC EXPRESSION IF THE CONSTANT
-- IS DECLARED BY A CONSTANT DECLARATION WITH A STATIC SUBTYPE
-- AND INITIALIZED WITH A STATIC EXPRESSION.
--
-- THIS IS A TEST BASED ON AI-00505/03-BI-WA.
-- HISTORY:
-- EDWARD V. BERARD, 27 AUGUST 1990
-- DAS 8 OCT 90 ADDED CODE TO MATCH EXAMPLE 1 IN
-- AI-00505.
-- JRL 05/29/92 CORRECTED MINOR PROBLEM IN REPORT.TEST STRING.
-- JRL 02/18/93 EXPANDED TEXT OF REPORT.TEST STRING.
-- PWN 04/14/95 CORRECTED MINOR COPYRIGHT COMMENT PROBLEM.
WITH REPORT ;
PROCEDURE A49027B IS
BEGIN -- A49027B
REPORT.TEST ("A49027B", "CHECK THAT IF A GENERIC ACTUAL " &
"PARAMETER IS A STATIC EXPRESSION AND THE " &
"CORRESPONDING FORMAL PARAMETER HAS A STATIC " &
"SUBTYPE IN THE INSTANCE, THEN EACH USE OF THE " &
"FORMAL PARAMETER IN THE INSTANCE IS SAID TO BE " &
"STATIC. CHECK THAT A NAME DENOTING A CONSTANT " &
"DECLARED IN A GENERIC INSTANCE IS ALLOWED AS " &
"A PRIMARY IN A STATIC EXPRESSION IF THE " &
"CONSTANT IS DECLARED BY A CONSTANT DECLARATION " &
"WITH A STATIC SUBTYPE AND INITIALIZED WITH A " &
"STATIC EXPRESSION. (AI-00505)");
LOCAL_BLOCK:
DECLARE
TYPE NUMBER IS RANGE 1 .. 10 ;
TYPE COLOR IS (RED, ORANGE, YELLOW, GREEN, BLUE) ;
MIDDLE_COLOR : CONSTANT COLOR := GREEN ;
ENUMERATED_VALUE : COLOR := COLOR'LAST ;
GENERIC
TYPE NUMBER_TYPE IS RANGE <> ;
X : INTEGER ;
TYPE ENUMERATED IS (<>) ;
FIRST_NUMBER : IN NUMBER_TYPE ;
SECOND_NUMBER : IN NUMBER_TYPE ;
THIRD_NUMBER : IN NUMBER_TYPE ;
FIRST_ENUMERATED : IN ENUMERATED ;
SECOND_ENUMERATED : IN ENUMERATED ;
THIRD_ENUMERATED : IN ENUMERATED ;
FIRST_INTEGER_VALUE : IN INTEGER ;
SECOND_INTEGER_VALUE : IN INTEGER ;
PACKAGE STATIC_TEST IS
Y : CONSTANT INTEGER := X;
Z : CONSTANT NUMBER_TYPE := 5;
SUBTYPE FIRST_NUMBER_SUBTYPE IS NUMBER_TYPE
RANGE FIRST_NUMBER .. SECOND_NUMBER ;
SUBTYPE SECOND_NUMBER_SUBTYPE IS NUMBER_TYPE
RANGE FIRST_NUMBER .. THIRD_NUMBER ;
SUBTYPE FIRST_ENUMERATED_SUBTYPE IS ENUMERATED
RANGE FIRST_ENUMERATED .. SECOND_ENUMERATED ;
SUBTYPE SECOND_ENUMERATED_SUBTYPE IS ENUMERATED
RANGE FIRST_ENUMERATED .. THIRD_ENUMERATED ;
SUBTYPE THIRD_NUMBER_TYPE IS INTEGER
RANGE FIRST_INTEGER_VALUE .. SECOND_INTEGER_VALUE ;
END STATIC_TEST ;
PACKAGE NEW_STATIC_TEST IS NEW STATIC_TEST
(NUMBER_TYPE => NUMBER,
X => 3,
ENUMERATED => COLOR,
FIRST_NUMBER => NUMBER'FIRST,
SECOND_NUMBER => NUMBER'LAST,
THIRD_NUMBER => NUMBER'SUCC(NUMBER'FIRST),
FIRST_ENUMERATED => RED,
SECOND_ENUMERATED => MIDDLE_COLOR,
THIRD_ENUMERATED => COLOR'VAL (1),
FIRST_INTEGER_VALUE => COLOR'POS (YELLOW),
SECOND_INTEGER_VALUE => NUMBER'POS (5)) ;
TYPE T1 IS RANGE 1 .. NEW_STATIC_TEST.Y;
TYPE T2 IS RANGE 1 .. NEW_STATIC_TEST.Z;
TYPE ANOTHER_NUMBER IS RANGE
NEW_STATIC_TEST.FIRST_NUMBER_SUBTYPE'FIRST ..
NEW_STATIC_TEST.FIRST_NUMBER_SUBTYPE'LAST ;
TYPE YET_ANOTHER_NUMBER IS RANGE
NEW_STATIC_TEST.SECOND_NUMBER_SUBTYPE'FIRST ..
NEW_STATIC_TEST.SECOND_NUMBER_SUBTYPE'LAST ;
TYPE STILL_ANOTHER_NUMBER IS RANGE
NEW_STATIC_TEST.THIRD_NUMBER_TYPE'FIRST ..
NEW_STATIC_TEST.THIRD_NUMBER_TYPE'LAST ;
BEGIN -- LOCAL_BLOCK
CASE ENUMERATED_VALUE IS
WHEN YELLOW => NULL ;
WHEN NEW_STATIC_TEST.FIRST_ENUMERATED_SUBTYPE'FIRST
=> NULL ;
WHEN NEW_STATIC_TEST.FIRST_ENUMERATED_SUBTYPE'LAST
=> NULL ;
WHEN NEW_STATIC_TEST.SECOND_ENUMERATED_SUBTYPE'LAST
=> NULL ;
WHEN COLOR'LAST => NULL ;
END CASE ;
END LOCAL_BLOCK ;
REPORT.RESULT ;
END A49027B ;

70
gcc/testsuite/ada/acats/tests/a/a49027c.ada Normal file
View File

@ -0,0 +1,70 @@
-- A49027C.ADA
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- CHECK THAT IF A GENERIC PARAMETER IS A STATIC EXPRESSION AND THE
-- CORRESPONDING (IN) PARAMETER HAS A STATIC SUBTYPE IN THE INSTANCE,
-- THEN EACH USE OF THE FORMAL PARAMETER IN THE INSTANCE IS SAID TO
-- BE STATIC.
--
-- SEE AI-00505. THIS TEST IS TAKEN FROM THE SECOND EXAMPLE.
--
-- HISTORY:
-- DAS 8 OCT 90 INITIAL VERSION.
-- PWN 12/01/95 CORRECTED FORMAT OF CALL TO REPORT.TEST
-- KAS 25NOV96 CHANGED LITERAL 7 TO (IMPDEF.CHAR_BITS-1)
--!
WITH REPORT; USE REPORT;
WITH IMPDEF;
PROCEDURE A49027C IS
GENERIC
X : INTEGER;
PACKAGE GP IS
TYPE REC IS
RECORD
C : STRING (1..X);
END RECORD;
END GP;
PACKAGE NP IS NEW GP (1);
TYPE NR IS NEW NP.REC;
FOR NR USE
RECORD
C AT 0 RANGE 0..IMPDEF.CHAR_BITS-1; -- SUBTYPE INDICATION
END RECORD; -- FOR C IN NP IS CONSIDERED STATIC.
BEGIN
TEST("A49027C", "CHECK THAT IF A GENERIC PARAMETER IS A STATIC " &
"EXPRESSION AND THE CORRESPONDING (IN) PARAMETER HAS A " &
"STATIC SUBTYPE IN THE INSTANCE, THEN EACH USE OF THE " &
"FORMAL PARAMETER IN THE INSTANCE IS SAID TO BE STATIC.");
RESULT;
END A49027C;

119
gcc/testsuite/ada/acats/tests/a/a54b01a.ada Normal file
View File

@ -0,0 +1,119 @@
-- A54B01A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT IF A CASE EXPRESSION IS A CONSTANT, VARIABLE,
-- TYPE CONVERSION, OR QUALIFIED EXPRESSION,
-- AND THE SUBTYPE OF THE
-- EXPRESSION IS STATIC, AN 'OTHERS' CAN BE OMITTED IF ALL
-- VALUES IN THE SUBTYPE'S RANGE ARE COVERED.
-- RM 01/23/80
-- SPS 10/26/82
-- SPS 2/1/83
WITH REPORT ;
PROCEDURE A54B01A IS
USE REPORT ;
BEGIN
TEST("A54B01A" , "CHECK THAT IF" &
" THE SUBTYPE OF A CASE EXPRESSION IS STATIC," &
" AN 'OTHERS' CAN BE OMITTED IF ALL" &
" VALUES IN THE SUBTYPE'S RANGE ARE COVERED" );
-- THE TEST CASES APPEAR IN THE FOLLOWING ORDER:
--
-- I. CONSTANTS
--
-- II. STATIC SUBRANGES
--
-- (A) VARIABLES (INTEGER , BOOLEAN)
-- (B) QUALIFIED EXPRESSIONS
-- (C) TYPE CONVERSIONS
DECLARE -- CONSTANTS
T : CONSTANT BOOLEAN := TRUE;
FIVE : CONSTANT INTEGER := IDENT_INT(5);
BEGIN
CASE FIVE IS
WHEN INTEGER'FIRST..4 => NULL ;
WHEN 5 => NULL ;
WHEN 6 .. INTEGER'LAST => NULL ;
END CASE;
CASE T IS
WHEN TRUE => NULL ;
WHEN FALSE => NULL ;
END CASE;
END ;
DECLARE -- STATIC SUBRANGES
SUBTYPE STAT IS INTEGER RANGE 1..5 ;
I : INTEGER RANGE 1..5 ;
J : STAT ;
BOOL: BOOLEAN := FALSE ;
CHAR: CHARACTER := 'U' ;
TYPE ENUMERATION IS ( FIRST,SECOND,THIRD,FOURTH,FIFTH );
ENUM: ENUMERATION := THIRD ;
BEGIN
I := IDENT_INT( 2 );
J := IDENT_INT( 2 );
CASE I IS
WHEN 1 | 3 | 5 => NULL ;
WHEN 2 | 4 => NULL ;
END CASE;
CASE BOOL IS
WHEN TRUE => NULL ;
WHEN FALSE => NULL ;
END CASE;
CASE STAT'( 2 ) IS
WHEN 5 | 2..4 => NULL ;
WHEN 1 => NULL ;
END CASE;
CASE STAT( J ) IS
WHEN 5 | 2..4 => NULL ;
WHEN 1 => NULL ;
END CASE;
END ; -- STATIC SUBRANGES
RESULT ;
END A54B01A ;

184
gcc/testsuite/ada/acats/tests/a/a54b02a.ada Normal file
View File

@ -0,0 +1,184 @@
-- A54B02A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT IF A CASE EXPRESSION IS A VARIABLE, CONSTANT, TYPE
-- CONVERSION, ATTRIBUTE (IN PARTICULAR 'FIRST AND 'LAST),
-- FUNCTION INVOCATION, QUALIFIED EXPRESSION, OR A PARENTHESIZED
-- EXPRESSION HAVING ONE OF THESE FORMS, AND THE SUBTYPE OF THE
-- EXPRESSION IS NON-STATIC, AN 'OTHERS' CAN BE OMITTED IF ALL
-- VALUES IN THE BASE TYPE'S RANGE ARE COVERED.
-- RM 01/27/80
-- SPS 10/26/82
-- SPS 2/2/83
-- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
WITH REPORT ;
PROCEDURE A54B02A IS
USE REPORT ;
BEGIN
TEST("A54B02A" , "CHECK THAT IF THE" &
" SUBTYPE OF A CASE EXPRESSION IS NON-STATIC," &
" AN 'OTHERS' CAN BE OMITTED IF ALL" &
" VALUES IN THE BASE TYPE'S RANGE ARE COVERED" );
-- THE TEST CASES APPEAR IN THE FOLLOWING ORDER:
--
-- (A) VARIABLES (INTEGER , BOOLEAN)
-- (B) CONSTANTS (INTEGER, BOOLEAN)
-- (C) ATTRIBUTES ('FIRST, 'LAST)
-- (D) FUNCTION CALLS
-- (E) QUALIFIED EXPRESSIONS
-- (F) TYPE CONVERSIONS
-- (G) PARENTHESIZED EXPRESSIONS OF THE ABOVE KINDS
DECLARE -- NON-STATIC RANGES
SUBTYPE STAT IS INTEGER RANGE 1..50 ;
SUBTYPE DYN IS STAT RANGE 1..IDENT_INT( 5 ) ;
I : STAT RANGE 1..IDENT_INT( 5 );
J : DYN ;
SUBTYPE DYNCHAR IS
CHARACTER RANGE ASCII.NUL .. IDENT_CHAR('Q');
SUBTYPE STATCHAR IS
DYNCHAR RANGE 'A' .. 'C' ;
CHAR: DYNCHAR := 'F' ;
TYPE ENUMERATION IS ( A,B,C,D,E,F,G,H,K,L,M,N );
SUBTYPE STATENUM IS
ENUMERATION RANGE A .. L ;
SUBTYPE DYNENUM IS
STATENUM RANGE A .. ENUMERATION'VAL(IDENT_INT(5));
ENUM: DYNENUM := B ;
CONS : CONSTANT DYN := 3;
FUNCTION FF RETURN DYN IS
BEGIN
RETURN 2 ;
END FF ;
BEGIN
I := IDENT_INT( 2 );
J := IDENT_INT( 2 );
CASE I IS
WHEN 1 | 3 | 5 => NULL ;
WHEN 2 | 4 => NULL ;
WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
END CASE;
CASE J IS
WHEN 1 | 3 | 5 => NULL ;
WHEN 2 | 4 => NULL ;
WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
END CASE;
CASE CONS IS
WHEN INTEGER'FIRST..INTEGER'LAST => NULL;
END CASE;
CASE DYN'FIRST IS
WHEN INTEGER'FIRST..0 => NULL;
WHEN 1..INTEGER'LAST => NULL;
END CASE;
CASE STATCHAR'LAST IS
WHEN CHARACTER'FIRST..'A' => NULL;
WHEN 'B'..CHARACTER'LAST => NULL;
END CASE;
CASE FF IS
WHEN 4..5 => NULL ;
WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
WHEN 1..3 => NULL ;
END CASE;
CASE DYN'( 2 ) IS
WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
WHEN 5 | 2..4 => NULL ;
WHEN 1 => NULL ;
END CASE;
CASE DYN( J ) IS
WHEN 5 | 2..4 => NULL ;
WHEN 1 => NULL ;
WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
END CASE;
CASE ( CHAR ) IS
WHEN ASCII.NUL .. 'P' => NULL ;
WHEN 'Q' => NULL ;
WHEN 'R' .. 'Y' => NULL ;
WHEN 'Z' .. CHARACTER'LAST => NULL ;
END CASE;
CASE ( ENUM ) IS
WHEN A | C | E => NULL ;
WHEN B | D => NULL ;
WHEN F .. L => NULL ;
WHEN M .. N => NULL ;
END CASE;
CASE ( FF ) IS
WHEN 1 | 3 | 5 => NULL ;
WHEN 2 | 4 => NULL ;
WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
END CASE;
CASE ( DYN'( I ) ) IS
WHEN 4..5 => NULL ;
WHEN 1..3 => NULL ;
WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
END CASE;
CASE ( DYN( 2 ) ) IS
WHEN 5 | 2..4 => NULL ;
WHEN 1 => NULL ;
WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
END CASE;
CASE (CONS) IS
WHEN 1..100 => NULL;
WHEN INTEGER'FIRST..0 => NULL;
WHEN 101..INTEGER'LAST => NULL;
END CASE;
CASE (DYNCHAR'LAST) IS
WHEN 'B'..'Y' => NULL;
WHEN CHARACTER'FIRST..'A' => NULL;
WHEN 'Z'..CHARACTER'LAST => NULL;
END CASE;
END;
RESULT ;
END A54B02A ;

147
gcc/testsuite/ada/acats/tests/a/a55b12a.ada Normal file
View File

@ -0,0 +1,147 @@
-- A55B12A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT THE SUBTYPE OF A LOOP PARAMETER IN A LOOP OF THE FORM
--
-- FOR I IN ST RANGE L..R LOOP
--
-- IS CORRECTLY DETERMINED SO THAT WHEN THE LOOP PARAMETER IS USED
-- IN A CASE STATEMENT AN 'OTHERS' ALTERNATIVE IS NOT REQUIRED IF
-- THE CHOICES COVER THE APPROPRIATE RANGE OF SUBTYPE VALUES.
-- CASE A :
-- L AND R ARE BOTH STATIC EXPRESSIONS, AND ST IS A STATIC
-- SUBTYPE COVERING A RANGE GREATER THAN L..R .
-- RM 02/02/80
-- JRK 03/02/83
WITH REPORT ;
PROCEDURE A55B12A IS
USE REPORT ;
BEGIN
TEST("A55B12A" , "CHECK THAT THE SUBTYPE OF A LOOP PARAMETER" &
" IN A LOOP OF THE FORM 'FOR I IN ST RANGE" &
" L..R LOOP' IS CORRECTLY DETERMINED (A)" );
DECLARE
SUBTYPE STAT IS INTEGER RANGE 1..10 ;
TYPE NEW_STAT IS NEW INTEGER RANGE 1..10 ;
TYPE ENUMERATION IS ( A,B,C,D,E,F,G,H,K,L,M,N );
SUBTYPE STAT_E IS ENUMERATION RANGE A..L ;
SUBTYPE STAT_B IS BOOLEAN RANGE FALSE..TRUE ;
SUBTYPE STAT_C IS CHARACTER RANGE 'A'..'L' ;
BEGIN
FOR I IN STAT RANGE 1..5 LOOP
CASE I IS
WHEN 1 | 3 | 5 => NULL ;
WHEN 2 | 4 => NULL ;
END CASE;
END LOOP;
FOR I IN NEW_STAT RANGE 1..5 LOOP
CASE I IS
WHEN 1 | 3 | 5 => NULL ;
WHEN 2 | 4 => NULL ;
END CASE;
END LOOP;
FOR I IN INTEGER RANGE 1..5 LOOP
CASE I IS
WHEN 1 | 3 | 5 => NULL ;
WHEN 2 | 4 => NULL ;
END CASE;
END LOOP;
FOR I IN REVERSE STAT RANGE 1..5 LOOP
CASE I IS
WHEN 1 | 3 | 5 => NULL ;
WHEN 2 | 4 => NULL ;
END CASE;
END LOOP;
FOR I IN STAT_E RANGE A..E LOOP
CASE I IS
WHEN C..E => NULL ;
WHEN A..B => NULL ;
END CASE;
END LOOP;
FOR I IN STAT_B RANGE TRUE..TRUE LOOP
CASE I IS
WHEN TRUE => NULL ;
END CASE;
END LOOP;
FOR I IN STAT_C RANGE 'A'..'E' LOOP
CASE I IS
WHEN 'A'..'C' => NULL ;
WHEN 'D'..'E' => NULL ;
END CASE;
END LOOP;
FOR I IN STAT_C RANGE 'E'..'B' LOOP
CASE I IS
WHEN 'D'..'C' => NULL ;
WHEN 'E'..'B' => NULL ;
WHEN 'F'..'A' => NULL ;
WHEN 'M'..'A' => NULL ;
END CASE;
END LOOP;
END ;
RESULT ;
END A55B12A ;

128
gcc/testsuite/ada/acats/tests/a/a55b13a.ada Normal file
View File

@ -0,0 +1,128 @@
-- A55B13A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- USING A CASE_STATEMENT , CHECK THAT IF L , R ARE LITERALS
-- OF TYPE T (INTEGER, BOOLEAN, CHARACTER, USER-DEFINED
-- ENUMERATION TYPE) THE SUBTYPE BOUNDS ASSOCIATED WITH A
-- LOOP OF THE FORM
-- FOR I IN L..R LOOP
-- ARE THE SAME AS THOSE FOR THE CORRESPONDING LOOP OF THE FORM
-- FOR I IN T RANGE L..R LOOP .
-- RM 04/07/81
-- SPS 3/2/83
-- JBG 8/21/83
-- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
WITH REPORT ;
PROCEDURE A55B13A IS
USE REPORT ;
BEGIN
TEST("A55B13A" , "CHECK THAT THE SUBTYPE OF A LOOP PARAMETER" &
" IN A LOOP OF THE FORM 'FOR I IN " &
" LITERAL_L .. LITERAL_R LOOP' IS CORRECTLY" &
" DETERMINED" );
DECLARE
TYPE ENUMERATION IS ( A,B,C,D,MIDPOINT,E,F,G,H );
ONE : CONSTANT := 1 ;
FIVE : CONSTANT := 5 ;
BEGIN
FOR I IN 1..5 LOOP
CASE I IS
WHEN 1 | 3 | 5 => NULL ;
WHEN 2 | 4 => NULL ;
END CASE;
END LOOP;
FOR I IN REVERSE ONE .. FIVE LOOP
CASE I IS
WHEN 1 | 3 | 5 => NULL ;
WHEN 2 | 4 => NULL ;
END CASE;
END LOOP;
FOR I IN REVERSE FALSE..TRUE LOOP
CASE I IS
WHEN FALSE => NULL ;
WHEN TRUE => NULL ;
END CASE;
END LOOP;
FOR I IN CHARACTER'('A') .. ASCII.DEL LOOP
CASE I IS
WHEN CHARACTER'('A')..CHARACTER'('U') => NULL ;
WHEN CHARACTER'('V')..ASCII.DEL => NULL ;
END CASE;
END LOOP;
FOR I IN CHARACTER'('A')..CHARACTER'('H') LOOP
CASE I IS
WHEN CHARACTER'('A')..CHARACTER'('D') => NULL ;
WHEN CHARACTER'('E')..CHARACTER'('H') => NULL ;
END CASE;
END LOOP;
FOR I IN REVERSE B..H LOOP
CASE I IS
WHEN B..D => NULL ;
WHEN E..H => NULL ;
WHEN MIDPOINT => NULL ;
END CASE;
END LOOP;
END ;
RESULT ;
END A55B13A ;

112
gcc/testsuite/ada/acats/tests/a/a55b14a.ada Normal file
View File

@ -0,0 +1,112 @@
-- A55B14A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- USING A CASE_STATEMENT , CHECK THAT THE SUBTYPE BOUNDS ASSOCIATED
-- WITH A LOOP OF THE FORM
-- FOR I IN ST LOOP
-- ARE, RESPECTIVELY, ST'FIRST..ST'LAST WHEN ST IS STATIC.
-- RM 04/07/81
-- SPS 3/2/83
-- JBG 3/14/83
WITH REPORT;
PROCEDURE A55B14A IS
USE REPORT;
USE ASCII ;
TYPE ENUMERATION IS ( A,B,C,D,MIDPOINT,E,F,G,H );
SUBTYPE ST_I IS INTEGER RANGE 1..5 ;
TYPE NEW_ST_I IS NEW INTEGER RANGE 1..5 ;
SUBTYPE ST_E IS ENUMERATION RANGE B..G ;
SUBTYPE ST_B IS BOOLEAN RANGE FALSE..FALSE;
SUBTYPE ST_C IS CHARACTER RANGE 'A'..DEL ;
BEGIN
TEST("A55B14A" , "CHECK THAT THE SUBTYPE OF A LOOP PARAMETER" &
" IN A LOOP OF THE FORM 'FOR I IN ST LOOP'" &
" ARE CORRECTLY DETERMINED WHEN ST IS STATIC" );
BEGIN
FOR I IN ST_I LOOP
CASE I IS
WHEN 1 | 3 | 5 => NULL;
WHEN 2 | 4 => NULL;
END CASE;
END LOOP;
FOR I IN NEW_ST_I LOOP
CASE I IS
WHEN 1 | 3 | 5 => NULL;
WHEN 2 | 4 => NULL;
END CASE;
END LOOP;
FOR I IN ST_B LOOP
CASE I IS
WHEN FALSE => NULL;
END CASE;
END LOOP;
FOR I IN ST_C LOOP
CASE I IS
WHEN 'A'..'U' => NULL;
WHEN 'V'..DEL => NULL;
END CASE;
END LOOP;
FOR I IN ST_E LOOP
CASE I IS
WHEN B..D => NULL;
WHEN E..G => NULL;
WHEN MIDPOINT => NULL;
END CASE;
END LOOP;
END;
RESULT;
END A55B14A;

130
gcc/testsuite/ada/acats/tests/a/a71004a.ada Normal file
View File

@ -0,0 +1,130 @@
-- A71004A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT ALL FORMS OF DECLARATION PERMITTED IN THE PRIVATE PART OF
-- A PACKAGE ARE INDEED ACCEPTED BY THE COMPILER.
-- TASKS, GENERICS, FIXED AND FLOAT DECLARATIONS ARE NOT TESTED.
-- DAT 5/6/81
-- VKG 2/16/83
WITH REPORT; USE REPORT;
PROCEDURE A71004A IS
BEGIN
TEST ("A71004A", "ALL FORMS OF DECLARATIONS IN PRIVATE PART");
DD:
DECLARE
PACKAGE P1 IS
TYPE P IS PRIVATE;
TYPE L IS LIMITED PRIVATE;
CP : CONSTANT P;
CL : CONSTANT L;
PRIVATE
ONE : CONSTANT := 1;
TWO : CONSTANT := ONE * 1.0 + 1.0;
N1, N2, N3 : CONSTANT := TWO;
TYPE I IS RANGE -10 .. 10;
X4, X5 : CONSTANT I := I(IDENT_INT(3));
X6, X7 : I := X4 + X5;
TYPE AR IS ARRAY (I) OF L;
X10 : ARRAY (IDENT_INT(1) .. IDENT_INT (10)) OF I;
X11 : CONSTANT ARRAY (1..10) OF I := (1..10=>3);
TYPE T3 IS (E12);
TYPE T4 IS NEW T3;
TYPE REC1 (D:BOOLEAN:=TRUE) IS RECORD NULL; END RECORD;
SUBTYPE REC1TRUE IS REC1( D => TRUE ) ;
TYPE L IS NEW REC1TRUE ;
X8 , X9 : AR;
TYPE A6 IS ACCESS REC1 ;
SUBTYPE L1 IS L ;
SUBTYPE A7 IS A6(D=>TRUE);
SUBTYPE I14 IS I RANGE 1 .. 1;
TYPE UA1 IS ARRAY (I14 RANGE <> ) OF I14;
TYPE UA2 IS NEW UA1;
USE STANDARD.ASCII;
PROCEDURE P1 ;
FUNCTION F1 (X : UA1) RETURN UA1;
FUNCTION "+" (X : UA1) RETURN UA1;
PACKAGE PK IS
PRIVATE
END;
PACKAGE PK1 IS
PACKAGE PK2 IS END;
PRIVATE
PACKAGE PK3 IS PRIVATE END;
END PK1;
EX : EXCEPTION;
EX1, EX2 : EXCEPTION;
X99 : I RENAMES X7;
EX3 : EXCEPTION RENAMES EX1;
PACKAGE PQ1 RENAMES DD.P1;
PACKAGE PQ2 RENAMES PK1;
PACKAGE PQ3 RENAMES PQ2 . PK2;
FUNCTION "-" (X : UA1) RETURN UA1 RENAMES "+";
PROCEDURE P98 RENAMES P1;
TYPE P IS NEW L;
CP : CONSTANT P := (D=> TRUE);
CL : CONSTANT L := L(CP);
END P1;
PACKAGE BODY P1 IS
PROCEDURE P1 IS BEGIN NULL; END P1;
FUNCTION F1 (X : UA1) RETURN UA1 IS
BEGIN RETURN X; END F1;
FUNCTION "+" (X : UA1) RETURN UA1 IS
BEGIN RETURN F1(X); END "+";
PACKAGE BODY PK1 IS
PACKAGE BODY PK3 IS END;
END PK1;
BEGIN
NULL ;
END P1;
BEGIN
NULL;
END DD;
RESULT;
END A71004A;

73
gcc/testsuite/ada/acats/tests/a/a73001i.ada Normal file
View File

@ -0,0 +1,73 @@
-- A73001I.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT IF A SUBPROGRAM IS DECLARED BY A RENAMING DECLARATION OR
-- GENERIC INSTANTIATION IN A PACKAGE SPECIFICATION NO PACKAGE BODY IS
-- REQUIRED.
-- BHS 6/26/84
WITH REPORT;
PROCEDURE A73001I IS
USE REPORT;
BEGIN
TEST ("A73001I", "CHECK THAT NO PACKAGE BODY IS REQUIRED FOR " &
"SUBPROGRAM DECLARED BY RENAMING DECLARATION " &
"OR GENERIC INSTANTIATION IN A PACKAGE " &
"SPECIFICATION");
DECLARE
PACKAGE PACK1 IS
FUNCTION ADDI (X,Y : INTEGER) RETURN INTEGER RENAMES "+";
END PACK1;
BEGIN
NULL;
END;
DECLARE
GENERIC
TYPE ITEM IS RANGE <>;
PROCEDURE P (X : IN OUT ITEM);
PROCEDURE P (X : IN OUT ITEM) IS
BEGIN
NULL;
END P;
PACKAGE PACK2 IS
PROCEDURE NADA IS NEW P (INTEGER);
END PACK2;
BEGIN
NULL;
END;
RESULT;
END A73001I;

78
gcc/testsuite/ada/acats/tests/a/a73001j.ada Normal file
View File

@ -0,0 +1,78 @@
-- A73001J.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT IF A SUBPROGRAM IS DECLARED BY A RENAMING DECLARATION OR
-- GENERIC INSTANTIATION IN A GENERIC PACKAGE SPECIFICATION, NO PACKAGE
-- BODY IS REQUIRED.
-- BHS 6/27/84
WITH REPORT;
PROCEDURE A73001J IS
USE REPORT;
BEGIN
TEST ("A73001J", "CHECK THAT NO PACKAGE BODY IS REQUIRED FOR " &
"SUBPROGRAM DECLARED BY RENAMING DECLARATION " &
"OR GENERIC INSTANTIATION IN A GENERIC " &
"PACKAGE SPECIFICATION");
DECLARE
GENERIC
TYPE ITEM IS RANGE <>;
PACKAGE PACK1 IS
FUNCTION ADDI (X,Y : ITEM) RETURN ITEM RENAMES "+";
END PACK1;
BEGIN
NULL;
END;
DECLARE
GENERIC
TYPE ITEM IS RANGE <>;
PROCEDURE P (X : IN OUT ITEM);
PROCEDURE P (X : IN OUT ITEM) IS
BEGIN
NULL;
END P;
GENERIC
TYPE OBJ IS RANGE <>;
PACKAGE PACK2 IS
PROCEDURE NADA IS NEW P (OBJ);
END PACK2;
BEGIN
NULL;
END;
RESULT;
END A73001J;

78
gcc/testsuite/ada/acats/tests/a/a74105b.ada Normal file
View File

@ -0,0 +1,78 @@
-- A74105B.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT THE FULL TYPE DECLARATION OF A PRIVATE TYPE WITHOUT
-- DISCRIMINANTS MAY BE A CONSTRAINED TYPE WITH DISCRIMINANTS.
-- DSJ 4/29/83
-- SPS 10/22/83
WITH REPORT;
PROCEDURE A74105B IS
USE REPORT;
BEGIN
TEST ("A74105B", "CHECK THAT THE FULL TYPE DECLARATION OF A " &
"PRIVATE TYPE WITHOUT DISCRIMINANTS MAY BE " &
"A CONSTRAINED TYPE WITH DISCRIMINANTS");
DECLARE
TYPE REC1 (D : INTEGER) IS
RECORD
C1, C2 : INTEGER;
END RECORD;
TYPE REC2 (F : INTEGER := 0) IS
RECORD
E1, E2 : INTEGER;
END RECORD;
TYPE REC3 IS NEW REC1 (D => 1);
TYPE REC4 IS NEW REC2 (F => 2);
PACKAGE PACK1 IS
TYPE P1 IS PRIVATE;
TYPE P2 IS PRIVATE;
TYPE P3 IS PRIVATE;
TYPE P4 IS PRIVATE;
PRIVATE
TYPE P1 IS ACCESS REC1;
TYPE P2 IS NEW REC4;
TYPE P3 IS NEW REC1 (D => 5);
TYPE P4 IS NEW REC2 (F => 7);
END PACK1;
BEGIN
NULL;
END;
RESULT;
END A74105B;

168
gcc/testsuite/ada/acats/tests/a/a74106a.ada Normal file
View File

@ -0,0 +1,168 @@
-- A74106A.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT A FULL DECLARATION FOR A PRIVATE TYPE OR FOR A LIMITED
-- PRIVATE TYPE CAN BE GIVEN IN TERMS OF ANY SCALAR TYPE, ARRAY TYPE,
-- RECORD TYPE (WITH OR WITHOUT DISCRIMINANTS), ACCESS TYPE (WITH
-- OR WITHOUT DISCRIMINANTS), OR ANY TYPE DERIVED FROM ANY OF THE
-- ABOVE.
-- PART A: TYPES NOT INVOLVING FLOATING-POINT DATA OR FIXED-POINT DATA.
-- RM 05/13/81
WITH REPORT;
PROCEDURE A74106A IS
USE REPORT;
BEGIN
TEST( "A74106A" , "CHECK THAT PRIVATE TYPES AND LIMITED PRIVATE " &
"TYPES CAN BE DEFINED IN TERMS OF " &
"VARIOUS OTHER TYPES" );
DECLARE
TYPE ENUM IS ( A , B , C , D );
PACKAGE P0 IS
TYPE T0 IS PRIVATE;
PRIVATE
TYPE T0 IS NEW INTEGER;
END P0;
PACKAGE P1 IS
USE P0;
TYPE T1 IS PRIVATE;
TYPE T2 IS PRIVATE;
TYPE T3 IS PRIVATE;
TYPE T4 IS PRIVATE;
TYPE T5 IS PRIVATE;
TYPE T6 IS PRIVATE;
TYPE T7 IS PRIVATE;
TYPE T8 IS PRIVATE;
TYPE T9 IS PRIVATE;
TYPE TA IS PRIVATE;
TYPE TB IS PRIVATE;
TYPE TC IS PRIVATE;
TYPE TD(I : INTEGER) IS PRIVATE;
TYPE NT IS NEW ENUM;
TYPE ARR_T IS ARRAY(1..2) OF BOOLEAN;
TYPE ACC_T IS ACCESS CHARACTER;
TYPE REC_T IS RECORD T : BOOLEAN; END RECORD;
TYPE D_REC_T(I : INTEGER := 1) IS
RECORD T : ENUM; END RECORD;
PRIVATE
TYPE TY(B : BOOLEAN) IS
RECORD G : BOOLEAN; END RECORD;
TYPE TC IS NEW T0;
TYPE T1 IS RANGE 1..100;
TYPE T2 IS NEW CHARACTER RANGE 'A'..'Z';
TYPE T3 IS NEW NT;
TYPE T4 IS ARRAY(1..2) OF INTEGER;
TYPE T5 IS NEW ARR_T;
TYPE T6 IS ACCESS ENUM;
TYPE T7 IS NEW ACC_T;
TYPE T8 IS
RECORD T : CHARACTER; END RECORD;
TYPE T9 IS NEW REC_T;
TYPE TA IS ACCESS TD;
TYPE TB IS ACCESS D_REC_T;
TYPE TD(I : INTEGER) IS
RECORD G : BOOLEAN; END RECORD;
END P1;
BEGIN
NULL;
END;
DECLARE
TYPE ENUM IS ( A , B , C , D );
PACKAGE P0 IS
TYPE T0 IS LIMITED PRIVATE;
PRIVATE
TYPE T0 IS NEW ENUM;
END P0;
PACKAGE P1 IS
USE P0;
TYPE T1 IS LIMITED PRIVATE;
TYPE T2 IS LIMITED PRIVATE;
TYPE T3 IS LIMITED PRIVATE;
TYPE T4 IS LIMITED PRIVATE;
TYPE T5 IS LIMITED PRIVATE;
TYPE T6 IS LIMITED PRIVATE;
TYPE T7 IS LIMITED PRIVATE;
TYPE T8 IS LIMITED PRIVATE;
TYPE T9 IS LIMITED PRIVATE;
TYPE TA IS LIMITED PRIVATE;
TYPE TB IS LIMITED PRIVATE;
TYPE TC IS LIMITED PRIVATE;
TYPE TD(I : INTEGER) IS LIMITED PRIVATE;
TYPE NT IS NEW ENUM;
TYPE ARR_T IS ARRAY(1..2) OF BOOLEAN;
TYPE ACC_T IS ACCESS CHARACTER;
TYPE REC_T IS RECORD T : BOOLEAN; END RECORD;
TYPE D_REC_T(I : INTEGER := 1) IS
RECORD T : ENUM; END RECORD;
PRIVATE
TYPE TY(B : BOOLEAN) IS
RECORD G : BOOLEAN; END RECORD;
TYPE TC IS NEW T0;
TYPE T1 IS RANGE 1..100;
TYPE T2 IS NEW CHARACTER RANGE 'A'..'Z';
TYPE T3 IS NEW NT;
TYPE T4 IS ARRAY(1..2) OF INTEGER;
TYPE T5 IS NEW ARR_T;
TYPE T6 IS ACCESS ENUM;
TYPE T7 IS NEW ACC_T;
TYPE T8 IS RECORD T : CHARACTER; END RECORD;
TYPE T9 IS NEW REC_T;
TYPE TA IS ACCESS TD;
TYPE TB IS ACCESS D_REC_T;
TYPE TD(I : INTEGER) IS
RECORD G : BOOLEAN; END RECORD;
END P1;
BEGIN
NULL;
END;
RESULT;
END A74106A;

159
gcc/testsuite/ada/acats/tests/a/a74106b.ada Normal file
View File

@ -0,0 +1,159 @@
-- A74106B.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT A FULL DECLARATION FOR A PRIVATE TYPE OR FOR A LIMITED
-- PRIVATE TYPE CAN BE GIVEN IN TERMS OF ANY SCALAR TYPE, ARRAY TYPE,
-- RECORD TYPE (WITH OR WITHOUT DISCRIMINANTS), ACCESS TYPE (WITH
-- OR WITHOUT DISCRIMINANTS), OR ANY TYPE DERIVED FROM ANY OF THE
-- ABOVE.
-- PART B: TYPES INVOLVING FLOATING-POINT DATA.
-- RM 05/08/81
WITH REPORT;
PROCEDURE A74106B IS
USE REPORT;
BEGIN
TEST( "A74106B" , "CHECK THAT PRIVATE TYPES AND LIMITED PRIVATE " &
"TYPES CAN BE DEFINED IN TERMS OF " &
"FLOATING-POINT TYPES" );
DECLARE
PACKAGE P0 IS
TYPE F0 IS PRIVATE;
PRIVATE
TYPE F0 IS NEW FLOAT;
END P0;
PACKAGE P1 IS
USE P0;
TYPE F1 IS PRIVATE;
TYPE F2 IS PRIVATE;
TYPE F3 IS PRIVATE;
TYPE F4 IS PRIVATE;
TYPE F5 IS PRIVATE;
TYPE F6 IS PRIVATE;
TYPE F7 IS PRIVATE;
TYPE F8 IS PRIVATE;
TYPE F9 IS PRIVATE;
TYPE FA IS PRIVATE;
TYPE FB IS PRIVATE;
TYPE FC IS PRIVATE;
TYPE FD(I : INTEGER) IS PRIVATE;
TYPE NF IS NEW FLOAT;
TYPE ARR_F IS ARRAY(1..2) OF FLOAT;
TYPE ACC_F IS ACCESS FLOAT;
TYPE REC_F IS RECORD F : FLOAT; END RECORD;
TYPE D_REC_F(I : INTEGER := 1) IS
RECORD F : FLOAT; END RECORD;
PRIVATE
TYPE FY(B : BOOLEAN) IS RECORD G : FLOAT; END RECORD;
TYPE FC IS NEW F0;
TYPE F1 IS DIGITS 3;
TYPE F2 IS NEW FLOAT DIGITS 4;
TYPE F3 IS NEW NF;
TYPE F4 IS ARRAY(1..2) OF FLOAT;
TYPE F5 IS NEW ARR_F;
TYPE F6 IS ACCESS FLOAT;
TYPE F7 IS NEW ACC_F;
TYPE F8 IS RECORD F : FLOAT; END RECORD;
TYPE F9 IS NEW REC_F;
TYPE FA IS ACCESS FD;
TYPE FB IS ACCESS D_REC_F;
TYPE FD(I : INTEGER) IS RECORD G : FLOAT; END RECORD;
END P1;
BEGIN
NULL;
END;
DECLARE
PACKAGE P0 IS
TYPE F0 IS LIMITED PRIVATE;
PRIVATE
TYPE F0 IS NEW FLOAT;
END P0;
PACKAGE P1 IS
USE P0;
TYPE F1 IS LIMITED PRIVATE;
TYPE F2 IS LIMITED PRIVATE;
TYPE F3 IS LIMITED PRIVATE;
TYPE F4 IS LIMITED PRIVATE;
TYPE F5 IS LIMITED PRIVATE;
TYPE F6 IS LIMITED PRIVATE;
TYPE F7 IS LIMITED PRIVATE;
TYPE F8 IS LIMITED PRIVATE;
TYPE F9 IS LIMITED PRIVATE;
TYPE FA IS LIMITED PRIVATE;
TYPE FB IS LIMITED PRIVATE;
TYPE FC IS LIMITED PRIVATE;
TYPE FD(I : INTEGER) IS LIMITED PRIVATE;
TYPE NF IS NEW FLOAT;
TYPE ARR_F IS ARRAY(1..2) OF FLOAT;
TYPE ACC_F IS ACCESS FLOAT;
TYPE REC_F IS RECORD F : FLOAT; END RECORD;
TYPE D_REC_F(I : INTEGER := 1) IS
RECORD F : FLOAT; END RECORD;
PRIVATE
TYPE FY(B : BOOLEAN) IS RECORD G : FLOAT; END RECORD;
TYPE FC IS NEW F0;
TYPE F1 IS DIGITS 3;
TYPE F2 IS NEW FLOAT DIGITS 4;
TYPE F3 IS NEW NF;
TYPE F4 IS ARRAY(1..2) OF FLOAT;
TYPE F5 IS NEW ARR_F;
TYPE F6 IS ACCESS FLOAT;
TYPE F7 IS NEW ACC_F;
TYPE F8 IS RECORD F : FLOAT; END RECORD;
TYPE F9 IS NEW REC_F;
TYPE FA IS ACCESS FD;
TYPE FB IS ACCESS D_REC_F;
TYPE FD(I : INTEGER) IS RECORD G : FLOAT; END RECORD;
END P1;
BEGIN
NULL;
END;
RESULT;
END A74106B;

155
gcc/testsuite/ada/acats/tests/a/a74106c.ada Normal file
View File

@ -0,0 +1,155 @@
-- A74106C.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT A FULL DECLARATION FOR A PRIVATE TYPE OR FOR A LIMITED
-- PRIVATE TYPE CAN BE GIVEN IN TERMS OF ANY SCALAR TYPE, ARRAY
-- TYPE, RECORD TYPE (WITH OR WITHOUT DISCRIMINANTS), ACCESS TYPE
-- (WITH OR WITHOUT DISCRIMINANTS), OR ANY TYPE DERIVED FROM ANY
-- OF THE ABOVE.
-- PART C: TYPES INVOLVING FIXED-POINT DATA.
-- HISTORY:
-- RM 05/11/81 CREATED ORIGINAL TEST.
-- DHH 10/15/87 CORRECTED RANGE ERRORS.
WITH REPORT;
PROCEDURE A74106C IS
USE REPORT;
BEGIN
TEST( "A74106C" , "CHECK THAT PRIVATE TYPES AND LIMITED PRIVATE" &
" TYPES CAN BE DEFINED IN TERMS OF" &
" FIXED-POINT TYPES" );
DECLARE
PACKAGE P0 IS
TYPE F0 IS PRIVATE;
PRIVATE
TYPE F0 IS DELTA 1.0 RANGE 0.0 .. 10.0;
END P0;
PACKAGE P1 IS
USE P0;
TYPE FX IS DELTA 0.1 RANGE 0.0 .. 1.0;
TYPE F1 IS PRIVATE;
TYPE F2 IS PRIVATE;
TYPE F3 IS PRIVATE;
TYPE F4 IS PRIVATE;
TYPE F5 IS PRIVATE;
TYPE F6 IS PRIVATE;
TYPE F7 IS PRIVATE;
TYPE F8 IS PRIVATE;
TYPE F9 IS PRIVATE;
TYPE FA IS PRIVATE;
TYPE FB IS PRIVATE;
TYPE FC IS PRIVATE;
TYPE NF IS DELTA 0.1 RANGE 1.0 .. 2.0;
TYPE ARR_F IS ARRAY(1..2) OF FX;
TYPE ACC_F IS ACCESS FX;
TYPE REC_F IS RECORD F : FX; END RECORD;
TYPE D_REC_F(I : INTEGER := 1) IS
RECORD F : FX; END RECORD;
PRIVATE
TYPE FC IS NEW F0;
TYPE F1 IS DELTA 100.0 RANGE -100.0 .. 900.0;
TYPE F2 IS NEW FX RANGE 0.0 .. 0.5;
TYPE F3 IS NEW NF;
TYPE F4 IS ARRAY(1..2) OF FX;
TYPE F5 IS NEW ARR_F;
TYPE F6 IS ACCESS FX;
TYPE F7 IS NEW ACC_F;
TYPE F8 IS RECORD F : FX; END RECORD;
TYPE F9 IS NEW REC_F;
TYPE FA IS ACCESS D_REC_F;
TYPE FB IS ACCESS D_REC_F;
END P1;
BEGIN
NULL;
END;
DECLARE
PACKAGE P0 IS
TYPE F0 IS LIMITED PRIVATE;
PRIVATE
TYPE F0 IS DELTA 1.0 RANGE 0.0 .. 10.0;
END P0;
PACKAGE P1 IS
USE P0;
TYPE FX IS DELTA 0.1 RANGE 0.0 .. 1.0;
TYPE F1 IS LIMITED PRIVATE;
TYPE F2 IS LIMITED PRIVATE;
TYPE F3 IS LIMITED PRIVATE;
TYPE F4 IS LIMITED PRIVATE;
TYPE F5 IS LIMITED PRIVATE;
TYPE F6 IS LIMITED PRIVATE;
TYPE F7 IS LIMITED PRIVATE;
TYPE F8 IS LIMITED PRIVATE;
TYPE F9 IS LIMITED PRIVATE;
TYPE FA IS LIMITED PRIVATE;
TYPE FB IS LIMITED PRIVATE;
TYPE FC IS LIMITED PRIVATE;
TYPE NF IS DELTA 0.1 RANGE 1.0 .. 2.0;
TYPE ARR_F IS ARRAY(1..2) OF FX;
TYPE ACC_F IS ACCESS FX;
TYPE REC_F IS RECORD F : FX; END RECORD;
TYPE D_REC_F(I : INTEGER := 1) IS
RECORD F : FX; END RECORD;
PRIVATE
TYPE FC IS NEW F0;
TYPE F1 IS DELTA 100.0 RANGE -100.0 .. 900.0;
TYPE F2 IS NEW FX RANGE 0.0 .. 0.5;
TYPE F3 IS NEW NF;
TYPE F4 IS ARRAY(1..2) OF FX;
TYPE F5 IS NEW ARR_F;
TYPE F6 IS ACCESS FX;
TYPE F7 IS NEW ACC_F;
TYPE F8 IS RECORD F : FX; END RECORD;
TYPE F9 IS NEW REC_F;
TYPE FA IS ACCESS D_REC_F;
TYPE FB IS ACCESS D_REC_F;
END P1;
BEGIN
NULL;
END;
RESULT;
END A74106C;

Some files were not shown because too many files have changed in this diff Show More