1-- C37403A.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-- CHECK THAT WHEN A FORMAL PARAMETER OF A SUBPROGRAM, ENTRY, OR 26-- GENERIC UNIT HAS AN UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT DO 27-- NOT HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' REGARDLESS OF THE MODE 28-- OF THE PARAMETER. 29 30-- R.WILLIAMS 9/1/86 31 32WITH REPORT; USE REPORT; 33PROCEDURE C37403A IS 34 35BEGIN 36 TEST ( "C37403A", "CHECK THAT WHEN A FORMAL PARAMETER OF A " & 37 "SUBPROGRAM, ENTRY, OR GENERIC UNIT HAS AN " & 38 "UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT " & 39 "DO NOT HAVE DEFAULTS, 'CONSTRAINED IS " & 40 "'TRUE' REGARDLESS OF THE MODE OF THE " & 41 "PARAMETER" ); 42 43 44 DECLARE 45 46 SUBTYPE INT IS INTEGER RANGE 1.. 10; 47 48 TYPE MATRIX IS ARRAY (INT RANGE <>, INT RANGE <>) 49 OF INTEGER; 50 51 TYPE SQUARE (SIDE : INT) IS 52 RECORD 53 MAT : MATRIX (1 .. SIDE, 1 .. SIDE); 54 END RECORD; 55 56 S1 : SQUARE (2) := (2, ((1, 2), (3, 4))); 57 58 S2 : SQUARE (2) := S1; 59 60 S3 : SQUARE (2); 61 62 SC : CONSTANT SQUARE := (SIDE => 1, MAT => (1 => (1 => 1))); 63 64 PROCEDURE P (PIN1, PIN2 : IN SQUARE; 65 PINOUT : IN OUT SQUARE; 66 POUT : OUT SQUARE) IS 67 68 BEGIN 69 IF PIN1'CONSTRAINED THEN 70 NULL; 71 ELSE 72 FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & 73 "OF IN MODE - 1" ); 74 END IF; 75 76 IF PIN2'CONSTRAINED THEN 77 NULL; 78 ELSE 79 FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & 80 "OF IN MODE - 2" ); 81 END IF; 82 83 IF PINOUT'CONSTRAINED THEN 84 NULL; 85 ELSE 86 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & 87 "OBJECT OF IN OUT MODE - 1" ); 88 END IF; 89 90 IF POUT'CONSTRAINED THEN 91 NULL; 92 ELSE 93 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & 94 "OBJECT OF OUT MODE - 1" ); 95 END IF; 96 97 POUT := (2, ((1, 2), (3, 4))); 98 END P; 99 100 TASK T IS 101 ENTRY Q (PIN1, PIN2 : IN SQUARE; 102 PINOUT : IN OUT SQUARE; 103 POUT : OUT SQUARE); 104 END T; 105 106 TASK BODY T IS 107 BEGIN 108 ACCEPT Q (PIN1, PIN2 : IN SQUARE; 109 PINOUT : IN OUT SQUARE; 110 POUT : OUT SQUARE) DO 111 112 BEGIN 113 IF PIN1'CONSTRAINED THEN 114 NULL; 115 ELSE 116 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & 117 "OBJECT OF IN MODE - 3" ); 118 END IF; 119 120 IF PIN2'CONSTRAINED THEN 121 NULL; 122 ELSE 123 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & 124 "OBJECT OF IN MODE - 4" ); 125 END IF; 126 127 IF PINOUT'CONSTRAINED THEN 128 NULL; 129 ELSE 130 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & 131 "OBJECT OF " & 132 "IN OUT MODE - 2" ); 133 END IF; 134 135 IF POUT'CONSTRAINED THEN 136 NULL; 137 ELSE 138 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & 139 "OBJECT OF " & 140 "OUT MODE - 2" ); 141 END IF; 142 143 POUT := (2, ((1, 2), (3, 4))); 144 END; 145 END Q; 146 END T; 147 148 GENERIC 149 PIN1, PIN2 : IN SQUARE; 150 PINOUT : IN OUT SQUARE; 151 PACKAGE R IS END R; 152 153 PACKAGE BODY R IS 154 BEGIN 155 IF PIN1'CONSTRAINED THEN 156 NULL; 157 ELSE 158 FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & 159 "OF IN MODE - 5" ); 160 END IF; 161 162 IF PIN2'CONSTRAINED THEN 163 NULL; 164 ELSE 165 FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & 166 "OF IN MODE - 6" ); 167 END IF; 168 169 IF PINOUT'CONSTRAINED THEN 170 NULL; 171 ELSE 172 FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & 173 "OBJECT OF IN OUT MODE - 3" ); 174 END IF; 175 176 END R; 177 178 PACKAGE S IS NEW R (S1, SC, S2); 179 180 BEGIN 181 P (S1, SC, S2, S3); 182 T.Q (S1, SC, S2, S3); 183 END; 184 185 RESULT; 186END C37403A; 187