| -- C380003.A |
| -- |
| -- Grant of Unlimited Rights |
| -- |
| -- The Ada Conformity Assessment Authority (ACAA) holds unlimited |
| -- rights in the software and documentation contained herein. Unlimited |
| -- rights are the same as those granted by the U.S. Government for older |
| -- parts of the Ada Conformity Assessment Test Suite, and are defined |
| -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA |
| -- intends to confer upon all recipients unlimited rights equal to those |
| -- held by the ACAA. These rights include rights to use, duplicate, |
| -- release or disclose the released technical data and computer software |
| -- in whole or in part, in any manner and for any purpose whatsoever, and |
| -- to have or permit others to do so. |
| -- |
| -- DISCLAIMER |
| -- |
| -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR |
| -- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED |
| -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE |
| -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE |
| -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A |
| -- PARTICULAR PURPOSE OF SAID MATERIAL. |
| --* |
| -- |
| -- OBJECTIVE: |
| -- Check that per-object expressions are evaluated as specified for |
| -- protected components. (Defect Report 8652/0002, as reflected in |
| -- Technical Corrigendum 1, RM95 3.6(22/1) and 3.8(18/1)). |
| -- |
| -- CHANGE HISTORY: |
| -- 9 FEB 2001 PHL Initial version. |
| -- 29 JUN 2002 RLB Readied for release. |
| -- |
| --! |
| with Report; |
| use Report; |
| procedure C380003 is |
| |
| subtype Sm is Integer range 1 .. 10; |
| |
| type Rec (D1, D2 : Sm) is |
| record |
| null; |
| end record; |
| |
| begin |
| Test ("C380003", |
| "Check compatibility of discriminant expressions" & |
| " when the constraint depends on discriminants, " & |
| "and the discriminants have defaults - protected components"); |
| |
| declare |
| protected type Cons (D3 : Integer := Ident_Int (11)) is |
| function C1_D1 return Integer; |
| function C1_D2 return Integer; |
| private |
| C1 : Rec (D3, 1); |
| end Cons; |
| protected body Cons is |
| function C1_D1 return Integer is |
| begin |
| return C1.D1; |
| end C1_D1; |
| function C1_D2 return Integer is |
| begin |
| return C1.D2; |
| end C1_D2; |
| end Cons; |
| |
| function Is_Ok |
| (C : Cons; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer) |
| return Boolean is |
| begin |
| return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2; |
| end Is_Ok; |
| |
| begin |
| begin |
| declare |
| X : Cons; |
| begin |
| Failed ("Discriminant check not performed - 1"); |
| if not Is_Ok (X, 1, 1, 1) then |
| Comment ("Shouldn't get here"); |
| end if; |
| end; |
| exception |
| when Constraint_Error => |
| null; |
| when others => |
| Failed ("Unexpected exception - 1"); |
| end; |
| |
| begin |
| declare |
| type Acc_Cons is access Cons; |
| X : Acc_Cons; |
| begin |
| X := new Cons; |
| Failed ("Discriminant check not performed - 2"); |
| begin |
| if not Is_Ok (X.all, 1, 1, 1) then |
| Comment ("Irrelevant"); |
| end if; |
| end; |
| exception |
| when Constraint_Error => |
| null; |
| when others => |
| Failed ("Unexpected exception raised - 2"); |
| end; |
| exception |
| when others => |
| Failed ("Constraint checked too soon - 2"); |
| end; |
| |
| begin |
| declare |
| subtype Scons is Cons; |
| begin |
| declare |
| X : Scons; |
| begin |
| Failed ("Discriminant check not performed - 3"); |
| if not Is_Ok (X, 1, 1, 1) then |
| Comment ("Irrelevant"); |
| end if; |
| end; |
| exception |
| when Constraint_Error => |
| null; |
| when others => |
| Failed ("Unexpected exception raised - 3"); |
| end; |
| exception |
| when others => |
| Failed ("Constraint checked too soon - 3"); |
| end; |
| |
| begin |
| declare |
| type Arr is array (1 .. 5) of Cons; |
| begin |
| declare |
| X : Arr; |
| begin |
| Failed ("Discriminant check not performed - 4"); |
| for I in Arr'Range loop |
| if not Is_Ok (X (I), 1, 1, 1) then |
| Comment ("Irrelevant"); |
| end if; |
| end loop; |
| end; |
| exception |
| when Constraint_Error => |
| null; |
| when others => |
| Failed ("Unexpected exception raised - 4"); |
| end; |
| exception |
| when others => |
| Failed ("Constraint checked too soon - 4"); |
| end; |
| |
| begin |
| declare |
| type Nrec is |
| record |
| C1 : Cons; |
| end record; |
| begin |
| declare |
| X : Nrec; |
| begin |
| Failed ("Discriminant check not performed - 5"); |
| if not Is_Ok (X.C1, 1, 1, 1) then |
| Comment ("Irrelevant"); |
| end if; |
| end; |
| exception |
| when Constraint_Error => |
| null; |
| when others => |
| Failed ("Unexpected exception raised - 5"); |
| end; |
| exception |
| when others => |
| Failed ("Constraint checked too soon - 5"); |
| end; |
| |
| begin |
| declare |
| type Drec is new Cons; |
| begin |
| declare |
| X : Drec; |
| begin |
| Failed ("Discriminant check not performed - 6"); |
| if not Is_Ok (Cons (X), 1, 1, 1) then |
| Comment ("Irrelevant"); |
| end if; |
| end; |
| exception |
| when Constraint_Error => |
| null; |
| when others => |
| Failed ("Unexpected exception raised - 6"); |
| end; |
| exception |
| when others => |
| Failed ("Constraint checked too soon - 6"); |
| end; |
| |
| end; |
| |
| Result; |
| |
| exception |
| when others => |
| Failed ("Constraint check done too early"); |
| Result; |
| end C380003; |