!* 14/04/82 !* !************ IMP80 version ************ !* %CONSTINTEGER TESTVERSION=1;! 0 NO 1 YES %CONSTINTEGER DICTVERSION=0;! 0 EMAS 1 VME !* !{2900C} %CONSTINTEGER W1=2 !{2900C} %CONSTINTEGER W2=4 !{2900C} %CONSTINTEGER W4=8 !{2900C} %CONSTINTEGER W6=12 {PERQC} %CONSTINTEGER W1=1 {PERQC} %CONSTINTEGER W2=2 {PERQC} %CONSTINTEGER W4=4 {PERQC} %CONSTINTEGER W6=6 !* !* !**** SYNTAX **** !* !* Syntax tables generated from file SYNTAX48 on 11/03/82 at 06.51.27 !* %CONSTHALFINTEGERARRAY SUB(0:77)= %C 0, 2, 1540, 218, 4522, 0, 4340, 4494, 38, 4282, 212, 2428, 2540, 778, 240, 266, 880, 578, 524, 350, 454, 600, 934, 1508, 1456, 1370, 1488, 1004, 1020, 1030, 1058, 1194, 1264, 1166, 1098, 1294, 1122, 1314, 1216, 1430, 3798, 3682, 2872, 2902, 2624, 2600, 2844, 2980, 3526, 4214, 3560, 3378, 3700, 4064, 3326, 3586, 4234, 2490, 2668, 2686, 2778, 2786, 2950, 3206, 3008, 3078, 3254, 3088, 3180, 3280, 3352, 3478, 3718, 3658, 3854, 3912, 4588, 4196; %CONSTHALFINTEGERARRAY LOOKUP(0:25) = %C 1542, 1570, 1594, 1756, 1812, 1960, 1970, 0, 2010, 0, 0, 2086, 0, 0, 2118, 2134, 0, 2202, 2326, 0, 0, 0, 2376, 2398, 0, 0; !{2900}%CONSTBYTEINTEGERARRAY COMP(0:4700)= %C !{2900} 0, 0, 1, 2, 0, 0, 1, 2, 0, 0, !{2900} 1, 3, 0, 0, 1, 4, 0, 0, 1, 5, !{2900} 0, 0, 1, 6, 0, 0, 1, 7, 0, 0, !{2900} 1, 8, 0, 0, 0, 0, 0, 1, 4, 1, !{2900} 0, 50, 21, 1, 70, 1, 0, 0, 0, 1, !{2900} 4, 2, 0, 70, 21, 1, 70, 2, 3, 40, !{2900} 0, 0, 1, 9, 0, 0, 0, 0, 0, 1, !{2900} 4, 3, 0, 94, 21, 1, 70, 3, 2, 40, !{2900} 0, 90, 1, 9, 0, 0, 0, 0, 0, 1, !{2900} 0, 0, 0, 1, 4, 4, 0, 114, 1, 10, !{2900} 0, 108, 70, 5, 0, 0, 0, 1, 112, 0, !{2900} 0, 0, 0, 1, 4, 5, 0, 146, 20, 5, !{2900} 1, 11, 0, 0, 4, 2, 0, 0, 21, 1, !{2900} 23, 0, 70, 2, 3, 40, 0, 0, 1, 9, !{2900} 0, 0, 0, 0, 0, 1, 1, 12, 0, 202, !{2900} 2, 42, 0, 180, 21, 3, 22, 0, 4, 2, !{2900} 0, 0, 21, 1, 23, 0, 70, 2, 3, 40, !{2900} 0, 0, 1, 9, 0, 0, 0, 0, 0, 1, !{2900} 4, 2, 0, 0, 21, 1, 23, 0, 70, 2, !{2900} 3, 40, 0, 0, 1, 9, 0, 0, 0, 0, !{2900} 0, 1, 4, 6, 0, 0, 79, 0, 0, 0, !{2900} 0, 1, 21, 7, 0, 0, 0, 1, 1, 13, !{2900} 0, 0, 2, 61, 0, 0, 1, 14, 0, 0, !{2900} 59, 7, 6, 0, 0, 0, 0, 0, 0, 2, !{2900} 107, 0, 6, 0, 0, 254, 1, 15, 0, 0, !{2900} 0, 0, 0, 17, 21, 0, 53, 0, 6, 0, !{2900} 0, 0, 0, 0, 0, 20, 1, 16, 0, 0, !{2900} 1, 17, 0, 0, 128, 0, 6, 0, 1, 90, !{2900} 2, 42, 1, 46, 59, 2, 1, 18, 0, 0, !{2900} 1, 19, 1, 42, 0, 0, 0, 23, 0, 0, !{2900} 0, 35, 2, 47, 1, 82, 2, 47, 1, 64, !{2900} 59, 2, 1, 18, 0, 0, 0, 0, 0, 45, !{2900} 59, 2, 1, 18, 0, 0, 1, 19, 1, 78, !{2900} 0, 0, 0, 52, 0, 0, 0, 64, 1, 19, !{2900} 0, 0, 0, 0, 0, 74, 0, 0, 0, 82, !{2900} 2, 43, 1, 108, 59, 2, 1, 20, 0, 0, !{2900} 0, 0, 0, 88, 2, 45, 1, 122, 59, 2, !{2900} 1, 20, 0, 0, 0, 0, 0, 93, 2, 62, !{2900} 1, 142, 60, 0, 6, 0, 0, 0, 59, 3, !{2900} 1, 14, 0, 0, 0, 0, 0, 98, 2, 33, !{2900} 1, 156, 59, 4, 1, 14, 0, 0, 0, 0, !{2900} 0, 102, 2, 38, 1, 170, 59, 4, 1, 14, !{2900} 0, 0, 0, 0, 0, 106, 2, 126, 1, 184, !{2900} 59, 4, 1, 14, 0, 0, 0, 0, 0, 110, !{2900} 2, 35, 0, 0, 59, 4, 1, 14, 0, 0, !{2900} 0, 0, 0, 116, 6, 0, 0, 0, 1, 17, !{2900} 0, 0, 128, 0, 6, 0, 2, 8, 2, 42, !{2900} 1, 234, 59, 2, 1, 18, 0, 0, 1, 19, !{2900} 1, 230, 0, 0, 0, 122, 0, 0, 0, 135, !{2900} 2, 47, 2, 0, 59, 2, 1, 18, 0, 0, !{2900} 1, 19, 1, 252, 0, 0, 0, 146, 0, 0, !{2900} 0, 159, 1, 19, 0, 0, 0, 0, 0, 170, !{2900} 0, 0, 0, 179, 6, 0, 0, 0, 1, 17, !{2900} 0, 0, 2, 42, 2, 34, 59, 2, 1, 18, !{2900} 0, 0, 0, 0, 0, 186, 2, 47, 2, 62, !{2900} 2, 47, 2, 52, 59, 2, 1, 18, 0, 0, !{2900} 0, 0, 0, 197, 59, 2, 1, 18, 0, 0, !{2900} 0, 0, 0, 206, 0, 0, 0, 217, 1, 21, !{2900} 0, 0, 4, 7, 2, 84, 59, 2, 1, 17, !{2900} 0, 0, 0, 0, 0, 224, 0, 0, 0, 230, !{2900} 2, 40, 2, 124, 21, 6, 6, 0, 2, 108, !{2900} 53, 0, 6, 0, 0, 0, 0, 0, 0, 233, !{2900} 61, 0, 1, 14, 0, 0, 2, 41, 0, 0, !{2900} 62, 0, 0, 0, 0, 236, 21, 0, 2, 40, !{2900} 3, 0, 56, 0, 6, 0, 0, 0, 69, 0, !{2900} 6, 0, 2, 224, 6, 0, 2, 194, 6, 0, !{2900} 2, 166, 1, 22, 0, 0, 110, 3, 120, 0, !{2900} 6, 0, 0, 0, 0, 0, 0, 241, 2, 41, !{2900} 2, 180, 6, 0, 0, 0, 82, 0, 0, 0, !{2900} 0, 247, 1, 23, 0, 0, 2, 41, 0, 0, !{2900} 82, 0, 0, 0, 0, 249, 1, 24, 0, 0, !{2900} 51, 0, 2, 40, 2, 220, 1, 22, 0, 0, !{2900} 110, 3, 120, 0, 6, 0, 0, 0, 0, 0, !{2900} 0, 253, 0, 0, 1, 5, 2, 41, 2, 238, !{2900} 58, 0, 6, 0, 0, 0, 0, 0, 1, 10, !{2900} 1, 25, 0, 0, 2, 41, 0, 0, 58, 0, !{2900} 6, 0, 0, 0, 0, 0, 1, 12, 53, 0, !{2900} 6, 0, 0, 0, 0, 0, 1, 18, 21, 1, !{2900} 2, 40, 3, 102, 65, 0, 6, 0, 0, 0, !{2900} 84, 0, 6, 0, 3, 78, 6, 0, 3, 48, !{2900} 1, 22, 0, 0, 110, 1, 120, 0, 6, 0, !{2900} 0, 0, 0, 0, 1, 21, 1, 24, 0, 0, !{2900} 78, 0, 2, 40, 3, 74, 1, 22, 0, 0, !{2900} 110, 1, 120, 0, 6, 0, 0, 0, 0, 0, !{2900} 1, 27, 0, 0, 1, 35, 2, 41, 3, 88, !{2900} 80, 0, 0, 0, 1, 40, 1, 26, 0, 0, !{2900} 2, 41, 0, 0, 80, 0, 0, 0, 1, 43, !{2900} 54, 0, 6, 0, 0, 0, 0, 0, 1, 46, !{2900} 2, 43, 3, 122, 59, 6, 0, 0, 1, 49, !{2900} 2, 45, 3, 132, 59, 6, 0, 0, 1, 52, !{2900} 2, 92, 3, 162, 59, 5, 2, 43, 3, 148, !{2900} 59, 6, 0, 0, 1, 55, 2, 45, 3, 158, !{2900} 59, 6, 0, 0, 1, 58, 0, 0, 1, 61, !{2900} 0, 0, 1, 64, 2, 58, 3, 202, 116, 0, !{2900} 6, 0, 0, 0, 2, 41, 3, 190, 116, 0, !{2900} 6, 0, 0, 0, 0, 0, 1, 67, 1, 27, !{2900} 0, 0, 3, 41, 0, 0, 0, 0, 1, 69, !{2900} 1, 27, 0, 0, 3, 58, 0, 0, 2, 41, !{2900} 3, 224, 116, 0, 6, 0, 0, 0, 0, 0, !{2900} 1, 73, 1, 27, 0, 0, 3, 41, 0, 0, !{2900} 0, 0, 1, 77, 61, 0, 110, 12, 1, 14, !{2900} 0, 0, 59, 7, 62, 0, 0, 0, 1, 83, !{2900} 110, 12, 1, 29, 0, 0, 0, 0, 1, 88, !{2900} 107, 0, 6, 0, 4, 22, 1, 30, 0, 0, !{2900} 59, 7, 0, 0, 1, 91, 21, 0, 103, 0, !{2900} 6, 0, 0, 0, 0, 0, 1, 96, 1, 16, !{2900} 0, 0, 1, 31, 0, 0, 1, 32, 4, 62, !{2900} 1, 33, 0, 0, 1, 34, 4, 58, 0, 0, !{2900} 1, 99, 0, 0, 1, 111, 1, 34, 4, 70, !{2900} 0, 0, 1, 121, 0, 0, 1, 129, 1, 35, !{2900} 4, 86, 1, 36, 0, 0, 0, 0, 1, 135, !{2900} 1, 37, 0, 0, 1, 30, 0, 0, 0, 0, !{2900} 1, 140, 6, 0, 0, 0, 6, 0, 0, 0, !{2900} 1, 31, 0, 0, 1, 32, 4, 130, 1, 33, !{2900} 0, 0, 1, 34, 4, 126, 0, 0, 1, 145, !{2900} 0, 0, 1, 158, 1, 34, 4, 138, 0, 0, !{2900} 1, 169, 0, 0, 1, 178, 6, 0, 0, 0, !{2900} 6, 0, 0, 0, 1, 31, 0, 0, 1, 32, !{2900} 4, 166, 1, 33, 0, 0, 0, 0, 1, 185, !{2900} 0, 0, 1, 196, 1, 38, 0, 0, 4, 7, !{2900} 4, 188, 59, 2, 1, 31, 0, 0, 0, 0, !{2900} 1, 203, 0, 0, 1, 212, 2, 40, 4, 228, !{2900} 21, 6, 6, 0, 4, 212, 103, 1, 6, 0, !{2900} 0, 0, 0, 0, 1, 215, 61, 0, 1, 30, !{2900} 0, 0, 3, 41, 0, 0, 62, 0, 0, 0, !{2900} 1, 218, 21, 0, 103, 0, 6, 0, 0, 0, !{2900} 0, 0, 1, 223, 4, 8, 4, 250, 59, 2, !{2900} 0, 0, 1, 226, 2, 47, 5, 4, 59, 2, !{2900} 0, 0, 1, 229, 2, 42, 0, 0, 59, 2, !{2900} 0, 0, 1, 232, 2, 43, 5, 24, 59, 2, !{2900} 0, 0, 1, 235, 2, 45, 0, 0, 59, 2, !{2900} 0, 0, 1, 238, 2, 62, 5, 50, 60, 0, !{2900} 6, 0, 0, 0, 59, 3, 0, 0, 1, 241, !{2900} 2, 33, 5, 60, 59, 4, 0, 0, 1, 244, !{2900} 2, 38, 5, 70, 59, 4, 0, 0, 1, 247, !{2900} 2, 126, 5, 80, 59, 4, 0, 0, 1, 250, !{2900} 2, 35, 0, 0, 59, 4, 0, 0, 1, 253, !{2900} 2, 42, 5, 118, 21, 3, 49, 0, 6, 0, !{2900} 0, 0, 2, 44, 5, 114, 1, 25, 0, 0, !{2900} 0, 0, 2, 0, 0, 0, 2, 5, 1, 39, !{2900} 0, 0, 59, 7, 6, 0, 0, 0, 57, 0, !{2900} 6, 0, 0, 0, 2, 44, 5, 146, 1, 25, !{2900} 0, 0, 0, 0, 2, 8, 0, 0, 2, 19, !{2900} 107, 0, 6, 0, 5, 164, 1, 15, 0, 0, !{2900} 0, 0, 2, 28, 21, 0, 126, 0, 6, 0, !{2900} 0, 0, 0, 0, 2, 31, 1, 14, 0, 0, !{2900} 59, 7, 64, 0, 6, 0, 0, 0, 2, 44, !{2900} 5, 200, 1, 24, 0, 0, 0, 0, 2, 34, !{2900} 3, 41, 0, 0, 0, 0, 2, 42, 21, 1, !{2900} 81, 0, 2, 44, 5, 224, 1, 26, 0, 0, !{2900} 0, 0, 0, 1, 0, 0, 0, 1, 1, 14, !{2900} 0, 0, 59, 7, 6, 0, 0, 0, 83, 0, !{2900} 6, 0, 0, 0, 2, 44, 6, 0, 1, 23, !{2900} 0, 0, 0, 0, 2, 48, 0, 0, 2, 61, !{2900} 127, 0, 4, 9, 6, 34, 21, 3, 55, 1, !{2900} 6, 0, 0, 0, 4, 10, 0, 0, 21, 1, !{2900} 46, 0, 6, 0, 0, 0, 0, 0, 2, 72, !{2900} 4, 11, 6, 58, 2, 40, 6, 50, 1, 40, !{2900} 0, 0, 0, 0, 2, 78, 1, 41, 0, 0, !{2900} 0, 0, 2, 84, 4, 12, 6, 118, 21, 1, !{2900} 2, 40, 6, 104, 66, 0, 6, 0, 0, 0, !{2900} 2, 41, 6, 86, 6, 0, 0, 0, 0, 0, !{2900} 2, 93, 1, 25, 0, 0, 50, 0, 6, 0, !{2900} 0, 0, 2, 41, 0, 0, 0, 0, 2, 98, !{2900} 66, 0, 6, 0, 0, 0, 6, 0, 0, 0, !{2900} 0, 0, 2, 106, 4, 13, 6, 126, 0, 0, !{2900} 2, 111, 4, 14, 6, 138, 1, 42, 0, 0, !{2900} 0, 0, 0, 1, 4, 15, 6, 152, 27, 0, !{2900} 1, 43, 0, 0, 0, 0, 0, 1, 4, 16, !{2900} 6, 184, 20, 3, 121, 0, 2, 42, 6, 176, !{2900} 21, 3, 22, 0, 1, 44, 0, 0, 0, 0, !{2900} 0, 1, 1, 45, 0, 0, 0, 0, 0, 1, !{2900} 4, 5, 6, 204, 20, 5, 121, 0, 1, 11, !{2900} 0, 0, 1, 44, 0, 0, 0, 0, 0, 1, !{2900} 4, 17, 6, 220, 2, 40, 0, 0, 1, 40, !{2900} 0, 0, 0, 0, 2, 113, 4, 18, 6, 232, !{2900} 1, 46, 0, 0, 0, 0, 0, 1, 4, 19, !{2900} 6, 244, 1, 47, 0, 0, 0, 0, 0, 1, !{2900} 4, 20, 7, 20, 20, 6, 121, 0, 2, 42, !{2900} 7, 12, 21, 3, 22, 0, 1, 44, 0, 0, !{2900} 0, 0, 0, 1, 1, 45, 0, 0, 0, 0, !{2900} 0, 1, 4, 21, 7, 32, 1, 48, 0, 0, !{2900} 0, 0, 0, 1, 4, 22, 7, 46, 104, 1, !{2900} 1, 49, 0, 0, 0, 0, 0, 1, 4, 23, !{2900} 7, 60, 104, 0, 1, 49, 0, 0, 0, 0, !{2900} 0, 1, 4, 24, 7, 84, 2, 40, 7, 76, !{2900} 1, 40, 0, 0, 0, 0, 2, 119, 1, 41, !{2900} 0, 0, 0, 0, 2, 125, 4, 25, 7, 94, !{2900} 113, 3, 0, 0, 2, 134, 4, 26, 7, 104, !{2900} 19, 1, 0, 0, 2, 137, 4, 27, 7, 130, !{2900} 19, 0, 21, 1, 70, 4, 2, 40, 7, 126, !{2900} 1, 9, 0, 0, 0, 0, 0, 1, 0, 0, !{2900} 0, 1, 4, 28, 7, 158, 1, 14, 0, 0, !{2900} 59, 7, 6, 0, 0, 0, 2, 41, 0, 0, !{2900} 4, 29, 0, 0, 113, 1, 0, 0, 2, 139, !{2900} 4, 30, 7, 168, 113, 2, 0, 0, 2, 148, !{2900} 4, 31, 7, 178, 88, 0, 0, 0, 0, 1, !{2900} 4, 32, 7, 202, 1, 50, 0, 0, 3, 41, !{2900} 0, 0, 7, 44, 0, 0, 1, 14, 0, 0, !{2900} 0, 0, 2, 151, 4, 33, 7, 218, 21, 0, !{2900} 55, 0, 6, 0, 0, 0, 0, 0, 2, 157, !{2900} 4, 34, 7, 250, 20, 1, 121, 0, 2, 42, !{2900} 7, 242, 21, 3, 22, 0, 1, 44, 0, 0, !{2900} 0, 0, 0, 1, 1, 45, 0, 0, 0, 0, !{2900} 0, 1, 4, 35, 8, 8, 1, 51, 0, 0, !{2900} 39, 0, 0, 0, 0, 1, 4, 36, 8, 22, !{2900} 104, 3, 1, 49, 0, 0, 0, 0, 0, 1, !{2900} 4, 37, 8, 38, 2, 40, 0, 0, 1, 40, !{2900} 0, 0, 0, 0, 2, 159, 4, 38, 8, 70, !{2900} 20, 4, 121, 0, 2, 42, 8, 62, 21, 3, !{2900} 22, 0, 1, 44, 0, 0, 0, 0, 0, 1, !{2900} 1, 45, 0, 0, 0, 0, 0, 1, 4, 39, !{2900} 8, 86, 2, 40, 0, 0, 1, 40, 0, 0, !{2900} 0, 0, 2, 165, 4, 40, 8, 112, 1, 52, !{2900} 0, 0, 2, 44, 8, 108, 110, 1, 1, 53, !{2900} 0, 0, 0, 0, 2, 171, 0, 0, 2, 182, !{2900} 4, 41, 8, 128, 3, 40, 0, 0, 1, 54, !{2900} 0, 0, 0, 0, 0, 1, 4, 42, 8, 154, !{2900} 89, 0, 6, 0, 8, 142, 0, 0, 2, 191, !{2900} 21, 5, 48, 0, 6, 0, 0, 0, 0, 0, !{2900} 2, 193, 4, 43, 8, 186, 20, 2, 121, 0, !{2900} 2, 42, 8, 178, 21, 3, 22, 0, 1, 44, !{2900} 0, 0, 0, 0, 0, 1, 1, 45, 0, 0, !{2900} 0, 0, 0, 1, 4, 44, 8, 230, 2, 40, !{2900} 8, 208, 1, 55, 0, 0, 110, 1, 1, 53, !{2900} 0, 0, 0, 0, 2, 195, 1, 52, 0, 0, !{2900} 2, 44, 8, 226, 110, 1, 1, 53, 0, 0, !{2900} 0, 0, 2, 203, 0, 0, 2, 214, 4, 45, !{2900} 8, 254, 111, 0, 6, 0, 8, 244, 0, 0, !{2900} 2, 223, 110, 12, 1, 14, 0, 0, 0, 0, !{2900} 2, 225, 4, 46, 9, 22, 2, 40, 9, 14, !{2900} 1, 40, 0, 0, 0, 0, 2, 229, 1, 41, !{2900} 0, 0, 0, 0, 2, 235, 4, 47, 9, 48, !{2900} 89, 0, 6, 0, 9, 36, 0, 0, 2, 244, !{2900} 21, 5, 48, 0, 6, 0, 0, 0, 0, 0, !{2900} 2, 246, 4, 48, 9, 72, 121, 0, 89, 0, !{2900} 6, 0, 9, 64, 0, 0, 0, 1, 1, 56, !{2900} 0, 0, 0, 0, 0, 1, 4, 49, 9, 94, !{2900} 2, 40, 0, 0, 1, 55, 0, 0, 110, 1, !{2900} 1, 53, 0, 0, 0, 0, 2, 248, 4, 50, !{2900} 9, 104, 40, 0, 0, 0, 0, 1, 4, 6, !{2900} 9, 114, 79, 0, 0, 0, 0, 1, 4, 51, !{2900} 0, 0, 98, 0, 0, 0, 0, 1, 2, 42, !{2900} 9, 182, 2, 40, 9, 170, 2, 42, 9, 150, !{2900} 3, 41, 0, 0, 123, 0, 7, 44, 0, 0, !{2900} 0, 0, 0, 1, 1, 28, 0, 0, 3, 41, !{2900} 0, 0, 123, 1, 22, 0, 7, 44, 0, 0, !{2900} 0, 0, 0, 1, 21, 3, 22, 0, 7, 44, !{2900} 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, !{2900} 2, 42, 9, 232, 2, 40, 9, 224, 2, 42, !{2900} 9, 208, 3, 41, 0, 0, 123, 2, 0, 0, !{2900} 0, 1, 1, 28, 0, 0, 3, 41, 0, 0, !{2900} 123, 1, 24, 0, 0, 0, 0, 1, 21, 3, !{2900} 24, 0, 0, 0, 0, 1, 0, 0, 0, 1, !{2900} 4, 34, 9, 246, 20, 1, 0, 0, 0, 1, !{2900} 4, 43, 10, 0, 20, 2, 0, 0, 0, 1, !{2900} 4, 16, 10, 10, 20, 3, 0, 0, 0, 1, !{2900} 4, 38, 10, 20, 20, 4, 0, 0, 0, 1, !{2900} 4, 20, 10, 30, 20, 6, 0, 0, 0, 1, !{2900} 4, 5, 0, 0, 20, 5, 0, 0, 0, 1, !{2900} 21, 1, 23, 0, 1, 58, 0, 0, 2, 44, !{2900} 10, 60, 1, 45, 0, 0, 0, 0, 0, 1, !{2900} 0, 0, 0, 1, 21, 1, 23, 0, 1, 58, !{2900} 0, 0, 1, 57, 10, 92, 2, 44, 10, 88, !{2900} 1, 44, 0, 0, 0, 0, 0, 1, 0, 0, !{2900} 0, 1, 2, 44, 10, 104, 1, 44, 0, 0, !{2900} 0, 0, 0, 1, 0, 0, 0, 1, 2, 40, !{2900} 10, 122, 25, 0, 1, 59, 0, 0, 0, 0, !{2900} 0, 1, 0, 0, 0, 1, 2, 42, 10, 142, !{2900} 114, 0, 3, 41, 0, 0, 35, 0, 0, 0, !{2900} 0, 1, 1, 60, 0, 0, 26, 0, 2, 44, !{2900} 10, 160, 1, 59, 0, 0, 0, 0, 0, 1, !{2900} 2, 41, 10, 170, 35, 0, 0, 0, 0, 1, !{2900} 3, 58, 0, 0, 2, 42, 10, 190, 114, 1, !{2900} 3, 41, 0, 0, 35, 0, 0, 0, 0, 1, !{2900} 1, 60, 0, 0, 26, 1, 2, 44, 10, 208, !{2900} 1, 59, 0, 0, 0, 0, 0, 1, 3, 41, !{2900} 0, 0, 35, 0, 0, 0, 0, 1, 1, 28, !{2900} 0, 0, 0, 0, 3, 0, 21, 5, 2, 42, !{2900} 11, 4, 36, 0, 21, 5, 37, 0, 2, 44, !{2900} 10, 250, 1, 61, 0, 0, 0, 0, 0, 1, !{2900} 3, 47, 0, 0, 38, 0, 0, 0, 0, 1, !{2900} 37, 0, 2, 44, 11, 18, 1, 61, 0, 0, !{2900} 0, 0, 0, 1, 3, 47, 0, 0, 38, 0, !{2900} 0, 0, 0, 1, 21, 1, 2, 40, 0, 0, !{2900} 25, 0, 1, 59, 0, 0, 2, 44, 11, 52, !{2900} 1, 46, 0, 0, 0, 0, 0, 1, 0, 0, !{2900} 0, 1, 2, 47, 11, 70, 27, 0, 1, 43, !{2900} 0, 0, 0, 0, 0, 1, 21, 1, 28, 0, !{2900} 3, 47, 0, 0, 1, 43, 0, 0, 0, 0, !{2900} 0, 1, 21, 1, 29, 0, 1, 58, 0, 0, !{2900} 2, 44, 11, 118, 2, 47, 11, 110, 1, 42, !{2900} 0, 0, 0, 0, 0, 1, 1, 43, 0, 0, !{2900} 0, 0, 0, 1, 2, 47, 11, 130, 1, 42, !{2900} 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, !{2900} 21, 1, 30, 0, 1, 63, 0, 0, 3, 47, !{2900} 0, 0, 1, 61, 0, 0, 122, 0, 7, 44, !{2900} 0, 0, 1, 47, 0, 0, 0, 0, 0, 1, !{2900} 30, 0, 1, 64, 0, 0, 2, 47, 0, 0, !{2900} 1, 61, 0, 0, 122, 0, 7, 44, 0, 0, !{2900} 1, 47, 0, 0, 0, 0, 0, 1, 2, 40, !{2900} 11, 216, 1, 65, 0, 0, 2, 44, 11, 212, !{2900} 1, 64, 0, 0, 0, 0, 0, 1, 0, 0, !{2900} 0, 1, 21, 1, 2, 40, 11, 244, 32, 0, !{2900} 1, 66, 0, 0, 2, 44, 11, 240, 1, 64, !{2900} 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, !{2900} 31, 0, 2, 44, 12, 2, 1, 64, 0, 0, !{2900} 0, 0, 0, 1, 0, 0, 0, 1, 41, 0, !{2900} 1, 67, 0, 0, 0, 0, 0, 1, 2, 40, !{2900} 12, 36, 1, 65, 0, 0, 3, 44, 0, 0, !{2900} 1, 67, 0, 0, 0, 0, 0, 1, 21, 1, !{2900} 2, 40, 12, 60, 41, 1, 1, 68, 0, 0, !{2900} 3, 44, 0, 0, 1, 67, 0, 0, 0, 0, !{2900} 0, 1, 3, 61, 0, 0, 41, 2, 21, 0, !{2900} 41, 3, 3, 44, 0, 0, 21, 0, 41, 4, !{2900} 2, 44, 12, 96, 21, 0, 41, 5, 3, 41, !{2900} 0, 0, 41, 6, 0, 0, 0, 1, 3, 41, !{2900} 0, 0, 41, 7, 41, 6, 0, 0, 0, 1, !{2900} 21, 0, 41, 8, 2, 44, 12, 124, 1, 68, !{2900} 0, 0, 0, 0, 0, 1, 3, 41, 0, 0, !{2900} 41, 9, 0, 0, 0, 1, 2, 40, 12, 162, !{2900} 32, 0, 1, 66, 0, 0, 2, 44, 12, 158, !{2900} 21, 1, 1, 63, 0, 0, 0, 0, 0, 1, !{2900} 0, 0, 0, 1, 31, 0, 2, 44, 12, 178, !{2900} 21, 1, 1, 63, 0, 0, 0, 0, 0, 1, !{2900} 0, 0, 0, 1, 32, 1, 6, 0, 12, 200, !{2900} 1, 22, 0, 0, 118, 0, 31, 1, 0, 0, !{2900} 0, 1, 1, 69, 0, 0, 0, 0, 0, 1, !{2900} 1, 28, 0, 0, 118, 0, 33, 0, 2, 44, !{2900} 12, 228, 1, 69, 0, 0, 0, 0, 0, 1, !{2900} 3, 41, 0, 0, 2, 40, 12, 248, 1, 22, !{2900} 0, 0, 118, 0, 34, 1, 0, 0, 0, 1, !{2900} 34, 0, 0, 0, 0, 1, 1, 70, 0, 0, !{2900} 118, 0, 2, 44, 13, 16, 1, 54, 0, 0, !{2900} 0, 0, 0, 1, 3, 41, 0, 0, 0, 0, !{2900} 0, 1, 21, 1, 3, 61, 0, 0, 102, 0, !{2900} 6, 0, 0, 0, 1, 29, 0, 0, 120, 0, !{2900} 6, 0, 0, 0, 0, 0, 3, 5, 1, 12, !{2900} 0, 0, 2, 42, 13, 126, 2, 40, 13, 98, !{2900} 1, 28, 0, 0, 3, 41, 0, 0, 123, 1, !{2900} 22, 0, 2, 40, 0, 0, 1, 71, 0, 0, !{2900} 2, 44, 13, 94, 1, 51, 0, 0, 0, 0, !{2900} 0, 1, 0, 0, 0, 1, 21, 3, 22, 0, !{2900} 2, 40, 0, 0, 1, 71, 0, 0, 2, 44, !{2900} 13, 122, 1, 51, 0, 0, 0, 0, 0, 1, !{2900} 0, 0, 0, 1, 2, 40, 0, 0, 1, 71, !{2900} 0, 0, 2, 44, 13, 146, 1, 51, 0, 0, !{2900} 0, 0, 0, 1, 0, 0, 0, 1, 42, 0, !{2900} 2, 45, 13, 178, 43, 0, 2, 44, 13, 170, !{2900} 1, 71, 0, 0, 0, 0, 0, 1, 3, 41, !{2900} 0, 0, 0, 0, 0, 1, 2, 44, 13, 190, !{2900} 1, 71, 0, 0, 0, 0, 0, 1, 3, 41, !{2900} 0, 0, 0, 0, 0, 1, 3, 40, 0, 0, !{2900} 21, 1, 30, 0, 1, 63, 0, 0, 3, 41, !{2900} 0, 0, 44, 0, 2, 44, 13, 228, 1, 48, !{2900} 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, !{2900} 21, 3, 49, 0, 2, 44, 13, 248, 1, 50, !{2900} 0, 0, 0, 0, 3, 10, 50, 0, 6, 0, !{2900} 0, 0, 0, 0, 3, 13, 1, 72, 14, 26, !{2900} 2, 44, 14, 18, 1, 73, 0, 0, 0, 0, !{2900} 3, 16, 3, 41, 0, 0, 0, 0, 3, 21, !{2900} 1, 41, 0, 0, 2, 44, 14, 66, 1, 73, !{2900} 14, 42, 0, 0, 3, 24, 1, 52, 0, 0, !{2900} 2, 44, 14, 58, 1, 73, 0, 0, 0, 0, !{2900} 3, 32, 3, 41, 0, 0, 0, 0, 3, 45, !{2900} 3, 41, 0, 0, 0, 0, 3, 56, 1, 72, !{2900} 0, 0, 2, 44, 14, 90, 1, 73, 0, 0, !{2900} 0, 0, 3, 62, 3, 41, 0, 0, 0, 0, !{2900} 3, 67, 2, 42, 14, 106, 0, 0, 3, 70, !{2900} 110, 1, 1, 14, 0, 0, 0, 0, 3, 73, !{2900} 2, 42, 14, 124, 0, 0, 3, 76, 110, 1, !{2900} 1, 14, 0, 0, 0, 0, 3, 79, 4, 52, !{2900} 14, 146, 1, 41, 0, 0, 0, 0, 3, 82, !{2900} 4, 53, 14, 158, 1, 52, 0, 0, 0, 0, !{2900} 3, 88, 4, 54, 14, 172, 110, 1, 1, 14, !{2900} 0, 0, 0, 0, 3, 94, 4, 55, 14, 186, !{2900} 21, 0, 6, 0, 0, 0, 0, 0, 3, 100, !{2900} 4, 56, 14, 200, 21, 0, 6, 0, 0, 0, !{2900} 0, 0, 3, 104, 4, 57, 0, 0, 110, 1, !{2900} 1, 14, 0, 0, 0, 0, 3, 108, 1, 72, !{2900} 14, 238, 2, 44, 14, 230, 1, 74, 0, 0, !{2900} 0, 0, 3, 114, 3, 41, 0, 0, 0, 0, !{2900} 3, 119, 1, 74, 14, 246, 0, 0, 3, 122, !{2900} 1, 41, 0, 0, 2, 44, 15, 6, 1, 74, !{2900} 0, 0, 0, 0, 3, 125, 3, 41, 0, 0, !{2900} 0, 0, 3, 133, 110, 1, 1, 72, 15, 40, !{2900} 2, 44, 15, 32, 1, 74, 0, 0, 0, 0, !{2900} 3, 139, 3, 41, 0, 0, 0, 0, 3, 144, !{2900} 1, 75, 0, 0, 3, 61, 0, 0, 1, 14, !{2900} 0, 0, 2, 44, 15, 64, 1, 74, 0, 0, !{2900} 0, 0, 3, 147, 3, 41, 0, 0, 0, 0, !{2900} 3, 156, 4, 58, 15, 80, 0, 0, 3, 163, !{2900} 4, 59, 15, 88, 0, 0, 3, 166, 4, 60, !{2900} 15, 96, 0, 0, 3, 169, 4, 61, 15, 104, !{2900} 0, 0, 3, 172, 4, 62, 15, 112, 0, 0, !{2900} 3, 175, 4, 63, 15, 120, 0, 0, 3, 178, !{2900} 4, 64, 15, 128, 0, 0, 3, 181, 4, 65, !{2900} 15, 136, 0, 0, 3, 184, 4, 66, 15, 144, !{2900} 0, 0, 3, 187, 4, 67, 15, 152, 0, 0, !{2900} 3, 190, 4, 68, 15, 160, 0, 0, 3, 193, !{2900} 4, 69, 15, 168, 0, 0, 3, 196, 4, 70, !{2900} 15, 176, 0, 0, 3, 199, 4, 71, 15, 184, !{2900} 0, 0, 3, 202, 4, 72, 15, 192, 0, 0, !{2900} 3, 205, 4, 73, 15, 200, 0, 0, 3, 208, !{2900} 4, 74, 15, 208, 0, 0, 3, 211, 4, 75, !{2900} 15, 216, 0, 0, 3, 214, 4, 76, 0, 0, !{2900} 0, 0, 3, 217, 2, 40, 16, 52, 73, 0, !{2900} 1, 53, 0, 0, 2, 61, 16, 38, 76, 0, !{2900} 6, 0, 0, 0, 1, 76, 0, 0, 3, 44, !{2900} 0, 0, 1, 76, 0, 0, 2, 44, 16, 20, !{2900} 1, 76, 0, 0, 3, 41, 0, 0, 1, 77, !{2900} 0, 0, 0, 0, 3, 220, 47, 1, 6, 0, !{2900} 0, 0, 3, 41, 0, 0, 1, 77, 0, 0, !{2900} 0, 0, 3, 235, 3, 41, 0, 0, 93, 0, !{2900} 1, 77, 0, 0, 0, 0, 3, 248, 125, 0, !{2900} 6, 0, 16, 84, 6, 0, 16, 66, 0, 0, !{2900} 0, 1, 21, 1, 53, 0, 72, 0, 6, 0, !{2900} 0, 0, 1, 77, 0, 0, 0, 0, 3, 253, !{2900} 110, 1, 1, 14, 0, 0, 59, 7, 1, 77, !{2900} 0, 0, 0, 0, 4, 2, 2, 44, 16, 114, !{2900} 68, 0, 1, 53, 0, 0, 0, 0, 4, 9, !{2900} 0, 0, 0, 1, 21, 1, 67, 0, 2, 44, !{2900} 16, 134, 1, 49, 0, 0, 0, 0, 0, 1, !{2900} 0, 0, 0, 1, 2, 47, 16, 166, 21, 1, !{2900} 124, 1, 3, 47, 0, 0, 2, 44, 16, 162, !{2900} 1, 56, 0, 0, 0, 0, 0, 1, 0, 0, !{2900} 0, 1, 21, 1, 124, 0, 2, 44, 16, 182, !{2900} 1, 56, 0, 0, 0, 0, 0, 1, 0, 0, !{2900} 0, 1, 2, 41, 16, 194, 0, 0, 0, 1, !{2900} 2, 42, 16, 220, 74, 0, 2, 44, 16, 212, !{2900} 1, 9, 0, 0, 0, 0, 0, 1, 3, 41, !{2900} 0, 0, 0, 0, 0, 1, 21, 1, 75, 0, !{2900} 2, 44, 16, 236, 1, 9, 0, 0, 0, 0, !{2900} 0, 1, 3, 41, 0, 0, 0, 0, 0, 1, !{2900} 4, 77, 0, 0, 1, 14, 0, 0, 59, 7, !{2900} 6, 0, 0, 0, 3, 41, 0, 0, 63, 0, !{2900} 6, 0, 17, 56, 18, 0, 21, 3, 55, 0, !{2900} 17, 0, 6, 0, 0, 0, 2, 44, 0, 0, !{2900} 21, 3, 55, 0, 17, 0, 6, 0, 0, 0, !{2900} 2, 44, 0, 0, 21, 3, 55, 0, 17, 0, !{2900} 6, 0, 0, 0, 0, 0, 4, 12, 4, 77, !{2900} 17, 124, 1, 14, 0, 0, 59, 7, 6, 0, !{2900} 0, 0, 2, 41, 0, 0, 63, 0, 6, 0, !{2900} 0, 0, 18, 0, 21, 3, 55, 0, 17, 0, !{2900} 6, 0, 0, 0, 2, 44, 0, 0, 21, 3, !{2900} 55, 0, 17, 0, 6, 0, 0, 0, 2, 44, !{2900} 0, 0, 21, 3, 55, 0, 17, 0, 6, 0, !{2900} 0, 0, 0, 0, 4, 19, 4, 29, 17, 134, !{2900} 113, 0, 0, 0, 4, 32, 1, 2, 0, 0, !{2900} 0, 0, 4, 41, 4, 77, 0, 0, 1, 14, !{2900} 0, 0, 59, 7, 6, 0, 0, 0, 3, 41, !{2900} 0, 0, 77, 0, 1, 3, 0, 0, 0, 0, !{2900} 4, 51, 2, 68, 0, 0, 3, 79, 0, 0, !{2900} 21, 3, 45, 0, 6, 0, 0, 0, 7, 44, !{2900} 0, 0, 21, 1, 46, 1, 6, 0, 0, 0, !{2900} 3, 61, 0, 0, 1, 76, 0, 0, 3, 44, !{2900} 0, 0, 1, 76, 0, 0, 2, 44, 17, 226, !{2900} 1, 76, 0, 0, 0, 0, 4, 61, 47, 1, !{2900} 6, 0, 0, 0, 0, 0, 4, 69, 110, 9, !{2900} 1, 14, 0, 0, 59, 7, 0, 0, 4, 75, !{2900} 0(101); %CONSTBYTEINTEGERARRAY SSTRING(0:600)= %C 7, 80, 82, 79, 71, 82, 65, 77, 8, 70, 85, 78, 67, 84, 73, 79, 78, 0, 10, 83, 85, 66, 82, 79, 85, 84, 73, 78, 69, 0, 9, 66, 76, 79, 67, 75, 68, 65, 84, 65, 9, 67, 72, 65, 82, 65, 67, 84, 69, 82, 5, 88, 67, 79, 68, 69, 2, 42, 42, 0, 2, 47, 47, 0, 6, 65, 83, 83, 73, 71, 78, 0, 2, 84, 79, 0, 9, 66, 65, 67, 75, 83, 80, 65, 67, 69, 4, 67, 65, 76, 76, 0, 8, 67, 79, 78, 84, 73, 78, 85, 69, 0, 7, 67, 79, 77, 77, 79, 78, 47, 6, 67, 79, 77, 77, 79, 78, 0, 7, 67, 79, 77, 80, 76, 69, 88, 5, 67, 76, 79, 83, 69, 9, 68, 73, 77, 69, 78, 83, 73, 79, 78, 4, 68, 65, 84, 65, 0, 15, 68, 79, 85, 66, 76, 69, 80, 82, 69, 67, 73, 83, 73, 79, 78, 11, 69, 81, 85, 73, 86, 65, 76, 69, 78, 67, 69, 15, 69, 88, 84, 69, 82, 78, 65, 76, 47, 65, 76, 71, 79, 76, 47, 8, 69, 88, 84, 69, 82, 78, 65, 76, 0, 7, 69, 78, 68, 70, 73, 76, 69, 5, 69, 78, 68, 73, 70, 3, 69, 78, 68, 5, 69, 78, 84, 82, 89, 7, 69, 76, 83, 69, 73, 70, 40, 4, 84, 72, 69, 78, 0, 4, 69, 76, 83, 69, 0, 6, 70, 79, 82, 77, 65, 84, 0, 5, 71, 79, 84, 79, 40, 4, 71, 79, 84, 79, 0, 7, 73, 78, 84, 69, 71, 69, 82, 8, 73, 77, 80, 76, 73, 67, 73, 84, 0, 9, 73, 78, 84, 82, 73, 78, 83, 73, 67, 7, 73, 78, 81, 85, 73, 82, 69, 7, 76, 79, 71, 73, 67, 65, 76, 4, 79, 80, 69, 78, 0, 5, 80, 82, 73, 78, 84, 9, 80, 65, 82, 65, 77, 69, 84, 69, 82, 5, 80, 65, 85, 83, 69, 4, 82, 69, 65, 76, 0, 4, 82, 69, 65, 68, 0, 6, 82, 69, 84, 85, 82, 78, 0, 6, 82, 69, 87, 73, 78, 68, 0, 4, 83, 84, 79, 80, 0, 4, 83, 65, 86, 69, 0, 5, 87, 82, 73, 84, 69, 7, 88, 80, 82, 73, 78, 84, 68, 8, 88, 77, 79, 78, 73, 84, 79, 82, 0, 5, 85, 78, 73, 84, 61, 4, 70, 77, 84, 61, 0, 4, 82, 69, 67, 61, 0, 4, 69, 78, 68, 61, 0, 4, 69, 82, 82, 61, 0, 7, 73, 79, 83, 84, 65, 84, 61, 8, 70, 73, 76, 69, 84, 89, 80, 69, 0, 6, 83, 84, 65, 84, 85, 83, 0, 6, 65, 67, 67, 69, 83, 83, 0, 9, 70, 79, 82, 77, 65, 84, 84, 69, 68, 4, 70, 79, 82, 77, 0, 4, 82, 69, 67, 76, 0, 5, 66, 76, 65, 78, 75, 5, 69, 88, 73, 83, 84, 6, 79, 80, 69, 78, 69, 68, 0, 6, 78, 85, 77, 66, 69, 82, 0, 5, 78, 65, 77, 69, 68, 4, 78, 65, 77, 69, 0, 4, 78, 82, 69, 67, 0, 10, 83, 69, 81, 85, 69, 78, 84, 73, 65, 76, 0, 6, 68, 73, 82, 69, 67, 84, 0, 11, 85, 78, 70, 79, 82, 77, 65, 84, 84, 69, 68, 7, 78, 69, 88, 84, 82, 69, 67, 4, 68, 69, 83, 67, 0, 4, 70, 73, 76, 69, 0, 3, 73, 70, 40, 0(11); %CONSTHALFINTEGERARRAY SHEADS(0:80)= %C 0, 0, 8, 18, 30, 40, 50, 56, 60, 64, 72, 76, 86, 92, 102, 110, 118, 126, 132, 142, 148, 164, 176, 192, 202, 210, 216, 220, 226, 234, 240, 246, 254, 260, 266, 274, 284, 294, 302, 310, 316, 322, 332, 338, 344, 350, 358, 366, 372, 378, 384, 392, 402, 408, 414, 420, 426, 432, 440, 450, 458, 466, 476, 482, 488, 494, 500, 508, 516, 522, 528, 534, 546, 554, 566, 574, 580, 586, 0(3); !{2900}%CONSTSTRING(8)%ARRAY SUBNAMES(0:82)= %C !{2900}"" ,"STAT" ,"SS" ,"ASS" ,"DO" , !{2900}"IFL" ,"IFA" ,"IFAS" ,"SSS" ,"DARL" , !{2900}"IDEN" ,"CHLEN" ,"TYPE" ,"VAR" ,"EX" , !{2900}"EXP" ,"ADOP" ,"F" ,"T" ,"EXT" , !{2900}"ET" ,"U" ,"SUBSTRG" ,"SFPAR" ,"SSLIST" , !{2900}"APLIST" ,"SFLST" ,"INTEXP" ,"CINTEXP" ,"CNSTEXP" , !{2900}"CEX" ,"CF" ,"CMULDIV" ,"CT" ,"CEXT" , !{2900}"CADSUB" ,"CET" ,"CLOGREL" ,"CU" ,"PEX" , !{2900}"AIOLIST" ,"UNIT" ,"CLIS1" ,"CLIS2" ,"CHLIST" , !{2900}"LIST" ,"DLIST" ,"DATLI" ,"ELIST" ,"FLIST" , !{2900}"LLIST" ,"ILIST" ,"FMT" ,"IOLIST" ,"PLIST" , !{2900}"CILIST" ,"SAVLIST" ,"CHLEN2" ,"DIMS" ,"DIMLI" , !{2900}"DBEXP" ,"DAT" ,"ODATLI" ,"VLIST" ,"DALIST" , !{2900}"IMPDO" ,"INTORSS" ,"IMPDOL" ,"IMPDSL" ,"INTLI" , !{2900}"PITEM" ,"LETLI" ,"CIKEY" ,"CILIST2" ,"AIOLST2" , !{2900}"CIKEY2" ,"DOEX" ,"JLIST" ,"" ,"" , !{2900}"" ,"" ,"" !* !*** ENDSYNTAX *** !* !* !*********************************************************************** !%INCLUDE "ERCS06.PERQ_DICTFMTS" ; !*********************************************************************** !* !* !*********************************************************************** !* Formats for accessing dictionary records * !*********************************************************************** !* %RECORDFORMAT PRECF( %C %BYTEINTEGER CLASS,TYPE,X0,X1, %C %INTEGER LINK1, LINK2, LINK3, ADDR4, %C %HALFINTEGER DISP,LEN,IDEN,IIN, %C %INTEGER LINE,XREF,CMNLENGTH, CMNREFAD) !* %RECORDFORMAT SRECF(%INTEGER INF0, LINK1, INF2, INF3, INF4) !* %RECORDFORMAT RESF((%INTEGER W %OR %HALFINTEGER H0, (%HALFINTEGER H1 %OR %BYTEINTEGER FORM,MODE))) !* %RECORDFORMAT DORECF( %C %INTEGER LABEL, LINK1, LOOPAD, ENDREF, %RECORD(RESF) INDEXRD, INCRD, FINALRD, ICRD, %INTEGER LABLIST,LINE) !* %RECORDFORMAT BFMT(%INTEGER L,U,M) !* %RECORDFORMAT ARRAYDVF(%HALFINTEGER DIMS, ADDRDV, %C %INTEGER ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH, %C %RECORD(BFMT) %ARRAY B(1 : 7)) !* !* %RECORDFORMAT LRECF(%INTEGER NOTFLAG,LINK1,ORLIST,ANDLIST,RELOP) !* %RECORDFORMAT IFRECF(%INTEGER TYPE,LINK1,ENDIFJUMP,FALSELIST, %C LABLIST,LINE) !* %RECORDFORMAT LABRECF(%BYTEINTEGER CLASS,TYPE,X0,X1, %C %INTEGER LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE, %C %HALFINTEGER DOSTART,DOEND,IFSTART,IFEND) !* %RECORDFORMAT PLABF(%INTEGER INDEX,CODEAD,REF,REFCHAIN) !* %RECORDFORMAT IMPDORECF(%INTEGER VAL,LINK,IDEN) !* %RECORDFORMAT CONRECF(%INTEGER MODE,LINK1,DADDR,CADDR) !* %RECORDFORMAT TMPF(%BYTEINTEGER REG,MODE,%HALFINTEGER INDEX, %C %INTEGER LINK1,ADDR) !* %RECORDFORMAT CHARF(%INTEGER ADESC,LINK,LEN) !* %RECORDFORMAT FNRECF(%INTEGER FPTR,LINK1,HEAD,PCT) !* !* !*********************************************************************** !* Constants defining the size of DICT records * !*********************************************************************** !* %CONSTINTEGER IDRECSIZE = 14;! size of dict entry reserved for a new identifier %CONSTINTEGER CONRECSIZE = 8 %CONSTINTEGER CNSTRECMIN = 2 %CONSTINTEGER IMPDORECSIZE = 6;! size of DATA-implied-DO list item %CONSTINTEGER LABRECSIZE = 20 %CONSTINTEGER PLABRECSIZE = 8 %CONSTINTEGER XREFSIZE = 4 %CONSTINTEGER CMNRECEXT = 8;! extra space on iden record for common block name %CONSTINTEGER TMPRECSIZE = 6 %CONSTINTEGER DVRECSIZE = 10 !* !*********************************************************************** !* TRIAD record format * !*********************************************************************** !* %RECORDFORMAT TRIADF( %C %BYTEINTEGER OP, (%BYTEINTEGER USE %OR %BYTEINTEGER VAL2), %HALFINTEGER CHAIN, (%RECORD(RESF) RES1 %OR %C (%HALFINTEGER OPD1,%BYTEINTEGER QOPD1,MODE %OR %C (%INTEGER SLN %OR %INTEGER VAL1))), (%RECORD(RESF) RES2 %OR %C %HALFINTEGER OPD2,%BYTEINTEGER QOPD2,MODE2)) !* !* !*********************************************************************** !*********************************************************************** !* !* !*********************************************************************** !%INCLUDE "ERCS06.PERQ_CONSTS" ; !*********************************************************************** !* !* !********************* TRIAD QUALIFIERS ******************************** !* %CONSTINTEGER NULL = 0 %CONSTINTEGER LIT = 1 %CONSTINTEGER CNSTID = 2 %CONSTINTEGER TRIAD = 3 %CONSTINTEGER LSCALID = 4 %CONSTINTEGER OSCALID = 5 %CONSTINTEGER CSCALID = 6 %CONSTINTEGER PSCALID = 7 %CONSTINTEGER TMPID = 8 %CONSTINTEGER ARRID = 9 %CONSTINTEGER LABID =10 %CONSTINTEGER PLABID =11 %CONSTINTEGER PROCID =12 %CONSTINTEGER ARREL =13 %CONSTINTEGER CHVAL =15 %CONSTINTEGER STKLIT =16 %CONSTINTEGER GLALIT =17 %CONSTINTEGER NEGLIT =18 %CONSTINTEGER ASCALID =19 %CONSTINTEGER PERMID = 20 !* !********************* MODES **************************************** !* %CONSTINTEGER INT2 = 0, INT4 = 1, INT8 = 2 %CONSTINTEGER REAL4 = 3, REAL8 = 4, REAL16 = 5 %CONSTINTEGER CMPLX8 = 6, CMPLX16 = 7, CMPLX32 = 8 %CONSTINTEGER LOG1 =13, LOG4 = 9, LOG8 =14 %CONSTINTEGER CHARMODE=10, HOLMODE =11 !* !********************* TYPES ************************************** !* %CONSTINTEGER INTTYPE = 1 %CONSTINTEGER REALTYPE = 2 %CONSTINTEGER CMPLXTYPE = 3 %CONSTINTEGER LOGTYPE = 4 %CONSTINTEGER CHARTYPE = 5 !* !********************* DICT INDEX SCALING FACTOR ****************** !* %CONSTINTEGER DSCALE = 0 !* !********************* REGISTER HOLDING INTERMEDIATE VALUE ******** !* %CONSTINTEGER INACC = 1 !* !*********************** length of maximum source statement *********** !* %CONSTINTEGER INPUT LIMIT = 1340 !* !*********************** fixed locations in global ******************** !* %CONSTINTEGER CONST REF = 6;! word displacement of 32 bit @ of const area !* !*********************************************************************** !*********************************************************************** !* !* !* !********************************* EXPORTS **************************** !* %INTEGERFNSPEC ANALSTART(%RECORD(TRIADF)%ARRAYNAME TRIADS, %INTEGER MAXTRIADS,ADCOM, %INTEGER ADICT0,ANAMES0,AMT,AM) %INTEGERFNSPEC GET COMAD %INTEGERFNSPEC FREESP(%INTEGER I) %INTEGERFNSPEC NEWLISTCELL(%INTEGERNAME HEAD,%INTEGER N) %ROUTINESPEC FREELISTCELL(%INTEGERNAME HEAD,%INTEGER N) %INTEGERFNSPEC SETLAB(%INTEGER LAB,%INTEGERNAME PTR) %ROUTINESPEC CHECKDOINDEX(%INTEGER RD,DOHEAD) %ROUTINESPEC FAULT(%INTEGER ER) %ROUTINESPEC LFAULT(%INTEGER ER) %ROUTINESPEC TFAULT(%INTEGER ER,TA,TB) %ROUTINESPEC IFAULT(%INTEGER ER,I) !{2900}%ROUTINESPEC FAULTNUM(%INTEGER ER,COMAD) !* !*********************************************************************** !* !* The following block of declarations must not be disturbed !* !* !* %OWNINTEGER CONTROL,OPTIONS,OPTIONS1,OPTIONS2,PTRACE, ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR, MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD, SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST, RESCOM1,RESCOM2,DUMGLACA,FNO,FAULTY,LINEST,CMNIIN,SFMK, LISTL,LISTSTREAM,DIAGSTREAM,LISTPOINT,XREF, PACKCMN,ITSMODE,PATHANAL,CHARACTER CODE,SPACE CHAR, HEADINGS,ARRAYCHECKS,JBRMODE,MESSLEN,NAMESLEN, NEXTCH,FUNRESDISP,WARNCOUNT,INP,MAXINP,MESSCOUNT, UNASSPATTERN,LISTCODE,PI21INT,DOPTR,SUBPROGPTR, FNLST,LAB,NAMESFREE,ALGOLREF,FIRSTSTATNUM,CEXPDICT, COMMONBASE,FASTPROLOGUE,STATEMENT,IFPTR, CNSTCA,COMMENTCNT,ADIDENT,ADERRIDEN, ADEXT,MAXDICT,MAXNAMES,MAXOUTPUT,MAXEXT, ACOMP,ASUBNAMES,MAXPSTACK, ATRIADS,TRFILEID,TRBLOCK,CMNCNT !* !{2900}%EXTRINSICINTEGER GLACA;! needed on 2900 for tying up format refs !* !* !{2900}%SYSTEMROUTINESPEC SIM2(%INTEGER EP, R1, R2, %INTEGERNAME R3) !{2900}%SYSTEMROUTINESPEC IOCP(%INTEGER EP,N) !{2900}%SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) !{2900}%SYSTEMROUTINESPEC LPUT(%INTEGER L1, L2, L3, L4) !{2900}%SYSTEMROUTINESPEC SUMMARY(%INTEGER ADDR OF SUMMARY RECORD) !{2900}%SYSTEMROUTINESPEC ITOE(%INTEGER AD,L) !{2900}%SYSTEMROUTINESPEC ETOI(%INTEGER AD,L) !* %EXTERNALROUTINESPEC DICFUL !{2900}%EXTERNALINTEGERFNSPEC ALLOC CHAR(%INTEGER L,AD, %INTEGERNAME GLA AD) {PERQ}%EXTERNALINTEGERFNSPEC ALLOC CHAR(%INTEGER L,AD, %HALFINTEGERNAME IIN,%INTEGERNAME DISP) %EXTERNALROUTINESPEC ALLOC(%INTEGER PTR) !{2900}%EXTERNALROUTINESPEC SETFUN(%INTEGER PTR) %EXTERNALROUTINESPEC ADD DATA ITEM(%INTEGER AREA,PTR,COUNT,DISP,L,AD) !{2900}%EXTERNALINTEGERFNSPEC CFORMATCD(%INTEGER FORMATAD,ARRAYADR, %C !{2900} INLEN,OUTLEN,INOUT,TYPE,LEVEL,%INTEGERNAME TABLE,ACTFMTLEN) !{2900}%EXTERNALROUTINESPEC PUTBYTES(%INTEGER AREA,NUMBER,FROM) !{2900}%EXTERNALROUTINESPEC PUTDESC(%INTEGER AREA,DR0,DR1) !{2900}%EXTERNALROUTINESPEC PUTWORD(%INTEGER AREA,VALUE) !{2900}%EXTERNALROUTINESPEC PLUGWORD(%INTEGER AREA,AT,VALUE) !{2900}%EXTERNALROUTINESPEC PAINIT(%INTEGER LINEST,FIRSTSTATNUM) !{2900}%EXTERNALROUTINESPEC SETLINENO(%INTEGER LINE) !{2900}%EXTERNALROUTINESPEC PATHCOUNT(%INTEGER LINE,MODE) !{2900}%EXTERNALROUTINESPEC CODEGEN(%INTEGER CGENEP, !{2900} %RECORD(TRIADF)%ARRAYNAME TRIADS, !{2900} %INTEGER COMAD) !{2900}%EXTERNALROUTINESPEC ICL9CEF77MTM(%INTEGER ERR0,ERR1,RC0,RC1, %C !{2900} BUFF0, BUFF1,LEN0,LEN1) !{2900}%EXTERNALINTEGERFNSPEC TO INTEGER (%INTEGER DATA AD,DATA LEN , !{2900} %INTEGER INT LEN , INT PTR , MODE ) !{2900}%EXTERNALINTEGERFNSPEC TO REAL (%INTEGER DATA AD , DATA LEN, !{2900} %INTEGER INT LEN , INT PTR , !{2900} %INTEGER DEC LEN , DEC PTR , !{2900} %INTEGER EXP LEN , EXP PTR , !{2900} %INTEGER DECS , SCALE FACTOR , MODE ) !* !{2900}%ROUTINESPEC SET HEADING(%INTEGER TYPE) !{2900}%ROUTINESPEC WARNING(%INTEGER ER) !* !{2900C} %ROUTINESPEC ALLDICT !* {PERQ}%EXTERNALROUTINESPEC SOURCE LINE(%INTEGER ABUFF0) {PERQ}%EXTERNALROUTINESPEC QCMESS(%INTEGER ER,%INTEGERNAME RC,LEN, %C {PERQ} %STRINGNAME TEXT) {PERQ}%EXTERNALINTEGERFNSPEC PFORMAT(%INTEGER AINPUT,INP,LEN, {PERQ} %STRINGNAME IDENTIFIER) {PERQ}%EXTERNALINTEGERFNSPEC TO INTEGER(%INTEGER DATA AD,DATA LEN, {PERQ} TEXT AD,TEXT LEN,TEXT INC,MODE) {PERQ}%EXTERNALINTEGERFNSPEC TO REAL(%INTEGER DATA AD,DATA LEN, {PERQ} TEXT AD,INT LEN,INT PTR, {PERQ} DEC LEN,DEC PTR,EXP LEN,EXP PTR, {PERQ} DECS,SCALE,MODE) {PERQ}%EXTERNALINTEGERFNSPEC GLA SPACE(%INTEGER LEN) !{PERQ}%EXTERNALINTEGERFNSPEC PERQREAL(%REAL X) {PERQ}%EXTERNALROUTINESPEC FAULTNUM(%INTEGER ER,COMAD,UPDATE) !* %EXTERNALINTEGERFNSPEC COERCE CONST(%INTEGER A,OLDMODE,NEWMODE) %EXTERNALROUTINESPEC GENERATE(%RECORD(TRIADF)%ARRAYNAME TRIADS, %INTEGERNAME NEXTTRIAD, %INTEGER LIN,PATH,LABRECAD,COMAD) !* %EXTRINSICINTEGER CODECA !{2900}%EXTRINSICINTEGER STACKCA %EXTRINSICINTEGER STACKBASE %EXTRINSICINTEGER PARCHECKS !* !* %OWNSTRING (32) IDENTIFIER,ERRIDEN,BLOCKDATAID !{2900}%OWNSTRING (32) AREANAME !* !{2900}%OWNBYTEINTEGERARRAY TBUFF(-13 : 161) {PERQ}%OWNBYTEINTEGERARRAY TBUFF(0 : 81) %EXTERNALINTEGERARRAY LABH(0 : 31) !{2900}%EXTERNALINTEGERARRAY LHEAD(0:154) {PERQ}%OWNINTEGERARRAYFORMAT LHEADF(0:155) {PERQ}%OWNINTEGERARRAYNAME LHEAD %EXTERNALINTEGERARRAY ASL(0 : 10) !* !****** INITIALISE FOLLOWING TO ZERO AT START OF EACH SUBPROG %OWNINTEGER PARAMLINK %OWNINTEGER CGOLAB %OWNINTEGER NOTFLAG, PCT %OWNINTEGER LASTSUBPROGEP %OWNINTEGER DIAGHEADS %OWNINTEGER CHEAD0,CHEAD1,CHEAD2,CHEAD3 %OWNINTEGER BLOCKIFSTATE %OWNINTEGER DATAHEAD %OWNINTEGER CHARMASK !****** %OWNINTEGER LEN %OWNINTEGER LABWARN %OWNINTEGER LINENO %OWNINTEGER HASHVALUE %OWNINTEGER LIN %OWNINTEGER TTYP %OWNINTEGER WARNLEN %OWNINTEGER COMAD;! address of common data %OWNSTRING(63) DIAGTEXT;! CONTAINS TEXT FOR INDICATING HEAD OF CURRENT %OWNINTEGER LTYPE %OWNINTEGER CRM4, CRM5 %OWNINTEGER CTYP %OWNINTEGER DATALAST;! FOR DEFERRED INIT DATA %OWNINTEGER STATFNREC !{2900C}%OWNINTEGER REAL LENGTH=4 !{2900C}%OWNINTEGER DP LENGTH=8 !{2900C}%OWNINTEGER INTEGER LENGTH !{2900C}%OWNINTEGER LOGICAL LENGTH {PERQC}%CONSTINTEGER REAL LENGTH=2;! no of 16 bit words {PERQC}%CONSTINTEGER DP LENGTH=4 %OWNINTEGER STATORDERMODE,CURSTATCLASS %OWNINTEGER MAXIBUFFVALUE %OWNINTEGER SAVELIST,CUR PSTACK !* %OWNINTEGER ADMESST %OWNINTEGER ADMESS !* !{2900}%OWNBYTEINTEGERARRAY INPUT(0: INPUT LIMIT) !{2900}%OWNBYTEINTEGERARRAY IBUFF(0 : INPUT LIMIT) !{2900}%OWNBYTEINTEGERARRAY TYPE(0 : INPUT LIMIT) !{2900}%OWNHALFINTEGERARRAY CHMARK(0:INPUT LIMIT) !{2900}%OWNBYTEINTEGERARRAY DEFAULT SIZE(1:6) !* {PERQ}%OWNBYTEINTEGERARRAYFORMAT INPUTF(0:1329) {PERQ}%OWNBYTEINTEGERARRAYNAME INPUT {PERQ}%OWNBYTEINTEGERARRAYNAME IBUFF {PERQ}%OWNBYTEINTEGERARRAYNAME TYPE {PERQ}%OWNBYTEINTEGERARRAYNAME CHMARK !* {PERQ}%CONSTBYTEINTEGERARRAY DEFAULT SIZE (0:6)= %C {PERQ} 0,X'51',X'52',X'53',X'54',X'05',X'62' %OWNINTEGERARRAY IMPTYPE(65 : 90) = %C 2,2,2,2,2,2,2,2,1,1,1,1,1,1,2, 2,2,2,2,2,2,2,2,2,2,2 %OWNINTEGERARRAY COMPAR(1 : 6) = %C M'GT',M'LT',M'NE',M'EQ',M'GE',M'LE' !* !* %INTEGERFNSPEC FORMAL PARAMETER(%INTEGER PTR,MODE) %INTEGERFNSPEC NEW SUBPROGRAM(%INTEGER PTR,TYPE,%INTEGERNAME ER) !{2900}%STRINGFNSPEC ITEXT(%INTEGER VAL,N) !{2900}%ROUTINESPEC ZERO(%INTEGER AD,L) !* %CONSTINTEGER FULL=2 %CONSTINTEGER YES=1 %CONSTINTEGER NO=0 %CONSTINTEGER DVAREA=7 %CONSTINTEGER PSEUDOCMN=20;! record for array area (treated as common in some respects) !{2900C}%CONSTINTEGER BLCMPTR=96;! blank common record {PERQC}%CONSTINTEGER BLCMPTR=48 !* !* !* !* %CONSTBYTEINTEGERARRAY HEX(0 : 15) = %C '0','1','2','3','4','5','6', '7','8','9','A','B','C','D','E','F' !* !* %CONSTBYTEINTEGERARRAY MAPLTYPE(0 : 7) = 0,0,1,2,4,4,5,5;! USED IN MAIN %CONSTBYTEINTEGERARRAY MODETOBYTES(0:14)= %C 4,4,8,4,8,16,8,16,32,4,0,0,0,4,8 !* %CONSTBYTEINTEGERARRAY NUMBYTES(0:7)=0(3),1,2,4,8,16 %CONSTBYTEINTEGERARRAY SETMODE(0:63)= %C 0(5),10,0(11),1,3,6,9,0(12),2,4,7,14,0(13),5,8,13,0(11) !* %CONSTBYTEINTEGERARRAY CLASS(0 : 127) = %C 15(10),12,15(14),13,15(6),0,14(3),X'8B', 14,X'8B',5,20,7,X'89',X'8A',18,X'8A',4,X'89',X'83'(10),X'8B',14(2), 19,14(3),X'81'(7),6,X'81'(18),14(6),17(26),14(4),16 !* !* !* !* {%CONSTSTRING(6)%ARRAY GEN NAME(1:24)= %C } { "SQRT" ,"EXP" ,"LOG" ,"LOG10" , } { "SIN" ,"COS" ,"TAN" ,"COT" , } { "ASIN" ,"ACOS" ,"ATAN" ,"ATAN2" , } { "SINH" ,"COSH" ,"TANH" ,"ERF" , } { "ERFC" ,"GAMMA" ,"LGAMMA","ABS", } { "LGE" ,"LGT", "LLE", "LLT" } !* !* %CONSTINTEGERARRAY FNHASH(0: 186)= %C X'00000000',X'00900366',X'00000000',X'00000000', X'00000000',X'002400D4',X'A934013E',X'00000000', X'0059021C',X'952500D8',X'00350144',X'00000000', X'00180090',X'002A00FA',X'00000000',X'001B00A0', X'00190094',X'002C0106',X'00000000',X'A51C00A6', X'00000000',X'00000000',X'002600DE',X'872700E4', X'00000000',X'00000000',X'00000000',X'9E2800EA', X'A6660272',X'83070028',X'007202BA',X'962B0100', X'840A0038',X'0008002C',X'007302C0',X'002D010C', X'9F0B003E',X'B265026C',X'0083031A',X'00870332', X'002900F2',X'00000000',X'8B1E00B2',X'002F011C', X'B37102B4',X'8E2100C2',X'85090032',X'A1310128', X'B02E0114',X'860C0044',X'00850326',X'90140072', X'88150078',X'004601AC',X'004A01C6',X'92160080', X'91380156',X'004701B2',X'005B0228',X'8F2000BC', X'A25A0222',X'A3300122',X'002300CE',X'0086032C', X'A44F01E6',X'0032012E',X'00580216',X'00000000', X'94170088',X'9D39015E',X'9C5F0240',X'0043019C', X'00690284',X'006B0290',X'00000000',X'004401A0', X'00000000',X'007802DC',X'97330136',X'00920370', X'00930376',X'005401FE',X'006D029C',X'980D004A', X'000E004E',X'00810310',X'80010000',X'000F0054', X'934501A6',X'00040012',X'81020006',X'00000000', X'00000000',X'00050018',X'00000000',X'00000000', X'B591036A',X'00000000',X'B65E023A',X'0040018A', X'0010005A',X'003D0178',X'0097038E',X'8203000C', X'00000000',X'003E017E',X'89060020',X'00000000', X'00620256',X'00000000',X'003B016C',X'00000000', X'0063025C',X'00000000',X'00000000',X'00980396', X'00420196',X'007D02FA',X'003F0184',X'00000000', X'00550204',X'007F0304',X'00000000',X'003C0172', X'0056020A',X'00640264',X'007E02FE',X'00000000', X'00110060',X'00120066',X'8A13006C',X'001A009A', X'001D00AC',X'8C1F00B6',X'002200C8',X'A736014A', X'00370150',X'003A0166',X'00410190',X'8D4801B8', X'AC4901BE',X'004B01CE',X'AF4C01D6',X'9B4D01DE', X'004E01E2',X'9A5001EA',X'005101EE',X'005201F2', X'005301F8',X'00570210',X'A05C022E',X'995D0234', X'B4600248',X'AA610250',X'00670278',X'0068027E', X'006A028A',X'006C0296',X'006E02A4',X'A86F02A8', X'007002AE',X'AB7402C6',X'007502CC',X'B17602D0', X'007702D6',X'007902E2',X'007A02E8',X'007B02EE', X'AE7C02F4',X'AD80030A',X'00820316',X'00840320', X'00880338',X'0089033E',X'008A0342',X'008B0348', X'008C034E',X'008D0354',X'008E035A',X'008F0360', X'0094037C',X'00950382',X'00960388',X'00000000', X'00000000',X'00000000',X'00000000' !* %CONSTBYTEINTEGERARRAY FNNAMES(0: 925)= %C 4, 83, 81, 82, 84, 0, 5, 68, 83, 81, 82, 84, 5, 81, 83, 81, 82, 84, 5, 67, 83, 81, 82, 84, 6, 67, 68, 83, 81, 82, 84, 0, 6, 67, 81, 83, 81, 82, 84, 0, 3, 69, 88, 80, 4, 68, 69, 88, 80, 0, 4, 81, 69, 88, 80, 0, 4, 67, 69, 88, 80, 0, 5, 67, 68, 69, 88, 80, 5, 67, 81, 69, 88, 80, 3, 76, 79, 71, 4, 65, 76, 79, 71, 0, 4, 68, 76, 79, 71, 0, 4, 81, 76, 79, 71, 0, 4, 67, 76, 79, 71, 0, 5, 67, 68, 76, 79, 71, 5, 67, 81, 76, 79, 71, 5, 76, 79, 71, 49, 48, 6, 65, 76, 79, 71, 49, 48, 0, 6, 68, 76, 79, 71, 49, 48, 0, 6, 81, 76, 79, 71, 49, 48, 0, 3, 83, 73, 78, 4, 68, 83, 73, 78, 0, 4, 81, 83, 73, 78, 0, 4, 67, 83, 73, 78, 0, 5, 67, 68, 83, 73, 78, 5, 67, 81, 83, 73, 78, 3, 67, 79, 83, 4, 68, 67, 79, 83, 0, 4, 81, 67, 79, 83, 0, 4, 67, 67, 79, 83, 0, 5, 67, 68, 67, 79, 83, 5, 67, 81, 67, 79, 83, 3, 84, 65, 78, 4, 68, 84, 65, 78, 0, 4, 81, 84, 65, 78, 0, 5, 67, 79, 84, 65, 78, 6, 68, 67, 79, 84, 65, 78, 0, 6, 81, 67, 79, 84, 65, 78, 0, 4, 65, 83, 73, 78, 0, 5, 65, 82, 83, 73, 78, 5, 68, 65, 83, 73, 78, 6, 68, 65, 82, 83, 73, 78, 0, 6, 81, 65, 82, 83, 73, 78, 0, 4, 65, 67, 79, 83, 0, 5, 65, 82, 67, 79, 83, 5, 68, 65, 67, 79, 83, 6, 68, 65, 82, 67, 79, 83, 0, 6, 81, 65, 82, 67, 79, 83, 0, 4, 65, 84, 65, 78, 0, 5, 68, 65, 84, 65, 78, 5, 81, 65, 84, 65, 78, 5, 65, 84, 65, 78, 50, 6, 68, 65, 84, 65, 78, 50, 0, 6, 81, 65, 84, 65, 78, 50, 0, 4, 83, 73, 78, 72, 0, 5, 68, 83, 73, 78, 72, 5, 81, 83, 73, 78, 72, 4, 67, 79, 83, 72, 0, 5, 68, 67, 79, 83, 72, 5, 81, 67, 79, 83, 72, 4, 84, 65, 78, 72, 0, 5, 68, 84, 65, 78, 72, 5, 81, 84, 65, 78, 72, 3, 69, 82, 70, 4, 68, 69, 82, 70, 0, 4, 81, 69, 82, 70, 0, 4, 69, 82, 70, 67, 0, 5, 68, 69, 82, 70, 67, 5, 71, 65, 77, 77, 65, 6, 68, 71, 65, 77, 77, 65, 0, 6, 76, 71, 65, 77, 77, 65, 0, 6, 65, 76, 71, 65, 77, 65, 0, 6, 68, 76, 71, 65, 77, 65, 0, 3, 76, 71, 69, 3, 76, 71, 84, 3, 76, 76, 69, 3, 76, 76, 84, 3, 73, 78, 84, 4, 73, 70, 73, 88, 0, 5, 73, 68, 73, 78, 84, 5, 73, 81, 73, 78, 84, 4, 82, 69, 65, 76, 0, 5, 68, 82, 69, 65, 76, 5, 81, 82, 69, 65, 76, 5, 70, 76, 79, 65, 84, 4, 83, 78, 71, 76, 0, 5, 83, 78, 71, 76, 81, 4, 68, 66, 76, 69, 0, 5, 68, 66, 76, 69, 81, 4, 81, 69, 88, 84, 0, 5, 81, 69, 88, 84, 68, 6, 68, 70, 76, 79, 65, 84, 0, 6, 81, 70, 76, 79, 65, 84, 0, 4, 81, 69, 88, 84, 0, 5, 67, 77, 80, 76, 88, 6, 68, 67, 77, 80, 76, 88, 0, 6, 81, 67, 77, 80, 76, 88, 0, 5, 73, 67, 72, 65, 82, 4, 67, 72, 65, 82, 0, 4, 65, 73, 78, 84, 0, 4, 68, 73, 78, 84, 0, 4, 81, 73, 78, 84, 0, 5, 65, 78, 73, 78, 84, 5, 68, 78, 73, 78, 84, 4, 78, 73, 78, 84, 0, 6, 73, 68, 78, 73, 78, 84, 0, 3, 65, 66, 83, 4, 73, 65, 66, 83, 0, 4, 68, 65, 66, 83, 0, 4, 81, 65, 66, 83, 0, 4, 67, 65, 66, 83, 0, 5, 67, 68, 65, 66, 83, 5, 67, 81, 65, 66, 83, 3, 77, 79, 68, 4, 65, 77, 79, 68, 0, 4, 68, 77, 79, 68, 0, 4, 81, 77, 79, 68, 0, 4, 83, 73, 71, 78, 0, 5, 73, 83, 73, 71, 78, 5, 68, 83, 73, 71, 78, 5, 81, 83, 73, 71, 78, 3, 68, 73, 77, 4, 73, 68, 73, 77, 0, 4, 68, 68, 73, 77, 0, 4, 81, 68, 73, 77, 0, 5, 68, 80, 82, 79, 68, 3, 77, 65, 88, 4, 77, 65, 88, 48, 0, 5, 65, 77, 65, 88, 49, 5, 68, 77, 65, 88, 49, 5, 81, 77, 65, 88, 49, 5, 65, 77, 65, 88, 48, 4, 77, 65, 88, 49, 0, 3, 77, 73, 78, 4, 77, 73, 78, 48, 0, 5, 65, 77, 73, 78, 49, 5, 68, 77, 73, 78, 49, 5, 81, 77, 73, 78, 49, 5, 65, 77, 73, 78, 48, 4, 77, 73, 78, 49, 0, 3, 76, 69, 78, 5, 73, 78, 68, 69, 88, 4, 73, 77, 65, 71, 0, 5, 65, 73, 77, 65, 71, 5, 68, 73, 77, 65, 71, 5, 81, 73, 77, 65, 71, 5, 67, 79, 78, 74, 71, 6, 68, 67, 79, 78, 74, 71, 0, 6, 81, 67, 79, 78, 74, 71, 0 !* %CONSTINTEGERARRAY FNDETAILS(0: 156)= %C X'00000000',X'01000065',X'01446225',X'01557205', X'01665345',X'01776345',X'01887305',X'02000065', X'02446225',X'02557205',X'02665345',X'02776345', X'02887305',X'03000065',X'03335265',X'03446225', X'03557205',X'03665345',X'03776345',X'03887305', X'04000025',X'04335225',X'04446225',X'04557205', X'05000065',X'05446225',X'05557205',X'05665345', X'05776345',X'05887305',X'06000065',X'06446225', X'06557205',X'06665345',X'06776345',X'06887305', X'07000025',X'07446225',X'07557205',X'08000025', X'08446225',X'08557205',X'09000025',X'09000025', X'09446225',X'09446225',X'09557205',X'0A000025', X'0A000025',X'0A446225',X'0A446225',X'0A557205', X'0B000025',X'0B446225',X'0B557205',X'0C000026', X'0C446226',X'0C557205',X'0D000025',X'0D446225', X'0D557205',X'0E000025',X'0E446225',X'0E557205', X'0F000025',X'0F446225',X'0F557205',X'10000025', X'10446225',X'10557205',X'11000025',X'11446225', X'12000025',X'12446225',X'13000025',X'13000025', X'13446225',X'15547206',X'16547206',X'17547206', X'18547206',X'81010039',X'81315209',X'81416209', X'81517209',X'8303007D',X'83746309',X'83857309', X'83135109',X'83436209',X'83537209',X'84040039', X'84547209',X'84355209',X'84456209',X'84145109', X'84155109',X'85050029',X'8600007A',X'8647620A', X'8658720A',X'87910509',X'88195109',X'89000029', X'89446229',X'89557209',X'8A000029',X'8A446229', X'8B010029',X'8B416209',X'8C000079',X'8C115119', X'8C446229',X'8C557209',X'14635305',X'14746305', X'14857305',X'8D00003A',X'8D33522A',X'8D44622A', X'8D55720A',X'8E00003A',X'8E00001A',X'8E44622A', X'8E55720A',X'8F00003A',X'8F00001A',X'8F44622A', X'8F55720A',X'9034520A',X'9100003F',X'9111513F', X'9133522F',X'9144622F',X'9155720F',X'9213510F', X'9331520F',X'9400003F',X'9411513F',X'9433522F', X'9444622F',X'9455720F',X'9513510F',X'9631520F', X'97910509',X'9891050A',X'9900004D',X'9963534D', X'9974630D',X'9987730D',X'9A66534D',X'9A44624D', X'9A88730D',X'00000000',X'00000000',X'00000000', X'00000000' !* %OWNINTEGERARRAY FNSPECIALS(0: 156)= %C X'00000000',X'00036000',X'00046006',X'0005A00C', X'00066012',X'0007A018',X'0008A020',X'00036028', X'0004602C',X'0005A032',X'00066038',X'0007A03E', X'0008A044',X'0003604A',X'0003604E',X'00046054', X'0005A05A',X'00066060',X'0007A066',X'0008A06C', X'00036072',X'00036078',X'00046080',X'0005A088', X'00036090',X'00046094',X'0005A09A',X'000660A0', X'0007A0A6',X'0008A0AC',X'000360B2',X'000460B6', X'0005A0BC',X'000660C2',X'0007A0C8',X'0008A0CE', X'000360D4',X'000460D8',X'0005A0DE',X'0003A0E4', X'0004A0EA',X'0005A0F2',X'000360FA',X'0003A100', X'00046106',X'0004A10C',X'0005A114',X'0003611C', X'00036122',X'00046128',X'0004A12E',X'0005A136', X'0003613E',X'00046144',X'0005A14A',X'00036150', X'00046156',X'0005A15E',X'00036166',X'0004616C', X'0005A172',X'00036178',X'0004617E',X'0005A184', X'0003618A',X'00046190',X'0005A196',X'0003A19C', X'0004A1A0',X'0005A1A6',X'0003A1AC',X'0004A1B2', X'0003A1B8',X'0004A1BE',X'0003A1C6',X'0004A1CE', X'000461D6',X'000041DE',X'000041E2',X'000041E6', X'000041EA',X'000041EE',X'000041F2',X'000041F8', X'000081FE',X'00004204',X'0000820A',X'00008210', X'00004216',X'0000421C',X'00008222',X'00004228', X'0000822E',X'00008234',X'0000823A',X'00008240', X'00008248',X'00008250',X'00004256',X'0000825C', X'00008264',X'0000426C',X'00004272',X'00036278', X'0004627E',X'0005A284',X'0003628A',X'00046290', X'00036296',X'0004629C',X'000362A4',X'000162A8', X'000462AE',X'0005A2B4',X'000662BA',X'0007A2C0', X'0008A2C6',X'000162CC',X'000362D0',X'000462D6', X'0005A2DC',X'000362E2',X'000162E8',X'000462EE', X'0005A2F4',X'000362FA',X'000162FE',X'00046304', X'0005A30A',X'0004A310',X'00004316',X'0000431A', X'00004320',X'00004326',X'0000832C',X'00004332', X'00004338',X'0000433E',X'00004342',X'00004348', X'0000434E',X'00008354',X'0000435A',X'00004360', X'00004366',X'0000436A',X'00008370',X'00004376', X'0000837C',X'00008382',X'00004388',X'0000438E', X'00008396',X'00000000',X'00000000',X'00000000', X'00000000' !* !* !* %CONSTBYTEINTEGERARRAY IFCHECK(0:15)= %C 1, 229, 229, 230, 1, 2, 3, 0, 1, 2, 3, 0, 1, 207, 207, 0 !* %CONSTBYTEINTEGERARRAY MODETOST(0:11)= %C X'41',X'51',X'61',X'52',X'62',X'72',X'53',X'63',X'73',X'54',X'05'(2) !* !* !{2900C} %ROUTINE MOVE(%INTEGER LENGTH, FROM, TO) !{2900C} %INTEGER I !{2900C} %RETURNIF LENGTH <= 0 !{2900C} I = X'18000000'!LENGTH !{2900C} *LSS_FROM !{2900C} *LUH_I !{2900C} *LDTB_I !{2900C} *LDA_TO !{2900C} *MV_%L=%DR !{2900C} %END; !OF MOVE !* !* {PERQC} %ROUTINE COPY(%INTEGER LEN,SBASE,%HALFINTEGER SDISP, {PERQC} %INTEGER TBASE,%HALFINTEGER TDISP) {PERQC} **@TBASE; *LDDW; **TDISP {PERQC} **@SBASE; *LDDW; **SDISP {PERQC} **LEN {PERQC} *STLATE_X'63'; *MVBW {PERQC} %END !* !{2900} %ROUTINE FILL(%INTEGER LENGTH,FROM,FILLER) !{2900} %INTEGER I !{2900} %RETURNIF LENGTH <= 0 !{2900} I = X'18000000'!LENGTH !{2900} *LDTB_I !{2900} *LDA_FROM !{2900} *LB_FILLER !{2900} *MVL_%L=%DR !{2900} %END !* %ROUTINE ZERODICT(%INTEGER START,LEN) %HALFINTEGER H H=LEN START=ADICT+START %WHILE H>0 %CYCLE HALFINTEGER(START)=0 START=START+W1 H=H-1 %REPEAT %END !* !* !* !****************************************************************************** !* * !* LIST MANIPULATION * !* * !****************************************************************************** !* !* !* %EXTERNALINTEGERFN FREESP(%INTEGER N) !*********************************************************************** !* OBTAIN N-WORD(32 BIT) LIST ITEM. SET PTR AND MAP SS RECORD * !*********************************************************************** %INTEGER PTR %RECORD(SRECF) %NAME SS PTR=ASL(N) %IF PTR = 0 %THENSTART PTR = DPTR SS == RECORD(ADICT+PTR) !{2900C} DPTR = DPTR+N<<2 {PERQC} DPTR=DPTR+N+N;! avoid long shift DICFUL %IF DPTR > DICLEN %FINISHELSESTART SS == RECORD(ADICT+PTR) ASL(N) = SS_LINK1 %FINISH SS_LINK1 = 0 %RESULT=PTR %END; ! FREESP !* %EXTERNALROUTINE FREE LIST CELL(%INTEGERNAME LISTHEAD,%INTEGER N) %INTEGER J %RECORD(SRECF) %NAME SS SS==RECORD(ADICT+LISTHEAD) J=SS_LINK1;! NEW LISTHEAD SS_LINK1=ASL(N) ASL(N)=LISTHEAD !PRINTSTRING(" !FREE LIST CELL ");WRITE(LISTHEAD,8);NEWLINE LISTHEAD=J %END;! FREE LIST CELL !* %EXTERNALINTEGERFN NEW LIST CELL(%INTEGERNAME LISTHEAD,%INTEGER N) %INTEGER PTR %RECORD(SRECF) %NAME SS PTR=FREESP(N) SS==RECORD(ADICT+PTR) SS_LINK1=LISTHEAD LISTHEAD=PTR %RESULT=PTR %END;! NEW LIST CELL !* !* !* !{2900}%ROUTINE LIST !{2900}%INTEGER I,J,K,L !{2900} %IF LISTL=0 %THEN %RETURN !{2900} L=LINENO+1 !{2900} I=ADDR(TBUFF(-11)) !{2900} STRING(I)=" " !{2900} J=-5 !{2900} %WHILE L#0 %CYCLE !{2900} K=L//10 !{2900} TBUFF(J)=L-10*K+'0' !{2900} J=J-1 !{2900} L=K !{2900} %REPEAT !{2900} TBUFF(-11)=LEN+11 !{2900} %IF LISTL&1#0 %THENSTART !{2900} %IF HEADINGS=0 %THEN SET HEADING(0) !{2900} IOCP(15,I);! FAST PRINTSTRING !{2900} NEWLINE !{2900} %FINISH !{2900} %IF LISTL&2#0 %THENSTART !{2900} SELECTOUTPUT(DIAGSTREAM) !{2900} IOCP(15,I);! FAST PRINTSTRING !{2900} NEWLINE !{2900} SELECTOUTPUT(LISTSTREAM) !{2900} %FINISH !{2900}%END !{2900}!* !{2900}%ROUTINE READ NEXT !{2900}%INTEGER I,J,K,L !{2900}GET LINE: !{2900} LINENO = LINENO+1 !{2900} I=ADDR(TBUFF(1)) !{2900} SIM2(0,I,0,LEN) !{2900} LEN = LEN-1 !{2900} %IF LEN<=0 %THEN ->GET LINE !{2900} %CYCLE J=1,1,LEN !{2900} %IF TBUFF(J)#' ' %THENSTART !{2900} %IF LEN<72 %THENSTART !{2900} K=X'18000000'!(72-LEN) !{2900} L=I+LEN !{2900} *LDTB_K !{2900} *LDA_L !{2900} *LB_X'20' !{2900} *MVL_%L=%DR !{2900} %FINISH !{2900} %IF J>72 %THEN ->GET LINE !{2900} %RETURN !{2900} %FINISH !{2900} %REPEAT !{2900} ->GET LINE !{2900}%END !* {PERQ}%ROUTINE LIST {PERQ} %IF LISTL=0 %THEN %RETURN {PERQ} WRITE(LINENO+1,5) {PERQ} SPACES(5) {PERQ} PRINTSTRING(STRING(ADDR(TBUFF(0)))) {PERQ} NEWLINE {PERQ}%END;! LIST {PERQ}!* {PERQ}%ROUTINE READ NEXT {PERQ} LINENO=LINENO+1 {PERQ} SOURCE LINE(ADDR(TBUFF(0))) {PERQ}%END;! READ NEXT !* %INTEGERFN READLINE %INTEGER I,J,K,L,M,N,P,KK,JJ, COUNT,BPTR,CONT,INLEN %INTEGER BC,EQ,COMMA,ER,IFRB,CHPTR %INTEGER P1,P2 %RECORDFORMAT BBF((%INTEGER W %OR %BYTEINTEGER B2,B3,B0,B1)) %RECORD(BBF) BB !{2900C} %LONGINTEGER II %SWITCH T(0 : 20) {PERQC}%INTEGER ATBUFF,AIBUFF,AINPUT {PERQC} ATBUFF=ADDR(TBUFF(0)) {PERQC} AIBUFF=ADDR(IBUFF(0)) {PERQC} AINPUT=ADDR(INPUT(0)) EOF: I=TBUFF(1) %IF I = 25 %THENSTART %IF LINENO=0 %THEN I=2 %ELSE I=1 %RESULT=I %FINISH LST: LIST -> NOTCOM %UNLESS I = 'C' %OR I='c' %OR I='*' GETNEXT: READNEXT I=TBUFF(1) J=TBUFF(6) %IF I = 25 %THENSTART %RESULT=1 %FINISH -> ER101 %UNLESS I = 'C' %OR I='c' %OR I='*' %OR J = '0' %OR J=' ' -> LST NOTCOM: LINEST = LINENO+1 INP = 1 P = 1 M = 0 COMMA = 0 EQ = 0 BC = 0 LAB = 0 CONT = 0 IFRB=0 COPY: COUNT = 72-M !{2900C} MOVE(COUNT,ADDR(TBUFF(M+1)) ,ADDR(IBUFF(P))) {PERQC} COPY(COUNT,ATBUFF,M+1,AIBUFF,P) P = COUNT+P MINUS: READNEXT I=TBUFF(1) %IF I='C' %OR I='c' %OR I='*' %THENSTART L=0 K=0 %CYCLE I=1,1,66 J=IBUFF(I) %IF J#' ' %THENSTART L=L<<8!J K=K+1 %IF K>3 %THENSTART CLOOP: LIST ->MINUS %FINISH %FINISH %REPEAT %IF L=M'END' %THEN ->SETIBUF %ELSE ->CLOOP LIST ->MINUS %FINISH %IF I=25 %THEN ->SETIBUF I=TBUFF(6);! CONTINUATION MARKER %IF I=' ' %OR I='0' %THEN ->SETIBUF CONT = CONT+1 -> ER103 %IF CONT > 19 M = 6 LIST !* !{2900} I=X'58000005' !{2900} J=ADDR(TBUFF(1)) !{2900} *LDTB_I !{2900} *LDA_J !{2900} *PUT_X'A084';! SWEQ 5 BYTES !{2900} *PUT_X'0020';! SPACES !{2900} *JCC_8, !{2900} ->ER102 !* {PERQ} %CYCLE JJ = 1,1,5 {PERQ} %IF TBUFF(JJ) # ' ' %THEN -> ER102 {PERQ} %REPEAT {PERQ} -> COPY ER102: LFAULT(102) -> COPY SETIBUF: IBUFF(P) = NL INLEN=P !* !{2900C} I=X'58000005' !{2900C} J=ADDR(IBUFF(1)) !{2900C} *LDTB_I !{2900C} *LDA_J !{2900C} *PUT_X'A084';! SWEQ 5 !{2900C} *PUT_X'0020';! SPACES !{2900C} *JCC_8, !* N=0 %CYCLE L = 1,1,5 I = IBUFF(L) %IF I#' ' %THENSTART J = CLASS(I) %IF J=X'83' %THENSTART;! digit N=1 LAB = 10*LAB+I&15 %FINISHELSESTART LFAULT(108);! non-numeric label LAB=0 ->COL7 %FINISH %FINISH %REPEAT %IF N#0 %AND LAB=0 %THEN IFAULT(110,0);! invalid label no. COL7: BPTR = 7 P = 0 -> NXTCHAR SETYPE: TYPE(INP) = J&31 INPUT(INP) = I CHMARK(INP)=CHPTR CHMARK(INP+1)=CHPTR+1 INP = INP+1 NXTCHAR: I = IBUFF(BPTR)&127;! AVOID FAILURE WITH DUFF CHARS J = CLASS(I) CHPTR=BPTR {PERQ} %WHILE CHPTR>72 %CYCLE {PERQ} CHPTR=CHPTR-66 {PERQ} %REPEAT BPTR = BPTR+1 LCTOUC: -> T(J) %IF J < 128 -> SETYPE !* T(0): ! space ->NXTCHAR !* !{2900C} I=X'58000080' !{2900C} J=ADDR(IBUFF(BPTR)) !{2900C} *LDTB_I !{2900C} *LDA_J !{2900C} *PUT_X'A0C0';! SWEQ 65 !{2900C} *PUT_X'0020';! SPACES !{2900C} *STD_II !{2900C} I=(II<<32)>>32 !{2900C} BPTR=I-J+BPTR !{2900C} ->NXTCHAR !* T(19): EQ = 2 %IF BC = 0 ;! = J=11 ->SETYPE T(18): COMMA = 1 %IF BC = 0 ;! COMMA J=7 ->SETYPE T(20): BC = BC+1 ;! ( J=11 ->SETYPE T(7): BC = BC-1 ;! ) %IF BC=0 %AND IFRB=0 %THEN IFRB=INP ->SETYPE T(4): ! . ->NOTOP %UNLESS TYPE(INP-1)=1 ;! UNLESS ALPHABETIC -> NOTOP %IF P = 0 %OR INP-P > 5 !{2900C} KK=X'58000004' !{2900C} JJ=ADDR(INPUT(P+1)) !{2900C} *LDTB_KK !{2900C} *LDA_JJ !{2900C} *LSS_(%DR) !{2900C} *ST_KK {PERQC} BB_B0=INPUT(P+1) {PERQC} BB_B1=INPUT(P+2) {PERQC} BB_B2=INPUT(P+3) {PERQC} BB_B3=INPUT(P+4) {PERQC} KK=BB_W %IF INP-P=5 %THENSTART %IF KK=M'NEQV' %THENSTART I='#' OPSET: INPUT(P) = I TYPE(P)=10 INP = P+1 P=0 -> NXTCHAR %FINISHELSE ->NOTOP %FINISH -> A107 %UNLESS INP-P = 4 KK=KK>>8 %IF KK=M'AND' %THEN I='&' %AND ->OPSET %IF KK=M'EQV' %THEN I='~' %AND ->OPSET %IF KK=M'NOT' %THEN I='\' %AND ->OPSET ->NOTOP NOTOP: P = INP;! note latest . in case start of comparator etc. ->SETYPE A107: K=KK>>16 %CYCLE JJ = 1,1,6 %IF K = COMPAR(JJ) %THEN -> A106 %REPEAT -> NOTOP %UNLESS K = M'OR' I = '!' -> OPSET A106: INPUT(P) = '>' INPUT(P+1) = JJ*2 TYPE(P)=10 TYPE(P+1) = 6 INP = P+2 -> NXTCHAR T(6): %IF INP < 4 %THEN -> A111;! H K = INP-1 %UNLESS TYPE(K) = 3 %THEN -> A111 A1190: K = K-1 -> A111 %IF K = 1 -> A1190 %IF TYPE(K) <4 %IF INPUT(K)='*' %THENSTART %IF TYPE(K+1)<3 %THEN ->A111 %ELSE ->A1190 %FINISH -> A111 %IF TYPE(K+1) <3 %CYCLE K = INP-1,-1,INP-4 -> A110 %UNLESS TYPE(K) = 3 %REPEAT A111: J = 1 -> SETYPE A110: N = 0 %CYCLE M = K+1,1,INP-1 N = 10*N+INPUT(M)&15 %REPEAT ER = 115;! invalid Holerith constant length -> A95 %UNLESS 0 < N <= 256 INPUT(INP) = 'H' TYPE(INP) = 6 CHMARK(INP)=CHPTR INP = INP+1 ER = 105;! incomplete Hollerith constant !{2900C} MOVE(N,ADDR(IBUFF(BPTR)),ADDR(INPUT(INP))) {PERQC} COPY(N,AIBUFF,BPTR,AINPUT,INP) BPTR=BPTR+N INP=INP+N %IF BPTR>INLEN %THEN ->A95;! HOLLERITH PAST END OF RECORD TYPE(INP-1) = 4 -> NXTCHAR T(5): P1 = INP+1;! ' P2 = BPTR TYPE(INP) = 5 A114: INPUT(INP) = I CHMARK(INP)=CHPTR INP = INP+1 TYPE(INP)=0;! to avoid later misclassification ( PI(107) ) I = IBUFF(BPTR) BPTR = BPTR+1 -> A116 %IF I = NL -> A114 %UNLESS I = '''' I = IBUFF(BPTR) -> A115 %UNLESS I = '''' INPUT(INP) = I CHMARK(INP)=CHPTR+1 INP = INP+1 BPTR = BPTR+1 -> A114 A115: TYPE(INP) = 11 INPUT(INP) = '''' CHMARK(INP)=CHPTR INP = INP+1 -> NXTCHAR A116: INP = P1 BPTR = P2 TYPE(P1-1) = 11 -> NXTCHAR T(8): ER = 100;! syntax error - should not occur here FAULT: FAULT(ER) -> EOF A98: ER = 109;! brackets not matched A95: LFAULT(ER) -> EOF ER103: ER = 103;! > 19 continuation statements -> A95 ER101: ER = 101;! first statement is a continuation -> A95 T(12): INPUT(INP) = NL TYPE(INP) = 12 MAXIBUFFVALUE=BPTR %IF INP = 1 %THENSTART %IF LINENO=1 %THEN LINENO=0 %AND ->GETNEXT %C %ELSE ->EOF %FINISH -> A98 %UNLESS BC = 0 LTYPE=COMMA+EQ %UNLESS INPUT(1)='I' %AND INPUT(2)='F' %AND INPUT(3)='(' %C %THEN %RESULT=0 %IF INPUT(IFRB+1)='=' %THEN %RESULT=0 LTYPE=LTYPE+4 BC=1 %CYCLE L=4,1,INP I=INPUT(L) %IF I='(' %THENSTART BC=BC+1 %FINISHELSESTART %IF I=')' %THENSTART BC=BC-1 %IF BC=0 %THENSTART %IF INPUT(L+1)='=' %THEN LTYPE=2 %RESULT=0 %FINISH %FINISH %FINISH %RESULT=0 T(13): %RESULT=1;! EOF T(14): ER=106;! invalid character T14A: CHMARK(INP)=CHPTR ->FAULT T(16): ! DEL T(15): ER=107;! invalid (non-graphic) character ->T14A T(17): ER=106;! lower-case char {PERQ} I=I-32;! lower case to upper case {PERQ} J=CLASS(I) {PERQ} ->LCTOUC ->T14A %REPEAT %RESULT=0 %END;! READ LINE !* !****************************************************************************** !* * !* NAME, LABEL AND CONST HANDLING * !* * !****************************************************************************** !* !* %EXTERNALINTEGERFN SETLAB(%INTEGER LAB,%INTEGERNAME LABRECPTR) !*********************************************************************** !* LOCATE ENTRY IN LABEL LIST OR CREATE NEW ENTRY * !*********************************************************************** %INTEGER LPTR,PTR,I,J %RECORD(LABRECF) %NAME LABREC PTR = LABH(LAB&31) LPTR=PTR %WHILE PTR # 0 %CYCLE LABREC == RECORD(ADICT+PTR) %IF LABREC_LAB = LAB %C %THEN LABRECPTR=PTR %AND %RESULT=0 PTR = LABREC_LINK1 %REPEAT !* J=ADICT+DPTR !* {PERQC} ZERODICT(DPTR,LABRECSIZE) !* !{2900C} I=X'18000028' !{2900C} *LDTB_I !{2900C} *LDA_J !{2900C} *LB_0 !{2900C} *MVL_%L=%DR !* PTR = DPTR LABREC == RECORD(ADICT+PTR) LABREC_CLASS=2; ! LABEL RECORD LABREC_LINK1 = LPTR LABREC_LAB = LAB LPTR = PTR DPTR = DPTR+LABRECSIZE LABH(LAB&31) = LPTR LABRECPTR=PTR %RESULT=1 %END; ! SETLAB !* %INTEGERFN FINDA(%INTEGER PTR) !*********************************************************************** !* SEARCHES FOR NAME, SET IN IDENTIFIER, ON LIST WITH PTR AT THE * !* FIRST ITEM. HOWEVER, IF THE CURRENT STATEMENT IS A STATEMENT FN THE * !* LIST ON SFNPTR (THE FORMAL PARAMETER LIST) IS SEARCHED FIRST. IF * !* SUCCESSFUL TTYP IS SET FROM THE ENTRY, OTHERWISE A NEW ENTRY IS * !* ESTABLISHED AT DPTR, POINTED AT BY PTR AND WITH TYPE TTYP * !*********************************************************************** %INTEGER I,J %HALFINTEGER HLEN %RECORD(PRECF) %NAME PP %RECORD(SRECF) %NAME SS %IF SFMK # 0 %THENSTART; ! STATEMENT FN I = PTR PTR = SFPTR %FINISHELSE I = 0 SEARCH: %WHILE PTR # 0 %CYCLE PP == RECORD(ADICT+PTR) %IF STRING(ANAMES+PP_IDEN) = IDENTIFIER %THENSTART TTYP = PP_TYPE %IF XREF#0 %THENSTART;! XREF J=FREESP(2) SS==RECORD(ADICT+J) SS_INF0=LINEST SS_LINK1=PP_XREF PP_XREF=PTR %FINISH %RESULT=PTR %FINISH PTR = PP_LINK1 %REPEAT %IF I # 0 %THENSTART; ! NOT A STATEMENT FN PARAMETER PTR = I I = 0 -> SEARCH %FINISH !* !******** NEW ENTRY SO CONSOLIDATE DICT ENTRY !* J=ADICT+DPTR !* {PERQC} ZERODICT(DPTR,IDRECSIZE) !* !{2900C} I=X'18000020' !{2900C} *LDTB_I !{2900C} *LDA_J !{2900C} *LB_0 !{2900C} *MVL_%L=%DR !* PTR = DPTR PP == RECORD(ADICT+PTR) %IF NAMESFREE+32 > NAMESLEN %THEN DICFUL STRING(ANAMES+NAMESFREE) = IDENTIFIER PP_IDEN=NAMESFREE PP_IIN=0 !{2900C} NAMESFREE = NAMESFREE + LENGTH(IDENTIFIER) + 1 {PERQC} HLEN=LENGTH(IDENTIFIER) {PERQC} NAMESFREE=NAMESFREE+(HLEN+2)>>1 DPTR = DPTR+IDRECSIZE %IF XREF#0 %THENSTART PP_LINE=LINEST;! line no of start of statement PP_XREF=0;! XREF chain DPTR=DPTR+XREFSIZE %FINISH %IF TTYP&X'F'=5 %THENSTART;! CHARACTER PP_LEN=TTYP>>8 TTYP=5 %FINISH PP_TYPE=TTYP PP_LINK1 = LHEAD(HASHVALUE) LHEAD(HASHVALUE) = PTR CTYP = -1; ! TYPE NOT ABSOLUTELY DETERMINED %IF LENGTH(IDENTIFIER)>6 %THENSTART !{2900} ERRIDEN=IDENTIFIER !{2900} LENGTH(ERRIDEN)=4 !{2900} %IF ERRIDEN#"ICL9" %THENSTART LFAULT(201);! iden too long !{2900} %FINISH %FINISH DICFUL %IF DPTR > DICLEN %RESULT=PTR %END; ! FINDA %ROUTINE SETNAME !*********************************************************************** !* EXTRACT IDEN FROM INPUT RECORD AND SET IN IDENTIFIER * !*********************************************************************** %INTEGER I,J %OWNBYTEINTEGERARRAY A(0 : 32) HASHVALUE = 0 WARNLEN = 0 I = 1 %WHILE 1 <= TYPE(INP) <= 3 %CYCLE; ! A - Z, 0 - 9 %IF I <= 32 %THENSTART J = INPUT(INP) A(I) = J J=J&31 HASHVALUE = HASHVALUE+J %FINISHELSESTART I=I-1 %FINISH I = I+1 INP = INP+1 %REPEAT A(0) = I-1 IDENTIFIER = STRING(ADDR(A(0))) HASHVALUE = (HASHVALUE-J+J<<3)&127 %END; ! SETNAME !* %EXTERNALINTEGERFN SETCONREC(%RECORD(RESF) RES) !*********************************************************************** !* On entry a copy of the const is held as the item last added to DICT * !* RES = (PTR>>DSCALE) << 16 ! x'100' ! mode * !* For numeric constants a search is made of the appropriate list * !* of 4, 8, or 16 byte entries to see whether a copy is already held. * !* If not, and also for non-numeric constants, a new 4 word record is * !* added to the appropriate list * !* Content is MODE mode * !* LINK1 link through chain of consts os same size * !* DADDR DICT @ of const * !* CADDR code @ of const if allocated, else 0 * !* (gla @ of descriptor for character amd Hollerith)* !*********************************************************************** !{2900}%CONSTBYTEINTEGERARRAY LIST(0:12)=0,1,2,1,2,3,2,3,0,1,0,0,0 {PERQ}%CONSTBYTEINTEGERARRAY LIST(0:12)=0,1,0,1,0,0,0,0,0,1,0,0,0 %INTEGER I,J,K,M,R %RECORD(CONRECF) %NAME CON %SWITCH S(0:3) M=RES_MODE R=RES_H0<S(I) !* S(1): J=CHEAD1 %WHILE J#0 %CYCLE CON==RECORD(ADICT+J) %IF INTEGER(K)=INTEGER(ADICT+CON_DADDR) %C %AND M=CON_MODE %THENSTART HIT: %RESULT=J %FINISH J=CON_LINK1 %REPEAT J=CHEAD1 CHEAD1=DPTR SET: CON==RECORD(ADICT+DPTR) CON_MODE=M CON_LINK1=J CON_DADDR=R CON_CADDR=0 I=DPTR DPTR=DPTR+CONRECSIZE %RESULT=I !* !{2900}S(2): J=CHEAD2 !{2900} %WHILE J#0 %CYCLE !{2900} CON==RECORD(ADICT+J) !{2900} %IF LONGINTEGER(K)=LONGINTEGER(ADICT+CON_DADDR) %C !{2900} %AND M=CON_MODE %THEN ->HIT !{2900} J=CON_LINK1 !{2900} %REPEAT !{2900} J=CHEAD2 !{2900} CHEAD2=DPTR !{2900} ->SET !{2900}!* !{2900}S(3): J=CHEAD3 !{2900} %WHILE J#0 %CYCLE !{2900} CON==RECORD(ADICT+J) !{2900} %IF LONGLONGREAL(K)=LONGLONGREAL(ADICT+CON_DADDR) %C !{2900} %AND M=CON_MODE %THEN ->HIT !{2900} J=CON_LINK1 !{2900} %REPEAT !{2900} J=CHEAD3 !{2900} CHEAD3=DPTR !{2900} ->SET !* S(0): J=CHEAD0 CHEAD0=DPTR ->SET %END;! SETCONREC !* !{2900} %EXTERNALINTEGERFN NEW CONST(%INTEGER LCONST, ADCONST,MODE) !{2900} %RECORD(RESF) R !{2900} %INTEGER I !{2900} I=DPTR !{2900} %IF MODE>9 %THENSTART !{2900} INTEGER(ADICT+DPTR)=LCONST !{2900} DPTR=DPTR+4 !{2900} %FINISH !{2900} MOVE(LCONST,ADCONST,ADICT+DPTR) !{2900} DPTR=DPTR+(LCONST+3)&X'FFC' !{2900} CTYP = MODETOST(MODE) !{2900} R_H0=I>>DSCALE; R_FORM=1; R_MODE=MODE !{2900} %RESULT=SETCONREC(R); ! LOCATES/CREATES A DICT RECORD !{2900} %END; ! NEW CONST !* !* %EXTERNALINTEGERFN LOCATE NAME(%STRING (32) NAME) !*********************************************************************** !* LOCATE DICTIONARY ENTRY FOR NAME. USE EXISTING ENTRY IF IT EXISTS * !* OTHERWISE CREATE A NEW ONE * !*********************************************************************** %INTEGER I,J,PTR %OWNBYTEINTEGERARRAY A(0 : 32) HASHVALUE = 0; ! FOR HASH VALUE STRING(ADDR(A(0))) = NAME %CYCLE I = 1,1,A(0) J=A(I)&31 HASHVALUE = HASHVALUE+J %REPEAT IDENTIFIER = NAME HASHVALUE = (HASHVALUE-J+J<<3)&127 PTR = LHEAD(HASHVALUE) WARNLEN = 0 %RESULT=FINDA(PTR) %END; ! LOCATE NAME !* !* %EXTERNALROUTINE CHECK DO INDEX(%INTEGER RD,DOHEAD) %RECORD(DORECF) %NAME DOREC %WHILE DOHEAD#0 %CYCLE DOREC==RECORD(ADICT+DOHEAD) %IF DOREC_INDEXRD_W=RD %THENSTART;! NESTED USE OF DO VAR LFAULT(147) %RETURN %FINISH DOHEAD=DOREC_LINK1 %REPEAT %END;! CHECK DO INDEX !* %ROUTINE CHECK SAVELIST !*********************************************************************** !* Check that all items in SAVE lists are valid * !*********************************************************************** %INTEGER I,J,ER %RECORD(SRECF) %NAME SS %RECORD(PRECF) %NAME PP I=SAVELIST %WHILE I#0 %CYCLE SS==RECORD(ADICT+I) PP==RECORD(ADICT+SS_INF0) IDENTIFIER=STRING(ANAMES+PP_IDEN) J=PP_CLASS&X'1F' %IF SS_INF3=1 %THENSTART;! common %UNLESS J=12 %THENSTART ER=188;! not a common block ERROR: IFAULT(ER,SS_INF2) %FINISH %FINISHELSESTART %IF J&1#0 %THEN ER=184 %AND ->ERROR;! argument %IF J&2#0 %THEN ER=186 %AND ->ERROR;! in common %IF J&8#0 %THENSTART %IF J=12 %THEN ER=187 %ELSE ER=185;! is a common block else procedure ->ERROR %FINISH %FINISH I=SS_LINK1 %REPEAT %END;! CHECK SAVELIST !* !* !* !* !======================================================================= !* %ROUTINE TRACE(%STRING(63) S,%INTEGER VAL) PRINTSTRING(S." ") WRITE(VAL,8) NEWLINE %END %INTEGERFN ANALYSE(%RECORD(TRIADF)%ARRAYNAME TRIADS, %INTEGER MAXTRIADS,%INTEGERNAME NEXTTRIAD, %INTEGER LTYPE,ADICT,%INTEGERNAME LINVAL) %ROUTINESPEC FIND %ROUTINESPEC CBNAME %INTEGERFNSPEC SCAN(%INTEGER CHAR) %ROUTINESPEC GENERATERD %ROUTINESPEC STRACE %INTEGERFNSPEC GET NEXT VARIABLE %INTEGERFNSPEC DATA IMPLIED DO %INTEGERFNSPEC EQUIVALENCE !{2900}%INTEGER SAVELINK, II, IJ, PARAM, PATH, ROUT {PERQ}%INTEGER PARAM {PERQ}%HALFINTEGER SAVELINK,II,IJ,PATH,ROUT %INTEGER ICOMP,OUTP,P,P1,P2,P3,TINP,DOIO,L1,PTR,ER %INTEGER I,J,K,L,M,N,SAVEP1,SPTR,RESL,RESR,PISW %INTEGER GSTATE,SCOMP0,SCOMP1 %INTEGER CHARLEN,CMNBLKPTR %INTEGER CRM1,CRM3,CRM8,CRM10 %INTEGER DIMSCOUNT %INTEGER DOIOP,FNMK,HGOLAB,PCOMX,PI21LENGTH,PI21MODE %INTEGER CCOUNT,VLISTHEAD,VLISTTAIL,VCOUNT,VMODE,VLENGTH,VAREA,VDISP %INTEGER IMPDOHEAD,CEXMODE,REPORTED ERROR,DOLEVEL %INTEGER COMPLEXLENGTH,SAVEPTR %INTEGER AINPUT %HALFINTEGER SAVEINDEX,H %RECORD(RESF) RES %INTEGERARRAY LDIM,UDIM(0:8) %RECORD(PRECF) %NAME PP %RECORD(PRECF) %NAME QQ %RECORD(PRECF) %NAME DD %RECORD(PRECF) %NAME CMNBLK %RECORD(SRECF) %NAME SS %RECORD(SRECF) %NAME SSS %RECORD(ARRAYDVF) %NAME DVREC %RECORD(PRECF) %NAME ARRAYREC %RECORD(PRECF) %NAME STATFN %RECORD(DORECF) %NAME DOREC %RECORD(IFRECF) %NAME IFREC %RECORD(LABRECF) %NAME LABREC %RECORD(IMPDORECF) %NAME IMPDOREC !* {PERQ}%BYTEINTEGERARRAYFORMAT FCOMP(0:4700) {PERQ}%BYTEINTEGERARRAYNAME COMP {PERQ}%STRING(9)%ARRAYFORMAT FSUBNAMES(0:90) {PERQ}%STRING(8)%ARRAYNAME SUBNAMES {PERQ}%HALFINTEGERARRAY SAVEII(0:100) {PERQ}%HALFINTEGERARRAY SAVEIJ(0:100) {PERQ}%HALFINTEGERARRAY SAVESL(0:100) {PERQ}%HALFINTEGERARRAY SAVEPATH(0:100) {PERQ}%HALFINTEGERARRAY SAVEROUT(0:100) {PERQ}%INTEGERARRAY SAVEPARAM(0:100) !* %CONSTBYTEINTEGERARRAY STATE(0 : 14) = %C 3,8,0,0,0,7, 2,2,4,5,0,1,0,0,1 !{2900}%CONSTINTEGERARRAY VALIDT(0 : 23) = 0,4,4,8,4,0,16,0, !{2900} 0,2,8,16,1,0,0,0, !{2900} 0,8,16,32,8,0,0,0 !{2900}%CONSTINTEGERARRAY VALIDST(0:23)=0,X'51',X'52',X'53',X'54',0,0,0, !{2900} 0,X'41',X'62',X'63',X'34',0,0,0, !{2900} 0,X'61',X'72',X'73',X'64',0,0,0 %INTEGERARRAYFORMAT FOUTPUT(0:4000) %INTEGERARRAYNAME OUTPUT %BYTEINTEGERARRAYFORMAT FBYTEDICT(0:32000) %BYTEINTEGERARRAYNAME BYTEDICT !{2900}%STRING(32)%ARRAYFORMAT EXTFMT(0:99) !{2900}%STRINGARRAYNAME EXTNAMES %RECORDFORMAT DDOFMT(%INTEGER START,CONTID,VALUE,INIT,INCR,FINAL,LEFT) %RECORD(DDOFMT) %ARRAY DDO(1:7) %SWITCH PIEXIT(1 : 4) %SWITCH UP(0 : 3) %SWITCH PI(0 : 150) %SWITCH P210(1 : 18), P59(1 : 15), P53(1 : 14) !* {PERQ}%ROUTINE SAVE {PERQ}%HALFINTEGER I {PERQ} I=SAVEINDEX {PERQ} SAVEII(I)=II {PERQ} SAVEIJ(I)=IJ {PERQ} SAVESL(I)=SAVELINK {PERQ} SAVEPATH(I)=PATH {PERQ} SAVEROUT(I)=ROUT {PERQ} SAVEPARAM(I)=PARAM {PERQ} SAVEINDEX=SAVEINDEX+1 {PERQ} %IF SAVEINDEX>100 %THEN %MONITOR %AND %STOP {PERQ}%END;! SAVE !* {PERQ}%ROUTINE RESTORE {PERQ}%HALFINTEGER I {PERQ} SAVEINDEX=SAVEINDEX-1 {PERQ} I=SAVEINDEX {PERQ} %IF I<0 %THEN %MONITOR %AND %STOP {PERQ} II=SAVEII(I) {PERQ} IJ=SAVEIJ(I) {PERQ} SAVELINK=SAVESL(I) {PERQ} PATH=SAVEPATH(I) {PERQ} ROUT=SAVEROUT(I) {PERQ} PARAM=SAVEPARAM(I) {PERQ}%END;! RESTORE !* !{2900} SCOMP0=X'58000002' !{2900} SCOMP1=ADDR(COMP(0)) {PERQ} COMP==ARRAY(ACOMP,FCOMP) {PERQ} SUBNAMES==ARRAY(ASUBNAMES,FSUBNAMES) OUTPUT==ARRAY(ADOUTPUT,FOUTPUT) BYTEDICT==ARRAY(ADICT,FBYTEDICT) AINPUT=ADDR(INPUT(0)) GSTATE=1 DOIO=0 FNMK=0 HGOLAB=0 DOIOP=0 IMPDOHEAD=0 CEXMODE=0 L1=0 CURSTATCLASS=0 REPORTED ERROR=0 STATEMENT=0;! WILL NOTE CURRENT STATEMENT TYPE IF NEED TO KNOW ICOMP=SUB(2+LTYPE) II=0 IJ=0 ROUT=0 PARAM=0 PATH = 0 SAVELINK=0 OUTP=1 SAVEINDEX=0 ->START L7: SAVELINK=1 START: !{2900} *LSQ_SAVELINK !{2900} *SLSD_PATH !{2900} *ST_%TOS {PERQ} SAVE ROUT = PATH L4: PIEXIT(1): EXIT1:P = COMP(ICOMP) P1 = COMP(ICOMP+1) ICOMP = ICOMP+2 ! ->PI(P) !{2900C} %IF PTRACE#0 %THENSTART !{2900C} STRACE !{2900C} %FINISH -> PI(P) ! SINGLE CHARACTER PI(2): -> L2 %IF P1 # NEXTCH L11: INP = INP+1 L10: ICOMP = ICOMP+2 NEXTCH = INPUT(INP) -> L4 ! SINGLE (OBLIGATORY) CHARACTER PI(3):%IF P1#NEXTCH %THEN ->SYNERR ->L11 ! STRING PI(4):I = SHEADS(P1) %UNLESS NEXTCH=SSTRING(I+1) %THEN ->L2 J = SSTRING(I) %CYCLE K = 1,1,J-1 -> L2 %IF INPUT(INP+K) # SSTRING(I+K+1) %REPEAT INP = INP+J -> L10 ! @ SYMBOL PI(6):PARAM = RES_W II = ICOMP ICOMP = ICOMP+2 IJ = INP PATH = 2 -> L7 ! META-VARIABLE ! SINGLE (OPTIONAL) CHARACTER PI(7):%IF P1=NEXTCH %THENSTART INP=INP+1 NEXTCH=INPUT(INP) %FINISH ICOMP=ICOMP+2 ->L4 ! PI(9):ICOMP=COMP(ICOMP)<<8!COMP(ICOMP+1) ->L4 ! PI(1):II = ICOMP ICOMP = SUB(P1) PATH = 1 IJ = INP ->L7 PIZERO: ! END OF DEFINITION PI(0): -> L1 %IF ROUT = 1 {PERQ} PARAM = COMP(ICOMP)<<8!COMP(ICOMP+1) !{2900} *LD_SCOMP0 !{2900} *INCA_ICOMP !{2900} *LSS_(%DR) !{2900} *ST_PARAM !* LIN = -OUTP UP2: UP(2):OUTPUT(OUTP) = PARAM OUTP = OUTP+1 ER = 307 ! -> EXIT4 %IF OUTP = OUTPL;!******************************************** RET: !{2900} *LSD_%TOS !{2900} *ST_PATH !{2900} *LSQ_%TOS !{2900} *ST_SAVELINK {PERQ} RESTORE %IF SAVELINK=0 %THEN LINVAL=LIN %AND %RESULT=1 %IF PATH=2 %THEN ->UP2 %IF PATH=0 %THEN ->UP0 %IF PATH=3 %THEN ->UP3 UP(1):ICOMP = II+2 PARAM = LIN II = ICOMP+2 IJ = INP PATH = 2 -> L7 UP0: UP(0):ICOMP = II %IF MAXINP L4 %UNLESS ICOMP = 0 !{2900} *LSD_%TOS !{2900} *ST_PATH !{2900} *LSQ_%TOS !{2900} *ST_SAVELINK {PERQ} RESTORE PATH = 0 %IF SAVELINK=0 %THEN LINVAL=LIN %AND %RESULT=1 ->UP(PATH) !* L1: LIN=COMP(ICOMP)<<8!COMP(ICOMP+1) ->RET !* SYNERR:ER=100;! SYNTAX ERROR PIEXIT(4): EXIT4P:FAULT(ER);! WITH POINTER ->UP3 EXIT4:LFAULT(ER) UP3: UP(3):%RESULT = 3 ! ---------------------------------------------------------------------- LFAULT:LFAULT(ER) ->EXIT1 !* PI(127): !*********************************************************************** !* Fast search for statements * !*********************************************************************** %IF 'A'<=NEXTCH<='Z' %THEN ICOMP=LOOKUP(NEXTCH-'A') ->EXIT1 !* PI(128): !*********************************************************************** !* Avoid operator search if not possible * !*********************************************************************** ICOMP=ICOMP+2 %UNLESS 9<=TYPE(INP)<=10 %THEN ->EXIT2;! unless * / + - > ! & ^ # ICOMP=ICOMP+2 ->EXIT1 !* PI(17): !*********************************************************************** !* FOLLOWING ARITHMETIC IF LABEL CHECK IF SAME AS NEXT LABEL * !*********************************************************************** J=0 %CYCLE I=1,1,5 K=TBUFF(I) %IF K#' ' %THEN J=10*J+K&X'F' %REPEAT %IF CRM1 = J %THEN RES = 0 -> EXIT1 !* PI(18): !*********************************************************************** !* BEFORE PROCESSING LABEL LIST TO ARITHMETIC IF DETERMINE * !* VALUE OF LABEL (IF ANY) TO NEXT STATEMENT * !*********************************************************************** CRM1 = 0 -> EXIT1 %IF TBUFF(1) = 'C' %CYCLE L = 1,1,5 I = TBUFF(L) J = CLASS(I) CRM1 = CRM1*10+I&15 %IF J = X'83';! I.E. IF DIGIT %REPEAT -> EXIT1 !* PI(19): !*********************************************************************** !* P1=1 END STATEMENT * !* 0 ENTRY * !*********************************************************************** LABWARN = 0 %IF P1=0 %THEN ->EXIT1;! ENTRY %IF STATORDERMODE>3 %AND SUBPROGTYPE=5 %THEN LFAULT(305);! exec stats in BLOCKDATA %IF BLOCKIFSTATE#0 %THEN LFAULT(208);! missing ENDIF CHECK SAVELIST !{2900}%IF ITSMODE=1 %THEN FAULTNUM(173,COMAD);! comment re ITS !PPROFILE -> EXIT1 !* PI(20): !*********************************************************************** !* NOTE DATA TYPE !* P1 =X'01' INTEGER * !* X'02' REAL * !* X'03' COMPLEX * !* X'04' LOGICAL * !* X'05' CHARACTER * !* X'06' DOUBLE PRECISION * !*********************************************************************** {PERQ} %IF P1=6 %THEN LFAULT(318);! no d.p. yet CRM8 = DEFAULT SIZE(P1) CHARLEN=1 -> EXIT1 !* PI(21): !*********************************************************************** !* SET UP NEXT IDENTIFIER OR CONSTANT FROM THE INPUT RECORD * !* ON ENTRY P1 INDICATES THE TYPE OF FIELD EXPECTED, AS FOLLOWS * !* P1 = 0 ANY FIELD * !* 1 IDENTIFIER * !* 3 INTEGER * !* 4 CONSTANT * !* 5 DATA CONSTANT * !* 6 COMPLEX CONSTANT (IF NOT EXITS TO ALTERNATIVE SYNTAX) * !* 7 OPTIONAL IDEN * !* ON EXIT CTYP IS SET AS FOLLOWS * !* CTYP = -1 'NEW' IDENTIFIER * !* 0 IDENTIFIER * !* 1 INTEGER * !* 2,10 REAL * !* 3,11 COMPLEX * !* 4 LOGICAL * !* 5 CHARACTER OR HOLLERITH * !* 6 HEX * !* 7 BLOCKDATA IDENTIFIER * !* FOR CTYP = -1 OR 0 PTR ADDRESSES THE DICT RECORD * !* CONSTANTS ARE SET IN A RECORD AT DPTR * !* PI21INT CONTAINS THE VALUE SET FOR INTEGER AND LOGICAL CONSTANTS * !* PI21LENGTH CONTAINS THE LENGTH OF THE CONSTANT FOR CTYP > 0 * !*********************************************************************** P3 = 0 P2 = 0 TINP = INP PCOMX = 0 COMPLEXLENGTH=0 SAVEP1=P1 %IF SAVEP1=7 %THEN P1=1 %AND BLOCKDATAID="" DD == RECORD(ADICT+DPTR) -> P210(TYPE(INP)) !******** A - Z P210(1): TTYP = IMPTYPE(INPUT(INP)); ! IMPLICIT TYPE FOR ALPHABETIC CHAR -> PI21IDEN !******** $ P210(2): !! TTYP = DOLLAR; ! IMPLICIT TYPE FOR $ PI21IDEN: %IF P1 <= 2 %OR P1=5 %THENSTART;! IDENTIFIER REQUIRED, OR ACCEPTABLE CTYP = 0; ! IDENTIFIER SETNAME FIND; ! WILL SET CTYP=-1 IF A 'NEW' IDENTIFIER RES_W=PTR PI21MODE=SETMODE(TTYP&X'3F');! TO ALLOW DIMENSION EXPRESSION ANALYSIS %IF P1=5 %THENSTART;! must be a constant name %IF PP_CLASS=16 %THENSTART CTYP=PP_TYPE RES_W=PP_LINK3 PI21INT=RES_H0 %IF RES_H1=X'101' %THEN %C PI21INT=INTEGER(ADICT+PI21INT<PI21EXIT %FINISHELSESTART INP=TINP NEXTCH=INPUT(INP) ->PI21H %FINISH %FINISH %IF SAVEP1=7 %THEN BLOCKDATAID=IDENTIFIER PI21EXIT:NEXTCH = INPUT(INP) -> EXIT1 %FINISH %IF P1 = 6 %THENSTART; ! SWITCH TO ALTERNATIVE SYNTAX(NOT COMPLEX CONST) SWITCH: INP = TINP ICOMP = ICOMP+2 NEXTCH = INPUT(INP) -> EXIT2 %FINISH PI21H:ER = 116; ! INVALID CONSTANT -> EXIT4P %UNLESS P1 = 5; ! MAY STILL BE ALRIGHT AS A DATA CONSTANT I = INP+1 !{2900} %IF INPUT(INP) = 'Z' %THENSTART; ! COULD BE A HEX CONSTANT !{2900}HEXLOOP: INP = INP+1 !{2900} J = INPUT(INP) !{2900} %IF 'A' <= J <= 'F' %THENSTART !{2900} INPUT(INP) = J&15+9 !{2900} -> HEXLOOP !{2900} %FINISH !{2900} %IF '0' <= J <= '9' %THENSTART !{2900} INPUT(INP) = J&15 !{2900} -> HEXLOOP !{2900} %FINISH !{2900} ER = 116; ! INVALID CONSTANT !{2900} L=INP-I !{2900} -> EXIT4P %IF L=0; ! NO HEX DIGITS, - NOT A VALID CONST !{2900} %IF L&1#0 %THEN I=I-1 %AND INPUT(I) = 0 !{2900} L=0 !{2900} %CYCLE J=I,2,INP-2 !{2900} BYTEINTEGER(ADICT+DPTR+L+4)=INPUT(J)<<4!INPUT(J+1) !{2900} L=L+1 !{2900} %REPEAT !{2900} INTEGER(ADICT+DPTR)=L !{2900} RES_H0=DPTR>>DSCALE; RES_H1=X'10C' !{2900} DPTR=DPTR+(L+3)&X'FFC' !{2900} CTYP = 6; ! HEX CONSTANT !{2900} PI21LENGTH=L !{2900} -> PI21EXIT !{2900} %FINISH I = INPUT(INP) -> EXIT4 %UNLESS I = 'T' %OR I = 'F' PI21INT = 0 %IF I = 'T' %THEN PI21INT = 1 ->PI21LOG !******** 0 - 9 P210(3): ER = 144; ! VARIABLE NOT FOUND WHEN EXPECTED -> EXIT4P %IF P1 = 1; ! IDENTIFIER REQUIRED !* L=0;! will locate start of digits after . (if any) M=0;! count of digits after . N=0;! will locate start of exponent (if any) P=0;! count of [sign] and digits in exponent PI21LENGTH=0;! will remain 0 for integers I=INP+1 %WHILE TYPE(I)=3 %CYCLE;! digit I=I+1 %REPEAT K=I-INP;! no. of digits before decimal point %IF P1=3 %THEN ->PI21GET;! integer requested J=INPUT(I) %IF J='.' %THENSTART PI21LENGTH=REAL LENGTH I=I+1 %IF TYPE(I)=3 %THENSTART;! digit PI21C: L=I;! start of digits after decimal point I=I+1 %WHILE TYPE(I)=3 %CYCLE;! digit I=I+1 %REPEAT M=I-L;! no. of digits after decimal point PI21D: J=TYPE(I) %IF J=1 %THENSTART;! alphabetic J=INPUT(I) %IF J='E' %THENSTART PI21LENGTH=REAL LENGTH PI21E: I=I+1 N=I;! start of exponent (excluding E,D,Q) J=INPUT(I) %IF J='+' %OR J='-' %THENSTART I=I+1 PI21F: %IF TYPE(I)=3 %THENSTART;! digit I=I+1 %WHILE TYPE(I)=3 %CYCLE;! digit I=I+1 %REPEAT P=I-N;! no. of characters in exponent ->PI21GET %FINISHELSESTART ER=117;! invalid real constant PTR=I ->EXIT4P %FINISH %FINISHELSE ->PI21F;! to check digits %FINISH %IF J='D' %THENSTART PI21LENGTH=DP LENGTH ->PI21E %FINISH !{2900} %IF J='Q' %THENSTART !{2900} LFAULT(119);! warn about use of Q !{2900} PI21LENGTH=16 !{2900} ->PI21E !{2900} %FINISH %FINISH ->PI21GET %FINISH %FINISH ->PI21D !* PI21GET: !* PTR locates start of const !* I-1 locates last char of const !* PI21LENGTH = 0 if integer !* 4,8 or 16 if real %IF PCOMX#0 %OR P1=6 %THENSTART;! complex %IF PI21LENGTH=0 %THEN PI21LENGTH=REAL LENGTH %IF COMPLEXLENGTH=0 %THENSTART COMPLEXLENGTH=PI21LENGTH %FINISHELSE PI21LENGTH=COMPLEXLENGTH %FINISH %IF PI21LENGTH=0 %THENSTART;! integer %IF P3#0 %THENSTART;! there is a sign to be included INP=INP-1 P3=0 %FINISH !{2900} J=TO INTEGER(ADICT+DPTR,4,I-INP,ADDR(INPUT(INP)),1) {PERQ} J=TO INTEGER(ADICT+DPTR,4,ADDR(INPUT(0)),I-INP,INP,1) %IF J>0 %THEN ER=120 %AND ->EXIT4P PI21INT=INTEGER(ADICT+DPTR) INP=I %IF TYPE(INP)=6 %THENSTART;! Hollerith PI21LENGTH=PI21INT !{2900C} MOVE(PI21LENGTH,ADDR(INPUT(INP+1)),ADICT+DPTR+CNSTRECMIN) {PERQC} COPY(PI21LENGTH,AINPUT,INP+1,ADICT+DPTR+CNSTRECMIN,0) INP=INP+PI21LENGTH+1 PI21MODE=11;! Hollerith ->PI21HOLL %FINISH !{2900} %IF INTEGER LENGTH=4 %THENSTART PI21MODE=1 CTYP=X'51' %IF 0<=PI21INT<=X'7FFF' %THENSTART RES_H0=PI21INT; RES_H1=1 ->PI21EXIT %FINISHELSESTART RES_H0=DPTR>>DSCALE; RES_H1=X'101' DPTR=DPTR+W2 %FINISH !{2900} %FINISHELSESTART;! INTEGER LENGTH=8 !{2900} PI21MODE=2 !{2900} CTYP=X'61' !{2900} %IF PI21INT<0 %THEN I=-1 %ELSE I=0 !{2900} INTEGER(ADICT+DPTR)=I !{2900} INTEGER(ADICT+DPTR+4)=PI21INT !{2900} RES_H0=DPTR>>DSCALE; RES_H1=X'102' !{2900} DPTR=DPTR+8 !{2900} %FINISH ->PI21EXIT %FINISHELSESTART;! real %IF P1=6 %AND P2=0 %THENSTART;! real part of complex const? %UNLESS INPUT(I)=',' %THEN ->SWITCH %FINISH !{2900} %IF L#0 %THEN L=ADDR(INPUT(L)) !{2900} %IF N#0 %THEN N=ADDR(INPUT(N)) {PERQ} %IF M#0 %THENSTART;! some digits after decimal . {PERQ} %CYCLE L=L,1,L+M-1 {PERQ} INPUT(L-1)=INPUT(L) {PERQ} %REPEAT {PERQ} %FINISH %IF P3#0 %THENSTART;! there is a sign to be included INP=INP-1 K=K+1 P3=0 %FINISH !{2900} J=TO REAL(ADICT+DPTR,PI21LENGTH,K,ADDR(INPUT(INP)), %C !{2900} M,L,P,N,0,0,1) {PERQ} J=TO REAL(ADICT+DPTR,PI21LENGTH,ADDR(INPUT(0)), {PERQ} K+M,INP,0,0,P,N,M,0,1) %IF J>0 %THEN ER=120 %AND ->EXIT4P;! const out of range %IF J<0 %THEN FAULT(174);! comment - too great precision INP=I !* {PERQ} %IF CONTROL&X'10000000'#0 %THENSTART;! PARM PARMX (for X-compiling) !{PERQ} INTEGER(ADICT+DPTR)=PERQREAL(REAL(ADICT+DPTR)) {PERQ} %FINISH !* %IF PI21LENGTH=W2 %THEN I=3 %ELSESTART %IF PI21LENGTH=W4 %THEN I=4 %ELSE I=5 %FINISH %IF (PCOMX=1 %OR P1=6) %THENSTART;! complex no. %IF P2=0 %THENSTART;! real part %UNLESS INPUT(INP)=',' %THENSTART %IF P1=6 %THEN ->SWITCH ER=118 ->EXIT4P %FINISH INP=INP+1 I=INPUT(INP) %IF I='+' %OR I='-' %THENSTART INP=INP+1 I=INPUT(INP) P3=1;! to ensure sign is included later %FINISHELSE P3=0 DPTR=DPTR+PI21LENGTH P2=1 K=0; L=0; M=0; N=0; P=0 NEXTCH=I ->P210(TYPE(INP)) %FINISHELSESTART;! imaginary part %UNLESS INPUT(INP)=')' %THEN ER=118 %AND ->EXIT4P INP=INP+1 I=I+3;! complex modes DPTR=DPTR-PI21LENGTH;! now points at start of real part PI21LENGTH=PI21LENGTH<<1 %FINISH %FINISH PI21MODE=I CTYP=MODETOST(I) RES_H0=DPTR>>DSCALE; RES_H1=X'100'!I DPTR=DPTR+PI21LENGTH %FINISH -> PI21EXIT !****** NON-ALPHANUMERICS P210(4): P210(7): P210(8): P210(9): P210(10): P210(11): P210(13): P210(14): P210(15): P210(16): P210(17): P210(18): K=0; L=0; M=0; N=0; P=0 %IF NEXTCH = '.' %THENSTART ER = 117; ! INVALID REAL NO. -> EXIT4P %IF P1 = 1 %OR P1 = 3;! IDEN OR INTEGER EXPECTED I=TYPE(INP+1) %IF I # 1 %THENSTART; ! NOT A LETTER %IF I # 3 %THENSTART -> EXIT4P %FINISH PI21LENGTH=REAL LENGTH;! to indicate the . I=INP+1 ->PI21C %FINISHELSESTART; ! A LETTER -> SWITCH %IF P1 = 6; ! NOT A COMPLEX CONSTANT INP=INP+1 SETNAME ER = 116; ! ILLEGAL CONST %IF IDENTIFIER = "TRUE" %THENSTART PI21INT = 1 %FINISHELSESTART %IF IDENTIFIER = "FALSE" %THENSTART PI21INT = 0 %FINISHELSE -> EXIT4P %FINISH -> EXIT4P %UNLESS INPUT(INP) = '.' PI21LOG: INP = INP+1 CTYP = X'54'; ! LOGICAL CONST PI21MODE=9 RES_H0=PI21INT; RES_H1=9 PI21LENGTH=4 -> PI21EXIT %FINISH %FINISH -> SWITCH %IF P1 = 6 %AND NEXTCH = '\';! MAY BE A VALID LOGICAL EXPRESSION ER = 106; ! INVALID CHAR -> EXIT4P %UNLESS 5 <= P1 <= 6; ! FOLLOWING ONLY VALID IF A CONSTANT EXPECTED %IF NEXTCH = '(' %THENSTART; ! MAY BE COMPLEX -> SWITCH %IF P1 = 6 PCOMX = 1 %FINISHELSESTART -> EXIT4P %UNLESS P3 = 0; ! SIGN ALREADY SET %IF NEXTCH='+' %OR NEXTCH='-' %THENSTART P3=1;! indicates presence of a sign %FINISHELSE ->EXIT4P %FINISH INP = INP+1 NEXTCH = INPUT(INP) -> P210(TYPE(INP)) !****** CHARACTER P210(5): PI21LENGTH = 0 {PERQC} K=DPTR+DPTR+4 %CYCLE INP = INP+1 I = INPUT(INP) %IF I = '''' %THENSTART INP = INP+1 I = INPUT(INP) %IF I # '''' %THENEXIT; ! END OF CHARACTER CONSTANT %FINISH !{2900C} BYTEINTEGER(ADICT+DPTR+CNSTRECMIN+PI21LENGTH) = I {PERQC} BYTEDICT(K+PI21LENGTH)=I PI21LENGTH = PI21LENGTH+1 %REPEAT PI21MODE=10;! to distinguish from Hollerith PI21HOLL: %IF P1=6 %THEN ->SWITCH ER = 116; ! INVALID CONST -> EXIT4P %UNLESS P1 = 0 %OR 4 <= P1 <= 5; ! ONLY VALID IF CONST REQUESTED CTYP = 5; ! CHARACTER CONST -> EXIT4P %UNLESS 0 < PI21LENGTH <=X'FFFF' {PERQC} K=DPTR+DPTR+4 %CYCLE J = 0,1,3 !{2900C} BYTEINTEGER(ADICT+DPTR+CNSTRECMIN+PI21LENGTH+J) = ' ' {PERQC} BYTEDICT(K+PI21LENGTH+J)=' ' %REPEAT !{2900} %IF CHARACTER CODE#0 %THENSTART;! EBCDIC INTERNAL !{2900} ITOE(ADICT+DPTR+CNSTRECMIN,PI21LENGTH+4) !{2900} %FINISH INTEGER(ADICT+DPTR)=PI21LENGTH RES_H0=DPTR>>DSCALE; RES_H1=X'100'!PI21MODE !{2900C} DPTR=DPTR+(PI21LENGTH+7)&X'FFC' {PERQC} DPTR=DPTR+2+(PI21LENGTH+1)>>1 -> PI21EXIT !****** END OF STATEMENT P210(12): ER = 104 %IF SAVEP1=7 %THEN ->PI112 -> EXIT4 !* PI(22): !*********************************************************************** !* CHECK THAT INT AFTER * IS VALID - MODIFY CRM8 IF NECESSARY * !*********************************************************************** %IF CRM8=5 %THENSTART;! CHARACTER %UNLESS 0EXIT1 %FINISH L22A: !{2900}LFAULT(242);! warn about use of * !{2900}L = CRM8&7 !{2900}%UNLESS PI21INT = VALIDT(L) %THENSTART !{2900} L = L+8 !{2900} %UNLESS PI21INT=VALIDT(L) %THENSTART !{2900} L=L+8 !{2900} %UNLESS PI21INT=VALIDT(L) %THEN FAULT(124) %AND ->EXIT1 !{2900} %FINISH !{2900}%FINISH !{2900}%IF P=24 %THEN PP_TYPE=VALIDST(L) %ELSE CRM8=VALIDST(L) !* {PERQ}%IF CRM8&7=INTTYPE %AND PI21INT=2 %THENSTART;! only int2 allowed {PERQ} LFAULT(319);! I*2 not yet available {PERQ} ! LFAULT(242);! warn that I*2 is non-standard {PERQ} %IF P=24 %THEN PP_TYPE=X'41' %ELSE CRM8=X'41' {PERQ}%FINISHELSE LFAULT(124) {PERQ} -> EXIT1 !* PI(23): !*********************************************************************** !* EXPLICITLY SETS TYPE (CRM8) IN CURRENT PREC, CHECKING VALIDITY * !*********************************************************************** SAVEPTR=PTR;! saved for resetting in PI24 if necesary I = PP_CLASS %IF I = 12 %THEN CBNAME %AND I = PP_CLASS IDENTIFIER =STRING(ANAMES+PP_IDEN) J = PP_X0 %IF J&8 = 0 %THENSTART; ! NOT ALREADY TYPED %IF I&X'1F' <= 8 %OR (I = 11 %AND SUBPROGTYPE = 2) %C %THENSTART ! SCALAR OR ARRAY OR EXTERNAL FN OR 'THIS FN' ! CONSTANT NAME TREATED AS SCALAR PP_X0=J!8; ! INDICATES THAT TYPE IS SET EXPLICITLY PP_TYPE=CRM8 %IF CRM8 = 5 %THEN PP_LEN=CHARLEN ! DEFAULT CHARACTER LENGTH -> EXIT1 %FINISHELSESTART %IF I&X'10'#0 %THEN J=239 %ELSE J=270 ! name cannot be typed after it has appeared in a PARAMETER statement ! else name must not appear in a type statement LFAULT(J) ->EXIT1 %FINISH %FINISH LFAULT(269); ! already typed ->EXIT1 !* PI(24): !*********************************************************************** !* OVERRIDE EXPLICIT TYPE SETTING AFTER * * !*********************************************************************** %IF CRM8=5 %THENSTART %UNLESS 0EXIT1 %FINISH -> L22A !* PI(25): !*********************************************************************** !* AFTER ( IN DIMENSION LIST * !*********************************************************************** %CYCLE I = PP_CLASS %IF I&X'C' = 0 = PP_X1&3 %THENEXIT; ! NOT SUBPROG OR ARRAY OR USED ER = 254; ! WRONG CLASS OF VAR DIMENSIONED OR ARRAY ALREADY %IF I&X'C'=4 %THEN ER=262;! ALREADY AN ARRAY %UNLESS I = 12 %THEN -> EXIT4; ! FAULT UNLESS COMMON BLOCK NAME CBNAME %REPEAT ARRAYREC==RECORD(ADICT+PTR);! REMEMBER THE CURRENT IDEN RECORD CEXMODE=3 DIMSCOUNT = 0 CEXPDICT=0 -> EXIT1 !* PI(26): !*********************************************************************** !* Following dimension value * !* P1 = 0 after lower, or only, bound * !* 1 after upper bound * !*********************************************************************** CURSTATCLASS=1 %IF STATORDERMODE>2 %THEN LFAULT(236) STATORDERMODE=2 GENERATE RD I=RES_FORM;! form of expression %IF I<=1 %THENSTART;! integer const K=RES_H0 %IF I#0 %THENSTART !{2900} K=K<>DSCALE; RES_H1=X'701' %FINISH K=RES_W!X'80000000' %IF ARRAYREC_CLASS&1=0 %THENSTART %IF ARRAYREC_CLASS=2 %THENSTART IDENTIFIER=STRING(ANAMES+ARRAYREC_IDEN) ER=251;! adjustable dims ->LFAULT %FINISH ARRAYREC_CLASS=X'61' I=PTR PTR=NEW LIST CELL(CHECKLIST,3) SS==RECORD(ADICT+PTR) SS_INF0=ADDR(ARRAYREC_CLASS)-ADICT SS_INF2=1;! CHECK IF PARAM PTR=I %FINISHELSE ARRAYREC_CLASS=X'41' %FINISH !***** entered from PI(114) after *) in dimension list PI26B:%IF DIMSCOUNT <= 7 %THENSTART %IF P1=0 %THENSTART;! after lower, or only, bound DIMSCOUNT=DIMSCOUNT+1 LDIM(DIMSCOUNT)=1 %FINISHELSESTART LDIM(DIMSCOUNT)=UDIM(DIMSCOUNT) %FINISH UDIM(DIMSCOUNT)=K %FINISH CEXPDICT=0 -> EXIT1 !* PI(27): !*********************************************************************** !* INTRODUCE BLANK COMMON, I.E. AFTER COMMON OR // * !*********************************************************************** PTR = BLCMPTR PP == RECORD(ADICT+PTR) %IF PP_LINK3 = BLCMPTR %THEN CTYP = -1 %ELSE CTYP = 0 !* PI(28): !*********************************************************************** !* INTRODUCE LABELLED COMMON, I.E. AFTER // * !*********************************************************************** CURSTATCLASS=1 %IF STATORDERMODE>2 %THEN ER=236 %AND ->EXIT4 STATORDERMODE=2 %CYCLE CMNBLKPTR = PTR %IF CTYP = -1 %THENSTART; ! FIRST USE - ESTABLISH REFERENCE PP_CLASS=12; ! COMMON BLOCK NAME PP_ADDR4 = CBNPTR CBNPTR = PTR PP_CMNLENGTH = 0 PP_LINK3 = PTR; ! LAST ITEM LINK TO ITSELF DPTR = DPTR+CMNRECEXT; ! RESERVE THE EXTRA DICT WORDS PP_CMNREFAD=0;! no reference set -> EXIT1 %FINISH I = PP_CLASS -> EXIT1 %IF I = 12; ! COMMON BLOCK ENTRY ALREADY ESTABLISHED ER = 121; ! ILLEGAL USE OF BLOCK NAME CMNBLKPTR = -1; ! UNLESS SET > 0 WILL INDICATE INVALID BLOCK NAME -> LFAULT %IF 8 < I < 12 CBNAME %REPEAT !* PI(29): !*********************************************************************** !* AFTER IDEN IN COMMON LIST * !*********************************************************************** %IF CMNBLKPTR < 0 %THEN -> EXIT1; ! INVALID BLOCK NAME ALREADY REPORTED %IF PP_CLASS = 12 %THEN CBNAME I = PP_CLASS J = PP_X1 %UNLESS I&X'7B' = 0 = J&3 %THENSTART; ! IF PARAM, (ALREADY) COMMON, INITIALISED OR USED J=I&X'7B' %IF J#0 %THENSTART ER=142;! SUBPROGRAM NAME %IF J=1 %THEN ER=123;! PARAMETER %IF J=2 %THEN ER=122;! ALREADY IN COMMON %IF J=16 %THEN ER=240;! SYMBOLIC CONSTANT NAME %IF J&64#0 %THEN ER=251;! adjustable dims %FINISHELSE ER=236;! ALREADY USED OR INITIALISED ->LFAULT %FINISH PP_CLASS=I!2; ! SET COMMON MARKER PP_X0=PP_X0!4; ! ?? PP_LINK3 = CMNBLKPTR CMNBLK == RECORD(ADICT+CMNBLKPTR) QQ == RECORD(ADICT+CMNBLK_LINK3); ! PREVIOUS LAST ITEM IN THIS COMMON AREA QQ_LINK2 = PTR CMNBLK_LINK3 = PTR %IF J&4 # 0 %THENSTART; ! IF 'EQUIVALENCED FROM' L = PP_LINK2; ! LINK TO CORRESPONDING EQUIV CHAIN ENTRY PP_LINK2=0 PP_X1=J&X'F3'; ! CLEAR EQUIVALENCE MARKERS ALLOC(PTR); ! FORCES ALLOCATION OF COMPLETE COMMON AREA SS == RECORD(ADICT+L); ! EQUIV CHAIN ENTRY SS == RECORD(ADICT+SS_LINK1); ! NEXT CHAIN ENTRY PTR = SS_INF0; ! CORRESPONDING DICT RECORD ALLOC(PTR); ! COMPLETE CHAIN %FINISH -> EXIT1 !* PI(30): !*********************************************************************** !* INITIALISATION FOR DATA OR EQUIVALENCE LIST * !*********************************************************************** CURSTATCLASS=1 CRM3 = 0; ! -1 ERROR DETECTED VLISTHEAD = 0; ! LISTHEAD OF LIST RECORDS FORMAT SS CCOUNT = 1; ! DEFAULT MULTIPLIER IN DATA INIT, USED IN EQUIV TO ! CHECK THAT <= 1 COMMON IS INCLUDED VCOUNT=0;! to ensure data init calls GET NEXT VARIABLE -> EXIT1 !* PI(31): !*********************************************************************** !* MAKE A SCALAR ENTRY TO LIST (IN TYPE STATEMENT AFTER / INDICATING * !* INITIALISATION FOR PREVIOUS ITEM) * !*********************************************************************** %IF P1=1 %THENSTART PTR=DOIOP;! saved by PI32(1) PP==RECORD(ADICT+PTR) %FINISH %IF PP_CLASS = 12 %THEN CBNAME ER = 301; ! WRONG CLASS OF VARIABLE IN DATA OR EQUIVALENCE LIST %IF PP_CLASS&X'19' # 0 %THEN CRM3 = -1 %AND -> LFAULT ! CONFLICT WITH PARAM OR SUBPROG NAME I = 0 PI31A: -> EXIT1 %IF CRM3 = -1; ! PREVIOUS ERROR L = PTR PTR=FREESP(5) SS==RECORD(ADICT+PTR) !****** Following code inserted to process char substrings %IF P1=1 %THENSTART;! substring RES_W=RESCOM1; J=RES_H0; %IF J=0 %THEN J=1;! lower bound RES_W=RESCOM2; K=RES_H0; %IF K=0 %THEN K=PP_LEN;! upper bound SS_INF4=K-J+1;! substring length I=I+J-1 RESCOM1=0 RESCOM2=0 %FINISHELSE SS_INF4=0 SS_INF2 = I; ! DISPLACEMENT FROM BASE ADDRESS (!X'1000000' FOR ARRAY ELEMENT) SS_INF3=LINEST SS_INF0 = L %UNLESS VLISTHEAD = 0 %THENSTART SS == RECORD(ADICT+VLISTTAIL) SS_LINK1 = PTR %FINISHELSE VLISTHEAD = PTR VLISTTAIL = PTR; ! POINTER TO LAST ITEM ON LIST -> EXIT1 !* PI(32): !*********************************************************************** !* SAVE DPTR VALUE BEFORE PROCESSING DIMENSION IN LIST ARRAY ELEMENT * !*********************************************************************** %IF P1=1 %THENSTART;! insertion for substrings DOIOP=PTR;! saved for resetting in PI31(1) RESCOM1=0 RESCOM2=0 %IF SCAN(':')=0 %THENSTART;! no substring ICOMP=ICOMP+2 ->EXIT2 %FINISH %FINISHELSE DIMSCOUNT=0 -> EXIT1 !* PI(33): !*********************************************************************** !* PRESERVE INTEGER DIMENSION VALUE EVALUATED BY PI21 * !*********************************************************************** RESCOM1=0 RESCOM2=0 DIMSCOUNT = DIMSCOUNT+1 %IF DIMSCOUNT <= 7 %THEN LDIM(DIMSCOUNT) = PI21INT -> EXIT1 !* PI(34): !*********************************************************************** !* AFTER ) TO DIMENSION LIST IN DATA STATEMENT * !* CALCULATE BYTE DISPLACEMENT OF ELEMENT AND MAKE LIST ENTRY * !*********************************************************************** %IF P1=1 %THENSTART PTR=DOIOP;! saved by PI32(1) PP==RECORD(ADICT+PTR) %FINISH %IF PP_CLASS=12 %THEN CBNAME ER = 245; ! SUBSCRIPTED VARIABLE NOT ARRAY NAME %UNLESS PP_CLASS&13 = 4 %THENSTART %IF PP_CLASS&4#0 %THEN ER=301 PI34ERR: CRM3 = -1 -> LFAULT %FINISH DVREC == RECORD(ADICT+PP_ADDR4) J = DVREC_DIMS PI34A:I=1;! to avoid IMP compiler bug L = LDIM(I)-DVREC_B(I)_L ER = 264; ! WRONG NO. OF SUBSCRIPTS %UNLESS DIMSCOUNT = J %THEN -> PI34ERR %IF DIMSCOUNT > 1 %THENSTART L = L+DVREC_B(1)_L %CYCLE I = 2,1,J L = L+DVREC_B(I-1)_M*(LDIM(I)-DVREC_B(I)_L+1) %REPEAT L = L-DVREC_ZEROTOFIRST %FINISH ER = 232 %UNLESS 0 <= L < DVREC_NUMELS %THEN %C IDENTIFIER=STRING(ANAMES+PP_IDEN) %AND -> PI34ERR ! OUTSIDE DECLARED BOUNDS %IF PP_TYPE=5 %THEN J=PP_LEN %ELSE %C J=NUMBYTES(PP_TYPE>>4);! BYTES PER ITEM %IF PP_TYPE&7=3 %THEN J=J<<1;! COMPLEX I = (L*J)!X'1000000' -> PI31A !* PI(35): !*********************************************************************** !* FOLLOWING CLOSING ) TO ARRAY DECLARATION * !*********************************************************************** CURSTATCLASS=1 %IF STATORDERMODE>2 %THEN LFAULT(236) STATORDERMODE=2 ER = 247; ! MORE THAN 7 DIMENSIONS %IF DIMSCOUNT > 7 %THEN -> EXIT4 J = ARRAYREC_CLASS ARRAYREC_CLASS=J!4;! array marker DVREC == RECORD(ADICT+DPTR) DVREC_DIMS = DIMSCOUNT %IF J&1 # 0 %THENSTART; ! PARAMETER ARRAY DVREC_ADFIRST = ARRAYREC_ADDR4;! GLA ADDRESS OF PARAM DESCRIPTOR %FINISHELSE DVREC_ADFIRST=0 ARRAYREC_ADDR4 = DPTR; ! LINK TO DOPE VECTOR DPTR=DPTR+DVRECSIZE+W6*DIMSCOUNT N=0 L=0; M=1 %CYCLE I=1,1,DIMSCOUNT J=LDIM(I) K=UDIM(I) DVREC_B(I)_L=J DVREC_B(I)_U=K %IF J&X'E0000000'=X'80000000' %OR %C K&X'E0000000'=X'80000000' %THENSTART;! adjustable dimension %IF J&X'E0000000'#X'80000000' %AND N=0 %THEN L=L+M*J N=1 PI35A: DVREC_B(I)_M=-1 %FINISHELSESTART %UNLESS J<=K %OR K&X'E0000000'=X'A0000000' %C %THEN FAULT(231) %AND K=J;! bounds inside out %IF N#0 %THEN ->PI35A;! already know it is adjustable %IF K&X'E0000000'=X'A0000000' %THEN K=0;! AVOID INTOVERFLOW L=L+M*J M=M*(K-J+1) DVREC_B(I)_M=M %FINISH %REPEAT %IF DVREC_B(DIMSCOUNT)_U&X'E0000000'=X'A0000000' %THEN %C ARRAYREC_CLASS=ARRAYREC_CLASS!X'80';! assumed size DVREC_NUMELS = M;! at least as far as can be DVREC_ZEROTOFIRST = L;! computed at compile time DVREC_ELLENGTH=NUMBYTES(ARRAYREC_TYPE>>4);! will be updated if nec. by ALLOC -> EXIT1 !* PI(36): !*********************************************************************** !* FOLLOWING MULTIPLIER IN DATA INITIALISATION LIST * !*********************************************************************** %UNLESS CTYP&7 = 1 %THEN -> PI34ERR; ! MUST BE AN INTEGER -> EXIT1 %IF CRM3 = -1 CCOUNT = PI21INT -> EXIT1 !* PI(37): !*********************************************************************** !* INITIALISE NEXT ENTRY IN DATA LIST * !*********************************************************************** %IF STATORDERMODE<3 %THEN STATORDERMODE=3 -> EXIT1 %IF CRM3 = -1 !* !* CCOUNT number of consts !* PI21LENGTH actual length of const !* PI21MODE mode of const !* %IF RES_H0&X'F00'=0 %THENSTART;! handle short literals like all others INTEGER(ADICT)=RES_H0 RES_W=0 %FINISHELSE RES_W=RES_H0<EXIT4 %FINISHELSE ->EXIT4P %FINISH %FINISH %IF VCOUNT=0 %THENSTART ER=286;! too many consts specified ->EXIT4P %FINISH !* I=PI21MODE J=RES_W K=PI21LENGTH %IF I=VMODE %THENSTART;! type and size(except char) matches %IF I=10 %THENSTART;! char, check const length PI37D: %IF KCCOUNT %THEN L=CCOUNT;! L=MIN(VCOUNT,CCOUNT) ADD DATA ITEM(VAREA,PTR,L,VDISP,VLENGTH,J) VCOUNT=VCOUNT-L CCOUNT=CCOUNT-L VDISP=VDISP+L*VLENGTH %IF CCOUNT=0 %THEN CCOUNT=1 %AND ->EXIT1;! for the next const ->PI37A;! to prepare next variable %FINISH !* %IF 1<=I<=8 %AND 1<=VMODE<=8 %THENSTART;! arithmetic coercion required M=VMODE PI37C: J=COERCE CONST(J,I,M) ->PI37B %FINISH !* %IF I=1 %AND VMODE=0 %THENSTART;! I*2 init J=J+2 ->PI37B %FINISH !* %IF I=2 %AND VMODE=0 %THENSTART J=J+6 ->PI37B %FINISH !* %IF I=9 %THENSTART;! logical const - must be logical var %IF VMODE=13 %THENSTART;! L*1 var J=J+3 ->PI37B %FINISH %IF VMODE=14 %THENSTART;! L*8 var I=1 M=2 ->PI37C;! use I*4 -> I*8 coercion %FINISH %FINISH !* %IF I=12 %THENSTART;! hex - allow anything to be init J=J+4 %IF KPI37B %FINISH !* %IF I=11 %THENSTART;! Hollerith - init any non-char %IF VMODE=10 %THEN FAULT(285);! wrong type %IF K>VLENGTH %THENSTART %IF REPORTED ERROR&1=0 %THEN FAULT(277);! Hollerith larger than item REPORTED ERROR=REPORTED ERROR!1 K=VLENGTH %FINISH %IF REPORTED ERROR&2=0 %THEN LFAULT(193);! Hollerith non-standard REPORTED ERROR=REPORTED ERROR!2 ->PI37D %FINISH !* %IF I=10 %THENSTART;! char %IF REPORTED ERROR&4=0 %THEN LFAULT(194);! char initialising non-char is non-standard REPORTED ERROR=REPORTED ERROR!4 ->PI37D %FINISH !* ER=285;! const not compatible ->EXIT4P !* PI(38): !*********************************************************************** !* AFTER / TERMINATING INITIALISATION DATA * !* UNWIND LIST AND REMOVE REDUNDANT ENTRIES * !*********************************************************************** %UNLESS CRM3 = -1 %THENSTART %IF VLISTHEAD#0 %THEN ER=GET NEXT VARIABLE;! TO ENABLE CLOSURE OF IMP DO LISTS %IF VLISTHEAD#0 %OR VCOUNT#0 %THEN FAULT(287);! not enough consts %FINISH UNWIND: %WHILE VLISTHEAD#0 %CYCLE FREE LIST CELL(VLISTHEAD,5) %REPEAT -> EXIT1 !* PI(39): !*********************************************************************** !* AFTER IMPLICIT LIST * !* MODIFY FUNCTION AND PARAM TYPES IF NECESSARY * !*********************************************************************** CURSTATCLASS=1 %IF STATORDERMODE>1 %THENSTART %IF STATORDERMODE=2 %THEN ER=238 %ELSE ER=236 LFAULT(ER) %FINISH -> EXIT1 %UNLESS 1 < SUBPROGTYPE < 4; ! NECESSARY FOR FUNCTIONS AND SUBROUTINES ONLY PTR = SUBPROGPTR PP == RECORD(ADICT+PTR) %IF PP_X0&8 = 0 %THENSTART; ! NOT EXPLICITLY TYPED !{2900C} I = BYTEINTEGER(ANAMES+PP_IDEN+1);! first char {PERQC} I=HALFINTEGER(ANAMES+PP_IDEN)>>8 I = IMPTYPE(I) %IF I&X'F'=5 %THENSTART;! CHAR PP_LEN=I>>8 I=5 %FINISH PP_TYPE=I %FINISH PTR = PP_LINK2; ! LINK TO PARAMETER CHAIN %WHILE PTR # 0 %CYCLE; ! THROUGH ALL PARAMETERS SS == RECORD(ADICT+PTR) PTR = SS_INF0 PP == RECORD(ADICT+PTR) %IF PP_X0&8 = 0 %THENSTART !{2900C} I = BYTEINTEGER(ANAMES+PP_IDEN+1);! first char {PERQC} I=HALFINTEGER(ANAMES+PP_IDEN)>>8 I = IMPTYPE(I) %IF I&X'F'=5 %THENSTART;! CHAR PP_LEN=I>>8 I=5 %FINISH PP_TYPE=I %FINISH PTR = SS_LINK1 %REPEAT -> EXIT1 !* PI(40): !*********************************************************************** !* AFTER %PRINTD , DUMP CONTENTS OF DICTIONARY * !*********************************************************************** !{2900C} ALLDICT -> EXIT1 !* PI(41): !*********************************************************************** !* Process DATA-implied-do * !*********************************************************************** I=DATA IMPLIED DO %IF I=0 %THEN ->EXIT1 %IF I=1 %THEN ->EXIT4P %IF I=2 %THEN ->EXIT4 ->PI34ERR !* PI(42): !*********************************************************************** !* AFTER FIRST OR ONLY LETTER IN IMPLICIT LIST ITEM * !*********************************************************************** CRM4 = NEXTCH !* PI(43): !*********************************************************************** !* AFTER SECOND LETTER IN IMPLICIT LIST ITEM * !*********************************************************************** %IF TYPE(INP) = 1 %THENSTART CRM5 = NEXTCH %IF CRM4 <= CRM5 %THENSTART K=CRM8 %IF K=5 %THEN K=CHARLEN<<8!5;! CARRY CHARLEN %CYCLE I = CRM4,1,CRM5 J=1<<(I-'A') %IF CHARMASK&J#0 %THENSTART %UNLESS P=43 %AND I=CRM4 %THENSTART !! L=X'0100'!I;! for string of length 1 !! IDENTIFIER=STRING(ADDR(L)+2) IDENTIFIER=TOSTRING(I) FAULT(274);! already specified %FINISH %FINISH CHARMASK=CHARMASK!J IMPTYPE(I) = K %REPEAT %FINISHELSE LFAULT(273);! invalid alphabetic sequence %FINISHELSE LFAULT(106);! invalid char INP = INP+1 NEXTCH = INPUT(INP) -> EXIT1 !* PI(44): !*********************************************************************** !* FOLLOWING CLOSING ) OF AN EQUIVALENCE LIST * !* VLISTHEAD IS THE HEAD OF THE LIST OF ITEMS CREATED BY PI(31),PI(34) * !* VLISTTAIL POINTS TO THE LAST ENTRY ON THE LIST * !*********************************************************************** %IF STATORDERMODE>2 %THEN ER=236 %AND ->EXIT4 STATORDERMODE=2 I=EQUIVALENCE %IF I#0 %THEN ->UNWIND %ELSE ->EXIT1 !* PI(45): !*********************************************************************** !* FOLLOWING LABEL IN DO * !* RES = NESTLEVEL<<24!@ OF LABEL RECORD IN DICT * !*********************************************************************** %IF DOPTR = 0 %THEN I = 1 %ELSESTART DOREC==RECORD(ADICT+DOPTR) I = DOREC_LABEL>>24+1 %FINISH ER = 110;! INVALID STATEMENT NO. -> EXIT4 %UNLESS 0 < PI21INT <= 99999 J=SETLAB(PI21INT,PTR) LABREC==RECORD(ADICT+PTR) %IF LABREC_X0&3#0 %THENSTART IFAULT(227,LABREC_LAB);! label already set at line # %FINISHELSESTART %IF LABREC_X0&8#0 %THEN IFAULT(228,LABREC_LINK5);! already ref. as FORMAT label %FINISH RES_H0 = I<<8; RES_H1=PTR>>DSCALE GSTATE=9 -> EXIT1 !* PI(46): !*********************************************************************** !* FOLLOWING COMPUTED GOTO INDEX,ASSIGNED IDEN, * !* DO CONTROLLED VARIABLE * !* IDENTIFIERS MUST BE SIMPLE VARIABLES * !*********************************************************************** ER=125;! INVALID CONST %IF CTYP>0 %THENSTART;! NOT AN IDENTIFIER ->EXIT4P %UNLESS CTYP&7=1;! MUST BE A SIMPLE INTEGER %IF 0EXIT1 %FINISH PTR=SETCONREC(RES) P3=CNSTID;! CONST RECORD %FINISHELSESTART;! AN IDENTIFIER !****** ENTRY FROM PI(55) TO PROCESS IDEN IN ASSIGNED GOTO L460: %IF PP_CLASS=12 %THEN CBNAME %IF P1=0 %THEN ER=126 %ELSE ER=293 %IF PP_CLASS&X'1C'#0 %THEN ->EXIT4P J=PP_TYPE&7 %IF (P1=0 %AND J#1) %OR (P1=1 %AND J>2) %THEN ->EXIT4P %IF PP_TYPE=X'41' %THEN ER=190 %AND ->EXIT4P ALLOC(PTR) J=PP_CLASS %IF J=0 %THENSTART;! LOCAL !{2900} P3=LSCALID;! SCALAR IN GLA {PERQ} P3=OSCALID %FINISHELSESTART %IF J=1 %THENSTART;! PARAM P3=PSCALID;! DICT RECORD FOR SCALAR PARAM %FINISHELSESTART;! COMMON P3=CSCALID;! DICT RECORD FOR COMMON SCALAR %FINISH %FINISH %FINISH RES_H0=PTR>>DSCALE; RES_H1=P3<<8!SETMODE(PP_TYPE&X'3F');! R.D. TO LOCATION ->EXIT1 !* PI(47): !*********************************************************************** !* SET RES TO DESC TO SMALL INT VALUE P1 * !* USED TO SET DEFAULT DATA SET NUMS,DO INCREMENTS AND POSITION PARS * !*********************************************************************** RES_H0=P1; RES_H1=(LIT<<8)!INT4 -> EXIT1 !* PI(48): !*********************************************************************** !* PAUSE OR PAUSE ' ' * !* STOP OR STOP '' * !*********************************************************************** %UNLESS CTYP&7=1 %OR CTYP=5 %THEN ->SYNERR -> EXIT1 !* PI(49): !*********************************************************************** !* FOLLOWING * I.E. LABEL PARAMETER TO SUBROUTINE * !* LABEL IN COMPUTED GOTO * !*********************************************************************** ER = 110;! STATEMENT NO. INVALID -> EXIT4 %UNLESS 0 < PI21INT <= 99999 I=SETLAB(PI21INT,PTR) LABREC==RECORD(ADICT+PTR) RES=0 %IF LABREC_X0&8#0 %THEN IFAULT(228,LABREC_LINK5) I = PTR PTR=FREESP(3);! 3 words required for later use in forward ref. list SS==RECORD(ADICT+PTR) SS_INF0=I %IF CGOLAB = 0 %THEN HGOLAB = PTR %ELSESTART LABREC==RECORD(ADICT+CGOLAB) LABREC_LINK1=PTR %FINISH CGOLAB = PTR -> EXIT1 !* PI(50): !*********************************************************************** !* FOLLOWING PARAMLIST TO CALL (TO PROCESS ANY LABEL PARAMS) * !* LABEL LIST TO COMPUTED GOTO * !*********************************************************************** RES_W = HGOLAB -> EXIT1 !* PI(51): !*********************************************************************** !* FOLLOWING CLOSING ) TO ARRAY ELEMENT SUBSCRIPT LIST IN EXP. * !*********************************************************************** CRM1 = 1; ! CRM1=0 IF ARRAY ELEMENT ON LHS OF ASSIGNMENT - SET BY PI(78) L511: SS==RECORD(ADICT+FNLST) FREE LIST CELL(FNLST,5) I = SS_INF0 NOTFLAG = I>>8 GSTATE = I&X'FF' I = SS_INF3 P1 = (I>>8)&X'FF'; ! NO. OF SUBSCRIPT EXPRESSIONS ER = 264; ! WRONG NO. OF SUBSCRIPTS %UNLESS P1 = PCT %THENSTART IDENTIFIER=STRING(ANAMES+SS_INF4) ->EXIT4 %FINISH PCT = I&X'FF' CTYP = I>>16 -> L582 !* PI(54): !*********************************************************************** !* REFERENCE TO SCALAR VARIABLE ON LHS OF ASSIGNMENT * !*********************************************************************** PI54: CRM1 = 0 -> L533 !* PI(126): ! in param list PI(53): !*********************************************************************** !* REFERENCE TO SCALAR IN EXPRESSION * !*********************************************************************** PI53: CRM1 = 1 %IF CTYP > 0 %THENSTART; ! SCALAR IS A CONSTANT PI53A: P2 = 0 %IF CTYP&7=1 %OR CTYP&7=4 %THENSTART;! INTEGER OR LOGICAL %IF 0<=PI21INT<=X'7FFF' %THENSTART RES_H0=PI21INT; RES_H1=(LIT<<8)!SETMODE(CTYP&X'3F') ->L536 %FINISH %FINISH PTR=SETCONREC(RES) RES_H0=PTR>>DSCALE; RES_H1=(CNSTID<<8)!SETMODE(CTYP&X'3F') -> L536 %FINISH L533: %IF PP_CLASS = 12 %THEN CBNAME P2 = PP_CLASS&X'1F' %IF P2=16 %THENSTART;! constant name %IF CRM1=0 %THEN ER=180 %AND ->EXIT4P RES_W=PP_LINK3 CTYP=PP_TYPE PI21INT=RES_H0;! for compatability %IF RES_H1=X'101' %THEN %C PI21INT=INTEGER(ADICT+PI21INT<PI53A %FINISH ER = 127; ! ILLEGAL USE OF SUBPROGRAM OR ARRAY NAME RES_H0=PTR>>DSCALE %IF P2 = 11 %THENSTART; !'CURRENT' SUBPROGRAM -> EXIT4 %UNLESS SUBPROGTYPE = 2; ! CAN ONLY BE VALID IF A FUNCTION RES_H1=PROCID<<8 CTYP = PP_TYPE %IF PP_X1&1 = 0 %THENSTART; ! NOT YET USED PP_X1 = PP_X1!1 %IF FUNRESDISP=0 %THENSTART !{2900} FUNRESDISP=STACKCA-STACKBASE I=16 %IF CTYP&15=3 %THEN I=I<<1 %IF CTYP=5 %THENSTART;! CHAR FN !{2900} PP_ADDR4=ALLOC CHAR(PP_LEN,0,J) {PERQ} PP_ADDR4=ALLOC CHAR(PP_LEN,0,H,J) ->L532 %FINISH !{2900} PUTBYTES(7,I,UNASSPATTERN) %FINISH PP_ADDR4 = FUNRESDISP %FINISH -> L532 %FINISH -> EXIT4 %IF P2 > 10; ! COMMON BLOCK OR STATEMENT FUNCTION %IF P2 = 8 %THENSTART; ! EXTERNAL SUBPROGRAM %IF P=126 %THENSTART;! in param list %IF PP_X0&6=4 %THENSTART ER=199;! this intrinsic fn cannot be a param ->EXIT4 %FINISH %FINISHELSESTART -> EXIT4 %UNLESS PP_X0&7 = 0 %FINISH !{2900} SETFUN(PTR) %FINISHELSE ALLOC(PTR) P2 = PP_CLASS&15 %IF P2 > 2 %THENSTART; ! EXTERNAL FUNCTION OR NAMELIST NAME -> EXIT4 %UNLESS GSTATE = 1 %AND CRM1 = 1 %IF P2=4 %OR P2=6 %THENSTART;! array name RES_H1= ARRID<<8 %FINISHELSE RES_H1=(PROCID<<8)!P2 GSTATE = 15 -> EXIT1 %FINISH %IF CTYP = 5 %THENSTART; ! CHARACTER CONST RES_H1=(CNSTID<<8)!CHARMODE -> L536 %FINISH CTYP = PP_TYPE %IF P2 = 2 %THENSTART; ! COMMON SCALAR RES_H1=CSCALID<<8 -> L532 %FINISH %IF P2 = 1 %THEN RES_H1=PSCALID<<8 %ELSESTART !{2900} RES_H1=LSCALID<<8 {PERQ} %IF PP_X0&X'10'#0 %THENSTART;! scalar in array area {PERQ} RES_H1=ASCALID<<8 {PERQ} %FINISHELSE RES_H1=OSCALID<<8 %FINISH %IF CRM1=0 %OR P=126 %THEN PP_X0=PP_X0!2;! MARK AS ASSIGNED TO !* L532: RES_H1 = RES_H1!SETMODE(CTYP&X'3F') L536: I=RES_H1&15 L536A: %IF MODETOST(I)&15 = LOGTYPE %THENSTART; ! LOGICAL P1 = 1 NOTFLAG = 2 %FINISHELSE P1 = 0 ER = 130; ! INVALID EXPRESSION IN ARITHMETIC STATEMENT -> P53(GSTATE) P53(1): P53(7): %IF CRM1 = 0 %THENSTART %IF P1 = 0 %THEN GSTATE = 9 %ELSE GSTATE = 1 -> EXIT1 %FINISH GSTATE = STATE(P1) -> EXIT1 P53(2): -> EXIT4P %UNLESS P1 = 0 GSTATE = 3 -> EXIT1 P53(3): P53(6): P53(8): P53(14): -> EXIT4P P53(4): P53(5): %IF P1#0 %THEN ->EXIT4P GSTATE = 6 -> EXIT1 P53(9): P53(10): %IF P1#0 %THEN ->EXIT4P GSTATE = 11 -> EXIT1 P53(12): P53(13): ER = 131 -> EXIT4P %UNLESS CTYP&15 <= 1 GSTATE = 14 -> EXIT1 !* PI(55): !*********************************************************************** !* FOLLOWING GOTO * !* GOTO (ASSIGNED GOTO) * !* ASSIGN ... (P1=1) * !* ERR= * !* END= * !* LABEL IN ARITHMETIC IF * !*********************************************************************** %IF CTYP<1 %THENSTART;! ONLY POSS IN ASSIGNED GOTO %WHILE TYPE(INP)#12 %CYCLE INP=INP+1;! SKIP ASSIGNED LABEL LIST %REPEAT NEXTCH=INPUT(INP) ->L460;! TO SET APPROPRIATE R.D. %FINISHELSESTART;! INTEGER LABEL %UNLESS 0 < PI21INT <= 99999 %THENSTART FAULT(110);! INVALID STATEMENT NO. PI21INT=0 %FINISH I=SETLAB(PI21INT,PTR) LABREC==RECORD(ADICT+PTR) CRM1=PI21INT;! SAVE LABEL NO. FOR ARITH IF CHECK ER=228;! LABEL ALREADY USED AS A FORMAT LABEL PI21INT=LABREC_LINE;! DECLARED LINE NO. (FOR ERROR MESSAGES) %IF P1#1 %THENSTART;! except ASSIGN ->EXIT4 %IF LABREC_X0&8#0 %FINISHELSESTART %IF LABREC_X0&10=0 %THEN LABREC_X0=16;! may be exec or format %FINISH RES_H0=PTR>>DSCALE; RES_H1=(LABID<<8)!INT4;! DICT RECORD FOR LABEL ->EXIT1 %FINISH !* PI(56): !*********************************************************************** !* AFTER ( IN EXPRESSION * !* ALLOCATE EXTERNAL REFERENCE AND SET FN TYPE IF IMPLICITLY RECOGNISED* !* SET FNMK * !* RES= POINTER TO FN ENTRY IN DICT * !* PUSHDOWN ENTRY IN FNLST * !* RESET GSTATE * !*********************************************************************** %IF PP_CLASS = 12 %THEN CBNAME %IF CTYP>0 %THEN ER=130 %AND ->EXIT4P I = PP_CLASS&X'1F';! to remove param array markers -> L561 %IF 3 < I < 7; ! ARRAY -> L562 %IF I = 13; ! STATEMENT FN. %IF I = 8 %THENSTART; ! EXTERNAL FUNCTION %IF PP_X0&X'4'#0 %THEN ->L56B;! actually an intrinsic function ->L567 %FINISH %IF I = 9 %THENSTART; ! EXTERNAL FUNCTION PARAM L569: ALLOC(PTR) PP_X0=PP_X0&X'F8';!CLEAR PARAM 'VALUE' MARKER IF SET -> L564 %FINISH %IF 0<=I<=2 %AND PP_TYPE=5 %THENSTART;! may be char substring %IF PP_X1&X'F'#0 %OR SCAN(':')#0 %THENSTART PISW=12;! for PI69 switch ->PI53 %FINISH %FINISH ER = 245; ! NOT AN ARRAY BEING SUBSCRIPTED -> EXIT4 %UNLESS 0 <= I <= 1; ! LOCAL OR PARAMETER SCALAR (DEFAULT) -> EXIT4 %UNLESS PP_X1&15 = 0; ! FAULT IF ALREADY USED AS A SCALAR PP_CLASS = I!8; ! SET FUNCTION BIT -> L569 %IF I = 1; ! TO PROCESS AS FUNCTION PARAM !****** SEARCH INTRINSIC FUNCTION LIST L56B: I=FN HASH(HASH VALUE) J=ADDR(FN NAMES(0)) L56A: K=I&X'FFFF' {PERQC} K=K>>1;! index in words %IF STRING(J+K)=IDENTIFIER %THENSTART;! INTRINSIC FN L=I>>16&X'FF' I=FN DETAILS(L) K=FNSPECIALS(L) %IF K&X'8000'#0 %THENSTART;! not there? %IF K&X'800000'=0 %THENSTART;! don't ignore the 'not there' bit LFAULT(178);! comment - not an intrinsic fn ->L567 %FINISH %FINISH %IF PP_X0&X'4'#0 %THENSTART !{2900C} MOVE(24,ADICT+PTR,ADICT+DPTR);! private copy {PERQC} COPY(24,ADICT+PTR,0,ADICT+DPTR,0) PTR=DPTR DPTR=DPTR+W6 PP==RECORD(ADICT+PTR) %FINISHELSESTART %IF DPTR=PTR+IDRECSIZE %THENSTART;! RECOVER DICT SPACE !! DPTR=PTR+W6;! KEEP MINIMAL RECORD LHEAD(HASH VALUE)=PP_LINK1;! REMOVE FROM IDEN LIST %FINISH %FINISH !{2900} J=I>>20&15;! modify parm requirements if necessary !{2900} %IF (J=1 %AND INTEGER LENGTH=8) %OR %C !{2900} (3<=J<=7 %AND REAL LENGTH=8) %THEN I=I+X'00101000' !{2900} J=I>>16&15;! modify fn result size if necessary !{2900} %IF (J=1 %AND INTEGER LENGTH=8) %OR %C !{2900} (3<=J<=7 %AND REAL LENGTH=8) %THEN I=I+X'00010000' PP_LINK2=I;! FN DETAILS FOR SUBSEQUENT CHECKING/MODIFICATION J=I>>16&X'F';! FN MODE %IF I#0 %THEN PP_TYPE=MODETOST(J);! N.B. WHAT IF ALREADY TYPED PP_X0=I>>2&3;! FN TYPE PP_X1=1 ->L564 %FINISHELSESTART %IF I>>24#0 %THENSTART I=FNHASH(I>>24) ->L56A %FINISH %FINISH !****** STANDARD FUNCTION L567: !{2900} SETFUN(PTR) L564: RES_W = PTR TTYP = PP_TYPE PTR=NEW LIST CELL(FNLST,5) SS==RECORD(ADICT+PTR) SS_INF2 = (PP_X0&7+1)<<8!TTYP; ! FNMK 1 FOR EXT FN, >1 FOR INTRINSIC AND STANDARD FNS SS_INF3 = PCT; ! SAVE INTRINSIC CODE FOR PARAMETER TYPE AND COUNT FNMK = 0 PISW = 2;! for PI69 switch I = 1 PP_X1=(PP_X1&X'CF')!X'10' -> PI56EXIT !****** ARRAY ELEMENT REFERENCE L561: ALLOC(PTR) TTYP = PP_TYPE RES_H0=PTR>>DSCALE; RES_H1=ARRID<<8!SETMODE(TTYP&X'3F'); ! DICT RECORD FOR ARRAY DVREC == RECORD(ADICT+PP_ADDR4); ! DOPE VECTOR IN DICT PTR=NEW LIST CELL(FNLST,5) SS==RECORD(ADICT+PTR) SS_INF2 = PP_ADDR4; ! DOPE VECTOR IN DICT SS_INF3 = TTYP<<16!DVREC_DIMS<<8!PCT SS_INF4 = PP_IDEN;! FOR ERROR MESSAGES PISW = 6;! for PI69 switch I = 12;! RESTRICT TO INTEGER SUBSCRIPTS -> PI56EXIT !****** STATEMENT FN REFERENCE L562: ER = 135; ! NESTED STATEMENT FUNCTION REFERENCE -> EXIT4P %IF PP_X1&1 # 0 ER = 136; ! INVALID ARRAY SUBSCRIPT IN IMPLIED DO -> EXIT4P %IF DOIOP > 0 PP_X1 = PP_X1!1; ! WILL FAULT ANY STATEMENT FN REFERENCE IN PARAMS RES_W = PTR PTR=NEW LIST CELL(FNLST,5) SS==RECORD(ADICT+PTR) SS_INF2 = RES_W SS_INF3 = PCT I = 1 PISW=10;! for PI69 switch PI56EXIT:SS_INF0=NOTFLAG<<8!GSTATE NOTFLAG = 0 GSTATE = I PCT = 0 -> EXIT1 !* PI(57): !*********************************************************************** !* AFTER PARAMETER IN EXTERNAL FN/ROUTINE CALL * !*********************************************************************** SS == RECORD(ADICT+FNLST) RES_H0=FNMK; RES_H1=SS_INF3&X'FF00'!PCT;! FNMK,PARAM TYPE,PCT PCT = PCT+1 %IF NEXTCH = ',' %THEN FNMK = 0;! NOT LAST PARAM GSTATE = 1 NOTFLAG = 0 -> EXIT1 !* PI(58): !*********************************************************************** !* FOLLOWING CLOSING ) OF PARAMETER LIST TO SUBPROGRAM CALL * !*********************************************************************** CRM1 = 1 SS==RECORD(ADICT+FNLST) FREE LIST CELL(FNLST,5) I = SS_INF0 NOTFLAG = I>>8 GSTATE = I&X'FF' I = SS_INF2 %IF FNMK = 0 %OR FNMK = 4 %THEN FNMK = I>>8 CTYP = I&X'FF' PCT = SS_INF3&X'FF' RES_W=PCT !***** merge with PI(51) - following array element reference L582: %IF CTYP&7 = 4 %THENSTART; ! LOGICAL P1 = 1 NOTFLAG = 2 %FINISHELSESTART P1 = 0 %FINISH ER = 130;! INVALID EXPRESSION -> P53(GSTATE) !* PI(59): !*********************************************************************** !* STATE TRANSITION TO CHECK VALIDITY OF SEQUENCE OF LOGICAL AND * !* ARITHMETIC OPERANDS AND OPERATORS * !*********************************************************************** ER = 132 -> P59(GSTATE) P59(1): GSTATE = STATE(P1) -> EXIT4P %IF GSTATE = 0 %IF P1 = 5 %THEN NOTFLAG = 1 -> L591 P59(2): P59(5): P59(10): P59(13): -> EXIT4P P59(3): -> EXIT4P %IF 7 > P1 > 3 %IF P1 = 7 %THENSTART %IF NOTFLAG#0 %THEN ->EXIT4P -> L591 %FINISH GSTATE = STATE(P1+5) %IF P1 = 3 %THEN NOTFLAG = 2 -> EXIT1 P59(4): -> EXIT4P %UNLESS P1 = 6 GSTATE = 5 -> EXIT1 P59(6): GSTATE = STATE(P1+7) -> EXIT4P %IF GSTATE = 0 -> L591 P59(7): -> EXIT4P %UNLESS P1 = 6 GSTATE = 2 -> EXIT1 P59(8): %UNLESS P1 = 4 %OR P1 = 7 %THENSTART %UNLESS P1=3 %AND (RES_W=8 %OR RES_W=6) %THEN ->EXIT4P %FINISH GSTATE = 1 -> L591 P59(9): P59(12): -> EXIT4P %UNLESS P1 = 6 GSTATE = GSTATE+1 -> EXIT1 P59(11): P59(14): -> EXIT4P %IF 2 < P1 < 7 GSTATE = GSTATE-1 %UNLESS P1=7 -> L591 P59(15): -> EXIT4P %UNLESS P1 = 7 L591: -> EXIT1 %UNLESS P1 = 7 RES_W = NOTFLAG NOTFLAG = 0 -> EXIT1 !* PI(60): !*********************************************************************** !* RES = COMPARATOR CODE FOLLOWING > SET BY READLINE * !* 1 .LT. 4 .GT. * !* 2 .LE. 5 .GT. * !* 3 .EQ. 6 .NE. * !*********************************************************************** RES_W = INPUT(INP)&15 ER = 106;! INVALID CHAR -> EXIT4P %UNLESS TYPE(INP) = 6;! CONFIRMS THAT ENTRY IS COMPARATOR CODE L601: INP = INP+1 L602: NEXTCH = INPUT(INP) -> EXIT1 !* PI(61): !*********************************************************************** !* FOLLOWING ( INTRODUCING A BRACKETED EXPRESSION * !*********************************************************************** PTR=NEW LIST CELL(L1,2) SS==RECORD(ADICT+PTR) SS_INF0 = NOTFLAG<<8!GSTATE %IF GSTATE = 1 %OR GSTATE = 7 %THEN GSTATE = 1 %ELSESTART %IF GSTATE > 10 %THEN GSTATE = 12 %ELSE GSTATE = 9 %FINISH -> EXIT1 !* PI(62): !*********************************************************************** !* FOLLOWING ) TERMINATING A BRACKETED EXPRESSION * !*********************************************************************** SS==RECORD(ADICT+L1) FREE LIST CELL(L1,2) NOTFLAG = SS_INF0>>8 I = SS_INF0&X'FF' %IF I>8 %THENSTART %IF I=11 %THEN GSTATE=11 ->EXIT1 %FINISH %IF 5 < GSTATE < 11 %THEN NOTFLAG = 2 -> EXIT1 %IF GSTATE < 11 %IF I=2 %OR I=3 %OR NOTFLAG=0 %THEN GSTATE=3 %ELSE GSTATE=6 -> EXIT1 !* PI(63): !*********************************************************************** !* FOLLOWING IF ( ) TO DETERMINE WHETHER ARITH OR LOG. * !*********************************************************************** ICOMP = ICOMP+2 %IF RES_W # 0 %THENSTART STATEMENT=3;! logical IF (required by EMAS ITS) -> EXIT2 %FINISH ! TEST COMPLEX ICOMP = ICOMP+2 -> EXIT1 !* PI(64): !*********************************************************************** !* FOLLOWING RECOGNITION OF SUBSCRIPT TO ARRAY ELEMENT * !*********************************************************************** PCT = PCT+1 RES_W=PCT GSTATE = 12;! RESTRICT TO INTEGER SUBSCRIPTS -> EXIT1 !* PI(65): !*********************************************************************** !* FOLLOWING ( ON LHS OF ASSIGNMENT * !* DETERMINE WHETHER ARRAY ELEMENT OR STATEMENT FN DEFINITION * !*********************************************************************** %IF PP_CLASS = 12 %THEN CBNAME I = PP_CLASS&X'1F';! to remove param array markers ER = 245;! IDEN IS NOT AN ARRAY NAME %IF (0<=I<=2 %OR I=11) %AND PP_TYPE=5 %THENSTART;! may be char substring PISW=8 %IF SCAN(':')#0 %THEN ->PI54 %FINISH %IF I # 0 %THENSTART -> EXIT4 %UNLESS 4 <= I <= 6; ! I.E. ONLY LOCAL PARAMETER OR COMMON ARRAY ALLOWED HERE -> L561; ! TO PROCESS IT %FINISHELSESTART; ! CAN ONLY BE A STATEMENT FN DEFINITION -> EXIT4 %UNLESS PP_X1 = 0 STATFN==RECORD(ADICT+PTR) STATFNREC=PTR STATFN_CLASS = 13 J=NUMBYTES(STATFN_TYPE>>4) %IF STATFN_TYPE&15=3 %THEN J=J+J I = (J+3)&X'FFFFFC';! SPACE FOR RESULT %IF STATFN_TYPE=5 %THEN I=8;! for descriptor GENERATE(TRIADS,NEXTTRIAD,0,-3,0,COMAD);! to register start of sf !{2900} STATFN_LINK2=STACKCA-STACKBASE !{2900} PUTBYTES(7,I,0) {PERQ} STATFN_LINK2=GLA SPACE(I) {PERQ} RES_H0=STATFN_LINK2 {PERQ} RES_FORM=GLALIT {PERQ} RES_MODE=SETMODE(STATFN_TYPE&X'3F') {PERQ} STATFN_LINK2=RES_W RES_W = PTR QQ == RECORD(ADICT+SUBPROGPTR) PCT = 0 GSTATE = 1 PISW=2;! for PI84 switch -> EXIT1 %FINISH !* PI(66): !*********************************************************************** !* FOLLOWING CALL * !*********************************************************************** I = PP_CLASS RES_W = PTR -> L661 %IF I = 8 %OR I = 9; ! SUBPROGRAM(MAY BE AS PARAMETER) %IF I=11 %THEN ER=244 %AND ->EXIT4 ER = 128; ! INVALID SUBPROGRAM NAME -> EXIT4 %UNLESS 0 <= I <= 1; ! ONLY SETTING PERMITTED IS SCALAR PARAMETER -> EXIT4 %UNLESS PP_X1 = 0; ! ALREADY USED AS SCALAR I = I!8; ! SET 'SUBPROGRAM' MARKER PP_CLASS = I L661: !{2900} %IF I # 8 %THEN ALLOC(PTR) %ELSE SETFUN(PTR); ! SET REFERENCE OR ALLOCATE PARAMETER SPACE PP==RECORD(ADICT+PTR) PP_X1=(PP_X1&X'CF')!X'20' PP_X0=PP_X0&X'F8';! CLEAR PARAM 'VALUE' MARKER IF SET -> EXIT1 !* PI(67): !*********************************************************************** !* FOLLOWING IN EXTERNAL LIST * !*********************************************************************** I=EXTERNALS %WHILE I#0 %CYCLE SS==RECORD(ADICT+I) %IF PTR=SS_INF0 %THEN FAULT(181) I=SS_LINK1 %REPEAT %IF PP_X0&X'40'#0 %THEN FAULT(179) %AND ->EXIT1;! already in an INTRINSIC statement %IF CRM8=1 %THEN PP_X0=PP_X0!X'80' !{2900} %IF OPTIONS1&1#0 %THENSTART;! CE only !{2900} J=COMREG(57) !{2900} %IF J#0 %THENSTART !{2900} EXTNAMES==ARRAY(J,EXTFMT) !{2900} J=0 !{2900} %WHILE EXTNAMES(J)#"" %CYCLE !{2900} %IF IDENTIFIER=EXTNAMES(J) %THENSTART !{2900} PP_X0=PP_X0!X'80' !{2900} %EXIT !{2900} %FINISH !{2900} J=J+1 !{2900} %REPEAT !{2900} %FINISH !{2900} %FINISH I=PP_CLASS -> EXIT1 %IF 8 <= I <= 9; ! ALREADY MARKED AS A SUBPROGRAM ER = 128; ! ILLEGAL IDENTIFIER IN AN EXTERNAL LIST -> EXIT4 %UNLESS I&14 = 0; ! ONLY VALID SETTING IS 'PARAM' -> EXIT4 %IF PP_X1 # 0 PP_CLASS=PP_CLASS!8 %IF CRM8=3 %THENSTART;! INTRINSIC I=FNHASH(HASH VALUE) J=ADDR(FN NAMES(0)) L67A: %IF STRING(J+I&X'FFFF')=IDENTIFIER %THENSTART K=I>>16&X'FF' L=FN SPECIALS(K) %IF L&X'80C000'=X'4000' %THENSTART;! valid in list PP_X0=PP_X0!4;! intrinsic marker FN SPECIALS(K)=L!X'400000' %IF L&X'2000'#0 %THEN PP_X0=PP_X0!2 PP_LINK2=FN DETAILS(K) PP_LINK3=FN SPECIALS(K) ->EXIT1 %FINISH %FINISHELSESTART %IF I>>24#0 %THENSTART I=FNHASH(I>>24) ->L67A %FINISH %FINISH LFAULT(279);! not a valid intrinsic name ->EXIT1 %FINISH I=PTR PTR=NEW LIST CELL(EXTERNALS,2) SS==RECORD(ADICT+PTR) SS_INF0=I -> EXIT1 !* PI(68): !*********************************************************************** !* SYNTAX CHECK AFTER , IN DEFN OF (PART OF DEFN) * !*********************************************************************** ER = 100;! SYNTAX %IF NEXTCH = NL %THEN -> EXIT4 %ELSE -> EXIT1 !* PI(69): !*********************************************************************** !* following ( switches to appropriate syntax * !* PISW has been set by PI(56) * !* 2 external function * !* 6 array element * !* 10 statement function * !* 12 possible character scalar substring * !*********************************************************************** ICOMP = ICOMP+PISW ->EXIT2 %UNLESS PISW=12 -> EXIT1; ! character scalar substring !* PI(70): !*********************************************************************** !* FOLLOWING SUBPROGRAM STATEMENT * !* P1 = 1 PROGRAM * !* 2 FUNCTION * !* 3 SUBROUTINE * !* 4 ENTRY * !* 5 BLOCKDATA * !*********************************************************************** PI70: CURSTATCLASS=1 %UNLESS P1=4 %THEN STATORDERMODE=1 I=NEW SUBPROGRAM(PTR,P1,ER) %IF SUBPROGTYPE#5 %THENSTART GENERATE(TRIADS,NEXTTRIAD,0,-2,RESCOM1,COMAD);! register private label %FINISH -> PIEXIT(I) !* PI(72): !*********************************************************************** !* FOLLOWING ( OR (IN ) * !* ALSO AFTER IN IMPLIED DO SUBSCRIPT LIST * !*********************************************************************** %IF NEXTCH='=' %THENSTART;! controlled variable of implied-DO loop %IF PP_CLASS&X'1C'#0 %OR PP_TYPE&X'F'>2 %THENSTART ER=293;! invalid iden ->EXIT4P %FINISH CRM4=RES_W RES_W=0;! will avoid attempt to process as I/O list item ->EXIT1 %FINISH PP==RECORD(ADICT+RES_H0<= ARRID<<8 %THEN ->EXIT1;! UNLESS SPECIAL IDEN -> EXIT4 %UNLESS PP_CLASS&12 = 4;! MUST BE AN ARRAY NAME RES_MODE = SETMODE(PP_TYPE&X'3F') -> EXIT1 !* PI(73): !*********************************************************************** !* FOLLOWING ( IN IOLIST, I.E. START OF IMPLIED DO * !*********************************************************************** DOIOP = DOIOP+1 -> EXIT1 !* PI(74): !*********************************************************************** !* FOLLOWING * IN FORMAL PARAMETER LIST * !*********************************************************************** %IF CUR PSTACK&1#0 %THENSTART;! first label param CUR PSTACK=CUR PSTACK+1 %IF CUR PSTACK>MAX PSTACK %THEN MAX PSTACK=CUR PSTACK %FINISH ER = 243; ! LABEL PARAMETER NOT ALLOWED IN FUNCTION -> EXIT4P %IF SUBPROGTYPE = 2 -> EXIT1 !* PI(75): !*********************************************************************** !* AFTER 'VALUE' FORMAL PARAMETER NAME * !*********************************************************************** CUR PSTACK=CUR PSTACK+6;! max possible param size %IF CUR PSTACK>MAX PSTACK %THEN MAX PSTACK=CUR PSTACK ER=129 -> PIEXIT(FORMAL PARAMETER(PTR,0)) !* PI(76): !*********************************************************************** !* AFTER = IN IMPLIED DO * !*********************************************************************** DOIOP = DOIOP-1 RES_W=CRM4 CHECK DO INDEX(RES_W,DOPTR) -> EXIT1 !* PI(77): !*********************************************************************** !* FOLLOWING IF ( ) WHEN FOLLOWS * !*********************************************************************** STATEMENT=3;! logical IF (required by EMAS ITS) ER = 133 -> EXIT4 %IF RES_W = 0 -> EXIT1 !* PI(78): !*********************************************************************** !* FOLLOWING CLOSING ) IN SUBSCRIPT LIST TO ARRAY ELEMENT ON * !* LHS OF ASSIGNMENT, ALSO IN I/0 LIST * !*********************************************************************** CRM1 = 0 CRM10 = 0;! WILL TRIGGER FAULT IF USED AS CONTROL VAR IN IMPLIED DO -> L511 !* PI(79): !*********************************************************************** !* CODE OR CODEX TO CONTROL LISTING OF COMPILED CODE * !* CODE0 CLEARS BUFFER THEN SETS FLAG FOR CODE LISTING * !*********************************************************************** CURSTATCLASS=1 LISTCODE=0 PTRACE=0 %IF NEXTCH = NL %THEN LISTCODE=1 %AND ->EXIT1 !!# %IF NEXTCH='0' %THEN PUSHBUFFER(1) %AND LISTCODE=1 %IF '1'<=NEXTCH<='2' %THEN PTRACE=NEXTCH&3 -> L601;! TO SKIP CHAR !* PI(80): !*********************************************************************** !* FOLLOWING CLOSING ) TO PARAMETER LIST ON LHS OF STATEMENT FN * !* DEFINITION * !*********************************************************************** CURSTATCLASS=1 %IF STATORDERMODE>3 %THEN LFAULT(236) STATORDERMODE=3 STATFN_DISP = PCT PCT = 0 SFMK = STATFNREC TTYP = STATFN_TYPE %IF TTYP&4 = 4 %THEN GSTATE = 1 %ELSE GSTATE = 9 -> EXIT1 !* PI(81): !*********************************************************************** !* AFTER STATEMENT FUNCTION FORMAL PARAM * !* CREATE NEW DICT ENTRY * !*********************************************************************** I=SFPTR PTR=NEW LIST CELL(SFPTR,8) QQ==RECORD(ADICT+PTR) ZERODICT(PTR,IDRECSIZE) QQ_LINK1=I QQ_IDEN=PP_IDEN TTYP=PP_TYPE QQ_TYPE=TTYP QQ_X1=X'21';! AREA CODE(I.E. ON STACK), ALLOCATED J=NUMBYTES(TTYP>>4) %IF TTYP&7=3 %THEN J=J<<1 I=(J+3)&X'FFFFFC' %IF TTYP=5 %THENSTART !{2900} QQ_ADDR4=ALLOC CHAR(PP_LEN,0,J) {PERQ} QQ_ADDR4=ALLOC CHAR(PP_LEN,0,H,J) QQ_LEN=PP_LEN QQ_DISP=0 %FINISHELSESTART !{2900} QQ_ADDR4=STACKCA-STACKBASE !{2900} PUTBYTES(7,I,0) {PERQ} QQ_ADDR4=GLA SPACE(I) %FINISH QQ_LINK3=STATFNREC PCT = PCT+1 -> EXIT1 !* PI(82): !*********************************************************************** !* FOLLOWING CLOSING ) IN PARAMETER LIST TO STATEMENT FN REFERENCE * !*********************************************************************** SS==RECORD(ADICT+FNLST) FREE LIST CELL(FNLST,5) QQ == RECORD(SS_INF2+ADICT) QQ_X1 = QQ_X1&X'FE'; ! CLEAR MARKER WHICH INHIBITED NESTED STAT FN CALLS ER = 139; ! WRONG NO OF PARAMETERS IN STAT FN REFERENCE -> EXIT4 %UNLESS QQ_DISP = PCT CTYP = QQ_TYPE CRM1 = 1 NOTFLAG = SS_INF0>>8 GSTATE = SS_INF0&X'FF' FNMK = 1 PCT = SS_INF3&X'FF' -> L582 !* PI(83): !*********************************************************************** !* FOLLOWING RECOGNITION OF A PARAMETER IN A STATEMENT FN. REFERENCE * !*********************************************************************** ER = 139; !WRONG NO. OF PARAMETERS -> EXIT4 %IF GSTATE = 15 GSTATE = 1 SS == RECORD(ADICT+FNLST) QQ==RECORD(ADICT+SS_INF2);! STATEMENT FN RECORD SS == RECORD(ADICT+QQ_LINK3) %IF PCT # 0 %THENSTART %CYCLE I = 1,1,PCT %IF SS_LINK1=0 %THENSTART QQ_X1=QQ_X1&X'FE';! PREVENT SPURIOUS 'NESTED STAT FN CALL' %IF I=1 %THENSTART %IF SFMK=0 %THEN %EXIT ER=140;! RECURSIVE STAT. FN DEFN. %FINISH ->EXIT4 %FINISH SS == RECORD(ADICT+SS_LINK1) %REPEAT %FINISH PCT = PCT+1 RES_W = SS_INF0 -> EXIT1 !* PI(84): !*********************************************************************** !* SWITCH FOLLOWING ( ON LHS OF ASSIGNMENT TO PROCESS A * !* STATEMENT FN DEFINITION OR ARRAY ELEMENT REFERENCE * !*********************************************************************** ICOMP = ICOMP+PISW -> EXIT2 %UNLESS PISW=8;! unless character substring -> EXIT1 !* !* PI(87): !*********************************************************************** !* RESET GSTATE AFTER SCALAR OR ARRAY ELEMENT ITEM IN * !*********************************************************************** GSTATE=1 ->EXIT1 !* PI(88): !*********************************************************************** !* FORMAT * !* PROCESS TEXT AND STORE IN GLA * !*********************************************************************** CURSTATCLASS=1 %IF LAB = 0 %THENSTART ER = 149;! NO LABEL ON FORMAT STATEMENT L879: LFAULT(ER) -> UP(3) %FINISH I=SETLAB(LAB,PTR);! 1 NEW 0 ALREADY EXISTS LABREC==RECORD(ADICT+PTR) PI21INT=LAB;! IN CASE OF FAULT 77 LAB = 0 ER = 227;! LABEL SET TWICE %UNLESS LABREC_ADDR4 = 0 %THENSTART PI21INT=LABREC_LINE -> L879 %FINISH LABWARN = 0 !{2900} PUTWORD(2,M'FMT ') !{2900} LABREC_ADDR4=GLACA+8;! to allow for the self-relative descriptor {PERQ} LABREC_ADDR4=CNSTCA LABREC_LINE=LINEST %IF I = 0 %THENSTART;! ALREADY REFERENCED ER = 302;! AS A STATEMENT LABEL %IF LABREC_X0=16 %THENSTART;! ASSIGNed LABREC_X0=8;! mark as definitely format I=LABREC_LINK3 !{2900} %WHILE I#0 %CYCLE;! fill in refs to fmt !{2900} SS==RECORD(ADICT+I) !{2900} PLUGWORD(2,SS_INF0,GLACA-4);! point at 'FMT' !{2900} LPUT(19,2,SS_INF0,2) !{2900} I=SS_LINK1 !{2900} %REPEAT %FINISHELSESTART -> L879 %IF LABREC_X0#8 %FINISH %FINISHELSESTART LABREC_X0=8 LABREC_CLASS=2 %FINISH I = INP L870: %UNLESS TYPE(I)=12 %AND INPUT(I)=10 %THEN I=I+1 %AND ->L870 %UNLESS TYPE(I)=12 %THEN I=I+1 %AND ->L870 J=I-INP LABREC_LINK3=J !{2900} J=J<<2 !{2900} %BEGIN !{2900} %BYTEINTEGERARRAY FMT(0:J) !{2900} %INTEGER K,FL,HL !{2900} %IF TESTVERSION=YES %THEN K=1 %ELSE K=0;! ALLOW Z FORMAT !{2900} ER=CFORMATCD(ADDR(INPUT(INP)),ADDR(FMT(0)), %C !{2900} I-INP,J,1,0,K,FL,HL) !{2900} %IF ER=0 %THENSTART !{2900} PUTDESC(2,X'18000000'!FL,8);! self-relative descriptor for ASSIGNed formats !{2900} PUTBYTES(2,FL,ADDR(FMT(0))) !{2900} %FINISHELSESTART;! report error !{2900} INP=INP+FL !{2900} %IF HL>32 %THEN HL=32 !{2900} INPUT(INP-1)=HL !{2900} IDENTIFIER=STRING(ADDR(INPUT(INP-1))) !{2900} %FINISH !{2900} %END {PERQ} ER=PFORMAT(ADDR(INPUT(0)),INP,J,IDENTIFIER) %IF ER#0 %THEN ->EXIT4;! to report error !{2900} SPTR=LABREC_LINK2 !{2900} %WHILE SPTR#0 %CYCLE;! THROUGH REFERENCES IN PREVIOUS I/O TABLES !{2900} SS==RECORD(ADICT+SPTR) !{2900} J=SS_INF0 !{2900} PLUGWORD(2,J,LABREC_LINK3);! FORMAT LENGTH !{2900} PLUGWORD(2,J+4,LABREC_ADDR4);! ADDRESS IN GLA !{2900} LPUT(19,2,J+4,2);! RELOCATE BY GLA BASE !{2900} FREE LIST CELL(SPTR,2) !{2900} %REPEAT INP = I NEXTCH = INPUT(INP) -> EXIT1 !* PI(89): !*********************************************************************** !* AVOID UNNECESSARY SEARCH IF NEXTCH IS NEWLINE * !* USED AFTER ,RETURN,PAUSE,STOP * !*********************************************************************** PI89: %IF NEXTCH = NL %THENSTART;! SKIP ALTERNATIVE SWITCH ICOMP = ICOMP+4 -> EXIT1 %FINISH ICOMP = ICOMP+2;! SWITCH TO ALTERNATIVE DEFN -> EXIT2 !* PI(90): !*********************************************************************** !* CONTROL * !*********************************************************************** CONTROL=PI21INT -> EXIT1 !* PI(92): !*********************************************************************** !* CHECK WHETHER CURRENT SUBSCRIPT IS SCALAR (DURING ) * !* RES = 1 SCALAR * !* 0 EXPRESSION (REQUIRING CO-ROUTINE IF IN IMPLIED DO OR READ * !*********************************************************************** K = INP ER = 100;! SYNTAX GSTATE = 12 %WHILE TYPE(K)<4 %CYCLE;! THROUGH ALPHANUMERICS K = K+1 %REPEAT -> EXIT4 %IF TYPE(K) = 12;! END OF STATEMENT %IF TYPE(K)=7 %THEN RES_W=1 %AND -> EXIT1;! , or ) RES_W=0;! C0-ROUTINE ALL SUBSCRIPT EXPRESSIONS -> EXIT1 !* PI(93): !*********************************************************************** !* FOLLOWING CLOSING ) IN I/0 LIST - REDUNDANT BRACKET PAIR * !*********************************************************************** DOIOP = DOIOP-1 -> EXIT1 !* PI(98): !*********************************************************************** !* %MONITOR * !*********************************************************************** %MONITOR %STOP -> EXIT1 !* PI(99): !*********************************************************************** !* FOLLOWING , * !* SET FREE FORMAT MARKER * !* BACKSPACE OVER , FOR PROCESSING * !*********************************************************************** INP = INP-1 -> L602;! RESET NEXTCH !* PI(102): !*********************************************************************** !* Following = in PARAMETER statement * !* Check that that no conflict exists * !*********************************************************************** CURSTATCLASS=1 %IF STATORDERMODE>2 %THEN LFAULT(236) GSTATE=1 I=PP_CLASS %IF I=16 %THENSTART PI102A: ER=240;! already a PARAMETER ->EXIT4P %FINISH %IF I&4#0 %THENSTART;! AN ARRAY ERRIDEN="as an array" PI102B: ER=241 ->PI102A %FINISH %IF I&1#0 %THENSTART ERRIDEN="as an argument" ->PI102B %FINISH %IF I>7 %THENSTART ERRIDEN="as an external name" ->PI102B %FINISH %IF PP_X1&X'80'#0 %THENSTART ERRIDEN="in an EQUIVALENCE statement" ->PI102B %FINISH PP_CLASS=16;! constant name PP_LINK2=SCPTR PP_LINK3=0 PP_ADDR4=0 PP_X1=1 RES_W=PTR ->EXIT1 !* PI(103): !*********************************************************************** !* Set RES for constant or 'restricted' identifier * !* Check for permitted content as determined by CEXMODE * !* CEXMODE = 0 any constant expression * !* 1 integer constant expression * !* 2 integer expression in DATA implied-D0 subscript * !* 3 integer dimension expression * !* P1 = 0 after var or non-complex const * !* 1 after complex const * !*********************************************************************** %IF CEXMODE=2 %THENSTART;! DATA implied-DO subscript %IF CTYP>0 %THENSTART;! constant %IF PI21MODE=1 %THEN ->PI103C;! integer value ER=253;! subscript must be integer ->EXIT4P PI103C: I=1;! TYPE INT PI103D: CRM1=1 ->L536A %FINISHELSESTART;! iden - note it I=IMPDOHEAD %WHILE I#0 %CYCLE IMPDOREC==RECORD(ADICT+I) %IF STRING(ANAMES+IMPDOREC_IDEN)=IDENTIFIER %THENSTART RES_H0=I; RES_H1=1;! first word of record will hold const ->PI103C %FINISH I=IMPDOREC_LINK %REPEAT IMPDOREC==RECORD(ADICT+PTR) IMPDOREC_LINK=IMPDOHEAD;! add new item to list STRING(ANAMES+NAMESFREE)=IDENTIFIER IMPDOREC_IDEN=NAMESFREE NAMESFREE=NAMESFREE+LENGTH(IDENTIFIER) IMPDOHEAD=DPTR DPTR=DPTR+IMPDORECSIZE ->PI103C %FINISH %FINISH %IF CEXMODE=3 %THENSTART;! dimension expression %IF PI21MODE>2 %THENSTART ER=249;! dimension must be integer ->EXIT4P %FINISH %IF CTYP>0 %THEN ->PI103C;! const I=PP_CLASS %IF 1<=I<=2 %THENSTART;! common or param scalar RES_H0=PTR>>DSCALE; RES_H1=(I+2)<<8!1 ->PI103C %FINISH %IF I>2 %THENSTART %IF I=16 %THENSTART PI103B: RES_W=PP_LINK3;! pick up result descriptor %IF RES_W=0 %THEN ->PI103E I=PP_TYPE&7 ->PI103C %FINISH ER=246;! name invalid in dimension expression ->EXIT4P %FINISH CTYP=0;! to avoid untoward failure in PI(53) state check RES_H0=PTR>>DSCALE; RES_H1=X'501';! name as yet unknown ->PI103C %FINISH %IF P1=1 %THEN ->EXIT1;! no further checks for complex const I=CTYP&7 %IF CTYP>0 %THEN ->PI103D;! const I=PP_TYPE&7 %IF PP_CLASS=16 %THEN ->PI103B;! const name PI103E:ER=275;! not symbolic name of a constant ->EXIT4P !* PI(104): !*********************************************************************** !* P1 = 0 EXTERNAL * !* 1 EXTERNAL /ALGOL/ * !* 2 GENERIC * !* 3 INTRINSIC * !*********************************************************************** CURSTATCLASS=1 %IF STATORDERMODE>2 %THEN ER=236 %AND ->EXIT4 STATORDERMODE=2 %IF P1=2 %THEN ->UP3;! IGNORE THIS STATEMENT (77+) %IF P1=1 %THENSTART %IF OPTIONS1&1#0 %THEN ER=100 %AND ->EXIT4P;! allow /ALGOL/ on EMAS only ALGOLREF=1 %FINISH CRM8=P1 ->EXIT1 !* PI(106): !*********************************************************************** !* SKIP REST OF STATEMENT * !*********************************************************************** ->UP3 !* PI(107): !*********************************************************************** !* Scan potential expression for first non-alphanumeric or dot or EOL * !* If , or ) or EOL then take alternate path to simplify analysis * !*********************************************************************** I=INP %WHILE TYPE(I)<7 %CYCLE I=I+1 %REPEAT ICOMP=ICOMP+2 J=TYPE(I) %IF J=7 %OR J=12 %THEN ->EXIT2;! if , or ) ICOMP=ICOMP+2 ->EXIT1 !* PI(108): !*********************************************************************** !* Skip rest of statement * !*********************************************************************** ->UP3;! SKIP REST OF STATEMENT !* PI(110): !*********************************************************************** !* Primarily to set GSTATE=12 prior to evaluating integer expressions * !*********************************************************************** %IF P1=3 %THEN ->EXIT1 GSTATE=P1 NOTFLAG=0 ->EXIT1 !* PI(111): !*********************************************************************** !* Check if RETURN valid in context * !* Follow by PI(89) * !*********************************************************************** %IF SUBPROGTYPE=1 %THEN LFAULT(202) STATEMENT=1;! classification for ITS ->PI89 !* PI(112): !*********************************************************************** !* Set default identifier for unnamed BLOCKDATA * !*********************************************************************** PI112:PTR=0;! to avoid unassigned check in call of NEWSUBPROGRAM P1=5;! TO INDICATE BLOCKDATA !{2900} BLOCKDATAID="ICL9HFBLKDTA" {PERQ} BLOCKDATAID="BLKDTA" ->PI70 !* PI(113): !*********************************************************************** !* Check sequencing of block IF statements * !*********************************************************************** STATEMENT=10+P1;! needed to ensure that forward refs to ENDIF label are not rejected ER=IFCHECK(BLOCKIFSTATE<<2!P1) %IF ER>200 %THENSTART;! invalid seqence ->EXIT4 %FINISH BLOCKIFSTATE=ER %IF BLOCKIFSTATE=0 %THENSTART I=IFPTR %WHILE I#0 %CYCLE IFREC==RECORD(ADICT+I) I=IFREC_LINK1 %IF IFREC_TYPE=0 %THEN %EXIT;! matching IF %REPEAT %IF I#0 %THENSTART;! nested IFs IFREC==RECORD(ADICT+I) BLOCKIFSTATE=IFREC_TYPE+1 %FINISH %FINISH ->EXIT1 PI(114): !*********************************************************************** !* after *) in dimension list * !*********************************************************************** K=X'A0000000' ->PI26B !* PI(116): !*********************************************************************** !* Note integer value in the analysis tree * !*********************************************************************** RES_W=P1 ->EXIT1 !* PI(118): !*********************************************************************** !* Call GENERATE to evaluate a const expression * !*********************************************************************** GENERATE RD ->EXIT1 !* PI(120): !*********************************************************************** !* Note previous character position for errors reported by GENERATE * !*********************************************************************** RES_W=INP-1 ->EXIT1 !* PI(121): !*********************************************************************** !* Check statement order for type statement * !*********************************************************************** CURSTATCLASS=1 %IF STATORDERMODE>2 %THEN LFAULT(236) STATORDERMODE=2 ->EXIT1 !* PI(122): !*********************************************************************** !* Report end of definition if NEXTCH is EOL * !*********************************************************************** %IF NEXTCH=10 %THEN ->PIZERO ->EXIT1 !* PI(123): !*********************************************************************** !* Process char length of form (*) or * !*********************************************************************** %IF P1#1 %THENSTART;! (*) PARCHECKS=YES;! to ensure parameter descriptor array is set up %IF P1#0 %THEN PI21INT=0 %AND ->PI24A;! ADJUST IDENTIFIER RECORD CHARLEN=0 ->EXIT1 %FINISH GENERATE RD PI21INT=RES_H0 %IF RES_FORM=1 %THEN PI21INT=INTEGER(ADICT+PI21INT<EXIT4;! bad character length ->EXIT1 !* PI(124): !*********************************************************************** !* Following recognition of an identifier in a SAVE list * !* P1 = 0 not a common block name * !* 1 a common block name * !*********************************************************************** PTR=FREESP(4) SS==RECORD(ADICT+PTR) SS_INF0=RES_W;! dict @ of iden record SS_INF2=LINEST SS_INF3=P1 SS_LINK1=SAVELIST SAVELIST=PTR ->EXIT1 !* PI(125): !*********************************************************************** !* Before I/O list item * !* Scan for EOL or iden only before , ) = EOL * !*********************************************************************** GSTATE=1 %IF NEXTCH=NL %THENSTART;! skip alternatives ICOMP=ICOMP+8 ->EXIT1 %FINISH %UNLESS TYPE(INP)=1 %THENSTART;! constant or expression PI125A: ICOMP=ICOMP+2 ->EXIT2 %FINISH I=INP+1 %CYCLE J=TYPE(I) %IF J>3 %THENSTART %IF J=7 %OR J=12 %OR INPUT(I)='=' %THENSTART ICOMP=ICOMP+6 ->EXIT2 %FINISHELSE ->PI125A %FINISH I=I+1 %REPEAT !* %ROUTINE FIND !*********************************************************************** !* SET PTR TO HEAD OF IDEN HASH LIST AND SEARCH * !*********************************************************************** PTR=FINDA(LHEAD(HASHVALUE)) PP==RECORD(ADICT+PTR) %END !* %ROUTINE CBNAME !*********************************************************************** !* NAME SEARCH HAS LOCATED A COMMON BLOCK NAME. IGNORE THIS AND * !* SEARCH FOR THE PERMITTED ALTERNATIVE DEFN. * !*********************************************************************** PP == RECORD(ADICT+PTR) PTR=FINDA(PP_LINK1) PP==RECORD(ADICT+PTR) %END; ! CBNAME !* %INTEGERFN SCAN(%INTEGER CHAR) !*********************************************************************** !* Scan for CHAR before next , or ) at current bracket level * !* Result = 0 not found * !* 1 found * !*********************************************************************** %INTEGER I,J,BC BC=0 I=INP J=INPUT(INP) %WHILE J#10 %CYCLE;! to EOL %IF BC=0 %THENSTART %IF J=CHAR %THEN %RESULT=1 %IF J=',' %OR J=')' %THEN %RESULT=0 %IF J='(' %THEN BC=BC+1 %FINISHELSESTART %IF J='(' %THEN BC=BC+1 %IF J=')' %THEN BC=BC-1 %FINISH I=I+1 J=INPUT(I) %REPEAT %RESULT=0 %END;! SCAN !* %ROUTINE GENERATE RD !*********************************************************************** !* Call generate to evaluate (what should be) a const expression * !*********************************************************************** GENERATE(TRIADS,NEXTTRIAD,LIN,-1,0,COMAD) RES_W=RESCOM1 RESL=RES_W RESR=RESCOM2 %IF RES_MODE=1 %THENSTART;! integer %IF RES_FORM=0 %THENSTART;! value in RES PI21INT=RES_H0 %FINISHELSESTART PI21INT=INTEGER(ADICT+RES_H0< 9 %THENSTART !{2900C} PRINTSTRING(" $") !{2900C} WRIT(P,2) !{2900C} PRINTSTRING("(") !{2900C} WRIT(P1,1) !{2900C} PRINTSTRING(")") !{2900C} NEWLINE !{2900C} %FINISHELSESTART !{2900C} %IF PTRACE=2 %THENSTART !{2900C} SPACES(4) !{2900C} %IF P = 2 %THEN PRINTSYMBOL(P1) %AND SPACES(5) !{2900C} %IF P = 6 %THEN PRINTSTRING("<@>") %AND SPACES(5) !{2900C} %IF P = 1 %THENSTART !{2900C} PRINTSTRING("<".SUBNAMES(P1).">") !{2900C} SPACES(5) !{2900C} %FINISH !{2900C} %IF P=0 %THEN PRINTSTRING("===") %AND SPACES(5) !{2900C} %IF P=4 %THENSTART !{2900C} PRINTSTRING(STRING(ADDR(SSTRING(SHEADS(P1))))) !{2900C} SPACES(5) !{2900C} %FINISH !{2900C} %IF P=7 %THENSTART !{2900C} PRINTSTRING("[") !{2900C} PRINTSYMBOL(P1) !{2900C} PRINTSTRING("]") !{2900C} %FINISH !{2900C} %IF P=3 %THENSTART !{2900C} PRINTSYMBOL(P1) !{2900C} PRINTSYMBOL('"') !{2900C} %FINISH !{2900C} NEWLINE !{2900C} %FINISH !{2900C} %FINISH %END;! STRACE !* !* %INTEGERFN GET NEXT VARIABLE %INTEGERFNSPEC IMPDO %CONSTBYTEINTEGERARRAY VSIZE(0:14)=2,4,8,4,8,16,8,16,32,4,0,0,0,1,8 %CONSTBYTEINTEGERARRAY LOGMODE(0:6)=0(3),13,0,9,14 %INTEGER VTYPE,RES,ARRAY %RECORD(SRECF) %NAME SS START:%IF VLISTHEAD=0 %THEN %RESULT=0;! VCOUNT still zero to provoke error 286 SS==RECORD(ADICT+VLISTHEAD) %IF SS_INF3<=0 %THENSTART;! IMPLIED DO RES=IMPDO %IF RES>0 %THEN %RESULT=-RES %IF RES<0 %THENSTART VLISTHEAD=SS_LINK1 ->START %FINISH %FINISH PTR=SS_INF0 PP==RECORD(ADICT+PTR) IDENTIFIER=STRING(ANAMES+PP_IDEN) VTYPE=PP_TYPE VMODE=SETMODE(VTYPE&X'3F') %IF VTYPE&X'F'=4 %THEN VMODE=LOGMODE(VTYPE>>4) %IF VTYPE=5 %THENSTART %IF SS_INF4#0 %THEN VLENGTH=SS_INF4 %C %ELSE VLENGTH=PP_LEN %FINISHELSE VLENGTH=VSIZE(VMODE) VCOUNT=1 VDISP=0 VAREA=7 %IF PP_CLASS&2=0 %OR PP_X0&16#0 %THENSTART;! not in comon %IF SUBPROGTYPE=5 %THEN %RESULT=284;! name not in common %FINISHELSESTART;! in common %IF SUBPROGTYPE#5 %THEN %RESULT=-282;! init common only in BLOCKDATA %IF PP_LINK3=BLCMPTR %THEN %RESULT=-283;! no init in blank common VAREA=6 %FINISH ALLOC(PTR) PP_X1=PP_X1!2;! initialised %IF PP_CLASS&4#0 %THENSTART;! array or array element DVREC==RECORD(ADICT+PP_ADDR4) !{2900} %IF SUBPROGTYPE#5 %THEN VAREA=5 %IF SS_INF2&X'FF000000'=0 %THENSTART;! whole array specified VCOUNT=DVREC_NUMELS %FINISHELSE VDISP=SS_INF2&X'00FFFFFF' %FINISHELSESTART;! scalar VDISP=SS_INF2 !{2900} %IF PP_X0&X'10'#0 %THEN VAREA=5;! scalar equiv to array area !{2900} %IF VTYPE=5 %AND VAREA=7 %THEN VAREA=2;! all char scalars in gla %FINISH {PERQ} VAREA=PP_IIN %IF SS_INF3>0 %THEN FREE LIST CELL(VLISTHEAD,5) %RESULT=0 %INTEGERFN IMPDO %INTEGER INIT,INC,FINAL,I,J,L,C,AD,ER %SWITCH A(0:5) !* %INTEGERFN VAL(%INTEGER P) %INTEGER I %RECORD(PRECF) %NAME PP %RECORD(RESF) RES %IF P&X'C0000000'#X'80000000' %THEN %RESULT=P P=P&X'7FFFFFFF' %CYCLE I=1,1,DOIO %IF DDO(I)_CONTID=P %THEN %RESULT=DDO(I)_VALUE %REPEAT PP==RECORD(ADICT+P) IDENTIFIER=STRING(ANAMES+PP_IDEN) %IF PP_CLASS=16 %THENSTART;! CONST RES_W=PP_LINK3 %IF RES_MODE#1 %THEN LFAULT(253) %AND %RESULT=1 J= RES_H0 %IF RES_H1=X'101' %THEN J=INTEGER(ADICT+J<A(-SS_INF3) !* A(0): ! INITIALISE L=SS_INF0 DOLEVEL=L INIT=VAL(DDO(L)_INIT) INC=VAL(DDO(L)_INCR) FINAL=VAL(DDO(L)_FINAL) %IF ER#0 %THEN %RESULT=ER %IF INC=0 %THEN %RESULT=295 C=(FINAL-INIT+INC)//INC %IF C<=0 %THEN %RESULT=290 DDO(L)_LEFT=C-1 DDO(L)_VALUE=INIT %RESULT=-1 !* A(1): ! ARRAY NAME ARRAY=VLISTHEAD PP==RECORD(ADICT+SS_INF0) DVREC==RECORD(ADICT+PP_ADDR4) %RESULT=-1 !* A(2): ! SUBSCRIPT LDIM(SS_INF2)=VAL(SS_INF0) %IF ER#0 %THEN %RESULT=ER %RESULT=-1 !* A(3): ! END OF SUBSCRIPT LIST VLISTHEAD=SS_LINK1 SS==RECORD(ADICT+ARRAY) J = DVREC_DIMS I=1;! to avoid IMP compiler bug L = LDIM(I)-DVREC_B(I)_L %IF J > 1 %THENSTART L = L+1 %CYCLE I = 2,1,J L = L+DVREC_B(I-1)_M*(LDIM(I)-DVREC_B(I)_L+1) %REPEAT L = L-DVREC_ZEROTOFIRST %FINISH %UNLESS 0 <= L < DVREC_NUMELS %THEN %C IDENTIFIER=STRING(ANAMES+PP_IDEN) %AND %RESULT=254 ! OUTSIDE DECLARED BOUNDS %IF PP_TYPE=CHARTYPE %THEN J=PP_LEN %ELSE %C J=NUMBYTES(PP_TYPE>>4);! BYTES PER ITEM %IF PP_TYPE&7=CMPLXTYPE %THEN J=J<<1;! COMPLEX I = (L*J)!X'1000000' SS_INF2=I %RESULT=0 !* A(4): ! END OF DO LOOP L=SS_INF0 C=DDO(L)_LEFT %IF C=0 %THEN %RESULT=-1 DDO(L)_LEFT=C-1 DDO(L)_VALUE=DDO(L)_VALUE+VAL(DDO(L)_INCR) SS==RECORD(ADICT+DDO(L)_START) %RESULT=-1 %END;! IMPDO %END;! GET NEXT VARIABLE !* %INTEGERFN DATA IMPLIED DO %SWITCH P41(0:10) K=0 ->P41(P1) !* P41(0): ! ( DOIO=DOIO+1 DOLEVEL=DOIO I=0 J=DOIO PI41A:PTR=FREESP(5) SS==RECORD(ADICT+PTR) SS_INF0=J; SS_INF4=0;! 5-word record needed for consistency with char substrings SS_INF2=K SS_INF3=I;! action switch %UNLESS VLISTHEAD=0 %THENSTART SS==RECORD(ADICT+VLISTTAIL) SS_LINK1=PTR %FINISHELSE VLISTHEAD=PTR VLISTTAIL=PTR %IF P1=0 %THEN DDO(DOIO)_START=PTR %RESULT=0 !* P41(1): ! arrayid( %IF PP_CLASS=12 %THEN CBNAME ER=245 %UNLESS PP_CLASS&13=4 %THEN %RESULT=3 {PI34ERR} ERRIDEN=STRING(ANAMES+PP_IDEN);! for subscript errors DVREC==RECORD(ADICT+PP_ADDR4) DIMSCOUNT=0 I=-1 J=PTR ->PI41A;! to enter array record !* P41(2): ! after controlled iden DDO(DOLEVEL)_CONTID=PTR %RESULT=0 !* P41(3): ! initial P41(4): ! final P41(5): ! increment %IF CTYP<=0 %THENSTART J=1<<31!PTR %FINISHELSESTART;! const %UNLESS CTYP=X'51' %THEN ER=131 %AND %RESULT=1 {EXIT4P} J=PI21INT %FINISH %IF P1=3 %THEN DDO(DOLEVEL)_INIT=J %ELSESTART %IF P1=4 %THEN DDO(DOLEVEL)_FINAL=J %ELSE DDO(DOLEVEL)_INCR=J %FINISH %RESULT=0 !* P41(6): ! default incr DDO(DOLEVEL+1)_INCR=1 %RESULT=0 !* P41(7): ! ) I=-4 J=DOLEVEL DOLEVEL=DOLEVEL-1 ->PI41A !* P41(8): ! after subscript %IF DIMSCOUNT>DVREC_DIMS %THENSTART PI41B: ER=264 IDENTIFIER=ERRIDEN %RESULT=2 {EXIT4} %FINISH DIMSCOUNT=DIMSCOUNT+1 K=DIMSCOUNT I=-2 %IF CTYP<=0 %THENSTART;! var J=1<<31!PTR %FINISHELSESTART %UNLESS CTYP=X'51' %THEN ER=136 %AND %RESULT=1 {EXIT4P} J=PI21INT %FINISH ->PI41A P41(9): ! ) following aray element %UNLESS DIMSCOUNT=DVREC_DIMS %THEN ->PI41B I=-3 J=0 ->PI41A %END;! DATA IMPLIED DO !* %INTEGERFN EQUIVALENCE %IF CRM3 = -1 %THEN %RESULT=1; ! FAULT ALREADY DETECTED %IF VLISTHEAD = VLISTTAIL %THENSTART; ! < 2 ITEMS IN LIST ER = 265 EQUIVERR:LFAULT(ER) %RESULT=1 %FINISH SPTR = VLISTHEAD %UNTIL SPTR = 0 %CYCLE SS == RECORD(ADICT+SPTR) PTR = SS_INF0 PP == RECORD(ADICT+PTR) %IF SS_INF2&X'FF000000'=X'01000000' %THEN %C SS_INF2 = SS_INF2&X'FFFFFF'; ! CLEAR FLAG SET BY PI(34) FOR ARRAY ELEMENT(NOT RELEVANT FOR EQUIV) PP_X1=PP_X1!X'80' %IF PP_CLASS&2 # 0 %THENSTART; ! COMMON ELEMENT ER = 266; ! > 1 COMMON ELEMENT IN LIST %IF CCOUNT # 1 %THEN -> EQUIVERR CCOUNT = PTR; ! SAVE COMMON ITEM POINTER %FINISHELSESTART; ! NOT A COMMON ITEM K = PP_X1; ! EQUIV TO : EQUIV FROM : DATA : ALLOCATED ER = 236; ! VARIABLE ALREADY ALLOCATED %IF K&1 # 0 %THEN %C IDENTIFIER=STRING(ANAMES+PP_IDEN) %AND -> EQUIVERR P=PTR J = VLISTHEAD PI44A: %IF J # SPTR %THENSTART; ! CHAIN THROUGH PREVIOUS ENTRIES TO CHECK CONTRADICTIONS SSS == RECORD(ADICT+J) %IF SSS_INF0 # PTR %THENSTART J = SSS_LINK1 -> PI44A %FINISHELSESTART; ! SPTR ITEM ALREADY INCLUDED IN CURRENT LIST ER = 267; ! CONTRADICTION IN EQUIV LIST PI21INT=SS_INF3 %IF SSS_INF2 # SS_INF2 %THEN -> EQUIVERR QQ_LINK1 = SS_LINK1; ! REMOVE DUPLICATE ENTRY FROM LIST FREE LIST CELL(SPTR,5) -> PI44B; ! LINK TO NEXT ITEM ALREADY SET %FINISH %FINISH %IF (K&4#0 %AND SPTR#PP_LINK2) %THENSTART ! NOW LINK IN EXISTING EQUIVALENCE CHAIN J = SS_LINK1; ! SAVE LINK TO NEXT (AS YET UNCHECKED) ITEM L = PP_LINK2; ! TO CORRESPONDING ENTRY ALREADY IN AN EQUIV LOOP SSS == RECORD(ADICT+L) K = SS_INF2-SSS_INF2; ! ADJUSTMENT REQUIRED TO ALLIGN EXISTING CHAIN N = SSS_LINK1 SS_LINK1 = N; ! START EQUIV CHAIN FROM THE NEW RECORD %UNTIL N = L %CYCLE SSS == RECORD(ADICT+N) SSS_INF2 = SSS_INF2+K N = SSS_LINK1 %REPEAT FREE LIST CELL(L,5) SSS_LINK1 = J %FINISHELSE PP_X1= K!4; ! SET 'EQUIV FROM' BIT PP_LINK2 = SPTR %FINISH QQ == RECORD(ADICT+SPTR) SPTR = SS_LINK1 PI44B: %REPEAT QQ_LINK1 = VLISTHEAD; ! COMPLETE THE LOOP %IF CCOUNT # 1 %THENSTART; ! COMMON ITEM IN CHAIN PTR = CCOUNT ALLOC(PTR); ! COMMON AREA PTR = P ALLOC(PTR); ! THE REST %FINISH %RESULT=0 %END;! EQUIVALENCE !* %END;! ANALYSE !* %INTEGERFN FORMAL PARAMETER(%INTEGER PTR,MODE) !*********************************************************************** !* PROCESS FORMAL PARAMETER * !* MODE = 0 'VALUE' TYPE * !* 1 'NAME' TYPE, I.E. / / * !*********************************************************************** !* %INTEGER I,ER %RECORD(PRECF) %NAME PP %RECORD(SRECF) %NAME SS PP==RECORD(ADICT+PTR) ER = 129; ! INVALID ARGUMENT %IF CTYP >= 0 %THENSTART; ! NOT FIRST OCCURENCE OF THIS IDEN %IF PP_CLASS&2#0 %OR PP_CLASS&X'1F'>9 %THENSTART ;! IN COMMON OR NAMELIST ETC. ERR: IDENTIFIER=STRING(ANAMES+PP_IDEN) %RESULT=4 %FINISH %UNLESS PP_X1&1#0 %THEN PP_CLASS=PP_CLASS!1;! MARK AS PARAM UNLESS ALLOC. %IF PP_CLASS&X'60'=X'60' %THEN PP_CLASS=PP_CLASS&X'DF';! clear 'not known as param' bit PP_X0=PP_X0!1 %UNLESS PTR < LASTSUBPROGEP %THEN ->ERR ! LASTSUBPROGEP SET BY PI(70) POINTING AT SUBPROG. RECORD %FINISHELSESTART; ! 'NEW' IDENTIFIER PP_X0 = 1; ! 'VALUE' PARAM PP_CLASS=1 %FINISH I=FREESP(2) SS==RECORD(ADICT+I) SS_INF0 = PTR INTEGER(PARAMLINK) = I; ! PARAMLINK LOCATES PREVIOUS LINK POSITION PARAMLINK = ADDR(SS_LINK1) %RESULT = 1 %END; ! FORMAL PARAM !* %INTEGERFN NEW SUBPROGRAM(%INTEGER PTR,P1,%INTEGERNAME ER) !*********************************************************************** !* FOLLOWS PROGRAM, SUBROUTINE, FUNCTION, ENTRY OR BLOCKDATA * !*********************************************************************** !* !{2900}%CONSTSTRING(12)%ARRAY PRG(0:5)= %C !{2900} "MAIN PROGRAM", !{2900} "PROGRAM ", !{2900} "FUNCTION ", !{2900} "SUBROUTINE ", !{2900} "", !{2900} "BLOCKDATA" !* {PERQ}%CONSTSTRING(12)%ARRAY PRG(0:5)= %C {PERQ} "Main Program", {PERQ} "Program ", {PERQ} "Function ", {PERQ} "Subroutine ", {PERQ} " Entry ", {PERQ} "Blockdata " !* %INTEGER I,J !* %RECORDFORMAT SMYFMT(%INTEGER SLINE,ELINE, %C %INTEGER ERRORS,WARNINGS,CODE,PLT,STACK,DIAG, %C %STRING(35) NAME,%STRING(11) ATTRIBUTES) !* %RECORD(SMYFMT) S %RECORD(PRECF) %NAME PP %RECORD(PRECF) %NAME QQ PP==RECORD(ADICT+PTR) %UNLESS P1=4 %THENSTART DATAHEAD=0 DATALAST=0 %FINISH %IF P1 = 4 %THENSTART; ! ENTRY ER = 100; ! SYNTAX %RESULT = 4 %UNLESS 2 <= SUBPROGTYPE <= 3 ! UNLESS FUNCTION OR SUBROUTINE ER = 141; ! INVALID ENTRY NAME %RESULT=4 %UNLESS CTYP<0 %OR PP_X1&1=0;! MUST BE A 'NEW' OR UNUSED IDENTIFIER %RESULT=4 %IF PP_CLASS#0 ER=235 %RESULT=4 %UNLESS DOPTR=0 %AND IFPTR=0;! NOT VALID INSIDE A DO LOOP OR IF BLOCK !*************************************************DEFINE PRIVATE LABEL FOR SIDE ENTRY I = SUBPROGPTR QQ==RECORD(ADICT+I) J=QQ_TYPE %IF PP_TYPE=5 %THENSTART %UNLESS J=5 %THEN ER=197 %AND %RESULT=4;! entry is char,fn is not %FINISHELSESTART %IF J=5 %THEN ER=198 %AND %RESULT=4;! fn is char,entry is not %FINISH %WHILE I>0 %CYCLE; ! THROUGH ENTRY POINT LIST QQ == RECORD(ADICT+I) I = QQ_LINK3 %REPEAT QQ_LINK3 = PTR %FINISHELSESTART {PERQ} MAX PSTACK=0 %IF P1=0 %THEN SUBPROGTYPE=1 %ELSE SUBPROGTYPE=P1 SUBPROGPTR=PTR FUNRESDISP=0;! NO RESULT SPACE YET ASSIGNED FOR FUNCTION !{2900} %IF PATHANAL#0 %THENSTART;! INITIALISE FOR THIS SUBPROG !{2900} PAINIT(LINEST,FIRSTSTATNUM) !{2900} %FINISH %FINISH {PERQ} %IF SUBPROGTYPE=2 %THENSTART;! function {PERQ} CUR PSTACK=4;! max result size {PERQ} %IF MAX PSTACK<4 %THEN MAX PSTACK=4 {PERQ} %FINISHELSE CUR PSTACK=0 {PERQ} %IF P1<=4 %THENSTART {PERQ} SELECTOUTPUT(0) {PERQ} SPACES(3) {PERQ} PRINTSTRING(PRG(P1)) {PERQ} %IF P1>0 %THENSTART {PERQ} PRINTSTRING(STRING(ANAMES+PP_IDEN)) {PERQ} %FINISH {PERQ} NEWLINE {PERQ} %IF LISTSTREAM>=0 %THEN SELECTOUTPUT(LISTSTREAM) {PERQ} %FINISH %IF P1#5 %THENSTART LASTSUBPROGEP = PTR; ! LOCATE THE 'LATEST' SUBPROG ENTRY PARAMLINK = ADDR(PP_LINK2); ! PARAM CHAIN LINK PP_CLASS = 11 RESCOM1=PTR;! will identify record for definition of plabel %FINISH !{2900} %IF P1=0 %THEN DIAGHEADS=0 %AND AREANAME="ICL9HFMAIN" !{2900} %IF 1<=P1<=3 %OR P1=5 %THENSTART !{2900} %IF OPTIONS1&X'11'=X'01' %THENSTART !{2900} I=COMREG(56) !{2900} %FINISHELSESTART !{2900} I=ANAMES+PP_IDEN !{2900} %FINISH !{2900} %IF I#0 %THEN AREANAME=STRING(I) !{2900} DIAGTEXT=ITEXT(LINEST,5)." ".PRG(P1) !{2900} %IF 1<=P1<=3 %THEN DIAGTEXT=DIAGTEXT.STRING(ANAMES+PP_IDEN) !{2900} DIAGHEADS=1 !{2900} %FINISH %IF P1=0 %THEN P1=1;! UNNAMED MAIN PROGRAM %IF P1<5 %THEN PP_X1=PP_X1!((P1-1)<<4) !{2900} %UNLESS 2<=P1<=3 %THEN FAST PROLOGUE=NO;! i.e. only for functions and subroutines with no side entries !{2900}%IF P1=4 %THENSTART;! SPECIALS FOR ITS AND PA !{2900} %IF OPTIONS1&1#0 %THENSTART;! CEMODE !{2900} S_SLINE=0 !{2900} S_NAME=STRING(ANAMES+PP_IDEN) !{2900} S_ATTRIBUTES="ENTRY" !{2900} SUMMARY(ADDR(S_SLINE)) !{2900} %FINISH !{2900} %IF ITSMODE#0 %THEN SET LINE NO(LINEST) !{2900} %IF PATHANAL#0 %THEN PATHCOUNT(LINEST,0) !{2900}%FINISH %RESULT = 1 %END; ! NEW SUBPROGRAM !* !* {PERQ}!* {PERQ}%ROUTINE LIST SOURCE LINE {PERQ}!*********************************************************************** {PERQ}!* reconstruct last line * {PERQ}!*********************************************************************** {PERQ}%INTEGER I, J, K {PERQ} %RETURN %IF LINENO=0;! EMPTY FILE {PERQ} WRITE(LINEST,5) {PERQ} %IF LAB = 0 %THENSTART {PERQ} SPACES(10) {PERQ} %FINISHELSE WRITE(LAB,10) {PERQ} SPACE {PERQ} PRINTSYMBOL(IBUFF(7)) {PERQ} I = 8 {PERQ}L1: J = IBUFF(I) {PERQ} PRINTSYMBOL(J) {PERQ} %UNLESS J=NL %THENSTART {PERQ} %IF I-7 = (I-7)//66*66 %THENSTART {PERQ} NEWLINE {PERQ} SPACES(16) {PERQ} PRINTSYMBOL('*') {PERQ} %FINISH {PERQ} I = I+1 {PERQ} -> L1 {PERQ} %FINISH {PERQ}%END;! LIST SOURCE LINE {PERQ}!* {PERQ}!* {PERQ}%INTEGERFN WARNCHECK(%INTEGER ER) {PERQ}%CONSTINTEGERARRAY LIST(0:15)= %C {PERQ} 119,183,191,200,201,242,193,194,-1(8) {PERQ}%INTEGER I {PERQ} %CYCLE I=0,1,15 {PERQ} %IF ER=LIST(I) %THEN %RESULT=1 {PERQ} %REPEAT {PERQ} %RESULT=0 {PERQ}%END;! WARNCHECK {PERQ}!* {PERQ}%ROUTINE POINT(%INTEGER J) {PERQ} %IF 00 %THENSTART {PERQ} J=CHMARK(INP) {PERQ} %WHILE J>72 %CYCLE {PERQ} J = J-66 {PERQ} %REPEAT {PERQ} %IF ER=100 %OR ER=106 %THEN PI21INT=J {PERQ} %FINISHELSE J=0 {PERQ} %IF DIAGSTREAM>=0 %THENSTART {PERQ} SELECTOUTPUT(DIAGSTREAM) {PERQ} LIST SOURCE LINE {PERQ} POINT(J) {PERQ} FAULTNUM(ER,COMAD,1) {PERQ} %FINISH {PERQ} %IF LISTSTREAM>=0 %THENSTART {PERQ} SELECTOUTPUT(LISTSTREAM) {PERQ} POINT(J) {PERQ} FAULTNUM(ER,COMAD,0) {PERQ} %FINISH {PERQ}%END {PERQ}!* {PERQ}%EXTERNALROUTINE LFAULT(%INTEGER ER) {PERQ} %IF CONTROL&1#0 %THEN %MONITOR;! parm quotes {PERQ} %IF WARNCHECK(ER)#0 %THEN %RETURN {PERQ} %IF ER#101 %AND ER#102 %THENSTART;! EXCEPT CONTINUATION ON FIRST STATEMENT {PERQ} %IF DIAGSTREAM>=0 %THENSTART {PERQ} SELECTOUTPUT(DIAGSTREAM) {PERQ} LIST SOURCE LINE {PERQ} %FINISH {PERQ} %FINISH {PERQ} %IF DIAGSTREAM>=0 %THENSTART {PERQ} SELECTOUTPUT(DIAGSTREAM) {PERQ} FAULTNUM(ER,COMAD,1) {PERQ} %FINISH {PERQ} %IF LISTSTREAM>=0 %THENSTART {PERQ} SELECTOUTPUT(LISTSTREAM) {PERQ} FAULTNUM(ER,COMAD,0) {PERQ} %FINISH {PERQ}%END {PERQ}!* {PERQ}!* {PERQ}%EXTERNALROUTINE TFAULT(%INTEGER E,TA,TB) {PERQ} IDENTIFIER=STRING(TA) {PERQ} %IF TB#0 %THEN ERRIDEN=STRING(TB) {PERQ} LFAULT(E) {PERQ}%END;! TFAULT {PERQ}!* {PERQ}%EXTERNALROUTINE IFAULT(%INTEGER E,I) {PERQ} PI21INT=I {PERQ} LFAULT(E) {PERQ}%END;! IFAULT !* !{2900}%ROUTINESPEC RECORD ERR(%STRINGNAME S,%INTEGER TYPE) !{2900}!* !{2900}%ROUTINE LISTER(%INTEGER TYPE) !{2900}%INTEGER I, J, K !{2900}%BYTEINTEGERARRAY A(0:120) !{2900}%STRING(120) M !{2900} %RETURN %IF LINENO=0;! EMPTY FILE !{2900} M=ITEXT(LINEST,5) !{2900} %IF LAB = 0 %THENSTART !{2900} M=M." " !{2900} %FINISHELSE M=M.ITEXT(LAB,11) !{2900} A(1)=' ' !{2900} A(2)=IBUFF(7) !{2900} K=2 !{2900} I = 8 !{2900}L1: J = IBUFF(I) !{2900} -> END %IF J = NL !{2900} %IF I-7 = (I-7)//66*66 %THENSTART !{2900} A(0)=K !{2900} M=M.STRING(ADDR(A(0))) !{2900} RECORD ERR(M,TYPE) !{2900} M=" *" !{2900} K=0 !{2900} %FINISH !{2900} K=K+1 !{2900} A(K)=J !{2900} I = I+1 !{2900} -> L1 !{2900}END: A(0)=K !{2900} M=M.STRING(ADDR(A(0))) !{2900} RECORD ERR(M,TYPE) !{2900}%END;! LISTER !{2900}!* !!{2900}%ROUTINE DICFUL !!{2900} NEWLINE !!{2900} PRINTSTRING(" DICTIONARY OVERFLOW") !!{2900} NEWLINE !!{2900} !! SUBPROGTYPE = 0 !!{2900} LFAULT(308) !!{2900} FAULTY = FAULTY+FNO !!{2900} !!!!!!! FINISH(1) !!{2900}%END !{2900}!* !{2900}!* !{2900}%EXTERNALROUTINE SET HEADING(%INTEGER TYPE) !{2900}%INTEGER I !{2900}%SWITCH T(0:6) !{2900} %IF HEADINGS#0 %THEN %RETURN !{2900} HEADINGS=1<T(TYPE) !{2900}!* !{2900}T(0): ! SOURCE !{2900} PRINTSTRING("LINE NUMBER FORTRAN TEXT") !{2900}OUT: NEWLINES(2) !{2900} %RETURN !{2900}!* !{2900}T(1): ! OBJECT !{2900} SPACES(18) !{2900} PRINTSTRING("OBJECT CODE LISTING") !{2900} ->OUT !{2900}!* !{2900}T(2): ! DIAGNOSTICS !{2900} SPACES(48) !{2900} PRINTSTRING("DIAGNOSTIC MESSAGES") !{2900} ->OUT !{2900}!* !{2900}T(3): ! DATA MAP !{2900} SPACES(51) !{2900} PRINTSTRING("DATA MAP") !{2900} NEWLINES(2) !{2900} %CYCLE I=0,1,1 !{2900} PRINTSTRING("NAME AREA OFFSET LENGTH") !{2900} %IF I=0 %THEN SPACES(22) !{2900} %REPEAT !{2900}OUT2: NEWLINE !{2900} %RETURN !{2900}!* !{2900}T(4): ! STATEMENT MAP !{2900} SPACES(48) !{2900} PRINTSTRING("STATEMENT MAP") !{2900} NEWLINES(2) !{2900} %CYCLE I=0,1,3 !{2900} PRINTSTRING("STMNT OFFSET") !{2900} %IF I#3 %THEN SPACES(14) !{2900} %REPEAT !{2900} ->OUT2 !{2900}!* !{2900}T(6): ! DUMMY TO PROVIDE REF TO SUBHEADING IN CASE NEEDED !{2900}!! SUBHEADING(TEXT,0,1) !{2900}%END;! SET HEADING !{2900}!* !{2900}%ROUTINE OUTSTRING(%STRING(120) S,%INTEGER TYPE) !{2900}%INTEGER J !{2900} %IF TYPE=2 %THENSTART;! OBLITERATE LINE NUMBER !{2900} %CYCLE J=1,1,5 !{2900} BYTEINTEGER(ADDR(S)+J)=' ' !{2900} %REPEAT !{2900} %FINISH !{2900} PRINTSTRING(S) !{2900} NEWLINE !{2900}%END;! OUTSTRING !{2900}!* !{2900}%EXTERNALROUTINE OUTPUT ERRS(%INTEGER MODE,%INTEGER TYPE) !{2900}%BYTEINTEGERARRAYFORMAT MTF(0:1000) !{2900}%STRING(120)%ARRAYFORMAT MF(0:1000) !{2900}%BYTEINTEGERARRAYNAME MESSTYPE !{2900}%STRINGARRAYNAME MESS !{2900}%INTEGER I,J !{2900} MESSTYPE==ARRAY(ADMESST,MTF) !{2900} MESS==ARRAY(ADMESS,MF) !{2900} %IF MODE=1 %THENSTART !{2900} PRINTSTRING("LINE MESSAGE EXPLANATION") !{2900} NEWLINES(2) !{2900} %IF LISTPOINT#0 %THEN TYPE=2 !{2900} %FINISHELSE NEWLINE !{2900} %CYCLE I=1,1,MESSCOUNT !{2900} J=MESSTYPE(I) !{2900} %IF J<=TYPE %THENSTART !{2900} %IF LISTPOINT=0 %THENSTART !{2900} %IF J=0 %THEN J=TYPE %ELSE J=0;! DON'T INHIBIT LINE NOS IN SOURCE !{2900} %FINISH !{2900} OUTSTRING(MESS(I),J) !{2900} %FINISH !{2900} %REPEAT !{2900}%END;! OUTPUT ERRS !{2900}!* !{2900}!* !{2900}%ROUTINE EMAS DISPLAY !{2900}%INTEGER I !{2900} %RETURN %IF OPTIONS1&1#0 !{2900} I=COMREG(40) !{2900} %IF I>=0 %THENSTART !{2900} LISTER(-1) !{2900} %FINISH !{2900}%END;! EMAS DISPLAY !{2900}!* !{2900}%EXTERNALROUTINE RECORD ERR(%STRINGNAME M,%INTEGER TYPE) !{2900} %BYTEINTEGERARRAYFORMAT MTF(0:1000) !{2900} %STRING(120)%ARRAYFORMAT MF(0:1000) !{2900} %BYTEINTEGERARRAYNAME MESSTYPE !{2900} %STRINGARRAYNAME MESS !{2900}%INTEGER LIST,DISPLAY,DEFER,I,J !{2900} %IF TYPE<0 %THEN ->EDISP;! LISTER CALL FOR DIAGFILE COPY !{2900} MESSTYPE==ARRAY(ADMESST,MTF) !{2900} MESS==ARRAY(ADMESS,MF) !{2900} %IF OPTIONS1&1=0 %THENSTART !{2900} PRINTSTRING(M) !{2900} NEWLINE !{2900}EDISP: I=COMREG(40) !{2900} %IF I>=0 %THENSTART !{2900} J=COMREG(23) !{2900} SELECTOUTPUT(I) !{2900} PRINTSTRING(M) !{2900} NEWLINE !{2900} SELECTOUTPUT(J) !{2900} %FINISH !{2900} %RETURN !{2900} %FINISH !{2900} LIST=LISTL&1 !{2900} DISPLAY=OPTIONS2&1 !{2900} DEFER=OPTIONS2&X'100' !{2900} %IF DEFER=0 %AND TYPE<2 %THENSTART !{2900} %IF LIST#0 %THENSTART !{2900} OUTSTRING(M,2) !{2900} %FINISH !{2900} %IF DISPLAY#0 %THENSTART !{2900} SELECTOUTPUT(DIAGSTREAM) !{2900} OUTSTRING(M,2) !{2900} SELECTOUTPUT(LISTSTREAM) !{2900} %FINISH !{2900} %FINISH !{2900} %IF OPTIONS2&X'1102'#0 %THENSTART;! ATEND OR ERRORLINES(LIST OR DISPLAY) !{2900} %IF MESSCOUNT=MESSLEN %THEN %RETURN !{2900} %IF DIAGHEADS&3=1 %THENSTART;! NOTE CURRENT SUBPROG !{2900} DIAGHEADS=3;! AT THIS POINT TO PREVENT LOOPING !{2900} %IF LISTPOINT=0 %THEN RECORD ERR(DIAGTEXT,2) !{2900} %FINISH !{2900} MESSCOUNT=MESSCOUNT+1 !{2900} MESS(MESSCOUNT)=M !{2900} MESSTYPE(MESSCOUNT)=TYPE !{2900} %FINISH !{2900}%END;! RECORD ERR !{2900}!* !{2900}%STRINGFN ITEXT(%INTEGER VAL,N) !{2900}%INTEGER J,K !{2900}%BYTEINTEGERARRAY C(0:20) !{2900} J=20 !{2900} %WHILE VAL#0 %CYCLE !{2900} K=VAL//10 !{2900} C(J)=VAL-10*K+'0' !{2900} J=J-1 !{2900} VAL=K !{2900} %REPEAT !{2900} %IF J=20 %THEN C(20)='0' %AND J=19 !{2900} %WHILE N>20-J %CYCLE !{2900} C(J)=' ' !{2900} J=J-1 !{2900} %REPEAT !{2900} C(J)=20-J !{2900} %RESULT=STRING(ADDR(C(J))) !{2900}%END;! ITEXT !{2900}!* !{2900}%INTEGERFN WARNCHECK(%INTEGER ER) !{2900}%CONSTINTEGERARRAY LIST(0:15)= %C !{2900} 119,183,191,200,201,242,193,194,-1(8) !{2900}%INTEGER I !{2900} %IF CONTROL&X'80000'=0 %THEN %RESULT=0;! PARM(FREE) !{2900} %CYCLE I=0,1,15 !{2900} %IF ER=LIST(I) %THEN %RESULT=1 !{2900} %REPEAT !{2900} %RESULT=0 !{2900}%END;! WARNCHECK !{2900}!* !{2900}%EXTERNALROUTINE FAULT(%INTEGER ER) !{2900}%INTEGER I, J !{2900}%BYTEINTEGERARRAY A(0:120) !{2900}%STRING(120) M !{2900}%OWNSTRING(1) S=" " !{2900} %IF WARNCHECK(ER)#0 %THEN %RETURN !{2900} %IF LISTL&1=0 %OR (LISTL&2=0 %AND OPTIONS2&X'FF'#0) %C !{2900} %THEN LISTER(2) %C !{2900} %ELSE EMAS DISPLAY !{2900} J = 6 !{2900} %IF INP<=0 %THEN ->BLANK !{2900} J=CHMARK(INP) !{2900} %WHILE J>72 %CYCLE !{2900} J = J-66 !{2900} %REPEAT !{2900} %IF ER=100 %OR ER=106 %THEN PI21INT=J !{2900} %UNLESS 0BLANK !{2900} %CYCLE I=1,1,10+J !{2900} A(I)=' ' !{2900} %REPEAT !{2900} I=I+1 !{2900} A(I)='!' !{2900} A(0)=I !{2900} M=STRING(ADDR(A(0))) !{2900} %IF LISTPOINT#0 %THENSTART !{2900} RECORD ERR(S,1) !{2900} LISTER(2) !{2900} %FINISH !{2900} RECORD ERR(M,1) !{2900} ->MESSAGE !{2900}BLANK: RECORD ERR(S,1) !{2900}MESSAGE: FAULTNUM(ER,COMAD) !{2900} %IF LISTPOINT=0 %THEN RECORD ERR(S,1) !{2900} %IF FNO > 200 %AND OPTIONS1&1=0 %THENSTART !{2900} PRINTSTRING(" MORE THAN 200 FAULTS") !{2900} NEWLINE !{2900} ER = 309 !{2900} !! SUBPROGTYPE = 0 !{2900} FAULTY = FAULTY+FNO !{2900} !!!!!!! FINISH(1) !{2900} %FINISH !{2900} %END !{2900}!* !{2900}%EXTERNALROUTINE LFAULT(%INTEGER ER) !{2900}%OWNSTRING(1) S=" " !{2900} %IF WARNCHECK(ER)#0 %THEN %RETURN !{2900} %IF ER#101 %AND ER#102 %THENSTART;! EXCEPT CONTINUATION ON FIRST STATEMENT !{2900} %IF LISTL&1=0 %OR (LISTL&2=0 %AND OPTIONS2&X'FF'#0) %C !{2900} %THEN LISTER(2) %C !{2900} %ELSE EMAS DISPLAY !{2900} %FINISH !{2900} %IF LISTPOINT=0 %THEN RECORD ERR(S,1) !{2900} FAULTNUM(ER,COMAD) !{2900} %IF LISTPOINT=0 %THEN RECORD ERR(S,1) !{2900}%END !{2900}!* !{2900}!* !{2900}%EXTERNALROUTINE WARNING(%INTEGER ERR) !{2900}%END !{2900}!* !{2900}%EXTERNALROUTINE TFAULT(%INTEGER E,TA,TB) !{2900} IDENTIFIER=STRING(TA) !{2900} %IF TB#0 %THEN ERRIDEN=STRING(TB) !{2900} LFAULT(E) !{2900}%END;! TFAULT !{2900}!* !{2900}%EXTERNALROUTINE IFAULT(%INTEGER E,I) !{2900} PI21INT=I !{2900} LFAULT(E) !{2900}%END;! IFAULT !{2900}!* !{2900}%EXTERNALROUTINE FAULTNUM(%INTEGER ER,COMAD) !{2900}!* !{2900} %CONSTBYTEINTEGERARRAY ITOITAB(0:255)=%C !{2900} 0,1,2,3,4,5,6,7,8,9,10, !{2900} 11,12,13,14,15,16,17,18,19,20, !{2900} 21,22,23,24,25,26,27,28,29,30, !{2900} 31,32,33,34,35,36,37,38,39,40, !{2900} 41,42,43,44,45,46,47,48,49,50, !{2900} 51,52,53,54,55,56,57,58,59,60, !{2900} 61,62,63,64,65,66,67,68,69,70, !{2900} 71,72,73,74,75,76,77,78,79,80, !{2900} 81,82,83,84,85,86,87,88,89,90, !{2900} 91,92,93,94,95,96,65,66,67,68, !{2900} 69,70,71,72,73,74,75,76,77,78, !{2900} 79,80,81,82,83,84,85,86,87,88, !{2900} 89,90,123,124,125,126,127,128,129,130, !{2900} 131,132,133,134,135,136,137,138,139,140, !{2900} 141,142,143,144,145,146,147,148,149,150, !{2900} 151,152,153,154,155,156,157,158,159,160, !{2900} 161,162,163,164,165,166,167,168,169,170, !{2900} 171,172,173,174,175,176,177,178,179,180, !{2900} 181,182,183,184,185,186,187,188,189,190, !{2900} 191,192,193,194,195,196,197,198,199,200, !{2900} 201,202,203,204,205,206,207,208,209,210, !{2900} 211,212,213,214,215,216,217,218,219,220, !{2900} 221,222,223,224,225,226,227,228,229,230, !{2900} 231,232,233,234,235,236,237,238,239,240, !{2900} 241,242,243,244,245,246,247,248,249,250, !{2900} 251,252,253,254,255 !{2900}!* !{2900}%CONSTSTRING(7)%ARRAY ETEXT(1:4)= %C !{2900} "COMMENT","WARNING","ERROR ","T ERROR" !{2900}!* !{2900}%STRING(127) S,T,U !{2900}%STRING(120) M !{2900}%INTEGER I,CE,SHORT,DEFER,ERRORLINES,ETYPE,RC,LEN !{2900} CE=OPTIONS1&1 !{2900} %IF CE=0 %AND JBRMODE=0 %AND TESTVERSION=YES %THENSTART !{2900} %MONITOR %IF CONTROL&1#0 %AND ER#0;! PARM(QUOTES) !{2900} %FINISH !{2900} SHORT=OPTIONS2&X'200' !{2900} DEFER=OPTIONS2&X'100' !{2900} ERRORLINES=OPTIONS2&X'1002' !{2900} %IF ERRORLINES#0 %THEN DEFER=0 !{2900} %RETURN %IF ER=0 !{2900} %IF ER>=100 %THENSTART !{2900} ICL9CEF77MTM(X'28000001',ADDR(ER),X'28000001',ADDR(RC), %C !{2900} X'1800007F',ADDR(T)+1,X'28000001',ADDR(LEN)) !{2900} %IF RC=0 %THENSTART !{2900} LENGTH(T)=LEN !{2900} %IF CE ! JBRMODE # 0 %THEN ETOI(ADDR(T)+1,LEN);! VMEB !{2900} ->SETI !{2900} %FINISH !{2900} %FINISH !{2900} T="E".ITEXT(ER,3) %AND LEN=4 !{2900}SETI: !{2900} I=ADDR(T)+5 !{2900} %IF LEN=4 %THEN BYTEINTEGER(I)=0 %ELSE %C !{2900} BYTEINTEGER(I)=LENGTH(T)-5 !{2900} S=STRING(I) !{2900} LENGTH(T)=1 !{2900} %IF T="C" %THEN ETYPE=1 %ELSESTART !{2900} %IF T="W" %THENSTART !{2900} ETYPE=2 !{2900} WARNCOUNT=WARNCOUNT+1 !{2900} %FINISHELSESTART !{2900} FNO=FNO+1 !{2900} %IF T="T" %THEN ETYPE=4 %ELSE ETYPE=3 !{2900} %FINISH !{2900} %FINISH !{2900} %IF ETYPE=1 %AND OPTIONS2&X'400'#0 %THEN %RETURN;! NOCOMMENTS !{2900} %IF S->T.("@").U %THENSTART !{2900} %IF SHORT=0 %THENSTART !{2900} S=T.IDENTIFIER.U !{2900} %FINISHELSE S="NAME ".IDENTIFIER !{2900} %FINISH !{2900} %IF S->T.("&").U %THENSTART !{2900} %IF SHORT=0 %THENSTART !{2900} S=T.ERRIDEN.U !{2900} %FINISHELSE S="NAME ".ERRIDEN !{2900} ->SET !{2900} %FINISH !{2900}QINT: %IF S->T.("#").U %THENSTART !{2900} %IF SHORT=0 %THENSTART !{2900} S=T.ITEXT(PI21INT,1).U !{2900} %FINISHELSESTART !{2900} S=ITEXT(PI21INT,1) !{2900} %FINISH !{2900} ->SET !{2900} %FINISH !{2900} %IF SHORT#0 %THEN S="" !{2900}SET: M=ETEXT(ETYPE) !{2900} T=ITEXT(ER,3) !{2900} %IF CE=0 %THENSTART;! EMAS and JOBBER !{2900} M="*".M." ".T !{2900} %FINISHELSESTART !{2900} M=ITEXT(LINEST,4)." ".M." (".T.")" !{2900} %FINISH !{2900} M=M." ".S !{2900} ->SKIP !{2900} I=ADDR(ITOITAB(0)) !{2900} CE=ADDR(M)+1 !{2900} *LSS_I !{2900} *LUH_X'18000100' !{2900} *LDTB_X'18000078' !{2900} *LDA_CE !{2900} *TTR_%L=%DR !{2900}SKIP: RECORD ERR(M,0) !{2900}!* !{2900}%END; ! FAULTNUM !* !* !*********************************************************************** !* ROUTINES TO DUMP DICTIONARY RECORDS * !*********************************************************************** !* !{2900C}%ROUTINE PRHEX(%INTEGER J) !{2900C}%INTEGER K !{2900C} %CYCLE K = 28,-4,0 !{2900C} PRINT SYMBOL(HEX((J>>K)&15)) !{2900C} %REPEAT !{2900C}%END !{2900C}!* !{2900C}%ROUTINE PH(%INTEGER I) !{2900C} PRHEX(INTEGER(I)) !{2900C} SPACES(2) !{2900C}%END !{2900C}!* !{2900C}%ROUTINE DICREC(%INTEGER A,ID) !{2900C}%INTEGER I !{2900C} I = ADICT+A !{2900C} PRHEX(A) !{2900C} SPACES(6) !{2900C} PH(I) !{2900C} PH(I+4) !{2900C} SPACES(2) !{2900C} PH(I+8) !{2900C} PH(I+12) !{2900C} SPACES(2) !{2900C} NEWLINE !{2900C} WRITE(A,7) !{2900C} SPACES(6) !{2900C} PH(I+16) !{2900C} PH(I+20) !{2900C} SPACES(2) !{2900C} PH(I+24) !{2900C} PH(I+28) !{2900C} SPACES(2) !{2900C} %IF ID#0 %THEN PRINTSTRING(STRING(ANAMES+HALFINTEGER(I+24))) !{2900C} NEWLINES(2) !{2900C}%END !{2900C}!* !{2900C}%ROUTINE DICRECLIST(%INTEGER HEAD,ID) !{2900C}%RECORD(PRECF) %NAME P !{2900C} %WHILE HEAD # 0 %CYCLE !{2900C} P == RECORD(ADICT+HEAD) !{2900C} DICREC(HEAD,ID) !{2900C} %IF ID#0 %AND P_CLASS&X'C'=4 %THEN DICREC(P_ADDR4,0);! ARRAY DV !{2900C} HEAD = P_LINK1 !{2900C} %REPEAT !{2900C}%END; ! DICRECLIST !{2900C}!* !{2900C}%ROUTINE ALLDICT !{2900C}%INTEGER I, J !{2900C} NEWLINE !{2900C} PRINTSTRING("IDEN LISTS:") !{2900C} NEWLINE !{2900C} %CYCLE I = 0,1,154 !{2900C} J = LHEAD(I) !{2900C} %IF J # 0 %THENSTART !{2900C} WRITE(I,1); NEWLINE !{2900C} DICRECLIST(J,1) !{2900C} %FINISH !{2900C} %REPEAT !{2900C} PRINTSTRING("LABEL LISTS:") !{2900C} NEWLINE !{2900C} %CYCLE I = 0,1,31 !{2900C} J = LABH(I) !{2900C} %IF J # 0 %THENSTART !{2900C} WRITE(I,1) !{2900C} NEWLINE !{2900C} DICRECLIST(J,0) !{2900C} %FINISH !{2900C} %REPEAT !{2900C}%END; ! ALLDICT !* !* !* !{2900}%ROUTINE ZERO(%INTEGER AD, L) !{2900}%INTEGER I !{2900} I=X'18000000'!L !{2900} *LDTB_I !{2900} *LDA_AD !{2900} *LB_0 !{2900} *MVL_%L=%DR !{2900}%END; ! ZERO !* !* %ROUTINE ANALINIT !*********************************************************************** !* Re-initialise at start of each subprogram * !*********************************************************************** %INTEGER I,J,PTR !{2900C}%INTEGER C {PERQC}%HALFINTEGER C %RECORD(PRECF) %NAME PP !{2900} ZERO(ADDR(LHEAD(0)),620) !{2900} ZERO(ADDR(LABH(0)),128) !{2900} ZERO(ADICT,256) {PERQ} %CYCLE C=0,1,154 {PERQ} LHEAD(C)=0 {PERQ} %REPEAT {PERQ} %CYCLE C=0,1,31 {PERQ} LABH(C)=0 {PERQ} %REPEAT {PERQ} ZERODICT(0,128) %CYCLE I = 1,1,10 ASL(I) = 0 %REPEAT CBNPTR=0 DOPTR=0 SCPTR=0 SFPTR=0 SUBPROGTYPE=0 SUBPROGPTR=0 FNLST=0 SFMK=0 HEADINGS=0 CHECKLIST=0 DATAHEAD=0 EXTERNALS=0 FNO=0 PARAMLINK=0 CGOLAB=0 NOTFLAG=0 PCT=0 LASTSUBPROGEP=0 DIAGHEADS=0 CHEAD0=0 CHEAD1=0 CHEAD2=0 CHEAD3=0 BLOCKIFSTATE=0 NAMESFREE=2;! free location for next identifier IFPTR=0;! nest of active IF blocks NEXT PLAB=1;! private label index INP = 1 J=DEFAULT SIZE(2) %CYCLE I = 'A',1,'Z' IMPTYPE(I) = J; ! SET IMPLICIT TYPE FOR ALPHABETICS TO REAL %REPEAT J=DEFAULT SIZE(1) %CYCLE I = 'I',1,'N' IMPTYPE(I) = J; ! OVER-RIDE I - N WITH IMPLICIT INTEGER %REPEAT CHARMASK=0;! for implicit bit settings STATORDERMODE=0 ALGOLREF=0;! WILL BE SET TO 1 IF EXTERNAL /ALGOL/ APPEARS !{2900} %IF OPTIONS1&1#0 %AND COMREG(57)#0 %THEN ALGOLREF=1 %CYCLE I=0,1,156 FNSPECIALS(I)=FNSPECIALS(I)&X'FFFFF';! reset %REPEAT !* !******** INITIALISE BLANK COMMON ENTRY IN DICT !* DPTR = BLCMPTR PTR=LOCATE NAME("F#BLCM") DPTR=DPTR+CMNRECEXT PP==RECORD(ADICT+PTR) PP_CLASS=12; ! COMMON BLOCK NAME PP_LINK3 = PTR; ! 'LAST ITEM' POINTER TO ITSELF - NO ITEMS YET DEFINED !{2900} PP==RECORD(ADICT+PSEUDOCMN);! local arrays treated as common sometimes !{2900} PP_CMNREFAD=8;! only relevant entry is disp of ref @ !{2900} DPTR=200;! WILL ENSURE THAT CONST VALUES ARE >=256 BYTES UP DICT !{2900} ! TO AVOID ERROR IN ADD DATA ITEM !* FIRSTSTATNUM=LINEST+1;! FOR STATEMENT MAP !* SAVELIST=0;! list of items in SAVE statements !* ADBLKDTAID=ADDR(BLOCKDATAID) !* %END;! ANALINIT !* !* %INTEGERFN ANALLOOP(%RECORD(TRIADF)%ARRAYNAME TRIADS,%INTEGER MAXTRIADS) %INTEGER I,J,TLTYP,PTR,SPTR,PATH,LIN,ER %INTEGER NEXTTRIAD !* %RECORD(DORECF)%NAME DOREC %RECORD(IFRECF)%NAME IFREC %RECORD(LABRECF)%NAME LABREC %RECORD(SRECF)%NAME SS !* %ROUTINE CHECK LAB REF %IF LABREC_DOSTART#0 %THENSTART;! within a DO loop %UNLESS SS_INF2>=LABREC_DOSTART %THEN IFAULT(206,SS_INF2) %FINISH %IF LABREC_IFSTART#0 %THENSTART;! within an IF block %UNLESS SS_INF2>=LABREC_IFSTART %OR STATEMENT=13 %C %THEN IFAULT(204,SS_INF2);! avoid test if ENDIF statement %FINISH %IF CURSTATCLASS=1 %THEN IFAULT(218,SS_INF2) %END;! CHECK LAB REF !* LOOP: !{2900} CODEGEN(0,TRIADS,COMAD) !* NEXTTRIAD=1 TRBLOCK=0 !* !****** INITIALISE INPUT BUFFERS !* !{2900} %CYCLE I = -5,1,0 !{2900} TBUFF(I) = ' ' !{2900} %REPEAT !{2900} TBUFF(-10) = 10; ! CONTROL CHAR FOR CALLS ON SIM2(1,... !* ANALINIT !* %UNLESS LINENO>0 %THENSTART FAULTY=0 READNEXT %FINISH I=TBUFF(1) J=TBUFF(6) %UNLESS I='C' %OR I='*' %OR I= 25 %OR J='0' %OR J=' ' %THENSTART LFAULT(101); ! FIRST STATEMENT HAS CONTINUATION MARKER %FINISH !* NEXT STATEMENT: I=READLINE %IF I#0 %THEN %RESULT=I LTYPE = MAPLTYPE(LTYPE); ! MAPLTYPE(0:7)=0,0,1,2,4,4,5,5 TLTYP = LTYPE %IF SUBPROGTYPE = 0 %THEN LTYPE = 6 ANALYSE LINE: LIN=0 NEXTCH = INPUT(1) INP = 1 MAXINP=1 CGOLAB=0 FNLST=0 NOTFLAG=0 PCT=0 SFMK=0 !* PATH=ANALYSE(TRIADS,MAXTRIADS,NEXTTRIAD,LTYPE,ADICT,LIN) !* %IF SUBPROGTYPE = 0 %AND NEXTCH # NL %THENSTART; ! MUST BE A MAIN PROGRAM !{2900} PTR=LOCATE NAME("ICL9HFMAIN") {PERQ} PTR=LOCATE NAME("F_MAIN") I=NEW SUBPROGRAM(PTR,0,ER);! MAIN PROGRAM GENERATE(TRIADS,NEXTTRIAD,0,-2,RESCOM1,COMAD);! register private label LTYPE = TLTYP; ! ORIGINAL CLASSIFICATION (OVER-RIDDEN BECAUSE SUBPROGTYPE WAS 0) -> ANALYSE LINE %FINISH !* %IF PATH#3 %AND CURSTATCLASS=0 %AND NEXTCH=10 %C %THEN STATORDERMODE=4;! executable statement !* %IF LAB = 0 %THENSTART !! %IF LABWARN#0 %THEN WARNING(1) PTR = 0 %FINISHELSESTART I=SETLAB(LAB,PTR) LABREC==RECORD(ADICT+PTR) %IF LABREC_LINE # 0 %THENSTART; ! LABEL ADDRESS ALREADY SPECIFIED IFAULT(227,LABREC_LINE); ! LABEL SET TWICE ->AFTER LABEL %FINISH LABREC_LINE=LINEST %IF CURSTATCLASS=0 %THEN CURSTATCLASS=2 LABREC_X0=LABREC_X0!CURSTATCLASS;! 1 non-exec 2 exec %IF LABREC_X0&8 # 0 %THENSTART IFAULT(228,LABREC_LINK5); ! LAB IS A FORMAT LABEL %FINISH %IF DOPTR#0 %THENSTART DOREC==RECORD(ADICT+DOPTR) LABREC_DOSTART=DOREC_LINE;! start of DO enclosure LABREC_DOEND=X'7FFF' I=NEW LIST CELL(DOREC_LABLIST,2) SS==RECORD(ADICT+I) SS_INF0=PTR %FINISH !* %IF IFPTR#0 %THENSTART IFREC==RECORD(ADICT+IFPTR) LABREC_IFSTART=IFREC_LINE;! start of IF block enclosure I=NEW LIST CELL(IFREC_LABLIST,2) SS==RECORD(ADICT+I) SS_INF0=PTR %FINISH !* SPTR=LABREC_LINK2;! LIST OF FORWARD REFERENCES %WHILE SPTR#0 %CYCLE SS==RECORD(ADICT+SPTR) CHECK LAB REF FREE LIST CELL(SPTR,3);! abandon these list cells now that triads are used %REPEAT LABREC_LINK2=0;! new entries will be set in CODEGEN SPTR=LABREC_LINK3;! LIST OF GLA WORDS TO HOLD LABEL @ %WHILE SPTR#0 %CYCLE SS==RECORD(ADICT+SPTR) %IF SS_INF2#0 %THEN CHECK LAB REF;! AVOID CHECK FOR ASSIGNED LABELS SPTR=SS_LINK1 %REPEAT %FINISH AFTER LABEL: !* GENERATE(TRIADS,NEXTTRIAD,LIN,PATH,PTR,COMAD) !* %IF SUBPROGTYPE < 0 %THENSTART;! END OF SUBPROGRAM FAULTY=FAULTY+FNO NEWLINES(3) %IF OPTIONS1&1=0;! SEPARATION WHEN NOT CE !{2900} %IF OPTIONS1&X'10'#0 %THEN ->LOOP;! separate modules requested ANALINIT NEXT TRIAD=1 %FINISH -> NEXT STATEMENT !* %END;! ANAL LOOP !* !* !* %EXTERNALINTEGERFN ANALSTART(%RECORD(TRIADF)%ARRAYNAME TRIADS, %INTEGER MAXTRIADS,ADCOM, %INTEGER ADICT0,ANAMES0,AMT,AM) %INTEGER I,J {PERQ}%BYTEINTEGERARRAY QINPUT(0:1329) {PERQ}%BYTEINTEGERARRAY QIBUFF(0:1329) {PERQ}%BYTEINTEGERARRAY QTYPE(0:1329) {PERQ}%BYTEINTEGERARRAY QCHMARK(0:1329) {PERQ}%INTEGERARRAY QLHEAD(0:155) {PERQ} INPUT==ARRAY(ADDR(QINPUT(0)),INPUTF) {PERQ} IBUFF==ARRAY(ADDR(QIBUFF(0)),INPUTF) {PERQ} TYPE==ARRAY(ADDR(QTYPE(0)),INPUTF) {PERQ} CHMARK==ARRAY(ADDR(QCHMARK(0)),INPUTF) {PERQ} LHEAD==ARRAY(ADDR(QLHEAD(0)),LHEADF) COMAD=ADCOM;! address of common data area ADICT=ADICT0 ANAMES=ANAMES0 ADMESST=AMT ADMESS=AM LINE NO=-1 LINEST=0 WARNCOUNT=0;! INDIVIDUAL COUNTS FOR EACH SUBPROG MESSCOUNT=0 COMMONBASE=0 HEADINGS=0 DIAGHEADS=0 ADIDENT=ADDR(IDENTIFIER) ADERRIDEN=ADDR(ERRIDEN) !* !{2900} I=OPTIONS1>>1;! R8,L8,I8 FLAGS AT RHS !{2900} J=(I&4)<<2;! R8 IF # 0 !{2900} %IF J=0 %THEN REAL LENGTH=4 %ELSE REAL LENGTH=8 !{2900} DP LENGTH=REAL LENGTH<<1 !{2900} DEFAULT SIZE(2)=X'52'+J !{2900} DEFAULT SIZE(3)=X'53'+J !{2900} DEFAULT SIZE(6)=X'62'+J !{2900} J=(I&2)<<3;! L8 IF # 0 !{2900} %IF J=0 %THEN LOGICAL LENGTH=4 %ELSE LOGICAL LENGTH=8 !{2900} DEFAULT SIZE(4)=X'54'+J !{2900} J=(I&1)<<4;! I8 IF # 0 !{2900} %IF J=0 %THEN INTEGER LENGTH=4 %ELSE INTEGER LENGTH=8 !{2900} DEFAULT SIZE(1)=X'51'+J !{2900} DEFAULT SIZE(5)=X'05';! CHARACTER !* !* %RESULT=ANAL LOOP(TRIADS,MAXTRIADS) !* %END;! ANALSTART !* %EXTERNALINTEGERFN GET COMAD COMAD=ADDR(CONTROL) %RESULT=COMAD %END;! GET COMAD !* %ENDOFFILE