1-- CC1302A.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 GENERIC DEFAULT SUBPROGRAM PARAMETERS MAY BE ATTRIBUTES 26-- OF TYPES, INCLUDING GENERIC FORMAL TYPES IN SAME GENERIC PART, 27-- OR IN GENERIC PART OF ENCLOSING UNIT. 28 29-- DAT 8/27/81 30-- SPS 2/9/83 31-- JBG 2/15/83 32-- JBG 4/29/83 33 34WITH REPORT; USE REPORT; 35 36PROCEDURE CC1302A IS 37BEGIN 38 TEST ("CC1302A", "GENERIC DEFAULT SUBPROGRAMS MAY BE" 39 & " FUNCTION ATTRIBUTES OF TYPES"); 40 41 DECLARE 42 GENERIC 43 TYPE T IS ( <> ); 44 T_LAST : T; 45 WITH FUNCTION SUCC (X : T) RETURN T IS T'SUCC; 46 PACKAGE PK1 IS 47 END PK1; 48 49 SUBTYPE CH IS CHARACTER RANGE CHARACTER'FIRST .. '~'; 50 SUBTYPE BL IS BOOLEAN RANGE FALSE .. FALSE; 51 SUBTYPE INT IS INTEGER RANGE -10 .. 10; 52 53 PACKAGE BODY PK1 IS 54 GENERIC 55 TYPE TT IS ( <> ); 56 TT_LAST : TT; 57 WITH FUNCTION PRED (X : TT) RETURN TT IS TT'PRED; 58 WITH FUNCTION IM(X : T) RETURN STRING IS T'IMAGE; 59 WITH FUNCTION VAL(X : STRING) RETURN TT IS TT'VALUE; 60 PACKAGE PK2 IS END PK2; 61 62 PACKAGE BODY PK2 IS 63 BEGIN 64 65-- CHECK THAT 'LAST GIVES RIGHT ANSWER 66 IF T'LAST /= T_LAST THEN 67 FAILED ("T'LAST INCORRECT"); 68 END IF; 69 70 IF TT'LAST /= TT_LAST THEN 71 FAILED ("TT'LAST INCORRECT"); 72 END IF; 73 74-- CHECK SUCC FUNCTION 75 BEGIN 76 IF T'PRED(SUCC(T'LAST)) /= T'LAST THEN 77 FAILED ("'PRED OR SUCC GIVES WRONG " & 78 "RESULT"); 79 END IF; 80 EXCEPTION 81 WHEN CONSTRAINT_ERROR => 82 FAILED ("SUCC HAS CONSTRAINTS OF " & 83 "SUBTYPE"); 84 WHEN OTHERS => 85 FAILED ("SOME EXCEPTION RAISED - 1"); 86 END; 87 88-- CHECK 'SUCC ATTRIBUTE 89 BEGIN 90 IF T'PRED(T'SUCC(T'LAST)) /= T'LAST THEN 91 FAILED ("'PRED OR 'SUCC GIVES WRONG " & 92 "RESULT"); 93 END IF; 94 EXCEPTION 95 WHEN CONSTRAINT_ERROR => 96 FAILED ("'PRED OR 'SUCC HAS CONSTRAINTS "& 97 "OF SUBTYPE"); 98 WHEN OTHERS => 99 FAILED ("SOME EXCEPTION RAISED - 2"); 100 END; 101 102-- CHECK VAL ATTRIBUTE 103 BEGIN 104 IF T'VAL(T'POS(T'SUCC(T'LAST))) /= 105 T'VAL(T'POS(T'LAST)+1) THEN 106 FAILED ("VAL OR POS ATTRIBUTE HAS " & 107 "INCONSISTENT RESULTS"); 108 END IF; 109 EXCEPTION 110 WHEN CONSTRAINT_ERROR => 111 FAILED ("VAL OR POS ATTRIBUTE HAS " & 112 "CONSTRAINTS OF SUBTYPE"); 113 WHEN OTHERS => 114 FAILED ("SOME EXCEPTION RAISED - 4"); 115 END; 116 117-- CHECK VAL FUNCTION 118 BEGIN 119 IF TT'VAL(TT'POS(TT'SUCC(TT'LAST))) /= 120 TT'VAL(TT'POS(TT'LAST)+1) THEN 121 FAILED ("VAL FUNCTION GIVES INCORRECT " & 122 "RESULTS"); 123 END IF; 124 EXCEPTION 125 WHEN CONSTRAINT_ERROR => 126 FAILED ("VAL FUNCTION HAS CONSTRAINTS " & 127 "OF SUBTYPE"); 128 WHEN OTHERS => 129 FAILED ("SOME EXCEPTION RAISED - 6"); 130 END; 131 132-- CHECK IM FUNCTION 133 BEGIN 134 IF T'IMAGE(T'SUCC(T'LAST)) /= 135 IM (T'SUCC(T'LAST)) THEN 136 FAILED ("IM FUNCTION GIVES INCORRECT " & 137 "RESULTS"); 138 END IF; 139 EXCEPTION 140 WHEN CONSTRAINT_ERROR => 141 FAILED ("IM FUNCTION HAS CONSTRAINTS " & 142 "OF SUBTYPE"); 143 WHEN OTHERS => 144 FAILED ("SOME EXCEPTION RAISED - 7"); 145 END; 146 147-- CHECK PRED FUNCTION 148 BEGIN 149 IF PRED(TT'SUCC(TT'LAST)) /= TT'LAST THEN 150 FAILED ("PRED FUNCTION GIVES INCORRECT " & 151 "RESULTS"); 152 END IF; 153 EXCEPTION 154 WHEN CONSTRAINT_ERROR => 155 FAILED ("PRED FUNCTION HAS CONSTRAINTS " & 156 "OF SUBTYPE"); 157 WHEN OTHERS => 158 FAILED ("SOME EXCEPTION RAISED - 8"); 159 END; 160 161 END PK2; 162 163 PACKAGE PK3 IS NEW PK2 (T, T'LAST); 164 END PK1; 165 166 PACKAGE PKG1 IS NEW PK1 (CH, CH'LAST); 167 PACKAGE PKG2 IS NEW PK1 (BL, BL'LAST); 168 PACKAGE PKG3 IS NEW PK1 (INT, INT'LAST); 169 BEGIN 170 NULL; 171 END; 172 173 RESULT; 174END CC1302A; 175