Skip to content

R
riscv-gcc-1
Commit 8d39e92b by Arnaud Charlet
Options

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

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

From-SVN: r72977
parent 57b4edef
Showing with 4967 additions and 0 deletions

Too many changes to show.
Plain diff Email patch

To preserve performance only 1000 of 1000+ files are displayed.

gcc/testsuite/ada/acats/elabd.lst 0 → 100644
c731001
c854002
ca11018
ca11019
ca5006a
gcc/testsuite/ada/acats/norun.lst 0 → 100644
templat
# Tests must be sorted in alphabetical order
gcc/testsuite/ada/acats/overflow.lst 0 → 100644
c45632a
c45632b
c45632c
c45504a
c45504b
c45504c
c45613a
c45613b
c45613c
c45304a
c45304b
c45304c
c46014a
c460008
c460011
c4a012b
gcc/testsuite/ada/acats/run_acats 0 → 100755
#!/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 "$@"
gcc/testsuite/ada/acats/run_all.sh 0 → 100755
#!/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
gcc/testsuite/ada/acats/support/checkfil.ada 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/enumchek.ada 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f340a000.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f340a001.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f341a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f390a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f392a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f392c00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f392d00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f393a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f393b00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f3a2a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f460a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f730a000.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f730a001.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f731a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/f940a00.a 0 → 100644
-- 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
gcc/testsuite/ada/acats/support/f954a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fa11a00.a 0 → 100644
-- 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
gcc/testsuite/ada/acats/support/fa11b00.a 0 → 100644
-- 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
gcc/testsuite/ada/acats/support/fa11c00.a 0 → 100644
-- 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
gcc/testsuite/ada/acats/support/fa11d00.a 0 → 100644
-- 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
gcc/testsuite/ada/acats/support/fa13a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fa13b00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fa21a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fb20a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fb40a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fc50a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fc51a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fc51b00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fc51c00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fc51d00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fc54a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fc70a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fc70b00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fc70c00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fcndecl.ada 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fd72a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fdb0a00.a 0 → 100644
-- 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;
gcc/testsuite/ada/acats/support/fdd2a00.a 0 → 100644
-- 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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment