-- C380004.A
|
-- C380004.A
|
--
|
--
|
-- Grant of Unlimited Rights
|
-- Grant of Unlimited Rights
|
--
|
--
|
-- The Ada Conformity Assessment Authority (ACAA) holds unlimited
|
-- The Ada Conformity Assessment Authority (ACAA) holds unlimited
|
-- rights in the software and documentation contained herein. Unlimited
|
-- rights in the software and documentation contained herein. Unlimited
|
-- rights are the same as those granted by the U.S. Government for older
|
-- 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
|
-- 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
|
-- 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
|
-- intends to confer upon all recipients unlimited rights equal to those
|
-- held by the ACAA. These rights include rights to use, duplicate,
|
-- held by the ACAA. These rights include rights to use, duplicate,
|
-- release or disclose the released technical data and computer software
|
-- release or disclose the released technical data and computer software
|
-- in whole or in part, in any manner and for any purpose whatsoever, and
|
-- in whole or in part, in any manner and for any purpose whatsoever, and
|
-- to have or permit others to do so.
|
-- to have or permit others to do so.
|
--
|
--
|
-- DISCLAIMER
|
-- DISCLAIMER
|
--
|
--
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED
|
-- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
--*
|
--*
|
--
|
--
|
-- OBJECTIVE:
|
-- OBJECTIVE:
|
-- Check that per-object expressions are evaluated as specified for entry
|
-- Check that per-object expressions are evaluated as specified for entry
|
-- families and protected components. (Defect Report 8652/0002,
|
-- families and protected components. (Defect Report 8652/0002,
|
-- as reflected in Technical Corrigendum 1, RM95 3.6(22/1), 3.8(18/1), and
|
-- as reflected in Technical Corrigendum 1, RM95 3.6(22/1), 3.8(18/1), and
|
-- 9.5.2(22/1)).
|
-- 9.5.2(22/1)).
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 9 FEB 2001 PHL Initial version.
|
-- 9 FEB 2001 PHL Initial version.
|
-- 29 JUN 2002 RLB Readied for release.
|
-- 29 JUN 2002 RLB Readied for release.
|
--
|
--
|
--!
|
--!
|
with Report;
|
with Report;
|
use Report;
|
use Report;
|
procedure C380004 is
|
procedure C380004 is
|
|
|
type Rec (D1, D2 : Positive) is
|
type Rec (D1, D2 : Positive) is
|
record
|
record
|
null;
|
null;
|
end record;
|
end record;
|
|
|
F1_Poe : Integer;
|
F1_Poe : Integer;
|
|
|
function Chk (Poe : Integer; Value : Integer; Message : String)
|
function Chk (Poe : Integer; Value : Integer; Message : String)
|
return Boolean is
|
return Boolean is
|
begin
|
begin
|
if Poe /= Value then
|
if Poe /= Value then
|
Failed (Message & ": Poe is " & Integer'Image (Poe));
|
Failed (Message & ": Poe is " & Integer'Image (Poe));
|
end if;
|
end if;
|
return True;
|
return True;
|
end Chk;
|
end Chk;
|
|
|
function F1 return Integer is
|
function F1 return Integer is
|
begin
|
begin
|
F1_Poe := F1_Poe - Ident_Int (1);
|
F1_Poe := F1_Poe - Ident_Int (1);
|
return F1_Poe;
|
return F1_Poe;
|
end F1;
|
end F1;
|
|
|
generic
|
generic
|
type T is limited private;
|
type T is limited private;
|
with function Is_Ok (X : T;
|
with function Is_Ok (X : T;
|
Param1 : Integer;
|
Param1 : Integer;
|
Param2 : Integer;
|
Param2 : Integer;
|
Param3 : Integer) return Boolean;
|
Param3 : Integer) return Boolean;
|
procedure Check;
|
procedure Check;
|
|
|
procedure Check is
|
procedure Check is
|
begin
|
begin
|
|
|
declare
|
declare
|
type Poe is new T;
|
type Poe is new T;
|
Chk1 : Boolean := Chk (F1_Poe, 17, "F1 evaluated");
|
Chk1 : Boolean := Chk (F1_Poe, 17, "F1 evaluated");
|
X : Poe; -- F1 evaluated
|
X : Poe; -- F1 evaluated
|
Y : Poe; -- F1 evaluated
|
Y : Poe; -- F1 evaluated
|
Chk2 : Boolean := Chk (F1_Poe, 15, "F1 not evaluated");
|
Chk2 : Boolean := Chk (F1_Poe, 15, "F1 not evaluated");
|
begin
|
begin
|
if not Is_Ok (T (X), 16, 16, 17) or
|
if not Is_Ok (T (X), 16, 16, 17) or
|
not Is_Ok (T (Y), 15, 15, 17) then
|
not Is_Ok (T (Y), 15, 15, 17) then
|
Failed ("Discriminant values not correct - 0");
|
Failed ("Discriminant values not correct - 0");
|
end if;
|
end if;
|
end;
|
end;
|
|
|
declare
|
declare
|
type Poe is new T;
|
type Poe is new T;
|
begin
|
begin
|
begin
|
begin
|
declare
|
declare
|
X : Poe;
|
X : Poe;
|
begin
|
begin
|
if not Is_Ok (T (X), 14, 14, 17) then
|
if not Is_Ok (T (X), 14, 14, 17) then
|
Failed ("Discriminant values not correct - 1");
|
Failed ("Discriminant values not correct - 1");
|
end if;
|
end if;
|
end;
|
end;
|
exception
|
exception
|
when others =>
|
when others =>
|
Failed ("Unexpected exception - 1");
|
Failed ("Unexpected exception - 1");
|
end;
|
end;
|
|
|
declare
|
declare
|
type Acc_Poe is access Poe;
|
type Acc_Poe is access Poe;
|
X : Acc_Poe;
|
X : Acc_Poe;
|
begin
|
begin
|
X := new Poe;
|
X := new Poe;
|
begin
|
begin
|
if not Is_Ok (T (X.all), 13, 13, 17) then
|
if not Is_Ok (T (X.all), 13, 13, 17) then
|
Failed ("Discriminant values not correct - 2");
|
Failed ("Discriminant values not correct - 2");
|
end if;
|
end if;
|
end;
|
end;
|
exception
|
exception
|
when others =>
|
when others =>
|
Failed ("Unexpected exception raised - 2");
|
Failed ("Unexpected exception raised - 2");
|
end;
|
end;
|
|
|
declare
|
declare
|
subtype Spoe is Poe;
|
subtype Spoe is Poe;
|
X : Spoe;
|
X : Spoe;
|
begin
|
begin
|
if not Is_Ok (T (X), 12, 12, 17) then
|
if not Is_Ok (T (X), 12, 12, 17) then
|
Failed ("Discriminant values not correct - 3");
|
Failed ("Discriminant values not correct - 3");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Failed ("Unexpected exception raised - 3");
|
Failed ("Unexpected exception raised - 3");
|
end;
|
end;
|
|
|
declare
|
declare
|
type Arr is array (1 .. 2) of Poe;
|
type Arr is array (1 .. 2) of Poe;
|
X : Arr;
|
X : Arr;
|
begin
|
begin
|
if Is_Ok (T (X (1)), 11, 11, 17) and then
|
if Is_Ok (T (X (1)), 11, 11, 17) and then
|
Is_Ok (T (X (2)), 10, 10, 17) then
|
Is_Ok (T (X (2)), 10, 10, 17) then
|
null;
|
null;
|
elsif Is_Ok (T (X (2)), 11, 11, 17) and then
|
elsif Is_Ok (T (X (2)), 11, 11, 17) and then
|
Is_Ok (T (X (1)), 10, 10, 17) then
|
Is_Ok (T (X (1)), 10, 10, 17) then
|
null;
|
null;
|
else
|
else
|
Failed ("Discriminant values not correct - 4");
|
Failed ("Discriminant values not correct - 4");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Failed ("Unexpected exception raised - 4");
|
Failed ("Unexpected exception raised - 4");
|
end;
|
end;
|
|
|
declare
|
declare
|
type Nrec is
|
type Nrec is
|
record
|
record
|
C1, C2 : Poe;
|
C1, C2 : Poe;
|
end record;
|
end record;
|
X : Nrec;
|
X : Nrec;
|
begin
|
begin
|
if Is_Ok (T (X.C1), 8, 8, 17) and then
|
if Is_Ok (T (X.C1), 8, 8, 17) and then
|
Is_Ok (T (X.C2), 9, 9, 17) then
|
Is_Ok (T (X.C2), 9, 9, 17) then
|
null;
|
null;
|
elsif Is_Ok (T (X.C2), 8, 8, 17) and then
|
elsif Is_Ok (T (X.C2), 8, 8, 17) and then
|
Is_Ok (T (X.C1), 9, 9, 17) then
|
Is_Ok (T (X.C1), 9, 9, 17) then
|
null;
|
null;
|
else
|
else
|
Failed ("Discriminant values not correct - 5");
|
Failed ("Discriminant values not correct - 5");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Failed ("Unexpected exception raised - 5");
|
Failed ("Unexpected exception raised - 5");
|
end;
|
end;
|
|
|
declare
|
declare
|
type Drec is new Poe;
|
type Drec is new Poe;
|
X : Drec;
|
X : Drec;
|
begin
|
begin
|
if not Is_Ok (T (X), 7, 7, 17) then
|
if not Is_Ok (T (X), 7, 7, 17) then
|
Failed ("Discriminant values not correct - 6");
|
Failed ("Discriminant values not correct - 6");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Failed ("Unexpected exception raised - 6");
|
Failed ("Unexpected exception raised - 6");
|
end;
|
end;
|
end;
|
end;
|
end Check;
|
end Check;
|
|
|
|
|
begin
|
begin
|
Test ("C380004",
|
Test ("C380004",
|
"Check evaluation of discriminant expressions " &
|
"Check evaluation of discriminant expressions " &
|
"when the constraint depends on a discriminant, " &
|
"when the constraint depends on a discriminant, " &
|
"and the discriminants have defaults - discriminant-dependent" &
|
"and the discriminants have defaults - discriminant-dependent" &
|
"entry families and protected components");
|
"entry families and protected components");
|
|
|
|
|
Comment ("Discriminant-dependent entry families for task types");
|
Comment ("Discriminant-dependent entry families for task types");
|
|
|
F1_Poe := 18;
|
F1_Poe := 18;
|
|
|
declare
|
declare
|
task type Poe (D3 : Positive := F1) is
|
task type Poe (D3 : Positive := F1) is
|
entry E (D3 .. F1); -- F1 evaluated
|
entry E (D3 .. F1); -- F1 evaluated
|
entry Is_Ok (D3 : Integer;
|
entry Is_Ok (D3 : Integer;
|
E_First : Integer;
|
E_First : Integer;
|
E_Last : Integer;
|
E_Last : Integer;
|
Ok : out Boolean);
|
Ok : out Boolean);
|
end Poe;
|
end Poe;
|
task body Poe is
|
task body Poe is
|
begin
|
begin
|
loop
|
loop
|
select
|
select
|
accept Is_Ok (D3 : Integer;
|
accept Is_Ok (D3 : Integer;
|
E_First : Integer;
|
E_First : Integer;
|
E_Last : Integer;
|
E_Last : Integer;
|
Ok : out Boolean) do
|
Ok : out Boolean) do
|
declare
|
declare
|
Cnt : Natural;
|
Cnt : Natural;
|
begin
|
begin
|
if Poe.D3 = D3 then
|
if Poe.D3 = D3 then
|
-- Can't think of a better way to check the
|
-- Can't think of a better way to check the
|
-- bounds of the entry family.
|
-- bounds of the entry family.
|
begin
|
begin
|
Cnt := E (E_First)'Count;
|
Cnt := E (E_First)'Count;
|
Cnt := E (E_Last)'Count;
|
Cnt := E (E_Last)'Count;
|
exception
|
exception
|
when Constraint_Error =>
|
when Constraint_Error =>
|
Ok := False;
|
Ok := False;
|
return;
|
return;
|
end;
|
end;
|
begin
|
begin
|
Cnt := E (E_First - 1)'Count;
|
Cnt := E (E_First - 1)'Count;
|
Ok := False;
|
Ok := False;
|
return;
|
return;
|
exception
|
exception
|
when Constraint_Error =>
|
when Constraint_Error =>
|
null;
|
null;
|
when others =>
|
when others =>
|
Ok := False;
|
Ok := False;
|
return;
|
return;
|
end;
|
end;
|
begin
|
begin
|
Cnt := E (E_Last + 1)'Count;
|
Cnt := E (E_Last + 1)'Count;
|
Ok := False;
|
Ok := False;
|
return;
|
return;
|
exception
|
exception
|
when Constraint_Error =>
|
when Constraint_Error =>
|
null;
|
null;
|
when others =>
|
when others =>
|
Ok := False;
|
Ok := False;
|
return;
|
return;
|
end;
|
end;
|
Ok := True;
|
Ok := True;
|
else
|
else
|
Ok := False;
|
Ok := False;
|
return;
|
return;
|
end if;
|
end if;
|
end;
|
end;
|
end Is_Ok;
|
end Is_Ok;
|
or
|
or
|
terminate;
|
terminate;
|
end select;
|
end select;
|
end loop;
|
end loop;
|
end Poe;
|
end Poe;
|
|
|
function Is_Ok
|
function Is_Ok
|
(C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
|
(C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
|
return Boolean is
|
return Boolean is
|
Ok : Boolean;
|
Ok : Boolean;
|
begin
|
begin
|
C.Is_Ok (D3, E_First, E_Last, Ok);
|
C.Is_Ok (D3, E_First, E_Last, Ok);
|
return Ok;
|
return Ok;
|
end Is_Ok;
|
end Is_Ok;
|
|
|
procedure Chk is new Check (Poe, Is_Ok);
|
procedure Chk is new Check (Poe, Is_Ok);
|
|
|
begin
|
begin
|
Chk;
|
Chk;
|
end;
|
end;
|
|
|
|
|
Comment ("Discriminant-dependent entry families for protected types");
|
Comment ("Discriminant-dependent entry families for protected types");
|
|
|
F1_Poe := 18;
|
F1_Poe := 18;
|
|
|
declare
|
declare
|
protected type Poe (D3 : Integer := F1) is
|
protected type Poe (D3 : Integer := F1) is
|
entry E (D3 .. F1); -- F1 evaluated
|
entry E (D3 .. F1); -- F1 evaluated
|
function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
|
function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
|
return Boolean;
|
return Boolean;
|
end Poe;
|
end Poe;
|
protected body Poe is
|
protected body Poe is
|
entry E (for I in D3 .. F1) when True is
|
entry E (for I in D3 .. F1) when True is
|
begin
|
begin
|
null;
|
null;
|
end E;
|
end E;
|
function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
|
function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
|
return Boolean is
|
return Boolean is
|
Cnt : Natural;
|
Cnt : Natural;
|
begin
|
begin
|
if Poe.D3 = D3 then
|
if Poe.D3 = D3 then
|
-- Can't think of a better way to check the
|
-- Can't think of a better way to check the
|
-- bounds of the entry family.
|
-- bounds of the entry family.
|
begin
|
begin
|
Cnt := E (E_First)'Count;
|
Cnt := E (E_First)'Count;
|
Cnt := E (E_Last)'Count;
|
Cnt := E (E_Last)'Count;
|
exception
|
exception
|
when Constraint_Error =>
|
when Constraint_Error =>
|
return False;
|
return False;
|
end;
|
end;
|
begin
|
begin
|
Cnt := E (E_First - 1)'Count;
|
Cnt := E (E_First - 1)'Count;
|
return False;
|
return False;
|
exception
|
exception
|
when Constraint_Error =>
|
when Constraint_Error =>
|
null;
|
null;
|
when others =>
|
when others =>
|
return False;
|
return False;
|
end;
|
end;
|
begin
|
begin
|
Cnt := E (E_Last + 1)'Count;
|
Cnt := E (E_Last + 1)'Count;
|
return False;
|
return False;
|
exception
|
exception
|
when Constraint_Error =>
|
when Constraint_Error =>
|
null;
|
null;
|
when others =>
|
when others =>
|
return False;
|
return False;
|
end;
|
end;
|
return True;
|
return True;
|
else
|
else
|
return False;
|
return False;
|
end if;
|
end if;
|
end Is_Ok;
|
end Is_Ok;
|
end Poe;
|
end Poe;
|
|
|
function Is_Ok
|
function Is_Ok
|
(C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
|
(C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
|
return Boolean is
|
return Boolean is
|
begin
|
begin
|
return C.Is_Ok (D3, E_First, E_Last);
|
return C.Is_Ok (D3, E_First, E_Last);
|
end Is_Ok;
|
end Is_Ok;
|
|
|
procedure Chk is new Check (Poe, Is_Ok);
|
procedure Chk is new Check (Poe, Is_Ok);
|
|
|
begin
|
begin
|
Chk;
|
Chk;
|
end;
|
end;
|
|
|
Comment ("Protected components");
|
Comment ("Protected components");
|
|
|
F1_Poe := 18;
|
F1_Poe := 18;
|
|
|
declare
|
declare
|
protected type Poe (D3 : Integer := F1) is
|
protected type Poe (D3 : Integer := F1) is
|
function C1_D1 return Integer;
|
function C1_D1 return Integer;
|
function C1_D2 return Integer;
|
function C1_D2 return Integer;
|
private
|
private
|
C1 : Rec (D3, F1); -- F1 evaluated
|
C1 : Rec (D3, F1); -- F1 evaluated
|
end Poe;
|
end Poe;
|
protected body Poe is
|
protected body Poe is
|
function C1_D1 return Integer is
|
function C1_D1 return Integer is
|
begin
|
begin
|
return C1.D1;
|
return C1.D1;
|
end C1_D1;
|
end C1_D1;
|
function C1_D2 return Integer is
|
function C1_D2 return Integer is
|
begin
|
begin
|
return C1.D2;
|
return C1.D2;
|
end C1_D2;
|
end C1_D2;
|
end Poe;
|
end Poe;
|
|
|
function Is_Ok (C : Poe; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer)
|
function Is_Ok (C : Poe; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer)
|
return Boolean is
|
return Boolean is
|
begin
|
begin
|
return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2;
|
return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2;
|
end Is_Ok;
|
end Is_Ok;
|
|
|
procedure Chk is new Check (Poe, Is_Ok);
|
procedure Chk is new Check (Poe, Is_Ok);
|
|
|
begin
|
begin
|
Chk;
|
Chk;
|
end;
|
end;
|
|
|
Result;
|
Result;
|
|
|
exception
|
exception
|
when others =>
|
when others =>
|
Failed ("Unexpected exception");
|
Failed ("Unexpected exception");
|
Result;
|
Result;
|
|
|
end C380004;
|
end C380004;
|
|
|