1-- C48009J.ADA 2 3-- Grant of Unlimited Rights 4-- 5-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, 6-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 7-- unlimited rights in the software and documentation contained herein. 8-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making 9-- this public release, the Government intends to confer upon all 10-- recipients unlimited rights equal to those held by the Government. 11-- These rights include rights to use, duplicate, release or disclose the 12-- released technical data and computer software in whole or in part, in 13-- any manner and for any purpose whatsoever, and to have or permit others 14-- to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 20-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE 21-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 22-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 23-- PARTICULAR PURPOSE OF SAID MATERIAL. 24--* 25-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR 26-- IS RAISED IF T IS AN UNCONSTRAINED ACCESS TYPE, ITS DESIGNATED TYPE 27-- IS ALSO UNCONSTRAINED, AND A DISCRIMINANT VALUE FOR X LIES OUTSIDE 28-- THE RANGE OF THE CORRESPONDING DISCRIMINANT SPECIFICATION FOR THE 29-- DESIGNATED TYPE, OR A NON-NULL INDEX BOUND LIES OUTSIDE THE RANGE OF 30-- AN INDEX SUBTYPE OF THE DESIGNATED TYPE. 31 32-- EG 08/30/84 33 34WITH REPORT; 35 36PROCEDURE C48009J IS 37 38 USE REPORT; 39 40BEGIN 41 42 TEST("C48009J","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & 43 "THAT CONSTRAINT_ERROR IS RAISED WHEN " & 44 "APPROPRIATE - ACCESS TYPE OF UNCONSTRAINED " & 45 "ACCESS TYPE"); 46 47 DECLARE 48 49 TYPE INT IS RANGE 1 .. 5; 50 51 TYPE UR(A : INT) IS 52 RECORD 53 NULL; 54 END RECORD; 55 TYPE UA IS ARRAY(INT RANGE <>) OF INTEGER; 56 57 PACKAGE P IS 58 TYPE UP(A : INT) IS PRIVATE; 59 TYPE UL(A : INT) IS LIMITED PRIVATE; 60 PRIVATE 61 TYPE UP(A : INT) IS 62 RECORD 63 NULL; 64 END RECORD; 65 TYPE UL(A : INT) IS 66 RECORD 67 NULL; 68 END RECORD; 69 END P; 70 71 TYPE A_UR IS ACCESS UR; 72 TYPE A_UA IS ACCESS UA; 73 TYPE A_UP IS ACCESS P.UP; 74 TYPE A_UL IS ACCESS P.UL; 75 76 TYPE AA_UR IS ACCESS A_UR; 77 TYPE AA_UA IS ACCESS A_UA; 78 TYPE AA_UP IS ACCESS A_UP; 79 TYPE AA_UL IS ACCESS A_UL; 80 81 V_AA_UR : AA_UR; 82 V_AA_UA : AA_UA; 83 V_AA_UP : AA_UP; 84 V_AA_UL : AA_UL; 85 86 BEGIN 87 88 BEGIN 89 V_AA_UR := NEW A_UR'(NEW UR(INT(IDENT_INT(6)))); 90 FAILED ("NO EXCEPTION RAISED - UR"); 91 EXCEPTION 92 WHEN CONSTRAINT_ERROR => 93 NULL; 94 WHEN OTHERS => 95 FAILED ("WRONG EXCEPTION RAISED - UR"); 96 END; 97 98 BEGIN 99 V_AA_UA := NEW A_UA'(NEW UA(4 .. 7)); 100 FAILED ("NO EXCEPTION RAISED - UA"); 101 EXCEPTION 102 WHEN CONSTRAINT_ERROR => 103 NULL; 104 WHEN OTHERS => 105 FAILED ("WRONG EXCEPTION RAISED - UA"); 106 END; 107 108 BEGIN 109 V_AA_UP := NEW A_UP'(NEW P.UP(0)); 110 FAILED ("NO EXCEPTION RAISED - UP"); 111 EXCEPTION 112 WHEN CONSTRAINT_ERROR => 113 NULL; 114 WHEN OTHERS => 115 FAILED ("WRONG EXCEPTION RAISED - UP"); 116 END; 117 118 BEGIN 119 V_AA_UL := NEW A_UL'(NEW P.UL(INT(IDENT_INT(0)))); 120 FAILED ("NO EXCEPTION RAISED - UL"); 121 EXCEPTION 122 WHEN CONSTRAINT_ERROR => 123 NULL; 124 WHEN OTHERS => 125 FAILED ("WRONG EXCEPTION RAISED - UL"); 126 END; 127 128 END; 129 130 RESULT; 131 132END C48009J; 133