URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c7/] [c731001.a] - Rev 294
Compare with Previous | Blame | View Log
-- C731001.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
-- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
-- software and documentation contained herein. Unlimited rights are
-- defined in DFAR 252.227-7013(a)(19). By making this public release,
-- the Government intends to confer upon all recipients unlimited rights
-- equal to those held by the Government. These rights include rights to
-- use, duplicate, release or disclose the released technical data and
-- computer software in whole or in part, in any manner and for any purpose
-- whatsoever, and to have or permit others to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE
-- Check that inherited operations can be overridden, even when they are
-- inherited in a body.
-- The test cases here are inspired by the AARM examples given in
-- the discussion of AARM-7.3.1(7.a-7.v).
-- This discussion was confirmed by AI95-00035.
--
-- TEST DESCRIPTION
-- See AARM-7.3.1.
--
-- CHANGE HISTORY:
-- 29 JUN 1999 RAD Initial Version
-- 23 SEP 1999 RLB Improved comments, renamed, issued.
-- 20 AUG 2001 RLB Corrected 'verbose' flag.
--
--!
with Report; use Report; pragma Elaborate_All(Report);
package C731001_1 is
pragma Elaborate_Body;
private
procedure Check_String(X, Y: String);
function Check_String(X, Y: String) return String;
-- This one is a function, so we can call it in package specs.
end C731001_1;
package body C731001_1 is
Verbose: Boolean := False;
procedure Check_String(X, Y: String) is
begin
if Verbose then
Comment("""" & X & """ = """ & Y & """?");
end if;
if X /= Y then
Failed("""" & X & """ should be """ & Y & """");
end if;
end Check_String;
function Check_String(X, Y: String) return String is
begin
Check_String(X, Y);
return X;
end Check_String;
end C731001_1;
private package C731001_1.Parent is
procedure Call_Main;
type Root is tagged null record;
subtype Renames_Root is Root;
subtype Root_Class is Renames_Root'Class;
function Make return Root;
function Op1(X: Root) return String;
function Call_Op2(X: Root'Class) return String;
private
function Op2(X: Root) return String;
end C731001_1.Parent;
procedure C731001_1.Parent.Main;
with C731001_1.Parent.Main;
package body C731001_1.Parent is
procedure Call_Main is
begin
Main;
end Call_Main;
function Make return Root is
Result: Root;
begin
return Result;
end Make;
function Op1(X: Root) return String is
begin
return "Parent.Op1 body";
end Op1;
function Op2(X: Root) return String is
begin
return "Parent.Op2 body";
end Op2;
function Call_Op2(X: Root'Class) return String is
begin
return Op2(X);
end Call_Op2;
begin
Check_String(Op1(Root'(Make)), "Parent.Op1 body");
Check_String(Op1(Root_Class(Root'(Make))), "Parent.Op1 body");
Check_String(Op2(Root'(Make)), "Parent.Op2 body");
Check_String(Op2(Root_Class(Root'(Make))), "Parent.Op2 body");
end C731001_1.Parent;
with C731001_1.Parent; use C731001_1.Parent;
private package C731001_1.Unrelated is
type T2 is new Root with null record;
subtype T2_Class is T2'Class;
function Make return T2;
function Op2(X: T2) return String;
end C731001_1.Unrelated;
with C731001_1.Parent; use C731001_1.Parent;
pragma Elaborate(C731001_1.Parent);
package body C731001_1.Unrelated is
function Make return T2 is
Result: T2;
begin
return Result;
end Make;
function Op2(X: T2) return String is
begin
return "Unrelated.Op2 body";
end Op2;
begin
Check_String(Op1(T2'(Make)), "Parent.Op1 body");
Check_String(Op1(T2_Class(T2'(Make))), "Parent.Op1 body");
Check_String(Op1(Root_Class(T2'(Make))), "Parent.Op1 body");
Check_String(Op2(T2'(Make)), "Unrelated.Op2 body");
Check_String(Op2(T2_Class(T2'(Make))), "Unrelated.Op2 body");
Check_String(Call_Op2(T2'(Make)), "Parent.Op2 body");
Check_String(Call_Op2(T2_Class(T2'(Make))), "Parent.Op2 body");
Check_String(Call_Op2(Root_Class(T2'(Make))), "Parent.Op2 body");
end C731001_1.Unrelated;
package C731001_1.Parent.Child is
pragma Elaborate_Body;
type T3 is new Root with null record;
subtype T3_Class is T3'Class;
function Make return T3;
T3_Obj: T3;
T3_Class_Obj: T3_Class := T3_Obj;
T3_Root_Class_Obj: Root_Class := T3_Obj;
X3: constant String :=
Check_String(Op1(T3_Obj), "Parent.Op1 body") &
Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
package Nested is
type T4 is new Root with null record;
subtype T4_Class is T4'Class;
function Make return T4;
T4_Obj: T4;
T4_Class_Obj: T4_Class := T4_Obj;
T4_Root_Class_Obj: Root_Class := T4_Obj;
X4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
private
XX4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
end Nested;
use Nested;
XXX4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
private
XX3: constant String :=
Check_String(Op1(T3_Obj), "Parent.Op1 body") &
Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
Check_String(Op2(T3_Obj), "Parent.Op2 body") &
Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
XXXX4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
end C731001_1.Parent.Child;
with C731001_1.Unrelated; use C731001_1.Unrelated;
pragma Elaborate(C731001_1.Unrelated);
package body C731001_1.Parent.Child is
XXX3: constant String :=
Check_String(Op1(T3_Obj), "Parent.Op1 body") &
Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
Check_String(Op2(T3_Obj), "Parent.Op2 body") &
Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
XXXXX4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
function Make return T3 is
Result: T3;
begin
return Result;
end Make;
package body Nested is
function Make return T4 is
Result: T4;
begin
return Result;
end Make;
XXXXXX4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
Check_String(Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
end Nested;
type T5 is new T2 with null record;
subtype T5_Class is T5'Class;
function Make return T5;
function Make return T5 is
Result: T5;
begin
return Result;
end Make;
XXXXXXX4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
end C731001_1.Parent.Child;
procedure C731001_1.Main;
with C731001_1.Parent;
procedure C731001_1.Main is
begin
C731001_1.Parent.Call_Main;
end C731001_1.Main;
with C731001_1.Parent.Child;
use C731001_1.Parent;
use C731001_1.Parent.Child;
use C731001_1.Parent.Child.Nested;
with C731001_1.Unrelated; use C731001_1.Unrelated;
procedure C731001_1.Parent.Main is
Root_Obj: Root := Make;
Root_Class_Obj: Root_Class := Root'(Make);
T2_Obj: T2 := Make;
T2_Class_Obj: T2_Class := T2_Obj;
T2_Root_Class_Obj: Root_Class := T2_Class_Obj;
T3_Obj: T3 := Make;
T3_Class_Obj: T3_Class := T3_Obj;
T3_Root_Class_Obj: Root_Class := T3_Obj;
T4_Obj: T4 := Make;
T4_Class_Obj: T4_Class := T4_Obj;
T4_Root_Class_Obj: Root_Class := T4_Obj;
begin
Test("C731001_1", "Check that inherited operations can be overridden, even"
& " when they are inherited in a body");
Check_String(Op1(Root_Obj), "Parent.Op1 body");
Check_String(Op1(Root_Class_Obj), "Parent.Op1 body");
Check_String(Call_Op2(Root_Obj), "Parent.Op2 body");
Check_String(Call_Op2(Root_Class_Obj), "Parent.Op2 body");
Check_String(Op1(T2_Obj), "Parent.Op1 body");
Check_String(Op1(T2_Class_Obj), "Parent.Op1 body");
Check_String(Op1(T2_Root_Class_Obj), "Parent.Op1 body");
Check_String(Op2(T2_Obj), "Unrelated.Op2 body");
Check_String(Op2(T2_Class_Obj), "Unrelated.Op2 body");
Check_String(Call_Op2(T2_Obj), "Parent.Op2 body");
Check_String(Call_Op2(T2_Class_Obj), "Parent.Op2 body");
Check_String(Call_Op2(T2_Root_Class_Obj), "Parent.Op2 body");
Check_String(Op1(T3_Obj), "Parent.Op1 body");
Check_String(Op1(T3_Class_Obj), "Parent.Op1 body");
Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body");
Check_String(Call_Op2(T3_Obj), "Parent.Op2 body");
Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body");
Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
Check_String(Op1(T4_Obj), "Parent.Op1 body");
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body");
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body");
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body");
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body");
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
Result;
end C731001_1.Parent.Main;
with C731001_1.Main;
procedure C731001 is
begin
C731001_1.Main;
end C731001;