%ENDOFLIST %CONSTSHORTINTEGERARRAY MAIN(1 : 359) = %C 1, 7, 13, 18, 22, 25, 29, 33, 37, 40, 47, 51, 54, 59, 62, 65, 68, 72, 76, 80, 84, 90, 94, 98, 103, 108, 113, 118, 122, 127, 135, 139, 0, 141, 144, 145, 152, 0, 157, 159, 161, 163, 0, 165, 167, 168, 169, 174, 0, 178, 181, 182, 186, 187, 188, 189, 0, 199, 202, 0, 205, 206, 207, 209, 0, 211, 213, 0, 215, 218, 0, 220, 226, 230, 233, 235, 238, 241, 243, 245, 247, 249, 0, 251, 253, 254, 256, 257, 259, 261, 263, 0, 265, 267, 268, 269, 272, 274, 275, 277, 279, 281, 0, 283, 285, 0, 287, 289, 0, 291, 294, 298, 301, 303, 304, 305, 306, 308, 309, 311, 312, 0, 316, 320, 321, 324, 325, 331, 0, 333, 338, 339, 341, 343, 347, 0, 351, 353, 355, 356, 357, 359, 361, 363, 365, 367, 369, 371, 373, 375, 377, 379, 0, 381, 382, 383, 0, 389, 396, 402, 403, 409, 410, 416, 417, 419, 422, 0, 424, 426, 0, 428, 435, 439, 0, 442, 444, 445, 447, 449, 451, 453, 455, 457, 459, 0, 461, 464, 0, 466, 469, 472, 476, 479, 481, 483, 485, 487, 490, 493, 495, 498, 501, 504, 506, 508, 511, 514, 517, 521, 523, 525, 529, 534, 536, 538, 540, 543, 0, 546, 547, 548, 550, 0, 552, 554, 555, 556, 557, 559, 560, 562, 0, 564, 566, 0, 569, 572, 573, 580, 589, 596, 0, 601, 605, 0, 607, 610, 0, 614, 616, 619, 622, 624, 627, 0, 630, 634, 635, 638, 639, 0, 645, 647, 648, 0, 653, 658, 659, 661, 0, 664, 666, 0, 668, 670, 671, 673, 0, 675, 677, 679, 680, 681, 682, 683, 686, 687, 688, 693, 694, 697, 700, 704, 0, 706, 710, 711, 712, 713, 718, 0, 720, 721, 722, 724, 728, 733, 736, 742, 750, 0, 756, 759, 760, 0, 768, 772, 773, 775, 776, 777, 778, 779, 780, 785, 790, 797, 801, 806, 811, 816, 819, 822, 0, 828, 829, 830, 832, 833, 835, 0, 838, 841, 842, 845, 0, 848, 854, 857, 858, 865, 0, 870, 873, 0, 877, 880, 882 %CONSTSHORTINTEGERARRAY SUB(2 : 883) = %C 24576, 4167, 28672, 4191, -4096, 0, 4202, 4251, 4156, 4364, -4096, 0, 4153, 4156, 4367, -4096, 0, 1, 4149, -4096, 0, 7, -4096, 0, 14, 4370, -4096, 0, 4345, 4342, -4096, 0, 21, 4205, -4096, 0, 25, -4096, 0, 4375, 4260, 4379, -8192, 4384, -4096, 0, 31, -8192, -4096, 0, 4158,-24576, 0, 39, -8192, 4384, -4096, 0, 44, -4096, 0, 50, -4096, 0, 55, -4096, 0, 64, -8192, -4096, 0, 69, -8192, -4096, 0, 76, 4334, -4096, 0, 83, 12288, -4096, 0, 91,-32768, 4410, 4412, -4096, 0, 16384, 98, 4096, 0, 100, 4285, -4096, 0, 102, 107, 4161, -4096, 0, -8192, 4352, 98, 4096, 0, 4134, 4345, 4142, -4096, 0, 109, 76, 4131, -4096, 0, 119, 125, -4096, 0, 133, 4222, 4129, -4096, 0, 135, 24576, 4216, 28672, 4181, 4179, -4096, 0, 137, 4420, -4096, 0, -4096, 0, 139, 4222, 4129, 0, 24576, 4342, 28672, 141, -8192, 143, 0, 141, -8192, 143, 4339, 0, 109, 0, 145, 0, 149, 0, 155, 0, 164, 0, 166, 0, 168, -8192, 4410, -16384, 0,-32768, 4145, 4147, 0, 174, 4139, 20480, 0, 139,-32768, 4145, 4147, 0, 4151, 0, 4216, 174, 24576, 4222, 139, 28672, 4222, 139, 4222, 0, 4199, 4251, 0, 176, 4151, 0, 180, 0, 185, 0, 187, 0, 195, 0, 200, 0, 174, 4216, 0, 4222, 0, 24576, 4216, 28672, 4181, 4179, 0, 207,-28672, 4179, 0, 217, 4329, 0, 220, 0, 227, 4164, 0, 235, 4188, 0, 243, 0, 248, 0, 253, 0, 262, 0, 267, 0, 273, 4167, 0, 4183, 4222, 0, 277, 0, 174, 0, 280, 0, 217, 0, 243, 0, 12288, 0, 4194, 4251, 0, 176, 4151, 0, 283, 0, 286, 0, 293, 0, 299, 0, 293, 0, 299, 0, 283, 0, 286, 0, 305, 50, 0, 305, 308, 4210, 0, 305, 316, 0, 305, 321, 0, 325, 0, 328, 4216, 0, 328, -8192, 0, -8192, 4218, 4212, 0, 141, 4222, 4220, 143, 0, 139, 4222, 4220, 0, 4232, 24576, 4227, 28672, 4225, 0,-20480, 0, 4236, 24576, 4227, 28672, 4225, 0, 20480, 0, 4216, 0, 141, 4222, 143, 0, 185, 4222, 185, 0, 164, 0, 166, 0, 330, 0, 164, 0, 166, 0, 332, 0, 334, 0, 185, 0, 337, 0, 340, 0, 343, 0, 137, 0, 346, 0, 349, 0, 135, 0, 351, 0, 24576, 4249, 4267, 28672, 4253, 0, 273, 24576, 4249, 4267, 28672, 4256, 0, 355, 24576, 4249, 4267, 28672, 4258, 0, 273, 24576, 4249, 4267, 28672, 4256, 0, 355, 24576, 4249, 4267, 28672, 4258, 0, 125, 0, 4345, 4264, 0, 358, 0, 368, 0, 371, 0, 24576, 4222, 28672, 4273, 4222, 4414, 0, 141, 4251, 143, 0, 4216, 4271, 0, 277, 4216, 0, 174, 0, 133, 0, 375, 0, 378, 0, 380, 0, 383, 0, 385, 0, 217, 0, 135, -8192, 0, -8192, 0, 388, -8192, 0, 393, -8192, 0, 401, 4315, -8192, 0, 406, -8192, 0, 411, 0, 416, 0, 422, 0, 427, 0, 431, 4282, 0, 437, 4282, 0, 444, 0, 451, 444, 0, 454, -8192, 0, 461, 4326, 0, 468, 0, 475, 0, 483, 4322, 0, 486, 4322, 0, 491, 4322, 0, 498, 12288, 4324, 0, 503, 0, 510, 0, 516, -8192, 4320, 0, 521, -8192, 98, 16384, 0, 526, 0, 532, 0, 539, 0, 545, -8192, 0, 550, 4317, 0, 556, 0, 559, 0, 562, 0, 349, 4282, 0, 12288, 0, 139, 12288, 0, 137, 0, 12288, 0, 16384, 0, -8192, 4332, 0, 141, 4222, 143, 0, 566, -8192, 141, 4400, 4408, 143, 0, 39, 24576, -8192, 4214, 141, 28672, -8192, 143, 0, 24576, 4342, 141, 28672, -8192, 143, 0, 141, -8192, 143, 4339, 0, 39, -8192, 4214, 0, 4342, 0, 4381,-32768, 0, 168, 4416, 4356, 0, 573, 0, 581, 573, 0, 119, 573, 0, 102, 0, 195, 102, 0, 586, 4354, 0, 141, 4232, 12288, 143, 0, 141, 12288, 143, 0,-32768, 141, 4360, 143, 4358, 0, 139, 4356, 0, 4222, 98, 4222, 4362, 0, 139, 4222, 98, 4222, 4362, 0, 44, 0, 4167, 4370, 0, 1, 0, 4167, 0, 593, 4372, 0, 44, 0, 4167, 0, 155, 0, 598, 0, 605, 0, 39, 0, 168, 613, 0, 613, 0, 141, 4386,-32768, 4391, 143, 0, 4260, 4418, 0, 4345, 4381, 0, 76, 4393, 613, 0, 613, 0, 4398, 4386,-32768, 4391, 0, 168, 0, 168,-32768, 4410, 4412, 0,-32768, 0, 139, 0,-20480, 0, 4345, 4381,-32768, 0, 76, 4393, 613,-32768, 0, 613,-32768, 0, 4345, 168,-32768, 4410, 4412, 0, 76, 24576, 4395, 141, 28672, -8192, 143, 0, 76, 141, -8192, 143, 4395, 0, 4398, 4400, 4408, 0, 141, 4232, 12288, 98, 4232, 12288, 143, 0, 139,-32768, 4410, 4412, 0, 4273, 4222, 0, 566, 0, 613, 0, 8192, 12288, 139, 12288, 0, 8193, 12288, 139, 4440, 0, 8195, 12288, 139, 12288, 139, 4435, 0, 8197, 4435, 4433, 0, 8199, 12288, 139, 4435, 0, 8201, 4446, 139, 4435, 0, 8203, 4446, 139, 4446, 0, 8205, 12288, 0, 618, 12288, 0, 137, 12288, 139, 4431, 4216, 0, 623, 0, 139, 12288, 0, 4449, 0, 12288, 4438, 0, 141, 12288, 143, 0, 4449, 4438, 0, 12288, 4443, 0, 141, 12288, 139, 12288, 143, 0, 141, 12288, 143, 0, 12288, 141, 12288, 139, 12288, 143, 0, 4449, 141, 12288, 143, 0, -8192, 4452, 0, 378, 4329, 383, 0, 164, 12288, 0, 166, 12288, 0 %CONSTBYTEINTEGERARRAY LITERAL(1 : 624) = %C 5, 99, 121, 99, 108, 101, 6, 114, 101, 112, 101, 97, 116, 6, 102, 105, 110, 105, 115, 104, 3, 101, 110, 100, 5, 98, 101, 103, 105, 110, 7, 99, 111, 109, 112, 105, 108, 101, 4, 115, 112, 101, 99, 5, 115, 116, 97, 114, 116, 4, 108, 105, 115, 116, 8, 36, 82, 69, 83, 84, 65, 82, 84, 4, 101, 100, 105, 116, 6, 115, 101, 110, 100, 116, 111, 6, 114, 101, 99, 111, 114, 100, 7, 99, 111, 110, 116, 114, 111, 108, 6, 115, 119, 105, 116, 99, 104, 1, 58, 1, 36, 4, 114, 101, 97, 108, 1, 115, 9, 101, 120, 116, 114, 105, 110, 115, 105, 99, 5, 115, 104, 111, 114, 116, 7, 114, 111, 117, 116, 105, 110, 101, 1, 35, 1, 46, 1, 42, 1, 44, 1, 40, 1, 41, 3, 111, 119, 110, 5, 99, 111, 110, 115, 116, 8, 101, 120, 116, 101, 114, 110, 97, 108, 1, 43, 1, 45, 5, 97, 114, 114, 97, 121, 1, 61, 3, 102, 111, 114, 4, 116, 104, 101, 110, 1, 33, 7, 99, 111, 109, 109, 101, 110, 116, 4, 108, 111, 110, 103, 6, 110, 111, 114, 109, 97, 108, 9, 112, 114, 105, 110, 116, 116, 101, 120, 116, 2, 45, 62, 6, 114, 101, 116, 117, 114, 110, 7, 114, 101, 115, 117, 108, 116, 61, 7, 109, 111, 110, 105, 116, 111, 114, 4, 115, 116, 111, 112, 4, 101, 120, 105, 116, 8, 99, 111, 110, 116, 105, 110, 117, 101, 4, 116, 114, 117, 101, 5, 102, 97, 108, 115, 101, 3, 97, 110, 100, 2, 61, 61, 2, 60, 45, 2, 105, 102, 6, 117, 110, 108, 101, 115, 115, 5, 119, 104, 105, 108, 101, 5, 117, 110, 116, 105, 108, 2, 111, 102, 7, 112, 114, 111, 103, 114, 97, 109, 4, 102, 105, 108, 101, 3, 105, 110, 116, 2, 109, 101, 1, 95, 1, 92, 1, 38, 2, 33, 33, 2, 60, 60, 2, 62, 62, 2, 42, 42, 2, 47, 47, 1, 47, 3, 110, 111, 116, 2, 111, 114, 9, 112, 114, 101, 100, 105, 99, 97, 116, 101, 2, 102, 110, 3, 109, 97, 112, 2, 60, 61, 1, 60, 2, 62, 61, 1, 62, 2, 92, 61, 4, 69, 68, 73, 84, 7, 67, 79, 77, 80, 73, 76, 69, 4, 83, 69, 78, 68, 4, 73, 78, 70, 79, 4, 67, 79, 68, 69, 5, 78, 65, 77, 69, 83, 4, 68, 85, 77, 80, 3, 77, 65, 80, 5, 73, 78, 80, 85, 84, 6, 79, 85, 84, 80, 85, 84, 6, 83, 89, 78, 84, 65, 88, 2, 78, 79, 6, 68, 69, 76, 69, 84, 69, 6, 77, 76, 69, 86, 69, 76, 6, 67, 65, 78, 67, 69, 76, 7, 77, 79, 78, 73, 84, 79, 82, 2, 85, 80, 4, 68, 79, 87, 78, 6, 82, 69, 83, 85, 77, 69, 4, 84, 82, 65, 80, 6, 73, 71, 78, 79, 82, 69, 5, 87, 72, 69, 82, 69, 4, 76, 73, 83, 84, 4, 70, 73, 78, 68, 5, 70, 79, 82, 67, 69, 6, 83, 89, 83, 79, 85, 84, 5, 67, 76, 69, 65, 82, 4, 76, 79, 79, 75, 5, 84, 82, 65, 67, 69, 2, 84, 79, 2, 79, 78, 3, 79, 70, 70, 6, 102, 111, 114, 109, 97, 116, 7, 105, 110, 116, 101, 103, 101, 114, 4, 98, 121, 116, 101, 6, 115, 116, 114, 105, 110, 103, 4, 101, 108, 115, 101, 6, 115, 121, 115, 116, 101, 109, 7, 100, 121, 110, 97, 109, 105, 99, 4, 110, 97, 109, 101, 4, 80, 85, 84, 95, 1, 64 %CONSTSHORTINTEGERARRAY FAULT NO(0 : 110) = %C 0, 14, 31, 47, 60, 87, 106, 129, 149, 169, 193, 212, 226, 257, 273, 287, 300, 318, 332, 352, 379, 418, 437, 468, 490, 514, 542, 555, 583, 605, 627, 650, 673, 691, 706, 724, 742, 760, 780, 798, 812, 0, 835, 0, 862, 877, 893, 915, 930, 954, 0, 970, 987, 1003, 1019, 1034, 1057, 1074, 0, 0, 0, 0, 1089, 1102, 1120, 1136,0, 0, 0, 1150, 1173, 1195, 1235, 1274, 1300, 1328, 0, 0, 0, 0, 0, 1360, 1374, 1389, 1405, 0, 0, 0, 1420, 1440, 0, 0, 0, 0, 0, 0, 0, 1454, 1470, 1490, 0, 1507, 1521, 1542, 1562, 1577, 1593, 1609, 1619, 1639, 1657 %CONSTBYTEINTEGERARRAY FAULT TEXT(0 : 1672) = %C 13, 'U', 'N', 'K', 'N', 'O', 'W', 'N', ' ', 'F', 'A', 'U', 'L', 'T', 16, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'R', 'E', 'P', 'E', 'A', 'T', 'S', 15, 'L', 'A', 'B', 'E', 'L', ' ', 'S', 'E', 'T', ' ', 'T', 'W', 'I', 'C', 'E', 12, '%', 'S', 'P', 'E', 'C', ' ', 'F', 'A', 'U', 'L', 'T', 'Y', 26, 'S', 'W', 'I', 'T', 'C', 'H', ' ', 'V', 'E', 'C', 'T', 'O', 'R', ' ', 'N', 'O', 'T', ' ', 'D', 'E', 'C', 'L', 'A', 'R', 'E', 'D', 18, 'S', 'W', 'I', 'T', 'C', 'H', ' ', 'L', 'A', 'B', 'E', 'L', ' ', 'E', 'R', 'R', 'O', 'R', 22, 'S', 'W', 'I', 'T', 'C', 'H', ' ', 'L', 'A', 'B', 'E', 'L', ' ', 'S', 'E', 'T', ' ', 'T', 'W', 'I', 'C', 'E', 19, 'N', 'A', 'M', 'E', ' ', 'D', 'E', 'C', 'L', 'A', 'R', 'E', 'D', ' ', 'T', 'W', 'I', 'C', 'E', 19, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'P', 'A', 'R', 'A', 'M', 'E', 'T', 'E', 'R', 'S', 23, 'P', 'A', 'R', 'A', 'M', 'E', 'T', 'E', 'R', ' ', 'O', 'F', ' ', 'W', 'R', 'O', 'N', 'G', ' ', 'T', 'Y', 'P', 'E', 18, 'T', 'O', 'O', ' ', 'F', 'E', 'W', ' ', 'P', 'A', 'R', 'A', 'M', 'E', 'T', 'E', 'R', 'S', 13, 'L', 'A', 'B', 'E', 'L', ' ', 'N', 'O', 'T', ' ', 'S', 'E', 'T', 30, 'G', 'E', 'N', 'E', 'R', 'A', 'L', ' ', 'T', 'Y', 'P', 'E', ' ', 'P', 'A', 'R', 'A', 'M', 'E', 'T', 'E', 'R', ' ', 'M', 'I', 'S', 'U', 'S', 'E', 'D', 15, '%', 'R', 'E', 'P', 'E', 'A', 'T', ' ', 'M', 'I', 'S', 'S', 'I', 'N', 'G', 13, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'E', 'N', 'D', 'S', 12, 'T', 'O', 'O', ' ', 'F', 'E', 'W', ' ', 'E', 'N', 'D', 'S', 17, 'N', 'A', 'M', 'E', ' ', 'N', 'O', 'T', ' ', 'D', 'E', 'C', 'L', 'A', 'R', 'E', 'D', 13, 'N', 'O', 'T', ' ', 'A', ' ', 'R', 'O', 'U', 'T', 'I', 'N', 'E', 19, 'S', 'W', 'I', 'T', 'C', 'H', ' ', 'V', 'E', 'C', 'T', 'O', 'R', ' ', 'E', 'R', 'R', 'O', 'R', 26, 'W', 'R', 'O', 'N', 'G', ' ', 'N', 'U', 'M', 'B', 'E', 'R', ' ', 'O', 'F', ' ', 'P', 'A', 'R', 'A', 'M', 'E', 'T', 'E', 'R', 'S', '&', 'S', 'W', 'I', 'T', 'C', 'H', '/', 'R', 'E', 'C', 'O', 'R', 'D', 'F', 'O', 'R', 'M', 'A', 'T', '/', 'P', 'R', 'E', 'D', 'I', 'C', 'A', 'T', 'E', ' ', 'I', 'N', ' ', 'E', 'X', 'P', 'R', 'N', 18, 'N', 'A', 'M', 'E', ' ', 'N', 'O', 'T', ' ', 'S', 'P', 'E', 'C', 'I', 'F', 'I', 'E', 'D', 30, 'A', 'C', 'T', 'U', 'A', 'L', ' ', 'P', 'A', 'R', 'A', 'M', 'E', 'T', 'E', 'R', ' ', 'O', 'F', ' ', 'W', 'R', 'O', 'N', 'G', ' ', 'T', 'Y', 'P', 'E', 21, 'R', 'O', 'U', 'T', 'I', 'N', 'E', ' ', 'N', 'A', 'M', 'E', ' ', 'I', 'N', ' ', 'E', 'X', 'P', 'R', 'N', 23, 'R', 'E', 'A', 'L', ' ', 'I', 'N', 'S', 'T', 'E', 'A', 'D', ' ', 'O', 'F', ' ', 'I', 'N', 'T', 'E', 'G', 'E', 'R', 27, 'C', 'Y', 'C', 'L', 'E', ' ', 'V', 'A', 'R', 'I', 'A', 'B', 'L', 'E', ' ', 'N', 'O', 'T', ' ', '%', 'I', 'N', 'T', 'E', 'G', 'E', 'R', 12, '%', 'F', 'A', 'U', 'L', 'T', ' ', 'E', 'R', 'R', 'O', 'R', 27, '%', 'T', 'R', 'U', 'E', '/', '%', 'F', 'A', 'L', 'S', 'E', ' ', 'O', 'U', 'T', ' ', 'O', 'F', ' ', 'C', 'O', 'N', 'T', 'E', 'X', 'T', 21, 'R', 'O', 'U', 'T', 'I', 'N', 'E', ' ', 'N', 'O', 'T', ' ', 'D', 'E', 'S', 'C', 'R', 'I', 'B', 'E', 'D', 21, 'L', 'H', 'S', ' ', 'N', 'O', 'T', ' ', 'A', ' ', 'D', 'E', 'S', 'T', 'I', 'N', 'A', 'T', 'I', 'O', 'N', 22, '%', 'R', 'E', 'T', 'U', 'R', 'N', ' ', 'O', 'U', 'T', ' ', 'O', 'F', ' ', 'C', 'O', 'N', 'T', 'E', 'X', 'T', 22, '%', 'R', 'E', 'S', 'U', 'L', 'T', ' ', 'O', 'U', 'T', ' ', 'O', 'F', ' ', 'C', 'O', 'N', 'T', 'E', 'X', 'T', 17, 'L', 'A', 'B', 'E', 'L', ' ', 'M', 'E', 'A', 'N', 'I', 'N', 'G', 'L', 'E', 'S', 'S', 14, 'O', 'U', 'T', ' ', 'O', 'F', ' ', 'C', 'O', 'N', 'T', 'E', 'X', 'T', 17, 'T', 'E', 'X', 'T', 'U', 'A', 'L', ' ', 'L', 'E', 'V', 'E', 'L', ' ', '>', ' ', '9', 17, 'R', 'O', 'U', 'T', 'I', 'N', 'E', ' ', 'L', 'E', 'V', 'E', 'L', ' ', '>', ' ', '5', 17, 'F', 'A', 'U', 'L', 'T', ' ', 'U', 'N', 'T', 'R', 'A', 'P', 'P', 'A', 'B', 'L', 'E', 19, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'D', 'I', 'M', 'E', 'N', 'S', 'I', 'O', 'N', 'S', 17, 'C', 'O', 'N', 'S', 'T', 'A', 'N', 'T', ' ', 'O', 'V', 'E', 'R', 'F', 'L', 'O', 'W', 13, 'R', 'E', 'A', 'L', ' ', 'E', 'X', 'P', 'O', 'N', 'E', 'N', 'T', 22, 'D', 'E', 'C', 'L', 'A', 'R', 'A', 'T', 'I', 'O', 'N', 'S', ' ', 'M', 'I', 'S', 'P', 'L', 'A', 'C', 'E', 'D', 26, 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'I', 'N', ' ', 'A', 'R', 'I', 'T', 'H', 'M', 'E', 'T', 'I', 'C', ' ', 'E', 'X', 'P', 'R', 'N', 14, 'C', 'O', 'N', 'S', 'T', 'A', 'N', 'T', ' ', 'E', 'R', 'R', 'O', 'R', 15, 'O', 'W', 'N', ' ', 'A', 'R', 'R', 'A', 'Y', ' ', 'E', 'R', 'R', 'O', 'R', 21, 'R', 'E', 'C', 'O', 'R', 'D', ' ', 'L', 'E', 'N', 'G', 'T', 'H', 'S', ' ', 'D', 'I', 'F', 'F', 'E', 'R', 14, 'D', 'A', 'N', 'G', 'L', 'I', 'N', 'G', ' ', '%', 'E', 'L', 'S', 'E', 23, 'S', 'U', 'B', 'S', 'T', 'I', 'T', 'U', 'T', 'E', ' ', 'C', 'H', 'A', 'R', ' ', 'I', 'N', ' ', 'T', 'E', 'X', 'T', 15, 'N', 'O', 'T', ' ', 'A', ' ', 'P', 'R', 'E', 'D', 'I', 'C', 'A', 'T', 'E', 16, 'S', 'P', 'U', 'R', 'I', 'O', 'U', 'S', ' ', '%', 'F', 'I', 'N', 'I', 'S', 'H', 15, '%', 'R', 'E', 'P', 'E', 'A', 'T', ' ', 'M', 'I', 'S', 'S', 'I', 'N', 'G', 15, '%', 'F', 'I', 'N', 'I', 'S', 'H', ' ', 'M', 'I', 'S', 'S', 'I', 'N', 'G', 14, 'S', 'P', 'U', 'R', 'I', 'O', 'U', 'S', ' ', '%', 'E', 'X', 'I', 'T', 22, '%', 'E', 'X', 'T', 'E', 'R', 'N', 'A', 'L', 'R', 'O', 'U', 'T', 'I', 'N', 'E', ' ', 'F', 'O', 'U', 'N', 'D', 16, '%', 'E', 'N', 'D', 'O', 'F', 'F', 'I', 'L', 'E', ' ', 'F', 'O', 'U', 'N', 'D', 14, '%', 'B', 'E', 'G', 'I', 'N', ' ', 'M', 'I', 'S', 'S', 'I', 'N', 'G', 12, 'W', 'R', 'O', 'N', 'G', ' ', 'F', 'O', 'R', 'M', 'A', 'T', 17, '%', 'R', 'E', 'C', 'O', 'R', 'D', 'S', 'P', 'E', 'C', ' ', 'E', 'R', 'R', 'O', 'R', 15, 'S', 'U', 'B', 'N', 'A', 'M', 'E', ' ', 'M', 'I', 'S', 'S', 'I', 'N', 'G', 13, 'W', 'R', 'O', 'N', 'G', ' ', 'S', 'U', 'B', 'N', 'A', 'M', 'E', 22, 'S', 'U', 'B', 'N', 'A', 'M', 'E', ' ', 'O', 'U', 'T', ' ', 'O', 'F', ' ', 'C', 'O', 'N', 'T', 'E', 'X', 'T', 21, 'I', 'N', 'V', 'A', 'L', 'I', 'D', ' ', 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'L', 'E', 'N', 'G', 'T', 'H','''', 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'E', 'X', 'P', 'R', 'N', ' ', 'C', 'O', 'N', 'T', 'A', 'I', 'N', 'S', ' ', 'N', 'O', 'N', '-', 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'E', 'N', 'T', 'I', 'T', 'Y', '&', 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'E', 'X', 'P', 'R', 'N', ' ', 'C', 'O', 'N', 'T', 'A', 'I', 'N', 'S', ' ', 'I', 'N', 'V', 'A', 'L', 'I', 'D', ' ', 'O', 'P', 'E', 'R', 'A', 'T', 'O', 'R', 25, 'R', 'E', 'S', 'O', 'L', 'U', 'T', 'I', 'O', 'N', ' ', 'O', 'U', 'T', ' ', 'O', 'F', ' ', 'C', 'O', 'N', 'T', 'E', 'X', 'T', 27, 'R', 'E', 'S', 'O', 'L', 'U', 'T', 'I', 'O', 'N', ' ', 'F', 'O', 'R', 'M', 'A', 'T', ' ', 'I', 'N', 'C', 'O', 'R', 'R', 'E', 'C', 'T', 31, 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'E', 'X', 'P', 'R', 'N', ' ', 'C', 'O', 'N', 'T', 'A', 'I', 'N', 'S', ' ', 'S', 'U', 'B', '-', 'E', 'X', 'P', 'R', 'N', 13, 'I', 'T', 'E', 'M', ' ', '=', '=', ' ', 'E', 'X', 'P', 'R', 'N', 14, 'N', 'O', 'T', ' ', 'A', 'N', ' ', 'A', 'D', 'D', 'R', 'E', 'S', 'S', 15, 'N', 'O', 'N', ' ', 'E', 'Q', 'U', 'I', 'V', 'A', 'L', 'E', 'N', 'C', 'E', 14, 'R', 'E', 'C', 'O', 'R', 'D', ' ', 'M', 'I', 'S', 'U', 'S', 'E', 'D', 19, 'N', 'O', 'T', ' ', 'A', 'N', ' ', 'A', 'R', 'R', 'A', 'Y', ' ', 'F', 'O', 'R', 'M', 'A', 'T', 13, 'A', 'R', 'R', 'A', 'Y', ' ', 'M', 'I', 'S', 'U', 'S', 'E', 'D', 15, 'N', 'O', ' ', 'A', 'C', 'T', 'I', 'V', 'E', ' ', 'B', 'R', 'E', 'A', 'K', 19, 'O', 'W', 'N', ' ', 'A', 'R', 'R', 'A', 'Y', ' ', 'T', 'O', 'O', ' ', 'L', 'A', 'R', 'G', 'E', 16, 'N', 'O', ' ', 'B', 'A', 'S', 'E', ' ', 'R', 'E', 'G', 'I', 'S', 'T', 'E', 'R', 13, 'L', 'I', 'N', 'E', ' ', 'T', 'O', 'O', ' ', 'L', 'O', 'N', 'G', 20, 'L', 'O', 'N', 'G', ' ', 'A', 'N', 'A', 'L', 'Y', 'S', 'I', 'S', ' ', 'R', 'E', 'C', 'O', 'R', 'D', 19, 'D', 'I', 'C', 'T', 'I', 'O', 'N', 'A', 'R', 'Y', ' ', 'O', 'V', 'E', 'R', 'F', 'L', 'O', 'W', 14, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'N', 'A', 'M', 'E', 'S', 15, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'L', 'E', 'V', 'E', 'L', 'S', 15, 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'T', 'O', 'O', ' ', 'L', 'O', 'N', 'G', 9, 'A', 'S', 'L', ' ', 'E', 'M', 'P', 'T', 'Y', 19, 'E', 'N', 'D', ' ', 'O', 'F', ' ', 'F', 'I', 'L', 'E', ' ', 'R', 'E', 'A', 'C', 'H', 'E', 'D', 17, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'R', 'O', 'U', 'T', 'I', 'N', 'E', 'S', 15, 'B', 'U', 'F', 'F', 'E', 'R', ' ', 'O', 'V', 'E', 'R', 'F', 'L', 'O', 'W' %CONSTBYTEINTEGERARRAY OPC(0 : 120) = 0, 8,9,X'10',X'11',X'12', X'13',X'20',X'21',X'22',X'23', X'30',X'31',X'32',X'33',X'24', X'34',0,X'45',X'46',X'47', X'54',X'55',X'56',X'57',X'58',X'59',X'5A',X'5B',X'5C', X'5D',X'5E',X'5F',X'68',X'69',X'6A', X'6B',X'6C',X'6D',X'6E',X'6F', X'78',X'79',X'7A',X'7B',X'7C', X'7D',X'7E',X'7F',0,X'70', X'60',X'50',X'4E',X'4F',X'4C', X'4B',X'4A',X'49',X'48',X'44', X'43',X'42',X'41',X'40',0, X'90',X'98',X'86',X'87',0, X'91',X'92',X'94',X'95',X'96', X'97',X'9C',X'9E',X'9D',X'9F', X'82',X'84',X'85',0,X'88', X'89',X'8A',X'8B',X'8C',X'8D', X'8E',X'8F',0,X'D0',X'D1', X'D2',X'D4',X'D5',X'D6',X'D7', X'D8',X'DC',X'DD',X'DE',X'DF', X'D3',0,X'F1',X'F2',X'F3', X'F8',X'F9',X'FA',X'FB',X'FC', X'FD',0,10,4,X'80' %CONSTINTEGERARRAY NEM(0 : 120) = M'CNOP', M'SSK',M'ISK',M'LP',M'LN',M'LT', M'LC',M'LPD',M'LND',M'LTD',M'LCD', M'LPE',M'LNE',M'LTE',M'LCE',M'HD', M'HE',0,M'BAL',M'BCT',M'BC', 'N',M'CL','O','X','L','C','A','S','M','D', M'AL',M'SL',M'LD',M'CD',M'AD', M'SD',M'MD',M'DD',M'AW',M'SW', M'LE',M'CE',M'AE',M'SE',M'ME', M'DE',M'AU',M'SU',0,M'STE', M'STD',M'ST',M'CVD',M'CVB',M'MH', M'SH',M'AH',M'CH',M'LH',M'EX', M'IC',M'STC',M'LA',M'STH',0, M'STM',M'LM',M'BXH',M'BXLE',0, M'TM',M'MVI',M'NI',M'CLI',M'OI', M'XI',M'SDV',M'HDV',M'TDV',M'CKC', M'PC',M'WRD',M'RDD',0,M'SRL', M'SLL',M'SRA',M'SLA',M'SRDL',M'SLDL', M'SRDA',M'SLDA',0,M'SSP',M'MVN', M'MVC',M'NC',M'CLC',M'OC',M'XC', M'LSP',M'TR',M'TRT',M'ED',M'EDMK', M'MVZ',0,M'MVO',M'PACK',M'UNPK', M'ZAP',M'CP',M'AP',M'SP',M'MP', M'DP',0,M'SVC',M'SPM',M'IDL' %TRUSTEDPROGRAM %LIST !*********************************************************************** !* * !* * !* IMP INTERPRETER VERSION 8 WITH MONITORING * !* * !* * !*********************************************************************** ! ! ! !**************************************************************** !* * !* STACKTOP : CODE TOP : ASTACK : APERM : GLA HEAD * !* * !* R9 : R10 : R11 : R12 : R13 * !* * !**************************************************************** ! ! !*** STREAM DEFINITIONS *** ! ! STREAM 79 OUTPUT ! STREAM 78 INPUT ! ! ! !*************************************************************** !* * !* GLA LAYOUT * !* * !* 0 : 0 - 0 ARRAY DEC FLAG * !* 0+: 1 - 3 0 TRAP RECORD ADDR * !* 1 : 4 - 7 X'50000000' LANGUAGE FLAG * !* 2 : 8 - 11 X'E2E2E2E2' DIAGS TERMINATOR * !* 3 : 12 - 15 FAULT TRAP WORD * !* 4 : 16 - 19 -1 CONSTANT FOR '\' * !* 5 : 20 - 21 DIAG BLOCK INDEX * !* 5+: 22 - 23 DIAG LINE NUMBER * !* 6 : 24 - 27 X'000000FF' BYTE MASK * !* 7 : 28 - 31 8 DIAG TABLE DISP * !* 8 : 32 - 35 FREE ARRAY SPACE * !* 9 : 36 - 39 ARRAY SPACE LIMIT * !* 10 : 40 - 43 PERM WORK SPACE * !* 11 : 44 - 55 PERM ENTRY INFO * !* 14 : 56 - 59 STRING LENGTH (RSLN) * !* 15 : 60 - 63 @ END OF STACK * !* 16 : 64 - 67 PERM WORK * !* 17 : 68 - 71 X'80000000' FLOATING CONSTANT * !* 18 : 72 - 75 X'4E000000' FLOATING CONSTANT * !* 19 : 76 - 81 *MVC_0(0,1),0(14) * !* 20+: 82 - 87 *MVC_0(0,2),0(1) * !* 22 : 88 - 95 X'8080808080808080' * !* 24 : 96 - 101 *MVC_0(0,1),0(2) * !* * !*************************************************************** ! !********************************************* !* * !* PERM ENTRY TABLE * !* * !* 0 : STOP SEQUENCE * !* 1 : 1-DIM ARRAY REFERENCE * !* 2 : N-DIM ARRAY REFERENCE * !* 3 : UNASSIGNED VARIABLE * !* 4 : CAPACITY EXCEEDED * !* 5 : MONITORSTOP * !* 6 : FAULT TRAP * !* 7 : MONITOR * !* 8 : SWITCH CHECKING + JUMP * !* 9 : RESOLUTION FAILS * !* 10 : CYCLE TESTING * !* 11 : INTEGER EXPONENTIATION * !* 12 : REAL EXPONENTIATION * !* 13 : NON-INTEGER QUOTIENT * !* 14 : STRING CONCATENATION * !* 15 : STRING RESOLUTION (FIRST ENTRY) * !* 16 : STRING RESOLUTION (OTHER ENTRIES) * !* 17 : SET ARRAY SPACE UNASSIGNED * !* 18 : ARRAY DECLARATION * !* 19 : STRING COMPARISON * !* 20 : PRINTTEXT * !* 21 : RESULT NOT SPECIFIED * !* 22 : EXCESS BLOCKS * !* 23 : CALL IOCP * !* 24 : TEST FOR EXCESS BLOCKS IN ROUTINE * !* 25 : ROUTINE FAULTY * !* 26 : RELOCATE ARRAYS * !* 27 : CLAIM LEVEL 1 ARRAY SPACE * !* 28 : CLAIM LEVEL N ARRAY SPACE * !* 29 : CORRUPT DOPE-VECTOR * !* 30 : BULK MOVE * !* 31 : ROUTINE NOT DESCRIBED * !* 32 : SET RECORD TO ZERO * !* 33 : MONITORING ENTRY FOR ROUTINES * !* * !********************************************* ! ! ! ! !****************************************************** !* * !* COMPILER FAULTS * !* * !* 200 : NO FREE REGISTERS * !* 201 : REGISTER NOT CLAIMED * !* * !* 208 : REAL INDEX REGISTER * !* 209 : REMOVE NON-EXISTANT LABEL * !* 210 : ZERO ASSOP * !* * !* 212 : CORRUPT COMPILER NAME * !* * !* 220 : ROUTINE ENTRY NOT CLAIMED * !* 221 : MAIN ROUTINE ENTRY LOST * !* 222 : ROUTINE HAS NO ENTRY POINT * !* * !* 240 : CANNOT RESTORE ROUTINE ENTRY POINT * !* * !* 250 : DUPLICATE BLOCK FOR SEND TO * !* 255 : DUPLICATE COMPILER NAME * !* * !****************************************************** ! ! ! !********************************************************************** !* * !* VAR FLAGS : 1 %SPEC WANTED * !* 2 %SPEC GIVEN : DEFINITION WANTED * !* 4 PARAMETER * !* 8 ASSIGN VIA '==' * !* 16 TYPE OF ROUTINE * !* 32 TYPE OF ROUTINE * !* 64 ASSOP = 1 * !* 128 ASSOP = 2 * !* * !********************************************************************** ! ! !************************************************ !* * !* VAR TYPES * !* * !* 0 : CONSTANT * !* 4 : INTEGER * !* 5 : BYTEINTEGER * !* 6 : SHORTINTEGER * !* 7 : RECORD * !* 8 : REAL * !* 10 : LONGREAL * !* 13 : GENERAL TYPE * !* 14 : PREDICATE * !* 15 : ROUTINE * !* 31 : RECORDFORMAT * !* 64 : SWITCH * !* 128+: ARRAYFORMAT * !* * !************************************************ !********************************************************* !* * !* VAR_FORM : 1 SCALAR * !* 2 NAME * !* 4 ARRAY * !* 8 RFMP / INDEX LIST * !* 16 == * !* 32 * !* 64 * !* 128 IN A REGISTER * !* * !********************************************************* ! ! ! !*************************************************** !* * !* COMP MODE 1 INPUT FROM TEXTP * !* 2 %EDIT * !* 4 ROUTINE/FN/MAP/BEGIN * !* 8 START/CYCLE * !* 16 ROUTINE/FN/MAP * !* 32 EDIT FLAG * !* 64 INPUT NOT FROM .TT * !* 128 FAULTY BLOCK * !* * !*************************************************** ! ! !******************************************** !* * !* CONTROL OPTIONS * !* * !* 1 : OUTPUT COMPILED CODE * !* 2 : PERMIT SIGNAL REPORTING * !* 3 : PRINT REGISTER USEAGE * !* 4 : EXTRA INFO * !* 5 : GIVE DUMP AT SIGNALS * !* 6 : MAKE INT:Q == INT:H * !* 7 : INHIBIT DIAG TABLE * !* 8 : INHIBIT UNASSIGNED CHECKING * !* * !******************************************** ! %CONSTINTEGERARRAY FIXEDGLA(0 : 29) = %C 0, X'50000000', X'E2E2E2E2', 0, -1, 0, X'FF', 8, 0(9), X'80000000', X'4E000000', X'D2001000', X'E000D200', X'20001000', X'80808080', X'80808080', X'D2001000', X'20000000', 0(3), X'FF000000' %CONSTBYTEINTEGERARRAY DIAGMAP(0 : 191) = %C 0, 0, 4, 97, 99, 0, 4, 0(9), 0, 0, 8, 97, 99, 0, 4, 0(9), 0, 0, 16, 97, 99, 0, 255, 132, 0(8), 0, 0, 5, 97, 99, 0(11), 0, 0, 6, 97, 99, 0, 2, 0(9), 0, 0, 10, 97, 99, 0, 8, 0(9), 0, 0, 4, 83, 99, 0, 4, 0(9), 0, 0, 8, 83, 99, 0, 4, 0(9), 0, 0, 16, 83, 99, 0, 4, 0(9), 0, 0, 5, 83, 99, 0(11), 0, 0, 6, 83, 99, 0, 4, 0(9), 0, 0, 10, 83, 99, 0, 4, 0(9) ! ! ABOVE ARE VAR TAGS RECORDS FOR EXTERNAL DIAGS ! %CONSTBYTEINTEGERARRAY DTAB MAP(0 : 13) = %C 0, 1, 2, 0, 3, 0(3), 4, 0(4), 5 ! ! ! ! ! STRING FOR INITIAL '%BEGIN' PROMPT ! %CONSTBYTEINTEGERARRAY INITP(0 : 15) = %C 15, ' ', ' ', ' ', '%', 'B', 'E', 'G', 'I', 'N', 13, 10, ' ', ' ', ' ', ':' %CONSTBYTEINTEGERARRAY NAME FLAG(4 : 16) = %C 1, 9, 17, 0, 2, 0, 26, 0, 0, 0, 0, 0, 5 %CONSTBYTEINTEGERARRAY TYPE CODE(1 : 7) = 4,5,6,8,10,16,7 %CONSTSHORTINTEGERARRAY ROUND(0 : 16) = %C 3, 3, 3, 3, 3, 0, 1, 3, 3, 3, 7, 3, 3, 3, 3, 3, 3 %CONSTSHORTINTEGERARRAY VBYTES(1 : 6) = %C 4, 1, 2, 4, 8, 4 %CONSTINTEGERARRAY OPCODE(0 : 24) = %C 0, X'1A', X'1B', X'14', X'17', X'16', 0(3), X'1C', X'1D', X'1D', 0, X'2A', X'2B', 0(6), X'2C', 0, X'2D', 0 %CONSTSHORTINTEGERARRAY CONCODE(1 : 8) = %C 8, 7, 13, 4, 11, 2, 7, 0 %CONSTSHORTINTEGERARRAY PARMMASK(0 : 7) = %C 15,12,13,0,26,26,15,15 %CONSTSHORTINTEGERARRAY PATTERN(0 : 7) = %C 0, 4, 1,0,24,26, 0, 0 %CONSTSHORTINTEGERARRAY LOADTYPE(0 : 16) = %C 4, 0(3), 4(3), 0, 10, 0, 10, 10, 0(4), 16 %CONSTSHORTINTEGERARRAY LOADCODE(0 : 16) = %C X'41', 0(3), X'58', X'43', X'48', -64, X'7A', 0, X'68', X'68', 0, -12, -23(2), X'41' %CONSTSHORTINTEGERARRAY STORECODE(0 : 16) = %C 0(4), X'50', X'42', X'40', -64, X'70', 0, X'60', 0(3), -20, 0, -71 %CONSTBYTEINTEGERARRAY CNTYPE(0 : 54) = %C 4, 4, 4, 4, 10, 10, 16, 4, 4, 16, 4, 4, 16, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 16, 4, 16, 4, 4, 4, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 4, 4, 4, 4, 4, 4, 4 %CONSTINTEGER RTMONENTRY = X'45FC0084'; ! ENTRY FOR MONITORING %CONSTINTEGER PERMSNL = X'4110C0C0' %CONSTINTEGER RTBASE = X'D070'; ! ADDRESS OF FIRST ROUTINE DESC. %CONSTINTEGER RESFLOP = X'C024'; ! PERM ENTRY FOR 'RESOLUTION FAILS' %CONSTINTEGER LIST SIZE = 4000; ! SIZE OF ARRAY FOR CELLS %CONSTINTEGER DATA FDP = 28; ! FDP NUMBER FOR LOADING DATA AREAS %CONSTINTEGER LOAD FDP = 28; ! FDP NUMBER FOR DYNAMIC LOADING %CONSTINTEGER FDP DATA REF = 'X'; ! SPECIAL FOR NOW %CONSTINTEGER FDP REF = 'E'; ! TYPE OF LOAD ! !######################## START OF MAIN PROGRAM ######################## ! %BEGIN %RECORDFORMAT AGFM(%INTEGER EP,%STRING(17) NAME, %C %INTEGER P1,P2, %INTEGERNAME FLAG) %RECORDFORMAT MON DIAG HEAD FM(%INTEGER DIAGS, %C %SHORTINTEGER LINE, NAME, %INTEGER INDEX, LINK) %RECORDFORMAT RTFM(%INTEGER CODE, GLA, EP, ENVIR) %RECORDFORMAT RBFM(%INTEGER LINK, TEXT, LENGTH, ENTRIES) %RECORDFORMAT BFM(%BYTEINTEGER FLAGS, TYPE, TYPE2, MODE, %C %SHORTINTEGER DISP, MAX DISP, %C %INTEGER SHEAD, LHEAD, R10, AD, X1, X2, X3) %RECORDFORMAT BLOCKFM(%SHORTINTEGER ADDR, %C %BYTEINTEGER SPARE, TYPE, %INTEGER CYCLE, ELSE, LINK) %RECORDFORMAT LABELFM(%INTEGER LABEL, ADDRESS, USE, LINK) %RECORDFORMAT VARFM(%SHORTINTEGER ADDRESS, %C %BYTEINTEGER TYPE, FORM, LEVEL, DIMENSION, LENGTH, %C FLAGS, %INTEGER INDEX, LINK) %DYNAMICROUTINESPEC HEX(%INTEGER N) %SYSTEMROUTINESPEC IIGEN(%STRING (8) S, %INTEGERNAME J, K) %SYSTEMROUTINESPEC IIDUMP(%INTEGER J, K) %SYSTEMROUTINESPEC DECODE(%INTEGER J, K, L) %DYNAMICROUTINESPEC CLEAR(%STRING (63) S) %DYNAMICROUTINESPEC DEFINE(%STRING (63) S) %SYSTEMROUTINESPEC RIM(%INTEGER CONSOLE, %STRING (15) S) %DYNAMICROUTINESPEC EDINNER( %C %INTEGER ST, SL, SEC1, SEC2, AWSP, %INTEGERNAME L) ! ST = @ START OF TEXT ! SL = LENGTH OF INPUT FILE ! AWSP = @ WORK SPACE ! L = INITIAL/FINAL LENGTH OF OUTPUT FILE %DYNAMICSTRINGFNSPEC TIME %DYNAMICSTRINGFNSPEC DATE %DYNAMICINTEGERFNSPEC TESTINT(%INTEGER C, %STRING (15) S) %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %SYSTEMROUTINESPEC I8INIT( %C %INTEGER DICT, NLADDR, DIAG, SYSOUT, IOUT, GLA, PERM, %C MODE) %SYSTEMROUTINESPEC AGENCY(%INTEGER EP, %RECORDNAME P) %SYSTEMROUTINESPEC PDIAG(%INTEGER A, B, C) %SYSTEMROUTINESPEC ITRAP(%INTEGER X, Y) %SYSTEMROUTINESPEC UNTRAP ! !*** LOCAL SPECS *** ! %ROUTINESPEC SIGNAL(%INTEGER EP,PARM,X,%INTEGERNAME FLAG) %ROUTINESPEC FDP(%INTEGER EP,%STRING(17) S, %C %INTEGER P1,P2,%INTEGERNAME F) %ROUTINESPEC RESET IO %ROUTINESPEC LOAD PERM %ROUTINESPEC STOP %ROUTINESPEC D C NAMES %ROUTINESPEC SEND TO %ROUTINESPEC DOT NAME %ROUTINESPEC HASH EXPRNS %ROUTINESPEC SKIPEXPRN %ROUTINESPEC FMESSAGE(%INTEGER N) %ROUTINESPEC FAULT(%INTEGER N) %ROUTINESPEC FAULT2(%INTEGER N, NAME) %INTEGERFNSPEC R V LEN(%INTEGER PT) %ROUTINESPEC C B PAIR(%INTEGERNAME L, R) %ROUTINESPEC SET UAV PAT(%INTEGER BYTES, AD1) %INTEGERFNSPEC NEW RT %ROUTINESPEC VTYPE(%RECORDNAME V) %ROUTINESPEC QNAME(%RECORDNAME V) %ROUTINESPEC RT(%RECORDNAME V) %ROUTINESPEC D DEC(%INTEGER N, AD, L, MODE) %ROUTINESPEC C NAME LIST(%INTEGER NAMES, BYTES) %ROUTINESPEC C L NAME LIST(%INTEGER BYTES) %ROUTINESPEC DECLARE %ROUTINESPEC COMP P LIST(%INTEGER NEW, OLD) %ROUTINESPEC DEC FP LIST(%INTEGER HEAD) %ROUTINESPEC C REC DEC(%INTEGER FLAG) %ROUTINESPEC C FP DEFN(%RECORDNAME HEADER) %ROUTINESPEC C RFM DEC %ROUTINESPEC C A DECLN %ROUTINESPEC RELEASE RT(%INTEGER N) %ROUTINESPEC MOVE(%INTEGER L, F, T) %ROUTINESPEC EDIT(%BYTEINTEGER MODE) %ROUTINESPEC DEFINE RT %ROUTINESPEC RESTRUCTURE(%INTEGER BP) %ROUTINESPEC TIDY LABELS %ROUTINESPEC TIDY STARTS %ROUTINESPEC TIDY(%INTEGERNAME CELL) %ROUTINESPEC TIDY ALL %ROUTINESPEC OLD BLOCK %ROUTINESPEC C END %ROUTINESPEC SET DIAG(%INTEGER AD, NAME) %ROUTINESPEC NEW DIAG(%INTEGER AD) %INTEGERFNSPEC NEW CELL %ROUTINESPEC NEW BLOCK(%BYTEINTEGER T) %ROUTINESPEC PUSH(%INTEGERNAME HEAD, %INTEGER X, Y, Z) %INTEGERFNSPEC ENAME(%INTEGER LIST) %ROUTINESPEC GET4(%INTEGERNAME N) %ROUTINESPEC GET8(%LONGREALNAME R) %ROUTINESPEC GET CYCLE SPACE(%INTEGERNAME A) %INTEGERFNSPEC GET FORMAT(%INTEGER FNAME) %INTEGERFNSPEC GET NAME(%INTEGER NAME) %ROUTINESPEC S LOAD(%INTEGER STRING, REGISTER) %ROUTINESPEC CSEXPRN(%INTEGERNAME ADDRESS) %ROUTINESPEC FILL JUMPS(%RECORDNAME HEAD) %ROUTINESPEC REMOVE LABEL(%INTEGER LABEL) %ROUTINESPEC LABEL FOUND(%INTEGER LABEL) %ROUTINESPEC JUMP TO(%INTEGER LABEL, MASK) %INTEGERFNSPEC FORWARD ADDRESS(%INTEGER LEN) %INTEGERFNSPEC FORWARD REF(%INTEGER MASK) %INTEGERFNSPEC COND TYPE %ROUTINESPEC S COND(%INTEGER MASK, LABEL) %ROUTINESPEC COND(%INTEGER VALIDITY, FARLABEL) %ROUTINESPEC C COND(%INTEGER CTYPE) %ROUTINESPEC S CPE(%RECORDNAME V, %INTEGER EX) %ROUTINESPEC GETSVAR(%RECORDNAME V) %ROUTINESPEC GET NAME VAR(%RECORDNAME V, %INTEGER FLT) %ROUTINESPEC AVAILABLE(%INTEGERNAME REGISTER, %BYTEINTEGER TYPE) %ROUTINESPEC STUAV(%INTEGER REG) %ROUTINESPEC TESTUAV(%BYTEINTEGER T, %INTEGER REGISTER) %ROUTINESPEC SETTEXT(%BYTEINTEGER FLAG) %ROUTINESPEC PUT4(%INTEGER N) %ROUTINESPEC PUT8(%LONGREAL R) %ROUTINESPEC CCONST(%RECORDNAME V) %ROUTINESPEC GETINFO(%INTEGER NAME, %RECORDNAME VAR) %ROUTINESPEC RT SAVE(%INTEGER R2) %ROUTINESPEC C C NAME(%RECORDNAME V) %ROUTINESPEC VAR(%RECORDNAME V) %ROUTINESPEC CLAIMSAFEREGISTER(%INTEGERNAME REGISTER) %ROUTINESPEC RELEASEREGISTER(%INTEGER REGISTER) %ROUTINESPEC PROTECT(%BYTEINTEGER TYPE) %ROUTINESPEC EQUATETYPES(%RECORDNAME LHS, RHS) %ROUTINESPEC LOAD(%RECORDNAME V, %INTEGER R) %ROUTINESPEC LOADADDR(%RECORDNAME V, %INTEGER REG) %ROUTINESPEC EXPRN(%RECORDNAME LHS) %ROUTINESPEC STORE(%RECORDNAME VAR, DEST) %ROUTINESPEC ASSIGN(%RECORDNAME LHS, %INTEGER ASSOP) %ROUTINESPEC CUI(%INTEGER UTYPE) %INTEGERFNSPEC FOR CLAUSE; ! COMPILES (VAR) = A,B,C %ROUTINESPEC C FINISH %ROUTINESPEC PUT LINE %ROUTINESPEC CSS(%INTEGER SST) %ROUTINESPEC COMPILE BLOCK %ROUTINESPEC EXECUTE CODE %ROUTINESPEC PLANT(%INTEGER N) %ROUTINESPEC SPLANT(%INTEGER N) %ROUTINESPEC DRR(%INTEGER OPCODE, R1, R2) %ROUTINESPEC DRX(%INTEGER OPCODE, R1, X, AD) %ROUTINESPEC DSS(%INTEGER OPCODE, LENGTH, AD1, AD2) %ROUTINESPEC DSI(%INTEGER OPCODE, ADDR, IM) %INTEGERFNSPEC FIND(%INTEGER NAME) %INTEGERFNSPEC CONSTANT(%BYTEINTEGER TYPE) %INTEGERFNSPEC NAME %ROUTINESPEC RECONSTRUCT %ROUTINESPEC DEC CONST ARRAY(%INTEGER LEN) %ROUTINESPEC PRINT LABEL(%INTEGER LABEL) %ROUTINESPEC FIND CYCLE(%INTEGERNAME P) %ROUTINESPEC GET RESLN VAR(%INTEGERNAME ENTRY) %ROUTINESPEC FLOAT(%RECORDNAME VAR, %INTEGER REG) %ROUTINESPEC TEMPREAL(%INTEGERNAME ADDRESS) %ROUTINESPEC CRES(%INTEGER LABEL, MASK) %ROUTINESPEC SET CONST(%INTEGER WTYPE, SLEN, PLUS) %ROUTINESPEC C OWN DEC %ROUTINESPEC DUMP SIGNAL(%INTEGER L) %ROUTINESPEC CREATE DIAG LIST(%INTEGERNAME NLINK) %ROUTINESPEC DEFINE DIAGS(%INTEGER AGLA, BLOCK) %ROUTINESPEC SET UP MONITOR(%BYTEINTEGER MODE) %INTEGERFNSPEC ASL LENGTH %ROUTINESPEC SET FILE(%BYTEINTEGER FLAG, %STRING (3) STREAM) %ROUTINESPEC DEFINE TRACE %ROUTINESPEC SET CONTROL(%INTEGER N) %ROUTINESPEC COMPARE RT(%RECORDNAME V, %INTEGER LIST) %ROUTINESPEC SPECIAL(%INTEGER ST) %ROUTINESPEC UN CLAIM %ROUTINESPEC ABORT %ROUTINESPEC PRINT USE %ROUTINESPEC NAME INFO(%INTEGER NAME) %ROUTINESPEC PRINT RECORD(%RECORDNAME N) %ROUTINESPEC I8DIAG(%INTEGER EP) %ROUTINESPEC C SWITCH %ROUTINESPEC SW REF %ROUTINESPEC CREATE DUMMY REFS(%INTEGER LIST) %ROUTINESPEC INT DUMP %INTEGERFNSPEC MCODE(%INTEGER J) %ROUTINESPEC CNOP(%INTEGER A, B) %ROUTINESPEC CUCI ! ! EXTERNAL BREAK CONTROL ! %SHORTINTEGER MONITOR BLOCK, MONITOR LINE %INTEGER DPT, MONENTRY, MONITOR GLA %RECORDARRAYNAME DIAG VAR(VARFM) %RECORDARRAYFORMAT DIAGMAPFORM(0 : 11)(VARFM) %RECORDNAME DIAG HEAD(MON DIAG HEAD FM) %RECORD DIAG BASE(MON DIAG HEAD FM) ! ! ANALYSIS RECORD ARRAY ! %SHORTINTEGERARRAY REC(0 : 300) %INTEGERARRAY LISTS(1 : LIST SIZE), DICT(0 : 2048), DIAG TAB(-2048 : %C 0) %BYTEINTEGERARRAY LINE(0 : 301), REGUSE(4 : 8) %BYTEINTEGERARRAY RENTRY(0 : 127) %INTEGER RTP, BLOCK NAME, BLOCK ENTRY ! ! VECTOR FOR CO-ROUTINE ENTRY FROM S#IMPMON ! %OWNINTEGER BR9, BR10, BR11, BR12, BR13, BR14 %EXTERNALINTEGER BRK R9 AD; ! ADDRESS OF BR9 ! ! ! INTERRUPT HANDLING BUFFERS ! %OWNINTEGERARRAY INT SAVES(0 : 14); ! FOR MON ? %OWNINTEGERARRAY SAVEAREA(4 : 16); ! FOR SIGNAL %OWNINTEGERARRAY DCONTAREA(4 : 16); ! FOR DOUBLE CONTINGENCY %OWNINTEGERARRAY DLENV(4 : 14); ! ENVIRONMENT FOR DYNAMIC LOADING %OWNBYTEINTEGER WT, ERRNUM, INTQ FLAG, SPECIAL INT %OWNINTEGER SIGAREA, ELISTP, FAIL INFO %OWNBYTEINTEGER INTQ INFO, INTQ SYM ! ! VARIABLES FOR DYNAMIC LOADING OF EXTERNALS ! %OWNINTEGER D LOAD ENV, D LOAD ENTRY, DR11, D ENTRY %OWNINTEGER DLC, DLG, DLEP, DLRA, MISSING EP ! ! PROMPT CONTROL WORDS ! %OWNINTEGER PAT1 = X'04202020' %OWNBYTEINTEGER PROMPTCH = ':' ! ! BUFFER FOR EXTERNAL NAMES ! %STRING (8) IOFILE %BYTEINTEGERARRAY ENTRY LIST(0 : 127) ! ! CONTROL VARIABLES ! %BYTEINTEGER DCOMP, PERMIT, USE, HALT, DUMP, SHORT FORM, DIAGS, TUAV ! ! ! %INTEGER LAST ASL, ASL; ! KEEP IN THIS ORDER ! ! CODE CONTROL VARIABLES ! %INTEGER STACK, CSTART, CODEIN, CODE HEAD, CODE START %INTEGER CODE TOP, CODE END ! ! GLA AND OWN CONTROL VARIABLES ! %RECORDARRAY RTS(-7 : 255)(RTFM) %INTEGER OWN DISP, OWN TOP, OWN END, OWN LIST HEAD %INTEGER GLA, GLAP, OWNLIST, OWNNAME, OWNHEAD ! ! LABEL PROCESSING VARIABLES ! %INTEGER ILAB, START HEAD, LABEL HEAD, LABEL ADDRESS %INTEGER CYCLE LABEL, ELSE LABEL ! ! BASIC LEVEL TEXT CONTROL ! %INTEGER DEC START, DEC FILE, DEC LIMIT, DEC1, DEC2, FIRST CHAR ! ! ROUTINE TEXT CONTROL VARIABLES ! %INTEGER TEXT HEAD, XFLAG %INTEGER TEXTIN, TEXTP, OLD TEXT, LINE ENTRY, LINE START, LINE LENGTH ! ! DICTIONARY CONTROL VARIABLES ! %INTEGER DICTHEAD, DICTFREE, DICT MAX, FIRST, LAST ! ! DIAGNOSTIC CONTROL VARIABLES ! %INTEGER DIAG PT, DIAG END, DIAG SAVE, MON LABEL, PERM ERROR, %C DIAG FLAG ! ! NAME PROCESSING VARIABLES ! %RECORDNAME WORK(VARFM) %INTEGER FORMATP, VNAME, FMLEN, LHS INDEX, OLD INDEX, DOPE VECTOR ! ! REGISTER CONTROL VARIABLES ! %INTEGER BASE REG, GPR1, FPR2, AREG ! ! ! ! ! ! ROUTINE MONITORING CONTROL VARIABLES ! %BYTEINTEGER RTMONENABLE, MON FILE CREATED %INTEGER RT MON FILE, RT MON NAMES, RT MON HEAD %SHORTINTEGERARRAY MONNAME(0 : 127) ! ! %INTEGER CYC NUM, LINE NUM, RTNAME ! ! ! %BYTEINTEGER LIST, SYNTAX, FAULTY, REALS, SUSPEND, RUNNING, PRINTED, %C ACCESS ! %BYTEINTEGER DEC FLAG, FN TYPE, FN TYPE 2, MAPV, ZERO EXP %BYTEINTEGER C LIST, UAVFLAG, LEVEL, DIS FLAG, R14, EXPRN TYPE %BYTEINTEGER NLFLAG, NASTY, EXTRINSIC, SPEC, RTYPE, ALLIGNMENT %BYTEINTEGER FP MODE, CPE LEN, SNLEN, S CONST, BLOCKTYPE, DEFNUM, %C EDDEF ! %OWNBYTEINTEGER STUDENT = 1; ! DEFAULT IS A STUDENT %INTEGER J, K, L ! %INTEGER SM, SYM, RP, SMAX, DISP, MAX DISP ! %INTEGER ASSOP, EFREE, COND1, COND2, COM36, SYSOUT, IOUT, MLEVEL %BYTEINTEGER FIDDLE FACTOR ! ! SAVE VARIABLES FOR RUNNING CODE'S R9 - R14 ! MUST BE LEFT IN THIS ORDER! ! %INTEGER STACKTOP, R10, ASTACK, APERM, GLA HEAD, RTFAULTY ! %OWNINTEGER CONNECT ADDRESS ! %OWNINTEGER CODE, INITIAL STACK, OLD CODE TOP SAVE ! %OWNBYTEINTEGER RESTART = 0; ! FLAG FOR RESTARTING %INTEGERNAME DIAG BLOCK, END A SPACE, A SPACE %INTEGERNAME LIST HEAD, LIST END, ENDOFSTACK, INDEXPT %RECORDARRAY BLOCK INF(0 : 11)(BFM) %RECORDNAME BLOCK(BFM) %RECORD LHS, DUMMYNAME, NEW NAME(VARFM) ! ! COMMUNICATION VARIABLES FOR INTSYSTY ! %EXTERNALBYTEINTEGER INSTREAM = 0; ! INPUT STREAM WHEN RUNNING %EXTRINSICSTRING(15) P STRING %EXTRINSICINTEGER INTSIZE, REG9, MON REP %EXTERNALBYTEINTEGER COMP MODE = 0, IOFLAG = 0 %EXTRINSICBYTEINTEGER MONLOCK %EXTERNALINTEGER MONFRAME, MONINFO ! ! *OI_4(13),5 *ST_11,INITIAL STACK ! ! RELOAD:!************ RETURN HERE TO RESTART THE PROCESS ************ ! ! *L_11,INITIAL STACK L = INTSIZE+24; K = L<<12-16 %IF RESTART = 0 %START IIGEN('II#CODE',L,J); ! SET UP II#CODE PRINTSTRING('CANNOT CREATE WORK FILE ') %ANDSTOP %IF J # 0 CONNECT ADDRESS = L %FINISH *LH_1, *ST_1,J %STOP %IF J # X'0AFE' CODE = CONNECT ADDRESS DEC START = (CODE+K>>1)&X'FFFFF8' DECLIMIT = DECSTART+8000 DECFILE = DEC START; BYTEINTEGER(DEC FILE) = NL STACK = DEC LIMIT ! ! SET UP THE CO-ROUTINE VECTOR ! *LA_14, *STM_9,14,BR9 BRK R9 AD = ADDR(BR9) ! ! SET UP RETURN ADDRESS FOR I8DIAG. ! *LA_1, *ST_1,MON LABEL ! ! PRINTED = 2 %IF IOFLAG # 0 ! DISP = X'9040' ! ! SET UP DUMMY NAME (USED AFTER FAULT 16 ETC.) ! DUMMY NAME = 0 DUMMY NAME_LEVEL = 255 DUMMY NAME_TYPE = B'100' DUMMY NAME_FORM = B'10001'; ! SET THE NAME BIT FOR UNDECLARED NAMES DUMMY NAME_FLAGS = B'10010000'; ! ASSOP = 2, RT TYPE = 1 ! ! SET UP ROUTINE ENTRY LIST ! %CYCLE RTP = 0,1,127; RENTRY(RTP) = RTP %REPEAT ! ! DEFINE DEFAULT %CONTROL OPTIONS ! !! DCOMP = 0 ! NO CODE OUTPUT !! PERMIT = 0 ! NO SIGNAL REPORTING !! USE = 0 ! NO REGISTER USEAGE PRINTING !! HALT = 1 ! REPORT INT:Q !! DUMP = 0 ! NO DUMPS AFTER SIGNALS !! SHORT FORM = 0 ! NO EXTRA INFO !! DIAGS = 3 ! DUMP DIAG TABLES/ LINE NOS !! TUAV = 1 ! UNASSIGNED CHECKING ON SET CONTROL(X'00010031') ! INITIALIZE ROUTINE MONITORING ! MON FILE CREATED = 0 RT MON ENABLE = 0 ! UAVFLAG = 0; SNLEN = 0; SPECIAL INT = 0 START HEAD = 0; SMAX = 0; CYC NUM = 0; DEFNUM = 0 MAPV = 0; NLFLAG = 0 LIST = 'Y'; RUNNING = 'N'; SYNTAX = 'Y' DIS FLAG = 0; C LIST = 0; PRINTED = 0 EXTRINSIC = 0; ! NOT OWN OR EXTRINSIC LABEL HEAD = 0; LINE ENTRY = 0 R14 = 0; REALS = 4; LEVEL = 0; FN TYPE = 3 ! '%BEGIN' EFREE <- X'B000'; BASE REG = 9; ILAB = X'FFFF0000' ! ! SET UP THE USER'S GLA ! GLA HEAD = ADDR(RTS(-7)_CODE); GLA = ADDR(RTS(128)_CODE) *L_1,FIXED GLA; *L_2,GLA HEAD; *MVC_0(120,2),0(1) ! SET UP GLA *ST_2,12(2,0) LOAD PERM STRING(GLA) = '*CONSTANTS:'; GLA = GLA+12 ! ! SET UP THE END OF STACK MARKER IN GLA ! ENDOFSTACK == RTS(-4)_ENVIR *L_2,ENDOFSTACK *L_1,68(13) *LA_0,4092(0,0); *SR_1,0 *ST_1,0(2) ! ! NOW SET UP TEXT HEAD HALF WAY DOWN THE FREE STACK ! *AR_1,11 *SRL_1,1(0); ! DIVIDE BY TWO *ST_1,TEXT HEAD ! ! ! A SPACE == RTS(-5)_CODE; END A SPACE == RTS(-5)_GLA A SPACE = STACK+4096; END A SPACE = CODE+K ! ! DEFINE ENTRY POINTS INTO PERM ERROR ROUTINES ETC. ! RTFAULTY = 25<<2+APERM PERM ERROR = APERM+31<<2 ! ! ! MLEVEL = X'FFFF' DIAG BLOCK == RTS(-6)_GLA CODE = CODE+32; ! TO LEAVE A BIT OF SPACE IN CASE OF TROUBLE CODEIN = CODE; CODE HEAD = CODEIN; R10 = CODEIN CODE END = DEC START-16 DIAG VAR == ARRAY(ADDR(DIAG MAP(0)),DIAG MAP FORM) DIAG BASE = 0; ! BASE FOR EXTERNAL DIAG INFO DIAGEND = ADDR(DIAG TAB(0)); DIAG SAVE = DIAG END DIAG PT = DIAG SAVE STACKTOP = STACK REG9 = STACK TOP BLOCK == BLOCK INF(0); BLOCK_TYPE = 0 BLOCK TYPE = 0; BLOCK ENTRY = -1; ! '%BEGIN' ! AREG = ADDR(REG USE(4)) *L_1,AREG; *XC_0(5,1),0(1); ! CLEAR REGUSE ! ! CLEAR THE HASHING AREA FOR NAMES ! *L_1,DICT *LA_2,17 DZER: *XC_0(250,1),0(1) *LA_1,250(1) *BCT_2, ! ! SET UP THE ASL (THIS TAKES TIME !!! ! J = ADDR(LISTS(1))&X'FFFFF0' ASL = ADDR(LISTS(LIST SIZE))&X'FFFFF0'-16 *L_1,J; *LA_2,16; *L_3,ASL; *XC_12(4,1),12(1) 117: *ST_1,28(1); *BXLE_1,2,<117> ! %CYCLE P=J,16,ASL: INTEGER(J+28)=J: %REPEAT ! ! DICT HEAD = ADDR(DICT(0)) DICT FREE = DICT HEAD+4096 DICT MAX = DICTHEAD+8180 CODESTART = CODE HEAD CODE TOP = CODE HEAD A STACK = STACKTOP+128 D C NAMES; ! DECLARE INTRINSIC NAMES SYSOUT = 0; IOUT = 0 ! ! GIVE INTSYSTY ITS PARAMETERS FOR COMMUNICATING BACK HERE ! THESE ARE NOT DONE USING EXTERNALS TO SAVE LODING TIME ! I8INIT(DICTHEAD,ADDR(NLFLAG),ADDR(DIAGPT),ADDR(SYSOUT), %C ADDR(IOUT),GLAHEAD,APERM,RESTART) ! ! DISCRIMINATE AGAINST STUDENTS ! *XC_80(16,11),80(11); ! CLEAR THE BUFFER *MVI_81(11),160; ! SERVICE NUMBER *MVI_95(11),7; ! SFI NUMBER *LD_0,80(11) *LD_2,88(11) SVCX: *SVC_254 *STD_4,80(11) *MVC_STUDENT(1),81(11) *NI_STUDENT,1 ! ! ! COMPILE IN THE INITIAL %BEGIN TO GET THINGS GOING ! CSS(9); COMP MODE = COMP MODE&64; ! LEAVE I/O BIT FOR SETTING SPECS ! INTEGER(CODE HEAD) = 0; ! NOTE: CODEIN=CODEHEAD HERE SO CSS(9) ! WILL HAVE CORRUPTED THIS WORD !!! IOFLAG = IOFLAG&1; ! REMOVE EXTRA BIT SET BY IMPIP %IF RESTART = 0 %START ! ! RESET COMREG(36) TO POINT TO TOP OF USER'S STACK, INSTEAD OF ! THE INTERPRETER'S STACK, TO HELP RECOVER FROM FAILURES ! IN EXTERNAL ROUTINES ! COM36 = COMREG(36); COMREG(36) = STACKTOP %FINISH ! ! THIS CODE IS TO DIRECT RETURNS FROM THE SYSTEM ! MONITOR INTO THE INTERPRETER, INSTEAD OF DIRECT BACK ! TO COMMAND LEVEL. ! *L_3,96(13); ! STOP VECTOR ADDRESS *SLR_1,1 ; ! NO FAULTS TRAPPED *L_2,STACKTOP; ! INITIAL STACK VALUE *STM_1,2,16(3); ! SET UP FOR FIRST ERROR *STM_1,2,0(2); ! SET UP FOR SUBSEQUENT ERRORS ! !****************. ! DIAG PT = DIAG PT-2; SHORTINTEGER(DIAG PT) = 0 ! END OF BASIC DIAGS SIGNAL(1,0,0,J); ! REMOVE 'DIAGS' SIGNAL SO AS TO TRAP ERRORS ! IN EXTERNAL ROUTINES DIAG SAVE = DIAG PT I8DIAG(0) %IF RESTART = 0; ! INITIALIZE DIAGS ! ! NOW SET UP THE DATA FOR DYNAMIC LOADING ! *L_1,DLENV+4; ! @ DLENV(4) *ST_1,D LOAD ENV *STM_4,14,0(1); ! SAVE CONTEXT *LA_1, *ST_1,D LOAD ENTRY *LA_1, *ST_1,MISSING EP ! RESTART = 1; ! SHOW RUNNING ONCE %PRINTTEXT ' IMP Interpreter' %IF STUDENT = 0 %THEN %PRINTTEXT ' Version 8d' %C %ELSE %PRINTTEXT ' Student Version' NEWLINES(2) ! ! GIVE %BEGIN PROMPT ! RIM(0,STRING(ADDR(INITP(0)))); J = NEXTSYMBOL ! TO FORCE IT OUT SKIPSYMBOL %AND J = NEXTSYMBOL %WHILE J = NL ! ! SET UP PROMPT INFO ! P STRING = 'DATA:'; ! IN CASE OF $RESTART INTEGER(STACKTOP+16) = COMREG(50);! TEMP @ CURPROMPT INTEGER(STACKTOP+20) = ADDR(P STRING) ! ! SET TRAP FOR DOUBLE CONTINGENCY ! DCONT: *L_1,DCONTAREA; ! J = ADDR(DCONTAREA(0)) *ST_1,J *LA_15,; ! RETURN ADDRESS FROM DOUBLE CONTINGENCY *STM_4,15,16(1); ! SAVE RECOVERY INFO *MVI_60(1),8; ! SET PROGRAM MASK (I THINK ??) SIGNAL(0,J+16,0,K); ! STACK SIGNAL ! ! RESET DIAGNOSTIC POINTERS & OWN ARRAY INFO ! DIAG PT = DIAG SAVE ! OWN DISP = 0 OWN LIST HEAD = 0 OWN END = END A SPACE OWN TOP = OWN END ! ! ! FIDDLE FACTOR = STUDENT -> SET ERROR ! ! DOUBLE CONTINGENCIES COME HERE ! DCTRAP: *STC_2,WT; ! WEIGHT OF SIGNAL RESET IO LEVEL = 1; ! IN CASE OF TROUBLE %IF WT # 128 %START %PRINTTEXT ' ***** CATASTROPHIC FAILURE'; WRITE(WT,1) %PRINTTEXT ' ***** ' %STOP %IF RESTART = 2 %FINISH %PRINTTEXT ' ' -> DCONT ! ! I8DIAG RETURNS TO HERE AFTER GIVING DIAGNOSTICS FOR ! CONTINGENCIES. ! INT RETURN: *L_1,INT SAVES; ! ADDRESS OF RECOVERY INFO FROM %MONITOR *LM_0,13,0(1); ! RESET REGISTERS -> SET ERROR ! ! TOP LEVEL SIGNALS COME HERE ! ERROR: *ST_1,SIGAREA; ! SAVE THE ADDRESS OF FAILURE SAVE AREA *STC_2,WT; ! SAVE THE WEIGHT *ST_3,INTQ INFO; ! SAVE INTQ SYMBOL (FOR INT:H) *L_1,4(1); ! L = FAILURE ADDRESS *ST_1,FAIL INFO *L_1,INT SAVES *STM_0,13,0(1) RESET IO %AND %PRINTTEXT ' ** CANCEL ** ' %C %AND -> CANCEL %IF WT = 244 -> RELOAD %IF WT = 240; ! RESTART FROM '%ENDOFINT' ! ! EXAMINE THE SIGNAL WEIGHT AND CONVERT IT INTO THE IMP FAULT NUMBER ! %IF RUNNING = 'N' %START %IF WT = 120 %OR WT = 100 %START FAULT(38) INTEGER(SIGAREA+8) = 0; ! CLEAR NEW REG 0 TO PREVENT ! TOO MANY FAULT 38'S INT Q FLAG = 1 -> RESUME COMPILATION %FINISH %IF WT = 132 %OR WT = 128 %START %IF WT = 128 %START %PRINTTEXT ' ' %AND -> CANCEL %IF INTQ SYM = 'H'+32 ! LOWER CASE %PRINTTEXT ' INT:Q ignored ' %FINISH %ELSE %PRINTTEXT ' TIME EXCEEDED (IGNORED) ' INT Q FLAG = 1 -> RESUME COMPILATION %FINISH %FINISH RESET IO %IF RUNNING = 'Y' %AND PERMIT&1 = 0 %START ERRNUM = 255 ERRNUM = 34 %IF WT = 92; ! ADDRESS ERROR ERRNUM = 13 %IF WT = 128; ! INT Q ERRNUM = 17 %IF WT = 104; ! DIVIDE ERROR ERRNUM = 1 %IF WT = 120; ! INTEGER OVERFLOW ERRNUM = 2 %IF WT = 100; ! REAL OVERFLOW ERRNUM = 12 %IF WT = 132; ! TIME EXCEEDED ERRNUM = 29 %IF WT = 136; ! OUTPUT EXCEEDED ERRNUM = 35 %IF WT = 84; ! UNEXPLAINED INTERRUPT %IF WT = 88 %START; ! ILLEGAL OPCODE %IF SPECIAL INT = 0 %THEN ERRNUM = 36 %ELSE %START SPECIAL INT = 0 ERRNUM = 0 %FINISH %FINISH ERRNUM = 18 %IF WT = 144; ! SUBSTITUTE CHAR IN DATA ERRNUM = 37 %IF WT = 152; ! STREAM NOT DEFINED %PRINTTEXT ' ' %AND -> SET ERROR %C %IF WT = 128 %AND (INTQ SYM = 'H' %C %OR INTQ SYM = 'H'+32) ! INT:H I8DIAG(ERRNUM) %IF ERRNUM # 255 %FINISH %IF WT = 140 %START; ! INPUT FILE ENDED I8DIAG(9) %IF RUNNING = 'Y' FAULT(108) CLOSE STREAM(78); CLEAR('ST78') COMPMODE = COMP MODE&B'10111111' -> SET ERROR %FINISH ! ! ALL HAS FAILED, SO SAY WHAT HAS HAPPENED ! ! ! SHOW A SIGNAL OCCURED ! %PRINTTEXT ' * SIGNAL WT' WRITE(WT,1) %PRINTTEXT ' at ' %AND HEX(FAIL INFO) %IF PERMIT&2 # 0 ! ! CALL I8DIAG FOR A MONITOR IF THE SIGNAL CAME FROM THE USER ! NEWLINES(2) %AND I8DIAG(0) %IF RUNNING = 'Y' %AND DUMP = 0 %IF RUNNING = 'N' %START ! ! THE INTERPRETER HAS FAILED !!!!! ! CLOSE OFF ANY OUTSTANDING BLOCKS AND TRY TO CARRY ON SAFELY ! %PRINTTEXT ' in compiler ' FAULT(48) %IF LEVEL > 1; ! JUST FOR FUN CANCEL: ! ENTRY POINT FROM ** CANCEL INTERRUPT %WHILE LEVEL > 1 %CYCLE RP = 0; REC(1) = 5; ! PSEUDO %END C END; ! FORCE AN END JUST IN CASE %REPEAT TIDY STARTS; TIDY LABELS DEFINE RT %IF COMP MODE&16 # 0 DIAG PT = DIAG SAVE %FINISH %PRINTTEXT ' ' -> SET ERROR %IF DUMP = 0 ! ! GIVE A DUMP OF THE CONTEXT OF THE ERROR ! DUMP SIGNAL(FAIL INFO); -> SET ERROR ! ! ! CO-ROUTINE ENTRY POINT FOR S#IMPMON ! EXT BREAK:SET UP MONITOR(0); -> EXT BREAK0 ! ! ! MEP: ! UNSATISFIED ENTRIES COME HERE ! *L_1,12(12); ! POINTER TO NAME *LR_2,11; ! STACK FRAME POINTER *LM_4,14,0(13); ! RESTORE INT ENVIRONMENT *LA_11,64(2); ! TO FREE SPACE *STM_1,2,J; ! REMEMBER THEM PRINTSTRING(' invalid call on '.STRING(J).' ') SPECIAL INT = 1; ! SHOW A FORCED SIGNAL COMING *L_2,K; ! OLD STACK FRAME POINTER *LM_4,14,16(2); ! RESTORE CONTEXT OF CALL ATTEMPT *PUT_0; ! FORCE ILLEGAL OPCODE ! ! DYNAMIC LOAD: ! DYNAMIC REFERENCES COME HERE FOR LOADING *LR_1,11 *LR_2,12 *LM_4,14,0(13) ; ! PICK UP THE INTERPRETER'S CONTEXT *STM_1,2,DR11; ! SAVE PARAMETERS *LA_11,4000(1); ! BUT LEAVE THE STACK ALONE *ST_15,DLRA ; ! REMEMBER THE RETURN ADDRESS ! IOFILE <- STRING(INTEGER(D ENTRY+12)); ! PICK UP THE ROUTINE NAME DLG = D LOAD ENV DLEP = D LOAD ENTRY; ! IN CASE OF OTHER DYNAMICS FDP(LOAD FDP,IOFILE,FDP REF,ADDR(DLC),L) %IF L # 0 %START; ! IF FAILED PRINTSTRING('dynamic loading of '.IOFILE.' fails ') SPECIAL INT = 1; ! SHOW FORCED INT COMING *L_11,DR11; ! RESTORE STACK FRAME *LM_4,14,16(11); ! RESTORE ENTRY CONTEXT *PUT_0; ! FORCE ILLEGAL OPCODE ! %FINISH ! I8DIAG WILL SEND ERRORS MILES AWAY FROM HERE !! L = COMREG(7) CREATE DUMMY REFS(L) %IF L # 0 INTEGER(D ENTRY) = DLC INTEGER(D ENTRY+4) = DLG INTEGER(D ENTRY+8) = DLEP ! FROM NOW ON THE ROUTINE WILL BE ENTRED DIRECTLY *L_11,DR11 *LM_12,15,DLC *BCR_15,14; ! GET INTO IT AT LAST ! !*** END OF DYNAMIC LOADING *** ! ! !*********************************************************************** ! %ROUTINE SIGNAL(%INTEGER EP, PARM, X, %INTEGERNAME FLAG) %RECORD P(AGFM) P_EP = EP P_P1 = PARM P_P2 = X P_FLAG == FLAG AGENCY(2, P) %END %ROUTINE FDP(%INTEGER EP,%STRING(17) S,%INTEGER P1,P2,%INTEGERNAME F) AGENCY(1, RECORD(ADDR(EP))) %END %ROUTINE SEND TO %SHORTROUTINE %INTEGER P, T, L, N, TP, J, M %RECORDNAME BLOCK(RBFM) %INTEGERARRAY NUM, TXT, TL(0 : 255) %CYCLE P = 0,1,255; NUM(P) = -1 %REPEAT P = CODE N = 0 %WHILE INTEGER(P) # 0 %CYCLE N = N+1 BLOCK == RECORD(P) P = BLOCK_LINK T = BLOCK_TEXT L = BLOCK_LENGTH TP = T>>24 FAULT(250) %IF NUM(TP) >= 0 NUM(TP) = N TXT(N) = T; TL(N) = L %REPEAT ! NOW OUTPUT LEVEL 1 DECLARATIONS %CYCLE J = DEC START,1,DEC FILE PRINTSYMBOL(BYTEINTEGER(J)) %REPEAT ! %CYCLE P = 0,1,DEFNUM M = NUM(P) %IF M >= 0 %START %PRINTTEXT ' ' T = TXT(M) %CYCLE J = T,1,T+TL(M)-1 PRINTSYMBOL(BYTEINTEGER(J)) %REPEAT %PRINTTEXT ' ' %FINISH %REPEAT %PRINTTEXT ' %ENDOFFILE ' SELECT OUTPUT(0) CLOSE STREAM(79) WRITE(N,1) %PRINTTEXT ' procedure' %PRINTTEXT 's' %IF N # 1 %PRINTTEXT ' output to file ' PRINTSTRING(IOFILE) NEWLINE %END %ROUTINE LOAD PERM %SHORTROUTINE %INTEGER F, R12, R13, R14 FDP(LOAD FDP,'S#I8PERM',FDP REF,ADDR(R12),F) %IF F # 0 %START %PRINTTEXT 'FAILED TO LOAD PERM'; WRITE(F,1) %PRINTTEXT ' '; %STOP %FINISH *L_1,GLA HEAD *MVC_44(12,1),R12; ! PERM REFERENCE IN GLA APERM = R14 %END %ROUTINE STOP ! COMREG 36 IS USED TO RETURN TO PREVIOUS LEVEL ! FROM THE IMP/IMPS MONITOR COMREG(36) = COM36; ! RESET 'TOP OF STACK' POINTER SIGNAL(1,0,0,J); ! REMOVE MY SIGNAL INFO *LM_4,15,16(9) *BCR_15,15 %END %ROUTINE D C NAMES ! DECLARES COMPILER NAMES E.G. ADDR,PRINT,READ ETC. ! THE INITIAL CALL ON NEW CELL IS TO STOP A DUBIOUS ADDRESS ! BEING PLANTED IN THE INDEX FIELD OF THE FIRST NAME. ! THE FORMAT OF THE NAME LIST IN 'BINAMES' IS :: ! , ,,,....., ! THE LIST IS TERMINATED BY A ZERO NAME NUMBER %SHORTROUTINE %ENDOFLIST %CONSTBYTEINTEGERARRAY BINAMES(0 : 467) = %C 1, 7, 73, 78, 84, 69, 71, 69, 82, 2, 11, 66, 89, 84, 69, 73, 78, 84, 69, 71, 69, 82, 3, 12, 83, 72, 79, 82, 84, 73, 78, 84, 69, 71, 69, 82, 4, 4, 82, 69, 65, 76, 5, 8, 76, 79, 78, 71, 82, 69, 65, 76, 6, 6, 83, 84, 82, 73, 78, 71, 7, 6, 82, 69, 67, 79, 82, 68, 8, 6, 76, 69, 78, 71, 84, 72, 9, 8, 84, 79, 83, 84, 82, 73, 78, 71, 10, 4, 65, 68, 68, 82, 11, 2, 78, 76, 12, 3, 83, 78, 76, 13, 4, 82, 69, 65, 68, 14, 10, 82, 69, 65, 68, 83, 89, 77, 66, 79, 76, 15, 6, 82, 69, 65, 68, 67, 72, 16, 10, 82, 69, 65, 68, 83, 84, 82, 73, 78, 71, 17, 8, 82, 69, 65, 68, 73, 84, 69, 77, 18, 5, 87, 82, 73, 84, 69, 19, 5, 80, 82, 73, 78, 84, 20, 7, 80, 82, 73, 78, 84, 70, 76, 21, 11, 80, 82, 73, 78, 84, 83, 84, 82, 73, 78, 71, 22, 11, 80, 82, 73, 78, 84, 83, 89, 77, 66, 79, 76, 23, 7, 80, 82, 73, 78, 84, 67, 72, 24, 7, 78, 69, 87, 76, 73, 78, 69, 25, 8, 78, 69, 87, 76, 73, 78, 69, 83, 26, 7, 78, 69, 87, 80, 65, 71, 69, 27, 5, 83, 80, 65, 67, 69, 28, 6, 83, 80, 65, 67, 69, 83, 29, 10, 78, 69, 88, 84, 83, 89, 77, 66, 79, 76, 30, 8, 78, 69, 88, 84, 73, 84, 69, 77, 31, 10, 83, 75, 73, 80, 83, 89, 77, 66, 79, 76, 32, 10, 70, 82, 79, 77, 83, 84, 82, 73, 78, 71, 33, 6, 67, 72, 65, 82, 78, 79, 34, 3, 73, 78, 84, 35, 5, 73, 78, 84, 80, 84, 36, 6, 70, 82, 65, 67, 80, 84, 37, 3, 83, 73, 78, 38, 3, 67, 79, 83, 39, 3, 84, 65, 78, 40, 6, 65, 82, 67, 83, 73, 78, 41, 6, 65, 82, 67, 67, 79, 83, 42, 6, 65, 82, 67, 84, 65, 78, 43, 6, 82, 65, 68, 73, 85, 83, 44, 4, 83, 81, 82, 84, 45, 3, 77, 79, 68, 46, 3, 76, 79, 71, 47, 3, 69, 88, 80, 48, 6, 80, 82, 79, 77, 80, 84, 49, 11, 'S', 'E', 'L', 'E', 'C', 'T', 'I', 'N', 'P', 'U', 'T', 50, 12, 'S', 'E', 'L', 'E', 'C', 'T', 'O', 'U', 'T', 'P', 'U', 'T', 51, 11, 'C', 'L', 'O', 'S', 'E', 'S', 'T', 'R', 'E', 'A', 'M', 52, 6, 'R', 'E', 'S', 'U', 'M', 'E', 53, 5, 'D', 'R', 'A', 'I', 'N', 54, 5, 'A', 'R', 'R', 'A', 'Y', 55, 3, 'M', 'O', 'N', 0 %LIST %INTEGER N, A, NP, P, AD; %BYTEINTEGER PACK P = 0; PACK = 0; A = NEW CELL %CYCLE N = BINAMES(P); ! NAME NUMBER A = NEWCELL %AND %RETURN %IF N = 0 P = P+1; ! ONTO THE STRING AD = ADDR(BINAMES(P)); ! POINTER TO STRING FIRST = BYTEINTEGER(AD+1) LAST = BYTEINTEGER(AD+BYTEINTEGER(AD)) NP = FIND(AD); ! LOOK FOR IT (AND FIND FREE SPACE TO PLUG IT) FAULT(255) %AND STOP %IF NP >= 0; ! ALREADY IN !!!!! A = A+8; ! COMPILER NAMES ONLY USE 8 BYTES OF LIST ! SO PACK TWO ENTRIES INTO ONE CELL %IF PACK = 0 %THEN A = NEWCELL-4 PACK = PACK!!1 INTEGER(A+8) = N; ! SET INDEX FIELD TO NAME NUMBER N = DICTHEAD+(\NP); ! ADDRESS OF FREE CELL INTEGER(N) = AD; INTEGER(N+4) = A ! INSERT THE INFO P = P+BYTEINTEGER(AD)+1;! ONTO THE NEXT NAME %REPEAT; ! AND ROUND AGAIN %END %ROUTINE RESET I O IN STREAM = 0 I OUT = 0 PRINTED = 0 I O FLAG = 0 SELECTINPUT(0) SELECTOUTPUT(SYSOUT) %END %ROUTINE DOT NAME %SHORTROUTINE %INTEGER J, K, M, N %STRING (255) PARAM, LINE SAVE ! SET UP AND COMPILE AN EXTERNAL SPEC, AND CALL THE ROUTINE N = REC(RP+3); ! PICK UP NAME POINTER FAULT2(40,N) %AND %RETURN %C %IF LEVEL # 1 %OR FIRST CHAR # OLD TEXT LINE(0) <- LINE LENGTH LINE SAVE = STRING(ADDR(LINE(0))) PARAM = '' PARAM = ' (%STRING(63) S)' %IF REC(RP+4) = 1 M = 150; ! PRESERVE CURRENT ANALYSIS RECORD J = REC(RP+1)+6; ! ROUGH END OF AREC. %CYCLE K = RP,1,J REC(M) = REC(K) M = M+1 %REPEAT TEXTP = ADDR(LINE(150)); ! THIS WILL DO FOR A BUFFER ! NOW PUT IN THE SOURCE TEXT STRING(TEXTP) = '%EXTERNALROUTINESPEC '.STRING( %C INTEGER(DICTHEAD+N)).PARAM.' '.TOSTRING(0) ! ZERO IS THE TERMINATOR FOR 'INPUT SYMBOL' TEXTP = TEXTP+1; ! ONTO TEXT PROPER COMP MODE = COMP MODE!1; ! SHOW INPUT COMING FROM 'TEXTP' COMPILE BLOCK; ! COMPILE THE SPEC COMP MODE = COMP MODE&254; ! JUST IN CASE !!! %RETURN %IF XFLAG # 0; ! ROUTINE NOT LOADED RP = 150; ! BACK FOR THE ROUTINE CALL STRING(ADDR(LINE(0))) = LINE SAVE; ! PRESERVE STRING CONSTANT DEC FLAG = 0; ! PREVENT DUPLICATING THE TEXT FOR THE SPEC CUI(1); ! IT LOOKS LIKE A UI OF TYPE 1 %END %ROUTINE HASH EXPRNS %SHORTROUTINE %INTEGER J, A %BYTEINTEGER REAL %RECORD V(VARFM) FAULT(33) %AND %RETURN %IF LEVEL # 1 %OR CODEIN # CSTART REAL = 0 %UNTIL REC(RP) = 2 %CYCLE COND1 = RP; COND2 = COND1 EXPRN TYPE = COND TYPE RP = COND1 %IF EXPRNTYPE&16 # 0 %START; ! STRING EXPRN C S EXPRN(A) EFREE = EFREE+256; ! PROTECT THE STRING S LOAD(A,1) PLANT(X'4100000B') %FINISH %ELSE %START EXPRN TYPE = B'1100';! SET TO AMBIGUOUS EXPRN(V) %IF EXPRN TYPE = B'1100' %START ! INTEGER LOAD(V,1) PLANT(X'41200001') J = X'41000013' %FINISH %ELSE %START LOAD(V,2) PLANT(X'41100007') REAL = 1 J = X'4100000A' %FINISH PLANT(J) %FINISH RTSAVE(2) PLANT(X'6040B050') %IF REAL # 0 PLANT(X'45FC0000'+23<<2) RP = RP+1 %REPEAT %END %ROUTINE RESTORE ENTRIES %SHORTROUTINE %WHILE ELISTP > 0 %CYCLE RELEASE RT(ENTRY LIST(ELISTP)) ELISTP = ELISTP-1 %REPEAT %END %ROUTINE SKIPEXPRN !* RP SET BEFORE P(EXPRN) RP = RP+1; ! ONTO P(EXPRN) RP = REC(RP+2) %UNTIL REC(RP) = 2; ! HOP OVER (OPERAND) %END %ROUTINE FMESSAGE(%INTEGER N) %SHORTROUTINE %RETURN %IF SYNTAX = 'N' %IF N >= 200 %C %THEN %PRINTTEXT ' (COMPILER OVERWORKED)' %C %ELSE %START N = 0 %IF N > 110; ! ONLY 110 FAULT MESSAGES ! MESSAGE(0) = (UNKNOWN FAULT) PRINTSTRING(' ('.STRING(ADDR(FAULTTEXT(FAULTNO(N)))). %C ')') %FINISH %END %ROUTINE FAULT(%INTEGER N) %SHORTROUTINE %INTEGER M, SPAC, J %BYTEINTEGER S, Q, S OPTION ! ! LIST THE LINE IF IT HAS NOT ALREADY BEEN LISTED ! %IF PRINTED = 2 %AND DEC2 > DEC1 %AND (N # 0 %C %OR SYNTAX = 'N') %START PRINTED = 3 WRITE(LINE NUM,4); SPACES(2) M = DEC1+72-5; M = DEC2 %IF DEC2 < M %CYCLE J = DEC1,1,M-2 S = BYTEINTEGER(J); PRINTSYMBOL(S) %EXIT %IF S = NL %REPEAT NEWLINE %IF S # NL %FINISH %PRINTTEXT '*' %IF COMP MODE&B'01000011' # 0 %OR PRINTED = 3 %START WRITE(LINENUM,3); SPAC = 16;! GIVE LINE NUMBER IN EDIT %FINISH %ELSE SPAC = 12 %IF N = 100 %START; ! ACCESS %PRINTTEXT ' ACCESS ' ACCESS = 1 %RETURN %FINISH FAULTY = 1 %IF N = 0 %START; ! FAULT(0) == SYNTAX S OPTION = SYNTAX SOPTION = 'N' %IF LINELENGTH-LINE START+SPAC > 70 %PRINTTEXT ' SYNTAX ' Q = 0; ! FLAG TO COUNT QUOTES ! NOW OUTPUT RECONSTRUCTED LINE %CYCLE J = LINE START,1,LINE LENGTH S = LINE(J) Q = Q!!1 %IF S = '''' PRINTSYMBOL(S) %IF S OPTION = 'Y' NEWLINE %AND %EXIT %C %IF S = ';' %AND J >= SM %AND Q = 0 %REPEAT %IF S OPTION = 'Y' %START SPACES(SM+SPAC-LINE START); %PRINTTEXT '!' %FINISH LINE ENTRY = 0 LINE ENTRY = J+2 %IF S = ';';! MORE ON THIS LINE %FINISH %ELSE %START %PRINTTEXT ' FAULT' M = !N!; ! N < 0 => NO NEWLINE WRITE(M,3) %IF SYNTAX = 'N' %OR M > 100 %PRINTTEXT ' disaster ' %IF M > 100 FMESSAGE(M) ! NOW PREVENT FAULTY ROUTINES FROM BEING CALLED RTS(BLOCK ENTRY)_EP = RT FAULTY %C %IF BASE REG # 9 %AND COMP MODE&68 # 0 %FINISH NEWLINE %UNLESS N < 0 PRINT USE %AND UN CLAIM %IF N >= 200 *XC_GPR1(8),GPR1; ! FORGET THEM JUST IN CASE !!!! %END %ROUTINE FAULT2(%INTEGER N, NAME) FAULT(-N) ! OUTPUT THE TEXT FOR 'NAME' SPACES(2) PRINTSTRING(STRING(INTEGER(NAME+DICTHEAD))) NEWLINE %END %INTEGERFN R V LEN(%INTEGER PT) ! THIS ROUTINE SEARCHES FOR THE RECORDFORMAT WITH A ! LIST OF 'PT', AND FROM IT EXTRACTS THE LENGTH OF ! EACH RECORD WITH THAT FORMAT ! VERY NASTY !! BUT ONLY USED FOR RECORD1 = RECORD2 %SHORTROUTINE %INTEGER N; %INTEGERNAME P %RECORDNAME V(VARFM) PT = PT&X'FFFFFF'; ! REMOVE TIDY BIT !!!! %CYCLE N = DICTHEAD,8,DICTHEAD+4088 P == INTEGER(N+4) %IF P # 0 %START V == RECORD(P) %CYCLE %RESULT = V_ADDRESS %C %IF V_TYPE = 31 %AND V_INDEX = PT %EXIT %IF V_LINK = 0 V == RECORD(V_LINK) %REPEAT %FINISH %REPEAT %RESULT = 0 %END %ROUTINE C B PAIR(%INTEGERNAME L, R) ! EVALUATES THE BOUND PAIR FOR SWITCHES AND ARRAYS IN RECORDS !* RP BEFORE P(CBPAIR) %SHORTROUTINE %BYTEINTEGER P P <- REC(RP+2); ! PLUS RP = RP+3; ! SKIP TYPE GET4(L) %IF P = 2 %THEN L = -L %ELSE %START %IF P = 3 %THEN L = \L %FINISH P <- REC(RP+1); RP = RP+2; GET4(R) %IF P = 2 %THEN R = -R %ELSE %START %IF P = 3 %THEN R = \R %FINISH R = L %AND FAULT(45) %UNLESS L <= R %END %ROUTINE SET UAV PAT(%INTEGER BYTES, AD1) %SHORTROUTINE %INTEGER A %IF UAV FLAG # 0 %AND T UAV # 0 %AND BYTES > 2 %START DSI(X'92',AD1,128) BYTES = BYTES-1; A = BYTES>>8; BYTES = BYTES&255 %WHILE A > 0 %CYCLE; A = A-1 DSS(X'D2',256,AD1+1,AD1) AD1 = AD1+256 %REPEAT DSS(X'D2',BYTES,AD1+1,AD1) %FINISH %END %INTEGERFN NEW RT ! RETURNS THE NEXT FREE ROUTINE VECTOR IN GLA ! THIS WHOLE AREA (ROUTINE ENTRY INFO ETC.) ! CAN BE IMPROVED BY GIVING EACH 'NORMAL' ROUTINE ! A TWO WORD VECTOR ( ,<@ ROUTINE BLOCK> ) ! OR EVEN JUST ONE WORD WITH THE ENTRY POINT (AS THE ! ADDRESS OF THE BLOCK IS SIMPLY 4 WORDS BACK) ! ANY FOUR WORD VECTORS WOULD THEN BE CLAIMED FROM GLA ! WHEN NEEDED (EXTERNALS AND ROUTINE PARMS) %INTEGER J RTP = (RTP+1)&127; ! WRAP AROUND J = RENTRY(RTP); RENTRY(RTP) = 255 FAULT(109) %IF J = 255; ! ALREADY CLAIMED %RESULT = J %END %ROUTINE VTYPE(%RECORDNAME V) ! SETS UP THE TYPE OF A VARIABLE ! AND DEALS WITH STRING MAX LENGTHS %SHORTROUTINE %RECORDSPEC V(VARFM) %BYTEINTEGER T RP = RP+1; T = REC(RP); ! TYPE T = REALS %IF T = 4; ! REALSLONG %IF T = 6 %START; ! STRINGS RP = RP+1; ! LOOK FOR LENGTH %IF REC(RP) = 2 %THEN SMAX = 0 %ELSE %START RP = RP+1; GET4(SMAX); ! ALSO SKIPPING TYPE SMAX = 0 %AND FAULT(70) %IF SMAX > 255 ! TOO BIG %FINISH %FINISH %ELSE SMAX <- VBYTES(T) V_LENGTH <- SMAX V_TYPE <- TYPE CODE(T) DIAG FLAG = V_TYPE DIAG FLAG = DIAG FLAG!128 %IF T = 6 %END %ROUTINE QNAME(%RECORDNAME V) ! SETS UP FLAGS FOR '%ARRAYNAME':'%NAME': %SHORTROUTINE %RECORDSPEC V(VARFM) %BYTEINTEGER F, T RP = RP+1; T <- REC(RP) %IF EXTRINSIC = 1 %START FAULT(46) %UNLESS T = 3 T = 2 %FINISH %IF T = 1 %START; ! %ARRAYNAME F = B'10111'; DIAGFLAG = 0 V_LENGTH = 16; UAV FLAG = 0 %FINISH %ELSE %START F = 1; ! (NULL) %IF T = 2 %START; ! %NAME F = B'10011'; DIAGFLAG = DIAG FLAG!128 SMAX = 0; V_LENGTH = 4 %FINISH %FINISH V_FORM = T<<5!F %END %ROUTINE RT(%RECORDNAME V) %SHORTROUTINE %RECORDSPEC V(VARFM) V_FORM = B'1000'; ! CHANGED FROM B'1001' FOR FN = 0 ?? RP = RP+1; RTYPE <- REC(RP) ! RTYPE 1 - %ROUTINE ! 2 - %FN/%MAP ! 3 - %PREDICATE %IF RTYPE = 1 %THEN V_TYPE = 15 %ELSE %START %IF RTYPE = 3 %THEN V_TYPE = 14 %ELSE %START VTYPE(V) RP = RP+1 %IF REC(RP) = 2 %THEN V_FORM = V_FORM!2 ! SET %NAME %FINISH %FINISH %IF RTYPE = 2 %AND V_FORM&2 # 0 %C %THEN V_FORM = V_FORM!224 %ELSE V_FORM = V_FORM!96 RTYPE = RTYPE+3 %END %ROUTINE D DEC(%INTEGER N, AD, L, MODE) ! FILLS IN THE HEADER OF A STRING OR RECORD WITH THE ! ADDRESS OF THE FREE SPACE, AND UPDATES THE POINTER ! INTO THAT SPACE ! AS THE DYNAMIC STACK IS USED BY THE COMPILATION PROCESS ! ALL DATA ON IT MUST BE VOLATILE. THEREFORE D DEC ! WILL TAKE SPACE FROM THE ARRAY SPACE IF THE DECLARATION ! IS AT LEVEL 1 (BASIC LEVEL) %SHORTROUTINE %INTEGER REG, RLEN, LENGTH, LIMIT, UAD, LAD %BYTEINTEGER LEN, FLAG %IF LEVEL = 1 %START; ! USE ARRAY SPACE PLANT(X'584D0000'+8<<2); REG = 4 FLAG = 1; LIMIT = 9<<2; UAD = X'4000' %FINISH %ELSE %START; ! USE THE STACK REG = 11; FLAG = 0; LIMIT = 15<<2; UAD = X'B000' %FINISH LEN = 0 %IF MODE = 0 %THEN MODE = L-1 %AND LEN = 1 LENGTH = N*L; RLEN = (LENGTH+3)&(\3) UAV FLAG = UAV FLAG!128 SET UAV PAT(RLEN,UAD) %IF TUAV # 0 UAV FLAG = UAV FLAG&127 %CYCLE N = 1,1,N DRX(X'50',REG,0,AD) %IF LEN = 1 %START DSI(X'92',AD,MODE) DSS(X'D2',2,REG<<12,X'D000'!22<<2) %IF TUAV # 0 %FINISH LAD = CODEIN DRX(X'41',REG,REG,L) ! TEST EXCESS BLOCKS DRX(X'59',REG,13,LIMIT); PLANT(X'472C0000'+22<<2) AD = AD+4 %REPEAT N = LENGTH&7; ! DOUBLE WORD ALLIGNED ? %IF N # 0 %THEN SHORTINTEGER(LAD+2) <- 8+L-N ! ROUND UP ! UPDATE POINTER INTO ARRAY SPACE %IF FLAG = 1 %THEN PLANT(X'504D0000'+8<<2) %END %ROUTINE C NAME LIST(%INTEGER NAMES, BYTES) ! COMPILES NAME LISTS PUTTING THE NEW TAGS FOR ! EACH NAME ONTO THEIR RESPECTIVE LISTS IN THE DIRECTORY. ! IT MAY BE POSSIBLE TO COMBINE 'C L NAME LIST' WITH THIS ! ROUTINE WITH VERY LITTLE OVERHEAD. %SHORTROUTINE %INTEGERNAME P %RECORDNAME V(VARFM) %INTEGER NAME, NAMEP, AD, L, UAD1, FLAG %STRING (8) EX NAME UAD1 = NEWNAME_ADDRESS; ! FIRST ADDRESS FOR SETTING UNASSIGNED GLA = (GLA+3)&(\3) %AND BYTES = 4 %IF EXTRINSIC = 1 ! EXTRINSICS ARE INDIRECT %CYCLE NAMES = 1,1,NAMES RP = RP+1; NAME = REC(RP); NAMEP = NAME+DICTHEAD P == INTEGER(NAMEP+4) %IF P # 0 %START %IF BYTEINTEGER(P+4) = LEVEL %C %THEN FAULT2(7,NAME) %AND -> E1 %FINISH %IF EXTRINSIC = 0 %THEN AD = NEWNAME_ADDRESS %C %ELSE %START AD = X'D000'!(GLA-GLA HEAD) NEW NAME_ADDRESS <- AD %IF EXTRINSIC = 1 %START EX NAME <- STRING(INTEGER(DICTHEAD+NAME)) INTEGER(GLA) = 0; ! JUST IN CASE FDP(DATA FDP,EXNAME,FDP DATA REF,GLA,FLAG) ! LOOK UP NAME %IF FLAG # 0 %START PRINTSTRING('* CANNOT LOAD '.EX NAME.' ') -> E1 %FINISH BYTEINTEGER(GLA) <- FMLEN; ! STRINGS ?? FLAG = COMREG(7); ! UNSAT. REF LIST CREATE DUMMY REFS(FLAG) %IF FLAG # 0 %FINISH GLA = GLA+BYTES %FINISH V == RECORD(NEW CELL) V = NEWNAME NEWNAME_ADDRESS = NEWNAME_ADDRESS+BYTES %C %IF EXTRINSIC = 0 V_LINK = P; P = ADDR(V); ! LINK IN NAME SET DIAG(AD,NAME) %UNLESS DIAGFLAG = 0 E1: %REPEAT L = NEWNAME_ADDRESS-UAD1 %IF EXTRINSIC # 0 %THEN NEWNAME_ADDRESS <- UAD1 %C %ELSE SET UAV PAT(L,UAD1) %END %ROUTINE C L NAME LIST(%INTEGER BYTES) %SHORTROUTINE ! COMPILES A LINKED NAME LIST FOR ROUTINES AND RECORD FORMATS !* RP BEFORE LENGTH OF NAMELIST !* 'LIST HEAD' == HEAD OF LIST !* 'LIST END' == END OF LIST ! %RECORDNAME P(VARFM) %INTEGER NAME, PT, NAMES, AD, TNAME RP = RP+1 %CYCLE NAMES = RP+1,1,REC(RP)+RP NAME = REC(NAMES) TNAME = NAME!NEWNAME_DIMENSION&3 SHORTINTEGER(ADDR(NEWNAME_LEVEL)) <- TNAME %IF FPMODE = 1 %START; ! FORMAT SO CHECK FOR DUPLICATION PT = LIST HEAD %WHILE PT # 0 %CYCLE P == RECORD(PT) %IF SHORTINTEGER(ADDR(P_LEVEL)) = TNAME %START FAULT2(7,NAME); -> NOUT;! DON'T RE-DECLARE IT %FINISH PT = P_LINK %REPEAT %FINISH P == RECORD(NEW CELL) P = NEWNAME LIST END = ADDR(P); LIST END == P_LINK; LIST END = 0 AD = NEWNAME_ADDRESS NEWNAME_ADDRESS <- AD+BYTES SET DIAG(AD,NAME) %UNLESS DIAGFLAG = 0 %OR SPEC # 0 NOUT: %REPEAT RP <- NAMES %END %ROUTINE DECLARE ! STRINGS (AND RECORDS) CAUSE PROBLEMS AS THERE ! ARE TWO TYPES OF STRING TYPE VARIABLE ! STRINGS DECLARED BY %STRING(8) S ARE ACCESSED INDIRECTLY ! THROUGH A ONE WORD HEADER, BUT STRING PARAMETERS ! AND STRINGS IN RECORDS ARE ACCESSED DIRECTLY ! I.E. ADDR(STRING) == *L_1,STRING ! ADDR(STRING PARM) == *LA_1,STRING ! AT THE MOMENT THIS IS FRIGGED BY A BIT IN FLAGS ! BUT A BETTER SOLUTION WOULD BE TO MODIFY 'LOAD ADDR' ! TO LOOK AFTER IT. %SHORTROUTINE %INTEGER J, L, M, N NEWNAME_LEVEL = LEVEL FAULT(40) %AND -> 1 %IF COMP MODE&B'101000' # 0 DEC FLAG = 1; ! SAVE ANY LEVEL 1 DECS RP = RP+1; J = REC(RP) %IF J = 1 %START; ! SCALARS QNAME(NEW NAME) DIAG FLAG = 0 %IF NEWNAME_TYPE = 7 ! RECORDS L = 3 %IF NEWNAME_FORM&2 = 0 %THEN L = ROUND(NEWNAME_TYPE) DISP = (DISP+L)&(\L); NEWNAME_ADDRESS = DISP RP = RP+1; N = REC(RP);! NUMBER OF NAMES J = NEW NAME_LENGTH; ! LENGTH OF EACH ITEM %IF NEW NAME_TYPE = B'10000' %C %AND NEWNAME_FORM&4 = 0 %START ! STRINGS L = 0 %IF NEWNAME_FORM&2 = 0 %START FAULT(70) %AND -> 1 %IF J = 0 L = J+1; ! TOTAL LENGTH, STRING+LENGTH BYTE %FINISH NEWNAME_LENGTH = 0 M = NEWNAME_ADDRESS UAVFLAG = 0 %IF L # 0; C NAME LIST(N,4) %IF L # 0 %START PUT LINE D DEC(N,M,L,0); ! CLAIM SPACE OFF THE STACK %FINISH %FINISH %ELSE %START %IF NEWNAME_TYPE = 7 %AND NEWNAME_FORM&2 = 0 %START M = NEWNAME_ADDRESS UAV FLAG = 0 C NAMELIST(N,4) PUT LINE D DEC(N,M,FMLEN,1) %FINISH %ELSE C NAME LIST(N,J) %FINISH DISP = NEW NAME_ADDRESS %FINISH %ELSE PUT LINE %AND C A DECLN UAV FLAG = 0 EXTRINSIC = 0 1: %END %ROUTINE COMP P LIST(%INTEGER NEW, OLD) %SHORTROUTINE ! !************************************************************* !* * !* THIS ROUTINE COMPARES THE TWO LINKED NAME LISTS SET UP * !* BY 'C RFM DEC'. THE OLD LIST ('OLD') IS DESTROYED. * !* * !************************************************************* ! %RECORDNAME NL, OL(VARFM) %INTEGER NP, F %BYTEINTEGER DEST DEST = 0 NP = NEW; DEST = 1 %IF NP > 0; NEW = !NEW! NL == RECORD(NEW); OL == RECORD(OLD) %WHILE NEW # 0 # OLD %CYCLE NL == RECORD(NEW); OL == RECORD(OLD) SHORTINTEGER(ADDR(OL_LEVEL)) = SHORTINTEGER(ADDR(NL_ %C LEVEL)) %IF DEST # 0 ! COPY NAME INFO NEW = NL_LINK; OLD = OL_LINK FAULT(9) %IF NL_TYPE # OL_TYPE %C %OR NL_FORM # OL_FORM %OR NL_LENGTH # OL_LENGTH %REPEAT %IF NEW # OLD %START F = 8; F = 10 %IF NEW = 0 FAULT(F) %FINISH %IF DEST # 0 %START; ! DESTROY NEW LIST NL_LINK = ASL; ASL = NP %FINISH %END %ROUTINE DEC FP LIST(%INTEGER HEAD) %SHORTROUTINE ! !************************************************************* !* * !* THIS ROUTINE DECLARES THE LINKED NAME LIST SET UP * !* BY 'C FP DEFN'. DUPLICATED NAMES ARE NOT REDECLARED. * !* * !************************************************************* ! %INTEGER BASE, NAME, NAMEP %INTEGERNAME PT %RECORDNAME PARM, P(VARFM) BASE = BASE REG<<12 %WHILE HEAD # 0 %CYCLE P == RECORD(HEAD) NAME = SHORTINTEGER(ADDR(P_LEVEL))&X'FFFC' ! & OFF DIM NAMEP = NAME+DICTHEAD PT == INTEGER(NAMEP+4) %IF PT # 0 %AND BYTEINTEGER(PT+4) = LEVEL %C %THEN FAULT2(7,NAME) %ELSE %START PARM == RECORD(NEW CELL) PARM = P PARM_LEVEL = LEVEL ! CHANGE BASE FROM R11 PARM_ADDRESS <- PARM_ADDRESS&X'FFF'!BASE PARM_LINK = PT; PT = ADDR(PARM) %FINISH HEAD = P_LINK; ! ONTO NEXT NAME %REPEAT %END %ROUTINE C REC DEC(%INTEGER FLAG) %SHORTROUTINE %INTEGER NAME, FNAME, FORMAT %INTEGERNAME PT %RECORDNAME HEAD(VARFM) %SWITCH RTYPE(1 : 4) SPEC = 1; ALLIGNMENT = 0 -> RTYPE(FLAG) ! RTYPE(1): ! '%FORMAT'(NAME)'('(RFDEC)(REST OF RFDEC')')' ! RP = RP+1; NAME = REC(RP) PT == INTEGER(NAME+DICTHEAD+4) %IF PT # 0 %AND BYTEINTEGER(PT+4) = LEVEL %START FAULT2(7,NAME); -> 1 %FINISH HEAD == RECORD(NEW CELL) HEAD_TYPE = 31; ! '%FORMAT' HEAD_LEVEL = LEVEL FPMODE = 1; CFPDEFN(HEAD) HEAD_DIMENSION = ALLIGNMENT FORMAT = (NEWNAME_ADDRESS+ALLIGNMENT)&(\ALLIGNMENT) HEAD_ADDRESS <- FORMAT HEAD_LINK = PT; PT = ADDR(HEAD) TIDY(PT) %IF FAULTY # 0 %AND LEVEL = 1 -> 1 ! RTYPE(2): ! '%SPEC'(HOLE)(ENAME'')'(' (MARK)(NAME) ')' ! RP = RP+1; FNAME = REC(REC(RP)) RT2: FORMAT = GET FORMAT(FNAME) -> 1 %IF FORMAT = 0 FORMAT = INTEGER(FORMAT+8);! F-LIST RP = RP+1; VNAME = REC(RP) HEAD == RECORD(GETNAME(VNAME)) RP = RP+1 %IF REC(RP) = 1 %START; ! '_(NAME)' RP = RP+1; VNAME = REC(RP) %IF HEAD_TYPE # 31 %THEN FAULT2(63,VNAME) %AND -> 1 HEAD == RECORD(ENAME(HEAD_INDEX)) %FINISH %ELSE %START %IF HEAD_TYPE = 31 %THEN FAULT2(64,VNAME) %AND -> 1 %FINISH %IF HEAD_TYPE # 7 %THEN FAULT2(63,VNAME) %AND -> 1 BYTEINTEGER(ADDR(FORMAT)) <- BYTEINTEGER(ADDR(FORMAT))!128 ! TO FOOL 'TIDY' HEAD_INDEX = FORMAT HEAD_FLAGS = HEAD_FLAGS&B'11111110' -> 1 ! RTYPE(3): ! (HOLE)(DECLN)'(' (MARK)(NAME) ')' ! RP = RP+1; FNAME = REC(REC(RP)) RT3: FORMATP = GET FORMAT(FNAME); -> 1 %IF FORMATP = 0 FMLEN = SHORTINTEGER(FORMATP); ! LENGTH OF EACH RECORD FLAG = BYTEINTEGER(FORMATP+5); ! ALLIGNMENT FORMATP = INTEGER(FORMATP+8); ! FORMAT LIST BYTEINTEGER(ADDR(FORMATP))<-BYTEINTEGER(ADDR(FORMATP))!128 ! TO FOOL 'TIDY' NEWNAME_TYPE = B'111' NEWNAME_FLAGS = 0 NEWNAME_INDEX = FORMATP; ! POINTER INTO FORMAT LIST NEWNAME_DIMENSION = 0 DIAG FLAG = 0; UAV FLAG = 15 DISP = (DISP+FLAG)&(\FLAG);! TO CORRECT BOUNDARY DECLARE; ! DECLARE RECORDS -> 1 ! RTYPE(4): ! NEW FORMAT RECORDS !!! ! RP = RP+1; FNAME = REC(RP); ! PICK UP NAME RP = RP+1 -> RT2 %IF REC(RP) = 1; ! '%SPEC' -> RT3; ! (DECLN) 1: %END %ROUTINE C FP DEFN(%RECORDNAME HEADER) %SHORTROUTINE ! !************************************************************* !* * !* THIS ROUTINE COMPILES FORMAL PARAMETER LISTS FOR BOTH * !* RECORDS AND ROUTINES. FPDELIM 5,6 ARE ONLY FOUND IN * !* RECORDS AND FPDELIM 1 CAN NEVER OCCUR IN RECORDS * !* (IT CORRESPONDS TO A BIP. (DUMMY) WHICH ALWAYS FAILS. * !* * !************************************************************* ! %RECORDSPEC HEADER(VARFM) %INTEGER L, U, N, NP, A, STR %IF FPMODE = 0 %START RP = RP+1 %IF REC(RP) = 2 %START HEADER_INDEX = 0; NEWNAME_ADDRESS <- 64 %RETURN %FINISH %FINISH HEADER_FORM = HEADER_FORM!8; ! SET INDEX LIST BIT %SWITCH FPDELIM(1 : 7) LIST HEAD == HEADER_INDEX LIST END == LIST HEAD; LIST END = 0 NEWNAME_FLAGS = 0; NEWNAME_DIMENSION = 0 NEWNAME_ADDRESS <- X'B040' %IF FPMODE # 0 %THEN NEWNAME_ADDRESS <- 0 MORE: NEWNAME_INDEX = 0; RP = RP+1; -> FP DELIM(REC(RP)) ! FPDELIM(2): ! (TYPE)(%QNAME)(NAME LIST) ! VTYPE(NEWNAME); QNAME(NEWNAME) NEWNAME_FLAGS = B'10000100' DIAG FLAG = DIAG FLAG&B'01111111' %IF NEWNAME_FORM&2 = 0 STR = -1; STR = 0 %IF NEWNAME_TYPE&B'10000' # 0 ! STRING L = 3 %IF NEWNAME_FORM&2 = 0 %THEN L = ROUND(NEWNAME_TYPE)&STR ALLIGNMENT = ALLIGNMENT!L NEWNAME_ADDRESS <- (NEWNAME_ADDRESS+L)&(\L) NEWNAME_FLAGS = B'10000100' %IF NEWNAME_FORM&16 # 0 %C %THEN NEWNAME_FLAGS = B'01000100' L = NEWNAME_LENGTH %IF STR = 0 %START %IF NEWNAME_FORM&2 = 0 %START FAULT(70) %IF L = 0 L = L+1 %FINISH %ELSE %START NEWNAME_FLAGS = NEWNAME_FLAGS&B'11111011' NEWNAME_LENGTH = 0 %FINISH %FINISH C L NAMELIST(L); -> NEXT ! FPDELIM(1): ! (RT)(NAME')(NAMELIST) ! RT(NEWNAME); U = NEW RT; DIAGFLAG = 0 RP = RP+1; ! SKIP (NAME') ELISTP = ELISTP+1; ENTRY LIST(ELISTP) <- U NEW NAME_DIMENSION <- U NEWNAME_FORM = NEWNAME_FORM!16 NEWNAME_FLAGS = B'01111101'; ! NO '%SPEC' ALLIGNMENT = ALLIGNMENT!3 NEWNAME_ADDRESS <- (NEWNAME_ADDRESS+3)&(\3) C L NAMELIST(4) -> NEXT ! FPDELIM(7): ! NEW FORMAT SCALAR RECORDS ! NP = RP+1; RP = NP -> FP6 ! FPDELIM(6): ! SCALAR RECORD ! RP = RP+1; NP = REC(RP); ! HOLE FP6: N = GET FORMAT(REC(NP)); -> RFAIL %IF N = 0 L = BYTEINTEGER(N+5); ! ALLIGNMENT FMLEN = SHORTINTEGER(N) A = INTEGER(N+8) BYTEINTEGER(ADDR(A)) <- BYTEINTEGER(ADDR(A))!128 RFAIL: NEWNAME_TYPE = 7 NEWNAME_INDEX = A NEWNAME_DIMENSION = 0 ALLIGNMENT = ALLIGNMENT!L NEWNAME_ADDRESS <- (NEWNAME_ADDRESS+L)&(\L) RP = RP+1 %IF REC(RP) = 1 %START NEWNAME_FORM = B'1010001' DEC CONST ARRAY(FMLEN) %FINISH %ELSE %START NEWNAME_FORM = B'0110001' NEWNAME_FLAGS = B'10111100' C L NAMELIST(FMLEN) %FINISH RP = NP %IF NP > RP -> NEXT ! FPDELIM(3): ! RECORD(ARRAY')'%NAME' ! DIAG FLAG = 0 RP = RP+1 %IF REC(RP) = 1 %START; ! %ARRAY L = 16; NEWNAME_FORM = B'0110111' %FINISH %ELSE %START L = 4; NEWNAME_FORM = B'1010011' %FINISH NEWNAME_TYPE = 7; NEWNAME_FLAGS = B'01000101' ! NO %SPEC ALLIGNMENT = ALLIGNMENT!3 NEWNAME_ADDRESS <- (NEWNAME_ADDRESS+3)&(\3) C L NAMELIST(L); -> NEXT ! FPDELIM(4): ! '%NAME'(NAMELIST) ! NEWNAME_FLAGS = B'01001000' DIAG FLAG = 0 NEWNAME_TYPE = 13; NEWNAME_FORM = 18 ALLIGNMENT = ALLIGNMENT!3 NEWNAME_ADDRESS <- (NEWNAME_ADDRESS+3)&(\3) C L NAMELIST(8) -> NEXT ! FPDELIM(5): ! (TYPE)'%ARRAY'(NAMELIST)(CBPAIR)(R SW LIST') ! ALLIGNMENT = ALLIGNMENT!7 VTYPE(NEWNAME); DEC CONST ARRAY(NEWNAME_LENGTH) ! NEXT: RP = RP+1; RP = RP+1 %AND -> MORE %IF REC(RP) = 1 %END %ROUTINE C RFM DEC ! COMPILES A ROUTINE DEFINITION OR SPEC. %SHORTROUTINE %RECORDNAME RTINF(RTFM) %INTEGER RTP %BYTEINTEGER EXTERNAL, SPECD, FLAG, RFM TYPE %INTEGER NAMEP, A, L, PT %INTEGERNAME P %RECORDNAME SPHEAD, HEAD(VARFM) %INTEGER XPT %STRING (8) XNAME FAULT(40) %AND COMPMODE = COMPMODE!128 %C %IF COMPMODE&8 # 0 %OR (MON LOCK # 0 %AND HALT # 7) RP = RP+1; EXTERNAL <- REC(RP) A = NEW CELL; HEAD == RECORD(A) FPMODE = 0; SPECD = 0; FLAG = 0 RT(HEAD); RFM TYPE = R TYPE RP = RP+1; SPEC = (2-REC(RP))<<1 %IF SPEC = 0 %AND EXTERNAL # 4 %THEN EXTERNAL = 4 ! IGNORE EXTERNAL/SYSTEM/DYNAMIC RP = RP+1; RTNAME = REC(RP); NAMEP = RTNAME+DICTHEAD P == INTEGER(NAMEP+4) %IF P # 0 %AND BYTEINTEGER(P+4) = LEVEL %START SPHEAD == RECORD(P) %IF SPHEAD_TYPE # HEAD_TYPE %C %OR SPHEAD_FORM # HEAD_FORM %OR SPEC # 0 %C %OR SPHEAD_FLAGS&2 = 0 %START FAULT2(7,RTNAME) %IF SPEC # 0 %START INTEGER(A+12) = ASL; ASL = A ! RECLAIM CELL -> 1; ! GET OUT QUICK %FINISH COMP MODE = COMP MODE!128 %FINISH %ELSE %START SPECD = 1; PT = P; P = SPHEAD_LINK %FINISH %FINISH %IF SPECD = 0 %THEN RTP = NEW RT %C %ELSE RTP = SPHEAD_DIMENSION MONNAME(RTP) = RTNAME; ! SAVE NAME FOR MONITORING HEAD_ADDRESS <- RTP<<4+RTBASE HEAD_DIMENSION = RTP; ! SAVE ENTRY INDEX HEAD_LEVEL = LEVEL; HEAD_FLAGS <- SPEC!B'00010000' %IF SPEC = 0 %START %IF LEVEL # 1 %START L = FORWARD REF(15) %FINISH %ELSE PLANT(X'07FC');! TO SKIP HEADER %IF BASEREG = 9 %C %THEN BLOCKNAME = NAMEP %AND BLOCKENTRY = RTP NEW BLOCK(RFM TYPE) ELISTP = ELISTP+1 ENTRY LIST(ELISTP) <- RTP; ! STACK ENTRY INFO EFREE = X'B000' FN TYPE = HEAD_TYPE; FN TYPE 2 = FN TYPE FN TYPE = B'100' %IF HEAD_FORM&2 # 0 ! MAP BLOCK_AD = L %FINISH C FPDEFN(HEAD) HEAD_LINK = P; P = A RTINF == RTS(RTP); RTINF_EP = PERM ERROR %IF EXTERNAL # 4 %START HEAD_FLAGS = HEAD_FLAGS!!B'00110000' XNAME <- STRING(INTEGER(NAMEP)) XNAME <- 'S#'.XNAME %IF EXTERNAL = 2 %AND STUDENT = 0 XPT = ADDR(RTINF_CODE) INTEGER(XPT+4) = D LOAD ENV INTEGER(XPT+8) = D LOAD ENTRY; ! IN CASE OF DYNAMICS FDP(LOAD FDP,XNAME,FDP REF,XPT,XFLAG) L = COMREG(7); ! UNSAT ENTRY POINT LIST CREATE DUMMY REFS(L) %IF L # 0 %IF XFLAG # 0 %START PRINTSTRING('* CANNOT LOAD '.XNAME.' ') TIDY(P) %FINISH %ELSE DEC FLAG = 1 HEAD_FLAGS = HEAD_FLAGS&B'11111101' -> 1 %FINISH %IF SPECD = 1 %START; ! SPEC WAS GIVEN, SO COMPARE COMP P LIST(HEAD_INDEX,SPHEAD_INDEX) HEAD_INDEX = SPHEAD_INDEX; ! PRESERVE OLD LIST SPHEAD_LINK = ASL; ASL = PT;! DESTROY SPEC LIST %FINISH DEC FLAG = SPEC RTINF_CODE = APERM; RTINF_GLA = GLA HEAD %IF SPEC = 0 %START; ! THIS ISN'T A SPEC ACCESS = 1 DEC FP LIST(HEAD_INDEX);! DECLARE THE PARAMETERS RTINF_EP = CODEIN; ! SET THE ENTRY POINT PLANT(X'50FB003C'); DRR(X'18',BASE REG,11) PLANT(X'41BB0040'); ! AT LEAST NEW DIAG(BASE REG<<12) LINE NUM = LINE NUM!X'80000000'; ! TO FORCE OUT DIAGS DIAGS = DIAGS!4 NASTY = 1; PUT LINE DIAGS = DIAGS&3 LINE NUM = LINE NUM&X'7FFFFFFF'; ! REMOVE TOP BIT ! SET UP CODE ADDRESSABILITY PLANT(X'45AC0000'!24<<2); ! EXCESS BLOCKS & SETS R10 R10 = CODEIN ! SET LOCALS TO THE END OF THE PARAMETERS DISP = NEWNAME_ADDRESS&X'FFF'!BASEREG<<12 MAX DISP = DISP BLOCK TYPE = RFM TYPE BLOCKTYPE = BLOCKTYPE!128 %IF HEAD_FORM&2 # 0 ! MAP %FINISH 1: %END %ROUTINE C A DECLN %SHORTROUTINE ! !************************************************************* !* * !* THIS ROUTINE DUMPS CODE TO SET UP THE DOPE VECTOR * !* FOR A LIST OF ARRAYS. THE D.V. IS PUT ONTO THE STACK * !* AT 'EFREE'. IF THE ARRAY IS AT BASIC LEVEL, PERM 26,27 * !* ARE USED TO RELOCATE THE D.V. AND ARRAY SPACE AT THE * !* END OF THE STACK. * !* * !************************************************************* ! !* RP ON P(ADECLN) %INTEGER A, N, NP, D, AD, DIM, DVEC, HEADER %RECORD DV(VARFM) %BYTEINTEGER STFLAG, FORMAT DEC NEWNAME_FORM = B'111'; STFLAG = NEWNAME_TYPE RP = RP+1; FORMAT DEC = REC(RP); ! ARRAY FORMAT ? NEWNAME_TYPE = NEWNAME_TYPE!128 %IF FORMAT DEC = 1 DEC1: NP = RP+2; N = REC(NP); ! NUMBER OF NAMES RP = NP+N+1; ! ONTO P(BPLIST) DIM = 0; ! DIMENSION ! NOW COUNT THE DIMENSION ! THIS HAS TO BE DONE HERE ELSE ARRAY A(4096:5112) WILL ! HAVE ITS CONSTANT TABLE CORRUPTED AT RUN TIME ! AS IT WILL BE OVERLAID BY THE DOPE-VECTOR A = RP; ! REMEMBER FOR LATER %UNTIL REC(RP) = 2 %CYCLE SKIP EXPRN; SKIP EXPRN; DIM = DIM+1 RP = RP+1; ! ON PAST (NULL R EXPRN) %REPEAT RP = A; ! RESTORE IT %IF DIM > 6 %START FAULT(37) %RETURN %IF LEVEL = 1 %FINISH %IF LEVEL = 1 %START GLA = (GLA+3)&(\3) EFREE <- GLA-GLAHEAD+X'D004' GLA = GLA+DIM*12+4; ! BUMP IT UP PAST DOPE VECTOR %FINISH %ELSE EFREE <- X'B004' DVEC = EFREE-4 DV_ADDRESS <- EFREE; ! ADDRESS OF DOPE-VECTOR DV_TYPE = B'100' DV_FORM = 1 DV_FLAGS = 0 DV_INDEX = 0 ASSOP = 2; ! FOR ASSIGN %UNTIL REC(RP) = 2 %CYCLE ASSIGN(DV,2); EFREE = EFREE+4; DV_ADDRESS <- EFREE ASSIGN(DV,2); EFREE = EFREE+8; DV_ADDRESS <- EFREE RP = RP+1 %REPEAT FMLEN = FMLEN+1 %IF STFLAG = B'10000' ! STRINGS PLANT(X'41000000'+FMLEN) PLANT(X'50000000'!DVEC&X'FFFF') DSI(X'92',DVEC+1,DIM) DRX(X'41',2,0,DVEC); ! PICK UP THE ADDRESS OF THE DOPE VECTOR PLANT(X'45FC0000'+18<<2); ! SET UP DOPE-VECTOR ! ! HEADER IN R0 : R1 : R2 : R3 ! LENGTH OF ARRAY IN R14 ! GLA = GLAHEAD+EFREE&X'FFF' %IF LEVEL = 1 A = (DISP+3)&(\3) AD = 27<<2+X'45FC0000' %IF LEVEL # 1 %THEN AD = 28<<2+X'45FC0000' NEWNAME_DIMENSION <- DIM NEWNAME_INDEX = FORMATP NEWNAME_ADDRESS <- A D = RP RP = NP DIAG FLAG = 0 %CYCLE N = 1,1,N PLANT(AD) %IF FORMAT DEC # 1;! ALLOCATE SPACE HEADER = A PLANT(X'1B011F11') %IF FORMAT DEC = 1 DRX(X'90',0,3,HEADER); ! SET UP HEADER DSI(X'92',HEADER,FMLEN) %IF STFLAG&16 # 0 A = A+16 %REPEAT ! ! LEVEL 1 ARRAYS NEED TO BE ALLOCATED BEFORE THE NAME IS DEFINED ! TO PREVENT 'EXCESS BLOCKS' OR 'ARRAY INSIDE-OUT' FORM ! LEAVING AN INCONSISTENT HEADER ! %IF LEVEL = 1 %START PLANT(X'9201D000'); ! SET FAILURE FLAG BYTEINTEGER(GLAHEAD) = 0; ! CLEAR FAILURE FLAG *BCR_0,0; ! FORCE THE COMPILER TO FORGET EXECUTE CODE; ! DECLARE THE ARRAYS CODEIN = CSTART SHORTINTEGER(CODEIN) = X'05FC' RUNNING = 'N' ! NOW SEE IF THE DECLARATION SUCCEEDED, IF NOT ! OMIT THE SETTING UP OF THE NAME REFERENCE -> 1 %IF BYTEINTEGER(GLAHEAD) = 0 %FINISH UAV FLAG = 0; C NAME LIST(N,16); UAV FLAG = 15 DISP <- A 1: RP = D+1 -> DEC1 %IF REC(RP) = 1 EFREE = X'B000' %END %ROUTINE RELEASE RT(%INTEGER N) %INTEGER J J = RENTRY(RTP); RENTRY(RTP) = N RTP = (RTP-1)&127 FAULT(220) %UNLESS J = 255 %END ! THIS ROUTINE IS USED IN PREFERENCE TO THE EXTERNALROUTINE MOVE ! IN ORDER TO SAVE TIME WHEN LOADING THE INTERPRETER AND ! TO PREVENT MORE PAGES OF MANAGR BEING BROUGHT IN WHEN THE ! ROUTINE IS CALLED. %ROUTINE MOVE(%INTEGER L, F, T) %CONSTINTEGER CC = 256 *LM_1,3,L M1: *C_1,CC; *BC_13, *MVC_0(256,3),0(2) *LA_2,256(2); *LA_3,256(3) *S_1,CC *BC_15, M2: *LTR_1,1; *BC_8, *BCTR_1,0 *EX_1, M3: %RETURN M4: *MVC_0(0,3),0(2) %END %ROUTINE EDIT(%BYTEINTEGER MODE) ! ! MODE : 0 - $EDIT ! 1 - $DELETE ! 2 - $LOOK ! %SHORTROUTINE %RECORDNAME V(VARFM) %INTEGER DESC, LEN, ESTART, ELEN, WSPLEN, N, R, END %INTEGERNAME PT %RECORDNAME BLOCK(RBFM) %RECORD RTHEAD(RTFM) %CONSTBYTEINTEGERARRAY EDPROMPT(0:8) = 8,'E','D', 'I', 'T',7,13,10,'>' %BYTEINTEGER SPARE, REPLY FAULT(33) %AND -> 1 %C %IF COMP MODE # 0 %OR LEVEL # 1 %OR (MON LOCK # 0 %C %AND HALT # 7) PRINTED = 2 %IF LIST = 'N' REPLY = 0 RP = RP+1; N = REC(RP)+DICT HEAD PT == INTEGER(N+4) %IF PT = 0 %START E1: PRINTSTRING('* cannot edit '.STRING(INTEGER(N)).' ') -> 1 %FINISH V == RECORD(PT) -> E1 %IF V_TYPE = 31 %OR V_FORM&8 = 0 %OR V_FLAGS&34 # 0 ! IT SEEMS OK TO EDIT THIS THING PT = V_LINK %IF MODE # 2; ! REMOVE OLD NAME REF DESC = V_DIMENSION RELEASE RT(DESC) %IF MODE # 2 RTHEAD = RTS(DESC); ! ROUTINE VECTOR BLOCK == RECORD(RTHEAD_ENVIR); ! BLOCK DESCRIPTOR TEXTP = A SPACE; WSPLEN = END A SPACE-TEXTP-64 ESTART = BLOCK_TEXT; END = BLOCK_LINK EDDEF = ESTART>>24; ! PICK OFF BLOCK NUMBER ESTART = ESTART&X'00FFFFFF'; ! LOOSE TOP BYTE ELEN = BLOCK_LENGTH-1 %IF ELEN+100 > WSPLEN %START %PRINTTEXT '* workspace full ' -> RESET %IF MODE # 2; %RETURN %FINISH E2: LEN = WSPLEN ! ! CALL THE EDITOR TO MODIFY THE TEXT ! %IF MODE # 1 %START RIM(0,STRING(ADDR(EDPROMPT(0)))) EDINNER(ESTART,ELEN,ESTART,ELEN,TEXTP,LEN) BYTEINTEGER(TEXTP+LEN) = 0; ! END MARKER %FINISH %ELSE LEN = 0; ! TO FORCE A DESTROY %RETURN %IF MODE = 2 ! ! ! COMP MODE = COMP MODE!35; ! SET FLAGS %IF LEN < 5 %START; ! NOT ENOUGH FOR '%REALFN A' PRINTSTRING('procedure '.STRING(INTEGER(N)). %C ' deleted ') -> DEST %FINISH NEWLINE ! ! COMPILE NEW VERSION OF TEXT ! RIM(0,'e:'); COMPILE BLOCK; ! PROMPT IN CASE %END IS LOST %IF FAULTY = 1 %OR COMP MODE&B'10000' = 0 %START RIM(0,'edit new file? ') READ: READSYMBOL(REPLY) SPARE = REPLY READSYMBOL(SPARE) %WHILE SPARE # NL -> READ %IF 'Y' # REPLY # 'N' %AND REPLY # 'L' %IF REPLY = 'Y' %START ELEN = TEXTIN-TEXT HEAD %C %AND TIDY(INTEGER(BLOCKNAME+4)) %C %IF COMP MODE&16 # 0 E START = TEXT HEAD TEXT P = A SPACE RESTORE ENTRIES -> E2 %FINISH %IF REPLY = 'L' %START; ! LET -> DEST %IF COMP MODE&B'10000' # 0 %PRINTTEXT 'cannot define procedure ' -> READ %FINISH RESTORE ENTRIES %IF COMP MODE&16 # 0 %C %THEN TIDY(INTEGER(BLOCKNAME+4)) %ELSE %START RESET: FAULT(240) %IF DESC # NEW RT %FINISH V_LINK = PT; ! RESTORE OLD NAME REF PT = ADDR(V) RTS(DESC) = RTHEAD; ! RESTORE ENTRY INFO -> E3 %FINISH DEST: N = BLOCK_ENTRIES %WHILE N < END %CYCLE R = INTEGER(N) RELEASE RT(R) %UNLESS R = DESC N = N+4 %REPEAT PT == ELEN; ELEN = ADDR(V) TIDY(PT) %IF LEN >= 5 %THEN DEFINE RT RESTRUCTURE(ADDR(BLOCK)) RTS(DESC)_EP = RT FAULTY %IF REPLY = 'L' E3: CODEIN = 0; ! TO STOP TWO CALLS ON DECODE COMP MODE = 0 1: PRINTED = 0 %END %ROUTINE DEFINE RT %SHORTROUTINE ! !************************************************************* !* * !* THE ROUTINE CREATES THE PROCEDURE BLOCK FOR THE LAST * !* PROCEDURE DEFINED, BY COPYING THE TEXT ONTO THE END * !* OF THE CODE AREA, AND FILLING IN THE HEADER BLOCK * !* * !************************************************************* ! %RECORDNAME BHEAD, WORKR(RBFM) %RECORDNAME RTINF(RTFM) %INTEGER LINK, TEXT, LENGTH, ENTRIES, SP, EP RTINF == RTS(BLOCK ENTRY) RTINF_ENVIR = CODE TOP BHEAD == RECORD(CODE TOP) TEXT = CODEIN BYTEINTEGER(TEXTIN) = 0; ! END MARKER FAULT(110) %AND ABORT %IF TEXT > STACK LENGTH = TEXTIN-TEXT HEAD+1 MOVE(LENGTH,TEXT HEAD,TEXT); ! MOVE IN THE TEXT ENTRIES = (CODEIN+LENGTH+7)&(\7) ENTRIES = ENTRIES+4 %IF ELISTP&1 # 0;! TO MAKE SURE THAT ! THE NEXT BLOCK STATRS ON A DOUBLE WORD BOUNDARY EP = ENTRIES %IF BLOCK ENTRY # ENTRY LIST(1) %THEN FAULT(221) %IF ELISTP > 0 %START %CYCLE SP = 1,1,ELISTP INTEGER(EP) <- ENTRY LIST(SP) EP = EP+4 %REPEAT %FINISH %ELSE FAULT(222) ELISTP = 0 %UNLESS COMPMODE&2 # 0 LINK = EP; INTEGER(LINK) = 0 FAULT(110) %AND -> 1 %IF EP > STACK %IF COMP MODE&2 = 0 %START DEFNUM = DEFNUM+1 EDDEF = DEF NUM %FINISH BYTEINTEGER(ADDR(TEXT)) <- EDDEF WORKR == RECORD(ADDR(LINK)) BHEAD = WORKR CODE TOP = LINK 1: NEWLINE %IF LIST = 'Y' %END %ROUTINE RESTRUCTURE(%INTEGER BP) ! REMOVE THE PROCEDURE BLOCK 'BP' AND MOVE UP ALL ! SUBSEQUENT BLOCKS TO FILL THE SPACE. ! THIS ENTAILS RELOCATING THE ENTRY POINTS AND ENTRY LISTS. %SHORTROUTINE %RECORDNAME BLOCK(RBFM) %RECORDNAME RD(RTFM) %INTEGER NB, ENTRIES, BLEN, MLEN, NEWSPACE BLOCK == RECORD(BP) NB = BLOCK_LINK NEWSPACE = BP; MLEN = NB-NEWSPACE BP = NB %WHILE INTEGER(BP) # 0 %CYCLE BLOCK == RECORD(BP) NB = BLOCK_LINK; ENTRIES = BLOCK_ENTRIES %UNTIL ENTRIES >= NB %CYCLE RD == RTS(INTEGER(ENTRIES)) RD_EP = RD_EP-MLEN RD_ENVIR = NEWSPACE ENTRIES = ENTRIES+4 %REPEAT BLEN = NB-BP MOVE(BLEN,BP,NEWSPACE) BP = NEWSPACE NEWSPACE = NEWSPACE+BLEN BLOCK == RECORD(BP); ! NEW POSN OF HEADER BLOCK_LINK = NEWSPACE; ! LINK TO NEXT BLOCK BLOCK_TEXT = BLOCK_TEXT-MLEN;! TO NEW TEXT BLOCK_ENTRIES = BLOCK_ENTRIES-MLEN ! TO NEW ENTRIES BP = NB %REPEAT CODE TOP = NEWSPACE CODE START = CODE TOP+12 INTEGER(CODE TOP) = 0; ! SHOW IT'S THE END OF THE LIST FAULTY = 1 %END %ROUTINE TIDY LABELS %SHORTROUTINE %RECORDNAME LAB(LABELFM) %INTEGER L %WHILE LABEL HEAD # 0 %CYCLE LAB == RECORD(LABEL HEAD) %IF LAB_USE # 0 %START L = LAB_LABEL REMOVE LABEL(L) ! FAULT LABEL NOT SET IF A USER DEFINED LABEL ! UNSET COMPILER LABELS SHOULD HAVE BEEN ACCOUNTED ! FOR BY OTHER FAULTS FAULT(-11) %AND PRINT LABEL(L) %IF L > X'FFFF0000' %FINISH %ELSE %START L = LABEL HEAD; LABEL HEAD = LAB_LINK LAB_LINK = ASL; ASL = L %FINISH %REPEAT %END %ROUTINE TIDY STARTS %SHORTROUTINE %INTEGER L, N %RECORDNAME ST(BLOCKFM) L = START HEAD %RETURN %IF L = 0 %UNTIL L = 0 %CYCLE ST == RECORD(L) L = ST_LINK N = 53 %IF ST_TYPE&15 = 0 %THEN N = 13 FAULT(N) %REPEAT ST_LINK = ASL; ASL = START HEAD; START HEAD = 0 %END ! ! %ROUTINE TIDY(%INTEGERNAME CELL) ! RELEASES A CELL AND ANY OF ITS LISTS TO THE ASL. %SHORTROUTINE %RECORDNAME CR(VARFM) %INTEGER P CR == RECORD(CELL) P = CR_LINK; CR_LINK = ASL; ASL = CELL; CELL = P %IF CR_INDEX > X'FFFF' %START CELL == CR_INDEX CELL == INTEGER(CELL+12) %UNTIL CELL = 0 CELL = ASL; ASL = CR_INDEX %FINISH %END %ROUTINE TIDY ALL ! REMOVE ALL THE TAGS FOR NAMES SET AT THIS LEVEL ( GIVING FAULT 28 ! WHERE NESC. AND CHECK THERE ARE NO REPEATS/FINISHES/LABELS ! OUTSTANDING. %SHORTROUTINE %INTEGER N %RECORDNAME TV(VARFM) %CYCLE N = DICTHEAD,8,DICTHEAD+4088 %IF INTEGER(N+4) # 0 %START TV == RECORD(INTEGER(N+4)) %IF TV_LEVEL = LEVEL %START FAULT2(28,N-DICTHEAD) %IF TV_FLAGS&2 # 0 TIDY(INTEGER(N+4)) %FINISH %FINISH %REPEAT TIDY STARTS TIDY LABELS %END %ROUTINE OLD BLOCK ! RESTORES THE CONTEXT OF THE CONTAINING BLOCK WHEN ! THE %END OF THE CURRENT BLOCK IS FOUND ! NOTE THAT 'DISP' MUST NOT BE RESET AT THE END OF BEGIN/END ! BLOCKS AS R11 WILL NOT THEN BE BUMPED UP PAST THEM WHEN ! THEN CONTAINING ROUTINE IS ENTERED COMP MODE <- BLOCK_MODE FN TYPE <- BLOCK_X3 FN TYPE 2 <- BLOCK_TYPE2 EFREE <- BLOCK_X1 START HEAD = BLOCK_SHEAD LABEL HEAD = BLOCK_LHEAD R10 = BLOCK_R10 LEVEL = LEVEL-1 %IF BLOCK TYPE # 0 %START ACCESS = BLOCK_FLAGS REG USE(BASE REG) = 0; BASE REG = BASE REG+1 MAX DISP = BLOCK_MAX DISP; DISP = BLOCK_DISP %FINISH BLOCK TYPE = BLOCK_TYPE BLOCK == BLOCK INF(LEVEL) %END %ROUTINE C END ! DEALS WITH ALL FORMS OF %END ! THIS INCLUDES THE RELOCATION OF OWN ARRAYS AND THE DIAG TABLE ! FOR THE BLOCK %SHORTROUTINE %RECORDNAME OWN INF(LABEL FM) %INTEGER J, K, LAB, L, RSAVE, OLD CODE BASE %BYTEINTEGER B OLD CODE BASE = R10 J = REC(RP+1) ! ! 1 : %ENDOFLIST ! 2 : %ENDOFPROGRAM ! 3 : %ENDOFFILE ! 4 : %ENDOFINT ! 5 : %END ! STOP %IF J = 4 %IF J = 1 %START ! ! %ENDOFLIST ! LIST = 'N' PRINTED = 2 %IF COMP MODE&3 # 0 -> 1 %FINISH %IF J = 3 %START ! ! %ENDOFFILE ! FAULT(56) %AND -> 1 %IF IOFLAG = 0 PRINTED = 0 IOFLAG = 0; COMPMODE = COMPMODE&B'10111111' SELECTINPUT(0); CLOSESTREAM(78); CLEAR('ST78') -> 1 %FINISH %IF LIST = 'Y' %START %IF IOFLAG = 1 %START WRITE(LINE NUM,4) SPACES((LEVEL-2)<<2+3) %PRINTTEXT 'END ' %FINISH %FINISH %IF LEVEL = 1 %AND J # 2 %THEN FAULT(14) %AND -> 1 STOP %IF J = 2; ! %ENDOFPROGRAM TIDY ALL J = DISP&X'FFF' MAX DISP = MAX DISP&X'FFF' MAX DISP = J %IF J > MAX DISP MAX DISP = (MAX DISP+7)&(\7) K = R10 RSAVE = R10-28 %IF BLOCK TYPE = 0 %THEN RSAVE = RSAVE+10 B = BLOCK TYPE; LAB = BLOCK_AD ! FILL IN INITIAL 'LA_11,??(11)' SHORTINTEGER(RSAVE) <- MAX DISP %UNLESS B = 0 OLD BLOCK LINE ENTRY = 0 %IF LEVEL = 1; ! IGNORE REST OF LINE %IF B&3 # 0 %THEN PUT LINE %C %AND PLANT(X'47FC0000'+21<<2) %ELSE %START DSS(X'D2',4,X'D014',SHORTINTEGER(RSAVE+4)) %IF B = 0 %C %THEN DRX(X'98',10,11,BLOCK INF(LEVEL+1)_DISP) %C %ELSE %START PLANT(X'984F0010'+(BASE REG-1)<<12) SPLANT(X'07FF') %FINISH %FINISH ! ! REMOVE ROUTINE REFERENCES INSIDE BEGIN/END BLOCKS ! %IF B = 0 %AND LEVEL = 1 %THEN RESTORE ENTRIES ! BRANCH AROUND DIAG TABLE AFTER BEGIN/END BLOCKS %IF B = 0 %THEN J = FORWARD REF(15) ! ! CONSTRUCT DIAGNOSTIC TABLE ! K = CODEIN-K %IF K > 4095 %START GLA = (GLA+3)&(\3) INTEGER(GLA) = K SHORTINTEGER(RSAVE+8) = X'580D' K = GLA-GLAHEAD GLA = GLA+4 %FINISH SHORTINTEGER(RSAVE+10) = K *L_1,CODEIN; *L_2,DIAG END; *LA_3,6(0,0) *SR_2,3; *MVC_0(6,1),0(2) L = 6 %IF DIAGS # 0 %START L = DIAG END-DIAG PT MOVE(L-6,DIAG PT,CODEIN+6) %FINISH CODEIN = CODEIN+L SHORTINTEGER(CODEIN) = 0; ! END MARKER CODEIN = CODEIN+2 DIAG PT = DIAG END+4; DIAG END = INTEGER(DIAG END) ! DEAL WITH OWN ARRAYS %IF OWN DISP # 0 %START; ! OWN ARRAY USED L = OWN END-OWN TOP; ! SIZE OF OWN ARRAYS CODEIN = (CODEIN+7)&(\7); ! ARRAYS START ON DOUBLE WORDS MOVE(L,OWN TOP,CODEIN); ! SHIFT IN THE ARRAYS CODEIN = CODEIN+L INTEGER(OWN DISP) = CODEIN-OLD CODE BASE %FINISH ! ! NOW RESTORE OWN DESCRIPTORS ! OWN INF == RECORD(OWN LIST HEAD) OWN LIST HEAD = OWN INF_LINK OWN INF_LINK = ASL ASL = ADDR(OWN INF) OWN DISP = OWN INF_LABEL OWN TOP = OWN INF_ADDRESS OWN END = OWN INF_USE ! ! REMOVE ANY UNDEFINED ROUTINE (FAULT 7 ETC.) ! %IF COMP MODE&128 # 0 %AND B # 0 %AND LEVEL = 1 %START CODEIN = RTS(BLOCK ENTRY)_EP-4 TIDY(INTEGER(BLOCK NAME+4)) COMP MODE = COMP MODE&B'01101111' FAULTY = 1; ! TO STOP IT BEING CALLED RESTORE ENTRIES %FINISH ! ! INHIBIT EXECUTION OF FAULTY ROUTINES ! %IF FAULTY # 0 %START %PRINTTEXT '* routine faulty ' %C %IF LEVEL = 1 %AND LIST = 'Y' RTS(BLOCK ENTRY)_EP = RT FAULTY %IF BLOCK ENTRY >= 0 %FINISH ! ! FILL IN JUMP ROUND DIAGS AND OWNS AND ROUTINES ! %IF B = 0 %THEN REMOVELABEL(J) %ELSE %START REMOVE LABEL(LAB) %UNLESS LEVEL = 1 %FINISH 1: %END %ROUTINE SET DIAG(%INTEGER AD, NAME) ! PLANT DIAGNOSTIC INFORMATION FOR 'NAME' DIAGPT = DIAGPT-6 SHORTINTEGER(DIAGPT) <- AD SHORTINTEGER(DIAGPT+2) <- NAME SHORTINTEGER(DIAGPT+4) <- DIAG FLAG ! ENABLE FLAG SHOULD BE ZERO ? DIAG SAVE = DIAG PT %IF LEVEL = 1 %END %ROUTINE NEW DIAG(%INTEGER AD) ! PRESERVE THE CURRENT DIAGS POINTERS AND SET UP A NEW ! BLOCK POINTER IN BYTES 20-21 OF GLA DSS(X'D2',4,AD,X'D014') PLANT(X'41000000'); PLANT(X'4000D014') %END %INTEGERFN NEW CELL ! %INTEGER CELL ! FAULT(107) %AND ABORT %IF ASL = 0 ! CELL = ASL ! ASL = INTEGER(ASL+12) ! INTEGER(CELL)=0: INTEGER(CELL+4)=0: ..... *L_1,ASL; *LTR_1,1; *BC_7,; FAULT(107); ABORT OK: *L_2,12(0,1); *STM_1,2,LAST ASL; *XC_0(16,1),0(1) %RETURN %END %ROUTINE NEW BLOCK(%BYTEINTEGER T) ! PRESERVE THE CURRENT CONTEXT AND CREATE A NEW CONTEXT FOR ! THE COMING BLOCK ! !* BLOCK TYPES 0 = '%BEGIN' !* 4 = '%ROUTINE' !* 5 = '%FN'/'%MAP' !* 6 = '%PREDICATE' %SHORTROUTINE %INTEGER AD %IF LEVEL = 11 %THEN FAULT(105) %AND %RETURN ! ! PRESERVE %OWN ARRAY INFO ! PUSH(OWN LIST HEAD,OWN DISP,OWN TOP,OWN END) OWN DISP = 0 OWN END = OWN TOP-4 OWN TOP = OWN END ! ! ! %IF IOFLAG = 1 %AND LIST = 'Y' %START %IF TESTINT(0,'NO') # 0 %START LIST = 'N' DCOMP = 0 %FINISH %ELSE %START WRITE(LINE NUM,4) SPACES((LEVEL-1)<<2+3) %IF T = 0 %THEN %PRINTTEXT 'BEGIN' %C %ELSE PRINTSTRING('RT/FN/MAP '.STRING(INTEGER( %C RTNAME+DICTHEAD))) NEWLINE %FINISH %FINISH %IF LEVEL = 1 %THEN ELISTP = 0 LEVEL = LEVEL+1 FAULT(34) %IF LEVEL > 9 BLOCK == BLOCK INF(LEVEL) BLOCK_TYPE <- BLOCK TYPE %IF T # 0 %START BASE REG = BASE REG-1 %IF BASE REG <= 4 %THEN FAULT(35) %AND BASE REG = 4 REG USE(BASE REG) = 'L';! LOCK THE REGISTER %FINISH %IF COMP MODE&12 = 0 %AND T # 0 %C %THEN COMP MODE = COMP MODE!16 BLOCK_MODE = COMP MODE; COMP MODE = COMP MODE!4 BLOCK_X3 = FNTYPE BLOCK_TYPE2 <- FN TYPE 2 BLOCK_X1 = EFREE BLOCK_FLAGS = ACCESS; COMP MODE = COMP MODE&B'11010111' BLOCK_DISP <- DISP BLOCK_MAX DISP <- MAX DISP BLOCK_SHEAD = START HEAD BLOCK_LHEAD = LABEL HEAD BLOCK_R10 = R10 START HEAD = 0; LABEL HEAD = 0 DIAGPT = DIAGPT-4; INTEGER(DIAGPT) = DIAGEND DIAGEND = DIAGPT; DIAGFLAG <- LINENUM AD = BASE REG %IF T = 0 %THEN AD = DISP SET DIAG(AD,RTNAME) %END %ROUTINE PUSH(%INTEGERNAME HEAD, %INTEGER X, Y, Z) %SHORTROUTINE %RECORDNAME P(LABELFM) %INTEGER CELL CELL = NEW CELL P == RECORD(CELL) P_LINK = HEAD HEAD = CELL P_LABEL = X P_ADDRESS = Y P_USE = Z %END %INTEGERFN ENAME(%INTEGER LIST) ! SEARCH THE FORMAT LIST 'LIST' FOR THE SUB-NAME 'VNAME' ! AND RETURN THE ADDRESS OF ITS DESCRIPTOR. ! GIVE FAULT 65 (WRONG SUBNAME) AND RETURN A DUMMY VALUE IF ! THE NAME IS NOT FOUND %SHORTROUTINE %RECORDNAME NEW(VARFM) %IF LIST # 0 %START NEW == RECORD(LIST) %CYCLE %IF SHORTINTEGER(ADDR(NEW_LEVEL))&X'FFFC' = %C VNAME %START ! NAME FOUND %RESULT = ADDR(NEW) %FINISH %EXIT %IF NEW_LINK = 0; ! END OF LIST NEW == RECORD(NEW_LINK) %REPEAT %FINISH FAULT2(65,VNAME) %RESULT = ADDR(DUMMY NAME) %END %ROUTINE GET4(%INTEGERNAME N) ! N = REC(RP+1)<<16!(REC(RP+2)&X'FFFF') ! RP = RP+2 *L_1,RP; *LA_2,2(1,1); *A_2,REC *L_3,N; *MVC_0(4,3),0(2) *LA_1,2(0,1); *ST_1,RP %END %ROUTINE GET8(%LONGREALNAME R) ! GET4(INTEGER(ADDR(R))) ! GET4(INTEGER(ADDR(R)+4)) *L_1,RP; *LA_2,2(1,1); *A_2,REC *L_3,R; *MVC_0(8,3),0(2) *LA_1,4(0,1); *ST_1,RP %END %ROUTINE GET CYCLE SPACE(%INTEGERNAME A) %INTEGER J A = (DISP+3)&(\3); J = A+12 DISP = J; MAX DISP = J %IF J > MAX DISP MAX DISP = J %IF J > MAX DISP %END %INTEGERFN GET FORMAT(%INTEGER FNAME) %INTEGER A A = GET NAME(FNAME) %IF BYTEINTEGER(A+2) # 31 %C %THEN FAULT2(62,FNAME) %AND %RESULT = 0 %RESULT = A %END %INTEGERFN GET NAME(%INTEGER NAME) %SHORTROUTINE %INTEGER NAMEP NAMEP = INTEGER(NAME+DICTHEAD+4) %IF NAMEP = 0 %START FAULT2(16,NAME); NAMEP = ADDR(DUMMYNAME) %FINISH %RESULT = NAMEP %END %ROUTINE S LOAD(%INTEGER STRING, REGISTER) %SHORTROUTINE %IF STRING < 16 %START; ! ADDRESS IN A REGISTER DRR(X'18',REGISTER,STRING) %UNLESS REGISTER = STRING %FINISH %ELSE %START DRX(X'58',REGISTER,0,STRING); STUAV(REGISTER) %FINISH GPR1 = 0 %IF REGISTER = 1 %END %ROUTINE CSEXPRN(%INTEGERNAME ADDRESS) ! COMPILES STRING EXPRESSIONS ! IF THE EXPRESSION IS SIMPLE (I.E. A SINGLE VARIABLE ! OR A CONSTANT) ADDRESS IS SET TO THE ADDRESS OF THAT ! ENTITY (POSSIBLY A REGISTER (FN,MAP,CONSTANTS ETC.) ! FOR CONCATENATION A TEMPORARY STRING OF 256 BYTES ! IS CLAIMED OFF THE STACK, SET TO THE NULL STRING ! AND THE COMPONENT PARTS OF THE EXPRESSION ARE ! CONCATENATED ONTO IT USING PERM 14 ! THE ADDRESS OF THIS STRING IS RETURNED IN REGISTER 1 %SHORTROUTINE %INTEGER P, ESAVE, LOADOP; %BYTEINTEGER XSAVE %RECORD S(VARFM) S CONST = 0 XSAVE = EXPRN TYPE; EXPRN TYPE = B'10000' RP = RP+1; ! SKIP P(EXPRN) P = REC(RP+2); ! MARK TO (ROX) %IF REC(P) = 1 %START; ! COMPLEX EXPRESSION (CONCATENATION) %IF R14 # 0 %START; ! RESOLUTION USING R14 CLAIMSAFEREGISTER(P);! PRESERVE IT DRR(X'18',P,14) %FINISH ! GET @ OF WORK STRING ON STACK PLANT(EFREE&X'FFFF'+X'41E00000') ESAVE = EFREE EFREE = EFREE+256; ! CLAIM STRING WORKSPACE ADDRESS <- 1; PROTECT(4) PLANT(X'9200E000'); ! SET WORK STRING TO NULL FAULT(72) %UNLESS REC(RP+1) = 4 %CYCLE RP = RP+2 GETSVAR(S) S_FORM = S_FORM&B'11111101' LOAD(S,1); STUAV(1) %IF S CONST = 0 PLANT(X'45FC0000'!14<<2); ! CONCATENATE GPR1 = 0; ! NOW FORGET IT RP = RP+1 %EXIT %IF REC(RP) # 1; ! NO MORE LEFT FAULT(72) %UNLESS REC(RP+1) = 12 ! '.' %REPEAT EFREE = ESAVE SPLANT(X'181E'); ! R1 POINTS TO RESULT %IF R14 # 0 %START RELEASE REGISTER(P) SPLANT(X'18E0'+P); ! RESTORE R14 FOR RESOLUTION %FINISH %FINISH %ELSE %START; ! SIMPLE EXPRN (SINGLE ENTITY) FAULT(73) %UNLESS REC(RP+1) = 4; ! NULL (PLUS) RP = RP+2; ! ONTO P(HOLE) GETSVAR(S) RP = RP+1; ! SKIP (ROX') %IF S_INDEX # 0 %OR S_FLAGS&4 # 0 %START ADDRESS <- S_ADDRESS PROTECT(4) %UNLESS ADDRESS = 1 ADDRESS = ADDRESS<<12 %IF S_FORM&128 # 0 LOADOP = X'58' %IF S_FLAGS&4 # 0 %THEN LOADOP = X'41' DRX(LOADOP,1,S_INDEX,ADDRESS) RELEASEREGISTER(S_INDEX) ADDRESS <- 1; STUAV(1) %IF S CONST = 0 %FINISH %ELSE ADDRESS <- S_ADDRESS&X'FFFF' %FINISH EXPRN TYPE = XSAVE %END %ROUTINE FILL JUMPS(%RECORDNAME HEAD) ! WORKS DOWN THE LIST 'HEAD' FILLING IN THE LABEL ! REFERENCES TO 'LABEL ADDRESS' %SHORTROUTINE %RECORDSPEC HEAD(LABELFM) %RECORDNAME LIST(LABELFM) %INTEGER R, P, Z, A, AD Z = (LABEL ADDRESS>>12&15)<<2 FAULT(99) %IF Z > 15*4 P = HEAD_USE HEAD_USE = 0; ! SHOW LABEL FOUND R = P AD = LABEL ADDRESS&X'FFF'!X'A000' %UNTIL P = 0 %CYCLE LIST == RECORD(P) A = LIST_LABEL %IF Z # 0 %START FAULT(99) %UNLESS SHORTINTEGER(A) = X'41DD' SHORTINTEGER(A) = X'58FC' SHORTINTEGER(A+2) = Z+X'00C8' FAULT(99) %IF BYTEINTEGER(A+5)&15 # 0 BYTEINTEGER(A+5) = BYTEINTEGER(A+5)!15 %FINISH SHORTINTEGER(A+6) = AD P = LIST_LINK %REPEAT LIST_LINK = ASL; ! RETURN CELLS TO ASL ASL = R %END %ROUTINE REMOVE LABEL(%INTEGER LABEL) ! FILLS ANY FORWARD REFERENCES TO 'LABEL' WITH HERE AND REMOVES ! THE REFERENCES. %SHORTROUTINE %RECORDNAME LAB(LABELFM) %INTEGER P %INTEGERNAME LAST LABEL ADDRESS <- CODEIN-R10 LAST == LABEL HEAD P = LAST %WHILE P # 0 %CYCLE LAB == RECORD(P) %IF LAB_LABEL = LABEL %START LAST = LAB_LINK %IF LAB_USE # 0 %THEN FILL JUMPS(LAB) LAB_LINK = ASL ASL = P %RETURN %FINISH LAST == LAB_LINK P = LAST %REPEAT FAULT(209); ! IT DON'T EXIST %END %ROUTINE LABEL FOUND(%INTEGER LABEL) ! FILLS IN ANY OUTSTANDING REFERENCES TO 'LABEL' ! AND REPLACES THE REFERENCE LIST WITH THE RELATIVE ! ADDRESS OF THE LABEL FROM REGISTER 10 %SHORTROUTINE %INTEGER P %RECORDNAME LAB(LABELFM) P = LABEL HEAD %CYCLE %IF P = 0 %START; ! A NEW LABEL PUSH(LABEL HEAD,LABEL,CODEIN-R10,0) %RETURN %FINISH LAB == RECORD(P) %EXIT %IF LAB_LABEL = LABEL; ! FOUND IT P = LAB_LINK; ! MOVE DOWN THE LIST %REPEAT %IF LAB_USE = 0 %START FAULT(-2); ! ALREADY SET PRINT LABEL(LABEL) %RETURN %FINISH LABEL ADDRESS <- CODEIN-R10 LAB_ADDRESS <- LABEL ADDRESS FILL JUMPS(LAB); ! REMOVE OUTSTANDING REFERENCES %END %ROUTINE JUMP TO(%INTEGER LABEL, MASK) %SHORTROUTINE %INTEGER A, X %RECORDNAME LAB(LABELFM) %IF LABEL HEAD = 0 %START; ! FIRST LABEL PUSH(LABEL HEAD,LABEL,0,0) LAB == RECORD(LABEL HEAD) -> 2 %FINISH LAB == RECORD(LABEL HEAD) %CYCLE %IF LAB_LABEL = LABEL %START;! ALREADY USED %IF LAB_USE = 0 %START; ! LABEL ALREADY SET A = LAB_ADDRESS X = 0 %IF A > 4095 %START PLANT(X'58FC00C8'+(A>>12&15)<<2) X = 15 A = A&X'0FFF' %FINISH DRX(X'47',MASK,X,A!X'A000') %RETURN %FINISH 2: PUSH(LAB_USE,CODEIN,0,0); ! ADD NEW REFERENCE PLANT(X'41DD0000'); ! NO-OP DRX(X'47',MASK,0,0) %RETURN %FINISH %IF LAB_LINK = 0 %START;! INSERT FIRST REFERENCE PUSH(LABEL HEAD,LABEL,0,0) LAB == RECORD(LABEL HEAD) -> 2 %FINISH LAB == RECORD(LAB_LINK) %REPEAT %END %INTEGERFN FORWARD ADDRESS(%INTEGER LEN) %INTEGER A A = (CODEIN-R10)&X'00FFFFFF'+LEN %IF A > X'0FFF' %START A = A+4 PLANT(X'58FC00C8'+(A>>12&15)<<2) A = A!X'F000' %FINISH %RESULT = A %END %INTEGERFN FORWARD REF(%INTEGER MASK) %INTEGER L L = ILAB-1; ILAB = L JUMP TO(ILAB,MASK) %RESULT = L %END %INTEGERFN COND TYPE ! EXAMINES THE COMPONENTS OF A CONDITION TO DETERMINE ! WHETHER IT IS STRING OR NUMERICAL. ! THE AMBIGUOUS CASE OF %IF 'A' > 'Z' %THEN ... ! IS DEEMED TO BE A NUMERICAL CONDITION ! ONLY THE FIRST TWO EXPRESSIONS ARE SEARCHED. %SHORTROUTINE %INTEGERFNSPEC TYPE(%INTEGER EP) ! %INTEGER T T = TYPE(COND2+2); ! LOOK AT SECOND EXPRN FIRST %IF T = B'10100' %START; ! SYMBOL OR STRING T = TYPE(COND1+2); ! LOOK AT FIRST EXPRN %IF T = B'10100' %THEN %RESULT = B'100' %FINISH %RESULT = T %INTEGERFN TYPE(%INTEGER EP) %INTEGER P %RECORDNAME WORK(VARFM) %RECORD R(VARFM) %RESULT = B'1100' %UNLESS REC(EP) = 4 ! NULL (PLUS) P = REC(EP+1); ! MARK %IF REC(P) = 1 %START; ! EXAMINE OPERATOR %IF REC(P+1) = 12 %THEN %RESULT = B'10000' ! '.' %RESULT = B'1100' %FINISH %RESULT = B'1100' %IF REC(EP+2) > 2 ! '(' (EXPRN) ')' ETC. %IF REC(EP+2) = 1 %THEN %RESULT = REC(EP+3) ! CONSTANT GET INFO(REC(EP+4),R); ! EXAMINE NAME RP = EP+4 %CYCLE %WHILE R_TYPE = 7 %CYCLE ! RECORD, SO SKIP DOWN FOR ENAME RP = RP+1 %AND SKIP EXPRN %WHILE REC(RP+1) = 1 ! THAT SKIPS ANY PARAMETERS. %RESULT = 4 %IF REC(RP+2) = 2 ! ENAME MISSING RP = RP+4; VNAME = REC(RP);! SKIP P(VAR) ? WORK == RECORD(ENAME(R_INDEX)); R = WORK %REPEAT %RESULT = LOAD TYPE(R_TYPE) %IF R_LEVEL # 0 ! COMPILER NAMES NEED SPECIAL TREATMENT %RESULT = CNTYPE(R_INDEX) %IF R_INDEX # 55 ! PRETEND 'MON_' IS A RECORD R_TYPE = 7 R_INDEX = DIAG HEAD_INDEX %REPEAT %END %END %ROUTINE S COND(%INTEGER MASK, LABEL) ! COMPILES 'SIMPLE' CONDITIONS, VERY DEVIOUS ALTER WITH CARE ! %SHORTROUTINE %RECORD LHS, RHS(VARFM) %INTEGER COMP, TLAB, R, A1, A2, NOT, ESAVE %BYTEINTEGER CTYPE %ROUTINESPEC COMPARE(%INTEGER WAY) %ROUTINESPEC LA(%RECORDNAME R, %INTEGER REG) TLAB = 0 NOT = REC(RP+1)-2 RP = RP+2 %IF REC(RP) = 1 %START; ! (EXPRN)(COMP)(EXPRN)(RSCOND) ESAVE = EFREE; R = 0 COND1 = RP+1; COND2 = REC(COND1) COMP = REC(COND2) %IF COMP = 8 %START; ! RESOLUTION RP = COND1 GET RESLN VAR(COND2) %IF COND2 # 0 %START RP = COND2 CRES(LABEL,(MASK+8!!NOT)&15) %FINISH RP = RP+1 %IF REC(RP) = 1 %START; ! DOUBLE SIDED FAULT(73) RP = RP+2 SKIP EXPRN %FINISH %RETURN %FINISH CTYPE <- COND TYPE %IF CTYPE&B'10000' # 0 %START; ! STRINGS RP = COND2; CSEXPRN(A2); COND2 = RP %IF A2 < 16 %START RELEASE REGISTER(A2) EFREE = EFREE+256;! PROTECT LAST STRING CLAIM SAFE REGISTER(R) DRR(X'18',R,A2) %FINISH %ELSE R = A2 RP = COND1; CSEXPRN(A1); RP = COND2+1 SLOAD(A1,1); SLOAD(R,2) PLANT(X'45FC0000'+19<<2) GPR1 = 0; ! FORGET IT %FINISH %ELSE %START; ! NUMERICAL EXPRN TYPE = B'1100';! SET TO AMBIGUOUS EXPRN RP = COND2; EXPRN(RHS); COND2 = RP RP = COND1; EXPRN(LHS); RP = COND2+1 EQUATE TYPES(RHS,LHS); COMPARE(0) RELEASE REGISTER(LHS_ADDRESS) %IF LHS_TYPE&8 = 0 %FINISH %IF REC(RP) = 1 %START; ! DOUBLE SIDED COMP = (\CONCODE(COMP))&15; ! SET TO 'FALSE' %IF MASK = NOT %START TLAB = FORWARD REF(COMP) %FINISH %ELSE JUMP TO(LABEL,COMP) RP = RP+1; COMP = REC(RP) FAULT(73) %IF COMP = 8 %IF CTYPE&B'10000' # 0 %START CSEXPRN(A1); SLOAD(A1,2); SLOAD(R,1) PLANT(X'45FC0000'+19<<2); GPR1 = 0 ! FORGET IT %FINISH %ELSE %START EXPRN(LHS); EQUATE TYPES(LHS,RHS) COMPARE(-1) RELEASE REGISTER(LHS_ADDRESS) %IF LHS_TYPE&8 = 0 %FINISH %FINISH RELEASE REGISTER(R) %IF 0 # R # A2 EFREE = ESAVE; ! RELEASE STRING WORKSPACE TC: COMP = (CONCODE(COMP)!!MASK!!NOT)&15 JUMP TO(LABEL,COMP) RELEASE REGISTER(RHS_ADDRESS) %C %IF CTYPE # 16 %AND RHS_TYPE&8 = 0 REMOVE LABEL(TLAB) %IF TLAB # 0 %FINISH %ELSE %START %IF REC(RP) = 3 %START COMP = 1; ASSOP = 2; VAR(LHS) RP = RP+1 %IF REC(RP) = 2 %START FAULT(49) %UNLESS LHS_TYPE = 14 ! %PREDICATE %FINISH %ELSE %START;! %IF (VAR) == (VAR) ASSOP = 2; VAR(RHS) LA(RHS,2); LA(LHS,1) SPLANT(X'1912'); GPR1 = 0 %FINISH -> TC %FINISH %ELSE COND(MASK!!NOT,LABEL) ! '(' (COND) ')' %FINISH FPR2 = 0 %RETURN %ROUTINE COMPARE(%INTEGER WAY) ! LOADS AND COMPARES THE TWO EXPRESSIONS 'LHS' AND 'RHS' ! THE TYPES OF WHICH WILL BE THE SAME ! POSSIBLY 'EQUATE TYPES SHOULD BE CALLED IN HERE ? %INTEGER OP, L, R AVAILABLE(R,RHS_TYPE) %AND LOAD(RHS,R) %C %IF RHS_FORM&128 = 0 %OR RHS_FORM&2 # 0 LOAD(LHS,3) %IF LHS_FORM&128 = 0 %OR LHS_FORM&2 # 0 LHS_TYPE = 1 %IF LHS_TYPE = 0; ! FOR ADDRESS COMPARISONS OP = (LHS_TYPE&B'1100')<<2!9 %IF WAY = 0 %C %THEN L = LHS_ADDRESS %AND R = RHS_ADDRESS %C %ELSE R = LHS_ADDRESS %AND L = RHS_ADDRESS DRR(OP,L,R) %END %ROUTINE LA(%RECORDNAME V, %INTEGER REG) ! GET THE ADDRESS OF 'V' INTO REGISTER 'REG' ! AND LOOSE THE TOP BYTE IN THE CASE OF STRINGS %RECORDSPEC V(VARFM) %BYTEINTEGER FLAG, MODE FLAG = V_TYPE %IF FLAG = 16 %START V_FORM = V_FORM!2 %IF V_FLAGS&4 = 0 %FINISH %IF FLAG # 7 %START MODE = V_FORM LOAD ADDR(V,REG) %IF FLAG = 16 %AND MODE&2 # 0 %C %THEN DRX(X'41',REG,REG,0) %FINISH %ELSE %START V_TYPE = 4 V_FORM = V_FORM!2 %IF V_FLAGS&4 = 0 LOAD ADDR(V,REG) %FINISH %END %END %ROUTINE COND(%INTEGER VALIDITY, FARLABEL) %SHORTROUTINE ! !************************************************************* !* * !* THIS ROUTINE COMPILES (COND), TRYING TO PROVE IT * !* 'VALIDITY' AND IF SO, JUMPING TO 'FARLABEL' * !* VALIDITY = -1 FOR 'FALSE', = 0 FOR 'TRUE' * !* * !************************************************************* ! %INTEGER P, MASK, LABEL RP = RP+2; P = REC(REC(RP)); ! SKIP P(COND) %IF P # 3 %START MASK = P-2; ! -1 FOR %AND, 1 FOR %OR %IF (P+VALIDITY)&1 = 0 %THEN LABEL = FARLABEL %C %ELSE LABEL = ILAB-1 %AND ILAB = LABEL SCOND(MASK,LABEL) %AND RP = RP+2 %C %UNTIL REC(REC(RP)) = 2 %FINISH SCOND(VALIDITY,FARLABEL); ! LAST CONDITION ALWAYS THE SAME RP = RP+1 REMOVE LABEL(LABEL) %UNLESS P = 3 %OR LABEL = FARLABEL %END %ROUTINE C COND(%INTEGER CTYPE) %SHORTROUTINE ! CTYPE = 1 => %IF ! = 2 => %UNLESS ! = 3 => %WHILE ! = 4 => %UNTIL %INTEGER ULAB, TRUTH TRUTH = -(CTYPE&1); ! -1 FOR IF & WHILE, 1 FOR UNLESS & UNTIL ELSE LABEL = ILAB-1; ILAB = ELSE LABEL %IF CTYPE > 2 %START ULAB = FORWARD REF(15) %IF CTYPE = 4 CYCLE LABEL = ILAB-1; ILAB = CYCLE LABEL LABEL FOUND(CYCLE LABEL) PUT LINE %FINISH COND(TRUTH,ELSE LABEL) %IF CTYPE = 4 %THEN REMOVE LABEL(ULAB) ! %CYCLE PRESERVES 'CYCLE LABEL' %AND 'ELSE LABEL' ! %START PRESERVES 'ELSE LABEL' %END %ROUTINE S CPE(%RECORDNAME V, %INTEGER EX) ! TESTS FOR STRING CAPACITY EXCEEDED ! A VERY NASTY THING IF RECORDS ARE ABOUT !!!!!! %SHORTROUTINE %RECORDSPEC V(VARFM) %INTEGER B %IF V_LENGTH # 255 %AND TUAV # 0 %START %IF V_DIMENSION = 7 %START DRX(X'58',15,0,DOPE VECTOR+8) B = X'F003' -> 1 %FINISH B = V_ADDRESS %IF V_LENGTH # 0 %THEN DSI(X'95',EX,V_LENGTH) %C %ELSE %START %IF V_INDEX # 0 %START DRX(X'41',15,V_INDEX,B); B = X'F000' %FINISH 1: DSS(X'D5',1,EX,B) %FINISH PLANT(X'472C0000'!4<<2) %FINISH %END %ROUTINE GETSVAR(%RECORDNAME V) ! RP ON (HOLE) %SHORTROUTINE %RECORDSPEC V(VARFM) %INTEGER P RP = RP+1 %IF REC(RP) = 2 %THEN VAR(V) %ELSE %START %IF REC(RP) = 1 %START CCONST(V) %IF V_TYPE = B'10100' %C %THEN V_ADDRESS <- V_ADDRESS!256 %C %AND V_TYPE = B'10000' %FINISH %ELSE %START P = 72 %IF REC(RP) = 3 %THEN P = 75 FAULT(P) RP = REC(RP-1)-1; ! SKIP PAST THE OPERAND V_INDEX = 0 V_ADDRESS = 0 V_TYPE = B'10000' V_FORM = 1 ! ALL DUMMY VALUES %FINISH %FINISH FAULT(71) %IF V_TYPE&B'10000' = 0 %AND V_LEVEL # 255 V_TYPE = 4 %IF V_FLAGS&4 # 0 %THEN V_TYPE = 0 %END %ROUTINE GET NAME VAR(%RECORDNAME V, %INTEGER FLT) %SHORTROUTINE %RECORDSPEC V(VARFM) %INTEGER ASSP %SHORTINTEGER ENTRY ENTRY = RP %IF REC(RP+2) # 4 %OR REC(RP+4) # 2 %THEN -> FLTY ASSP = ASSOP; ASSOP = 1 RP = RP+4; VAR(V); ASSOP = ASSP; RP = RP+1 %IF REC(RP) = 1 %START RP = ENTRY FLTY: FAULT(FLT); SKIP EXPRN V = DUMMY NAME %FINISH %END %ROUTINE AVAILABLE(%INTEGERNAME REGISTER, %BYTEINTEGER TYPE) ! SEARCHES THE REGISTER LIST AND RETURNS A FREE REGISTER ! TRYING REGISTER 1 FIRST ! REAL EXPRESSIONS WILL ALWAYS GET FPR2 %SHORTROUTINE %IF TYPE&B'100' # 0 %START %IF GPR1 = 0 %THEN REGISTER = 1 %C %ELSE CLAIMSAFEREGISTER(REGISTER) %RETURN %FINISH PROTECT(8) REGISTER = 1 %END %ROUTINE STUAV(%INTEGER REG) ! CHECK THE STRING AT 'REG' FOR UNASSIGNED %RETURN %IF TUAV = 0 DSS(X'D5',2,REG<<12,X'D000'!22<<2) PLANT(X'478C000C') S CONST = 0 %END %ROUTINE TESTUAV(%BYTEINTEGER T, %INTEGER REGISTER) %SHORTROUTINE %RETURN %IF TUAV = 0 %IF T = B'100' %THEN T = X'59' %ELSE %START %IF T = B'1010' %THEN T = X'69' %ELSE %START %RETURN %UNLESS T = B'1000' T = X'79' %FINISH %FINISH DRX(T,REGISTER,13,22<<2) PLANT(X'478C000C') %END %ROUTINE SETTEXT(%BYTEINTEGER FLAG) ! DUMPS THE GIVEN TEXT IN-LINE, PREFIXED BY A SUITABLE ! BRANCH AND LINK %SHORTROUTINE ! RP ON P(TYPE) %INTEGER AD, T, L RP = RP+1; L = REC(RP); ! LENGTH OF TEXT RP = RP+1; AD = ADDR(LINE(REC(RP))) BYTEINTEGER(AD) <- L T = (L+2)&(\1); ! FOR HALFWORD ALLIGNMENT %IF FLAG = 0 %START; ! NORMAL STRINGS PROTECT(4) PLANT(X'451A0000'+FORWARD ADDRESS(T+4)) %FINISH %ELSE %START DRX(X'41',14,0,(EFREE+7)&(\7)); ! NEW R11 FOR PTXT PLANT(X'45FC0000'!20<<2); ! PRINTTEXT %FINISH STRING(CODEIN) = STRING(AD); ! MOVE IN TEXT CODEIN = CODEIN+T %END %ROUTINE PUT4(%INTEGER N) ! REC(RP) <- SHORTINTEGER(ADDR(N)) ! REC(RP+1) <- SHORTINTEGER(ADDR(N)+2) ! RP = RP+2 *L_1,RP; *LA_2,0(1,1); *A_2,REC *MVC_0(4,2),N *LA_1,2(0,1); *ST_1,RP %END %ROUTINE PUT8(%LONGREAL R) ! PUT4(INTEGER(ADDR(R))) ! PUT4(INTEGER(ADDR(R)+4)) *L_1,RP; *LA_2,0(1,1); *A_2,REC *MVC_0(8,2),R *LA_1,4(0,1); *ST_1,RP %END %ROUTINE CCONST(%RECORDNAME V) %SHORTROUTINE %RECORDSPEC V(VARFM) %INTEGER IC, T, F %LONGREAL RC F = 1; ! FORM RP = RP+1 T = REC(RP); ! TYPE OF CONSTANT %IF T&B'100' # 0 %START; ! INTEGER (OR SYMBOL) GET4(IC); ! PICK UP THE CONSTANT %IF T = B'10100' %AND EXPRNTYPE&B'10000' # 0 %START PROTECT(4) %IF IC = 0 %THEN PLANT(X'411D0006') %ELSE %START PLANT(X'451A0000'+FORWARD ADDRESS(6)) IC = IC+256 %UNLESS IC = 0; ! ZERO LENGTH FOR NULL SHORTINTEGER(CODEIN) <- IC; ! PLUG IN STRING CODEIN = CODEIN+2 %FINISH -> STR %FINISH %ELSE T = B'100' %IF EXPRN TYPE&B'100' = 0 %START T = B'1011'; ! EXTRA BIT FOR '$** ETC %IF IC = 0 %THEN -> 1; ! WASTE OF TIME FLOATING RC = IC; -> REAL %FINISH %IF IC>>12 = 0 %START; ! CAN USE 'LA' ZERO EXP = ZERO EXP!1 %IF IC = 0 F = 0; T = 0 1: V_TYPE = T V_FORM = F V_ADDRESS <- IC V_INDEX = 0 %RETURN %FINISH INTEGER(GLA) = IC; ! PUT INTO GLA IC = GLA-GLAHEAD!X'D000' GLA = GLA+4 -> 1 %FINISH %IF T&B'1000' # 0 %START; ! REAL EXPRNTYPE = B'1010' %IF EXPRNTYPE = B'1100' ! SET TO REAL (FOR COND-EXPRNS) GET8(RC) REAL: IC = (GLA+7)&(\7) GLA = IC+8 LONGREAL(IC) = RC; ! PUT INTO GLA IC = IC-GLAHEAD!X'D000' -> 1 %FINISH ! STRINGS :: (TYPE)(LENGTH)(TEXT) SET TEXT(0); S CONST = 1 STR: V_ADDRESS <- 1 V_TYPE = B'10000' V_FORM = 128 V_FLAGS = 0 V_LENGTH = 0 V_INDEX = 0 GPR1 = ADDR(V) %END ! %ROUTINE GETINFO(%INTEGER NAME, %RECORDNAME VAR) !* RP SET BEFORE P(VAR) %RECORDSPEC VAR(VARFM) *LM_1,2,NAME *L_3,DICT HEAD *L_1,4(3,1) *LTR_1,1; *BC_7, **1,@DUMMYNAME SET: *MVC_0(12,2),0(1) ! !***** IMP VERSION ***** ! ! NAME=INTEGER(NAME+DICT HEAD+4) ! VAR = RECORD(NAME) %END %ROUTINE RT SAVE(%INTEGER R2) ! SAVES REGISTERS 4 - 'R2' ON THE STACK AND BUMPS ! EFREE ON PAST THEM (MORE OR LESS !) %INTEGER A EFREE = (EFREE+7)&(\7); ! DOUBLE WORD BOUNDARY A = EFREE+16; ! WHERE TO START STM DRX(X'90',4,R2,A) %IF EFREE # X'B000' %THEN DRX(X'41',11,0,EFREE) EFREE <- A+60; ! BUMP R11 PAST SAVE AREA %END %ROUTINE TEST STUDENT %IF STUDENT # FIDDLE FACTOR %START; ! DEVIOUS GOINGS ON *LM_4,15,16(9) *BCR_15,15 %FINISH FAULT2(16,VNAME) %IF STUDENT # 0 %END %ROUTINE C C NAME(%RECORDNAME V) ! !**************************************************************** !* * !* THIS ROUTINE DUMPS CODE FOR BUILT IN NAMES. * !* IT IS VERY MESSY AND COULD DO WITH A COMPLETE * !* RETHINK AND REWRITE. HOWEVER THE SETTING OF * !* ALL THE FLAGS IS CRITICAL SO LOOK OUT ! * !* * !**************************************************************** ! %SHORTROUTINE %RECORDSPEC V(VARFM) %RECORDNAME WORK VAR(VARFM) %RECORD X2, X3(VARFM) %OWNBYTEINTEGER ADDR TYPE %INTEGER A, P, R, N, BINAME, R2, ESAVE, FORMAT NAME %BYTEINTEGER RFLAG, XSAVE %CONSTBYTEINTEGERARRAY EP(13 : 54) = %C 1, 2, 3, 4, 5,19, 9,10,11,12,13,14,15,16,17,18, 6, 7, 8,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,38,39,40, 41,42,0 %ROUTINESPEC CIOCP(%INTEGER R) %SWITCH CN(0 : 55) BINAME = VNAME ESAVE = EFREE; XSAVE = EXPRN TYPE RFLAG = 0; R2 = 0 P = V_INDEX; V = 0 PROTECT(4) %AND PROTECT(8) %IF P >= 12 -> CN(P) CN(0): FAULT(212); V = DUMMYNAME; -> 1 ! CN(1): ! INTEGER CN(2): ! BYTEINTEGER CN(3): ! SHORTINTEGER CN(4): ! REAL CN(5): ! LONGREAL CN(6): ! STRING CN(7): ! RECORD ! TEST STUDENT -> F19 %IF REC(RP) = 2 FAULT(84) %IF P = 7 %AND ASSOP # 1 EXPRN TYPE = B'100'; EXPRN(V) %IF P = 7 %START CLAIM SAFE REGISTER(R); LOAD(V,R) V_FORM = B'10000011' %FINISH %ELSE %START %IF V_TYPE # 0 %START %IF V_FORM&2 = 0 %THEN V_FORM = V_FORM!2 %C %ELSE %START CLAIM SAFE REGISTER(R); LOAD(V,R) V_FORM = V_FORM!2;! IT'S STILL INDIRECT %FINISH V_FLAGS = V_FLAGS&B'11111011' %FINISH %ELSE %START V_FORM = V_FORM!2 %IF V_FORM&128 # 0 %FINISH V_FORM = V_FORM!1; ! SET VARIABLE BIT %FINISH V_DIMENSION <- V_TYPE V_TYPE = TYPE CODE(P); V_LENGTH = 255 -> TINDEX ! CN(10): ! ADDR ! TEST STUDENT -> F19 %IF REC(RP) = 2 GET NAME VAR(V,22) FAULT(22) %IF V_FORM&3 = 0 ADDR TYPE = V_TYPE; BINAME = VNAME %IF V_FORM&128 = 0 %START V_FORM = V_FORM!2 %C %IF (V_TYPE = B'10000' %AND V_LENGTH = 0) %C %OR (V_TYPE = B'111' %AND V_FLAGS&4 = 0) V_TYPE = 4 %IF V_FORM&2 = 0 %THEN V_TYPE = 0 V_FLAGS = V_FLAGS!4 V_FORM = V_FORM&B'11111100' TINDEX: %IF V_INDEX # 0 %START CLAIM SAFE REGISTER(R) LOAD(V,R) %FINISH -> NMP %FINISH V_TYPE = 0 %IF V_INDEX # 0 %START DRR(X'1A',V_INDEX,V_ADDRESS) RELEASE REGISTER(V_ADDRESS) V_ADDRESS = V_INDEX V_INDEX = 0; V_TYPE = B'100' %FINISH V_FLAGS = V_FLAGS!4 V_FORM = 128 -> NMP ! CN(55): ! MON_..... FAULT(97) %IF MON LOCK = 0 -> SF19 %IF REC(RP) # 2 RP = RP+1 FAULT(64) %AND %RETURN %IF REC(RP) # 1 ! SUBNAME RP = RP+2; VNAME = REC(RP); ! PICK UP NAME WORK VAR == RECORD(ENAME(DIAG HEAD_INDEX)) V = WORK VAR A = V_ADDRESS; V_ADDRESS = A&X'FFF' V_LENGTH = 255; ! FIDDLE FOR STRINGS AS LENGTH UNKNOWN R = A>>10&X'3C' CLAIM SAFE REGISTER(R2) INDEX PT = R2 DRX(X'58',R2,13,0); ! PICK UP FRAME POINTER DRX(X'58',R2,R2,R); ! PICK UP BASE REGISTER -> NMP CN(54): ! ARRAY(EXPRN, FORMAT) ! TEST STUDENT -> F19 %IF REC(RP) = 2 FAULT(89) %IF ASSOP # 1 INDEX PT = 4 EXPRN TYPE = 4; ! ADDRESSES ARE INTEGERS EXPRN(X2) RP = RP+1; -> F19 %IF REC(RP) = 2 R2 = RP %IF REC(RP+2) # 4 %OR REC(RP+4) # 2 %START AF22: FAULT(22) RP = R2 SKIP EXPRN V = DUMMY NAME %FINISH %ELSE %START RP = RP+6; FORMATNAME = REC(RP) GET INFO(FORMATNAME,V) -> AF22 %IF REC(RP+1) # 2 %OR REC(RP+2) # 2 %C %OR REC(RP+3) # 2 RP = RP+3 %FINISH FAULT2(88,VNAME) %IF V_TYPE&132 = 0; ! NOT A FORMAT LOAD(X2,4); ! REGISTER 4 WILL BE FREE REGUSE(4) = 'C'; ! LOCK REGISTER 4 V_TYPE = V_TYPE&127; ! REMOVE FORMAT BIT V_FORM = B'00000101'; ! MAKE IT LOOK LIKE A RECORD ARRAY -> NMP ! CN(8): ! LENGTH ! -> F19 %IF REC(RP) = 2 C S EXPRN(A) %IF A < 16 %START STUAV(A) GPR1 = ADDR(V) %IF A = 1 EFREE = EFREE+1; ! PROTECT LENGTH BYTE V_FORM = B'10000011' %FINISH %ELSE V_FORM = B'11' V_ADDRESS <- A; V_TYPE = B'101' -> NMP ! CN(11): ! ! NL -> SF19 %IF REC(RP) = 1 V_TYPE = 0; V_FORM = 0; V_ADDRESS <- 10 -> 1 ! CN(12): ! SNL ! -> SF19 %IF REC(RP) = 1 PLANT(PERM SNL) V_TYPE = B'10000'; V_FORM = 128; V_ADDRESS <- 1 S CONST = 1 GPR1 = ADDR(V) -> 1 CN(9): ! TOSTRING -> F19 %IF REC(RP) = 2 EXPRNTYPE = B'100'; EXPRN(V); LOAD(V,1) STR: EFREE = (EFREE+1)&(\1); ! WORK SPACE PLANT(X'40100000'+EFREE&X'FFFF'); GPR1 = 0 ! FORGET IT S CONST = 1 DSI(X'92',EFREE,1) V_TYPE = B'10000'; V_FORM = 1; V_ADDRESS <- EFREE V_LENGTH = 1; V_FLAGS = 4 EFREE = EFREE+2 -> NMP %UNLESS RFLAG = 4; -> 1 CN(13): ! READ CN(14): ! READSYMBOL CN(15): ! READCH -> F19 %IF REC(RP) = 2 GET NAME VAR(X2,22) PROTECT(4) A = CODEIN CIOCP(0) V_ADDRESS = 1; V_TYPE = B'100'; V_FORM = 128 %IF P = 13 %START; ! READ FAULT(22) %IF X2_TYPE&B'10000' # 0 %OR X2_FORM&3 = 0 %IF X2_TYPE&B'1000' # 0 %START; ! REAL PARM V_TYPE = B'1010'; ! LONGREAL V_ADDRESS = 2; ! RESULT IN FPR2 SHORTINTEGER(A+2) = 37 %FINISH %FINISH %ELSE %START FAULT(22) %IF X2_TYPE&B'11000' # 0 %OR X2_FORM&3 = 0 %FINISH ASSOP = 2 STORE(V,X2) V_TYPE = 15; V_FORM = 0 -> NMP CN(16): ! READSTRING CN(17): ! READ ITEM -> F19 %IF REC(RP) = 2 V_INDEX = 10; C C NAME(V) LOAD(V,1) FAULT(22) %UNLESS ADDR TYPE = B'10000' ! STRING CIOCP(1) V_FORM = 0; V_TYPE = 15 -> 1 CN(18): ! WRITE -> F19 %IF REC(RP) = 2 EXPRNTYPE = B'100' EXPRN(V) RP = RP+1; -> F19 %IF REC(RP) = 2 EXPRN(X2); R2 = 2 LOAD(X2,2); LOAD(V,1) V_TYPE = 15; V_FORM = 0 RFLAG = 8 -> RT ENTRY CN(19): ! PRINT CN(20): ! PRINTFL -> F19 %IF REC(RP) = 2 EXPRNTYPE = B'1010'; EXPRN(V) RP = RP+1; -> F19 %IF REC(RP) = 2 EXPRN TYPE = B'100'; EXPRN(X2); RFLAG = 2 R2 = 1 %IF P # 20 %START; ! PFL RP = RP+1; -> F19 %IF REC(RP) = 2 R2 = 2; EXPRN(X3) LOAD(X3,2) %FINISH LOAD(V,2); LOAD(X2,1) V_TYPE = 15; V_FORM = 0 -> RTENTRY CN(48): ! PROMPT CN(21): ! PRINTSTRING -> F19 %IF REC(RP) = 2; RFLAG = 8 CSEXPRN(A); EFREE = EFREE+256 %IF A < 16 S LOAD(A,1) V_TYPE = 15; V_FORM = 0 R2 = 1; -> RT ENTRY CN(49): ! SELECTINPUT CN(50): ! SELECTOUTPUT CN(51): ! CLOSESTREAM CN(22): ! PRINTSYMBOL CN(23): ! PRINTCH R2 = 1; N = 0; -> NS2 CN(24): ! NEWLINE N = X'4110000A' NS0: P = 22 PLANT(N) V_TYPE = 15; V_FORM = 0; CIOCP(1) -> SF19 %IF REC(RP) = 1 -> 1 CN(25): ! NEWLINES N = 10 NS1: P = 28; R2 = 2 NS2: -> F19 %IF REC(RP) = 2 EXPRNTYPE = B'100'; EXPRN(V); LOAD(V,R2) PLANT(X'41100000'+N) %UNLESS N = 0 RFLAG = 8 CN(53): ! DRAIN CN(52): ! RESUME V_TYPE = 15; V_FORM = 0; -> RT ENTRY CN(26): ! NEWPAGE N = X'4110000C'; -> NS0 CN(27): ! SPACE N = X'41100020'; -> NS0 CN(28): ! SPACES N = 32; -> NS1 CN(29): ! NEXTSYMBOL CN(30): ! NEXTITEM CN(31): ! SKIPSYMBOL -> SF19 %IF REC(RP) = 1 CIOCP(0) -> STR %IF P = 30 V_TYPE = 15; V_FORM = 0 %IF P = 29 %START V_ADDRESS = 1; V_FORM = 128; V_TYPE = B'100' GPR1 = ADDR(V) %FINISH -> 1 CN(32): ! FROMSTRING CN(33): ! CHARNO -> F19 %IF REC(RP) = 2 A = RP; SKIP EXPRN RP = RP+1; -> F19 %IF REC(RP) = 2 EXPRN TYPE = B'100'; ! INTEGER PARM WANTED EXPRN(V) R2 = 2 %IF P = 32 %START; ! FROM STRING S CONST = 1 R2 = 3 RP = RP+1; -> F19 %IF REC(RP) = 2 EXPRN(X2) %FINISH N = RP; RP = A; C S EXPRN(A); RP = N EFREE = EFREE+256 %IF A < 16 S LOAD(A,1) LOAD(V,2) LOAD(X2,3) %IF P = 32 CIOCP(R2) V = 0 V_ADDRESS = 1; V_FORM = 128 V_TYPE = 4; ! INTEGER (SYMBOL) %IF P = 32 %THEN V_TYPE = 16; ! STRING GPR1 = ADDR(V) -> NMP CN(34): ! INT CN(35): ! INTPT CN(36): ! FRACPT CN(37): ! SIN CN(38): ! COS CN(39): ! TAN CN(40): ! ARCSIN CN(41): ! ARCCOS CN(44): ! SQRT CN(45): ! MOD CN(46): ! LOG CN(47): ! EXP -> F19 %IF REC(RP) = 2 EXPRNTYPE = B'1010'; EXPRN(V); LOAD(V,1) RFLAG = 1 %IF P = 34 %OR P = 35 %START V_ADDRESS = 1; V_TYPE = B'100' RFLAG = 9 %FINISH CIOCP(R2) %IF RFLAG # 1 %THEN GPR1 = ADDR(V) %ELSE FPR2 = ADDR(V) -> NMP CN(42): ! ARCTAN CN(43): ! RADIUS -> F19 %IF REC(RP) = 2 EXPRN TYPE = B'1000' EXPRN(V) RP = RP+1; -> F19 %IF REC(RP) = 2 EXPRN(X2) LOAD(X2,2) LOAD(V,1) RFLAG = 3 CIOCP(2) FPR2 = ADDR(V) ->NMP SF19: %UNTIL REC(RP) = 2 %CYCLE SKIP EXPRN; RP = RP+1 %REPEAT F19: FAULT2(19,BINAME); V = DUMMY NAME; -> 1 FN: -> STR %IF P = 30 %IF RFLAG = 12 %START V_ADDRESS = X'E000' V_TYPE = ADDR TYPE V_FORM = 1 %FINISH V_ADDRESS <- 1; V_TYPE = B'100'; V_FORM = 128; -> 1 RT ENTRY: CIOCP(R2) -> 1 %IF RFLAG = 0 -> FN %IF RFLAG&4 # 0 ! ! CHECK THERE ARE NO MORE PARAMETERS ! NMP: RP = RP+1; -> SF19 %IF REC(RP) = 1 1: VNAME = BINAME; EXPRN TYPE = XSAVE EFREE <- ESAVE; %RETURN ! !******************************************************************** !* * !* %SYSTEMROUTINE I8IOCP(%INTEGER EP,IP1,%LONGREAL RP1,RP2) * !* * !******************************************************************** ! %ROUTINE CIOCP(%INTEGER R) NASTY = 1 PLANT(X'41000000'+EP(P)); ! SERVICE NUMBER RTSAVE(R) *XC_GPR1(8),GPR1 %IF RFLAG&1 # 0 %THEN PLANT(X'6020B048') %IF RFLAG&2 # 0 %THEN PLANT(X'6040B050') PLANT(X'45FC0000'!23<<2) %END %END %ROUTINE VAR(%RECORDNAME V) ! RP ON P(VAR)-1 %SHORTROUTINE %RECORDSPEC V(VARFM) %RECORDNAME VV(VARFM) %ROUTINESPEC CRFM %ROUTINESPEC CAREF %INTEGER INDEX, FLIST; %BYTEINTEGER REC FLAG, NSFLAG RP = RP+2; VNAME = REC(RP); ! NAME OF VARIABLE REC FLAG = 0; NSFLAG = 0 INDEX = 0; ! INDEX REGISTER *L_1,VNAME; *L_2,V; *L_3,DICT HEAD *L_1,4(3,1) *LTR_1,1; *BC_8,; ! ZERO => NOT SET *MVC_0(12,2),0(1) -> 3 NNS: FAULT2(16,VNAME); ! NAME NOT DECLARED NSFLAG = 1 %IF LEVEL > 1 %START; ! DECLARE THE NAME VV == RECORD(NEW CELL) VV = DUMMY NAME VV_LEVEL = LEVEL INTEGER(VNAME+DICTHEAD+4) = ADDR(VV) %FINISH 1: RELEASE REGISTER(INDEX); INDEX = 0 V = DUMMYNAME; SUSPEND = 'Y' 3: %IF V_FLAGS&1 # 0 %THEN FAULT2(21,VNAME) %AND -> 1 FAULT2(20,VNAME) %AND -> 1 %IF V_TYPE > 30 OLD INDEX = V_INDEX; ! REMEMBER IT FOR REC1=REC2 RP = RP+1 %IF V_LEVEL = 0 %C %THEN INDEXPT == INDEX %AND CCNAME(V) %ELSE %START V_TYPE = 4 %AND FAULT2(12,VNAME) %IF V_TYPE = 13 %IF V_FORM&B'1100' # 0 %START; ! RFM OR ARRAY %IF V_FORM&B'100' # 0 %THEN CAREF %ELSE CRFM %FINISH %ELSE %START V_DIMENSION = 255 %AND CAREF %IF REC(RP) = 1 %FINISH %FINISH ! NOW TEST FOR (ENAME) RP = RP+1 %IF REC(RP) = 1 %START; ! (ENAME) FOUND REC FLAG = 1 FAULT2(19,VNAME) %C %IF V_FORM&B'1100' # 0 %AND NSFLAG = 0 RP = RP+2; VNAME = REC(RP); ! SKIP P(VAR) / SUB-NAME %IF V_TYPE # B'111' %START FAULT2(69,VNAME) %IF NSFLAG = 0 -> 1 %FINISH V_FORM = V_FORM!2 %IF V_FLAGS&4 = 0 FLIST = V_INDEX; V_INDEX = INDEX; V_TYPE = B'100' CLAIM SAFE REGISTER(INDEX) %IF INDEX = 0 LOAD ADDR(V,INDEX) WORK == RECORD(ENAME(FLIST)); V = WORK %IF V_LEVEL = 255 %C %THEN RELEASEREGISTER(INDEX) %AND SUSPEND = 'Y' V_DIMENSION = V_DIMENSION&3 V_LEVEL = 1 %IF V_LEVEL = 0 ! TO PREVENT FAULT 212 FROM _A ETC. -> 3 %FINISH V_INDEX = INDEX; CPELEN = V_LENGTH %RETURN ! %ROUTINE CRFM ! COMPILES ROUTINE/FN/MAP/PREDICATE REFERENCES ! MAY BE DUBIOUS IN DEALING WITH MAPNAME PARMS ! %RECORD PARM(VARFM) %LONGREAL REGS1 %INTEGER ESAVE, A, TNAME, AD %BYTEINTEGER XSAVE PROTECT(4); PROTECT(8) ESAVE = EFREE %IF REC(RP) = 2 %START; ! NO PARMS GIVEN %IF V_INDEX = 0 %START; ! NONE WANTED RT SAVE(14) %AND -> ENTRY %C %IF MAPV = 1 %OR ASSOP # 1 %RETURN %FINISH %RETURN %IF ASSOP <= 1 A = 21 %IF V_INDEX >= 0 %C %THEN A = 19 %AND RELEASEREGISTER(V_INDEX) V_INDEX = 0 FAULT2(A,VNAME) %IF NSFLAG = 0 V_FORM = 1; V_TYPE = B'100' %RETURN %FINISH ! PARMS GIVEN -> SFLT %UNLESS V_INDEX > 0 *L_1,AREG; ! %CYCLE P=4,1,8 *MVC_REGS1(5),0(1); ! REGSAVE(P)=REGUSE(P): REGUSE(P)=0 *XC_0(5,1),0(1); ! %REPEAT TNAME = VNAME RT SAVE(14) XSAVE <- EXPRN TYPE WORK == RECORD(V_INDEX); PARM = WORK 1: ASSOP = PARM_FLAGS>>6 MAPV = 0 %IF PARM_FORM&B'1000' = 0 %THEN MAPV = 1 ASSIGN(PARM,ASSOP); ! COMPILE PARAMETER RP = RP+1 %IF REC(RP) = 1 %START %IF PARM_LINK = 0 %START SFLT: FAULT2(19,VNAME) %IF NSFLAG = 0 SKIP EXPRN %AND RP = RP+1 %UNTIL REC(RP) = 2 -> ENTRY0 %FINISH WORK == RECORD(PARM_LINK); PARM = WORK EFREE = PARM_ADDRESS -> 1 %FINISH FAULT2(19,VNAME) %UNLESS PARM_LINK = 0 %OR NSFLAG = 1 ENTRY0: *L_1,AREG; *MVC_0(5,1),REGS1 ! %CYCLE P=4,1,8: REGUSE(P)=REGSAVE(P): %REPEAT VNAME = TNAME; EXPRN TYPE = XSAVE ENTRY: EFREE = ESAVE %IF 0 # V_TYPE # 15 %START %IF V_TYPE&8 = 0 %THEN GPR1 = ADDR(V) %C %ELSE FPR2 = ADDR(V) %FINISH A = V_FLAGS>>4&3; ! SORT OF ROUTINE ! 1 = NORMAL, 2 = EXTERNAL, 3 = PARAM AD = V_ADDRESS&X'FFFF' %IF RT MON ENABLE # 0 %AND A # 3 %START ! MONITOR IT PLANT(X'41E00000'+AD); ! @ENTRY VECTOR PLANT(X'41000000'+(AD-RTBASE)>>4&255) ! RT INDEX PLANT(RT MON ENTRY); ! OFF TO PERM %FINISH %ELSE %START %IF A = 1 %THEN PLANT(AD+X'58E00008') %ELSE %START %IF A = 2 %THEN PLANT(AD+X'98CE0000') %C %ELSE %START PLANT(X'58E00000'+AD) PLANT(X'98CFE000') PLANT(X'9849F010') %FINISH %FINISH SPLANT(X'05FE') %FINISH NASTY = 1 V_FORM = V_FORM&B'11' V_FORM = V_FORM!129 V_FORM = 0 %IF V_TYPE = 15 %OR V_TYPE = 14 V_ADDRESS = 1 %IF V_TYPE&B'1000' # 0 %THEN V_ADDRESS = 2 %END %ROUTINE CAREF ! COMPILES ARRAY REFERENCES ! THE TEST ON ARRAYNAMES COULD BE DONE BY THE ! COMPILER BUT IT IS VERY TEDIOUS %RECORD S, P(VARFM) %INTEGER N, XSAVE, ESAVE, PERM, R, TNAME, SINDEX N = 0; ! COUNT FOR NUMBER OF DIMENSIONS %IF REC(RP) = 1 %START; ! PARMS GIVEN PROTECT(4) S_FORM = 1 S_INDEX = 0; S_TYPE = B'100'; S_ADDRESS <- EFREE ESAVE = EFREE; XSAVE = EXPRNTYPE EXPRNTYPE = B'100' SINDEX = OLD INDEX R = 2 TNAME = VNAME %CYCLE EXPRN(P) RP = RP+1; N = N+1 %EXIT %IF REC(RP) # 1; ! NO MORE PARMS STORE(P,S); ! WILL LOAD IF NEEDED EFREE = EFREE+4 S_ADDRESS <- EFREE GPR1 = 0; ! FORGET IT %REPEAT %IF N > 1 %START; ! MULTI-DIMENSIONAL STORE(P,S); DRX(X'41',1,0,EFREE) EFREE = ESAVE; PERM = X'45FC0008' %FINISH %ELSE %START LOAD(P,1); PERM = X'45FC0004' GPR1 = 0; ! FORGET IT %FINISH EXPRNTYPE = XSAVE %IF V_DIMENSION&7 # N %START %IF V_DIMENSION&7 # 0 %START FAULT2(19,VNAME) %IF NSFLAG = 0 %FINISH %ELSE %START BYTEINTEGER(INTEGER(VNAME+DICTHEAD+4)+5) %C <- N %UNLESS REC FLAG = 1 %OR V_LEVEL = 255 %FINISH %FINISH V_DIMENSION = 0 VNAME = TNAME %FINISH %ELSE %START R = 1 FAULT2(19,VNAME) %UNLESS ASSOP = 1 %OR NSFLAG = 1 %FINISH DOPE VECTOR = V_ADDRESS&X'FFFF' %IF V_FORM&B'10000' = 0 %START %IF R = 1 %THEN R = DOPEVECTOR %C %ELSE DRX(X'41',2,0,DOPEVECTOR) %FINISH %ELSE %START %IF INDEX # 0 %START %IF R = 1 %THEN R = INDEX %C %ELSE RELEASE REGISTER(INDEX) DRX(X'41',R,INDEX,DOPEVECTOR) V_FORM = V_FORM!128 INDEX = 0 %FINISH %ELSE %START %IF R = 1 %THEN R = DOPE VECTOR %C %ELSE PLANT(X'41200000'+DOPE VECTOR) %FINISH %FINISH V_ADDRESS <- R %IF N # 0 %START %IF V_FORM&B'10000' # 0 %AND N > 1 %START PLANT(X'58F20008') DSI(X'95',X'F001',N) PLANT(X'477C0000'!29<<2); ! CORRUPT DOPE-VECTOR %FINISH PLANT(PERM) V_FORM = B'10000011' V_ADDRESS <- 1; V_FLAGS = V_FLAGS!4 ! FOR STRINGS V_DIMENSION = 7; ! TO SHOW AN ARRAY GPR1 = ADDR(V); ! PROTECT IT %FINISH OLD INDEX = S INDEX %END %END ! THE REGISTER ALLOCATION MECHANISM WILL BE IMPROVED IN FUTURE ! AS THE REGISTER SEARCH IS ONLY STARTED FROM THE CURRENT ! BASE REGISTER, THERE IS NO NEED TO CLAIM THAT REGISTER. ! THE NEW ROUTINES WILL KEEP ALL INFORMATION ABOUT REGISTERS ! IN AN INTEGER, ONE BYTE PER AVAILABLE REGISTER ! ZERO INDICATING FREE ! HENCE AFTER COMPILING EACH STATEMENT THIS INTEGER ! CAN BE CLEARED, THUS AVIODING SOME FAULT 200'S ! SO THERE ! ! %ROUTINE CLAIMSAFEREGISTER(%INTEGERNAME REGISTER) ! RETURNS A REGISTER IN THE RANGE 4 <= REGISTER <= 8, ! AS THESE REGISTERS ARE SAVED AND RESTORED ON ! FUNCTION ENTRY AND EXIT. %SHORTROUTINE REGISTER = BASE REG; ! TOP LIMIT OF FREE REGISTERS %WHILE REGISTER > 4 %CYCLE REGISTER = REGISTER-1 %IF REGUSE(REGISTER) = 0 %START REGUSE(REGISTER) = 'C'; ! LOCK THE REGISTER %RETURN %FINISH %REPEAT FAULT(200) %IF SUSPEND = 'N' REGISTER = 3 ! SUSPEND IS SET AFTER VARIOUS FAULTS (E.G. FAULT 16) ! IN ORDER TO INHIBIT SPURIOUS FAULT MESSAGES (> 200) %END %ROUTINE RELEASEREGISTER(%INTEGER REGISTER) %IF REGISTER = 1 %THEN GPR1 = 0 %AND -> 1 -> 1 %UNLESS 4 <= REGISTER <= 8 %IF REGUSE(REGISTER) # 'C' %START FAULT(201) %IF SUSPEND = 'N' %FINISH REGUSE(REGISTER) = 0 1: %END %ROUTINE PROTECT(%BYTEINTEGER TYPE) ! GPR1 CONTAINS THE ADDRESS OF THE DESCRIPTOR OF ANY ! TEMPORARY RESULT IN REGISTER 1. ! GPR1 = 0 => REGISTER 1 FREE ! SIMILARLY FOR FPR2 %SHORTROUTINE %INTEGER R %RECORDNAME V(VARFM) %IF TYPE = 4 %START %RETURN %IF GPR1 = 0 V == RECORD(GPR1) %IF REG USE(6) = 0 %START CLAIMSAFEREGISTER(R) DRR(X'18',R,V_ADDRESS); V_ADDRESS <- R %FINISH %ELSE %START TEMPREAL(R); DRX(X'50',V_ADDRESS,0,R) V_ADDRESS = R; V_FORM = V_FORM&B'01111111' %FINISH GPR1 = 0; ! FORGET IT %FINISH %ELSE %START %RETURN %IF FPR2 = 0 TEMPREAL(R) V == RECORD(FPR2) FPR2 = 0; ! FORGET IT DRX(X'60',V_ADDRESS,0,R) V_ADDRESS <- R V_FORM = 1 V_TYPE <- B'1011'; ! TO PREVENT UAV TEST %FINISH %END %ROUTINE EQUATETYPES(%RECORDNAME LHS, RHS) ! FLOATS PARTS OF EXPRNS AS NESC. ! THERE IS A FAULT AROUND THE AREA OF %IF REAL=INTEGER=REAL ! WHICH MAY BE IN HERE !!!!! %SHORTROUTINE %RECORDSPEC LHS(VARFM) %RECORDSPEC RHS(VARFM) %IF RHS_TYPE&B'1000' # 0 %START;! RHS REAL %IF LHS_TYPE&B'1000' = 0 %START; ! LHS INTEGER FLOAT(LHS,2) %FINISH %FINISH %ELSE %START %IF LHS_TYPE&B'1000' # 0 %THEN FLOAT(RHS,4) %FINISH %END %ROUTINE LOAD(%RECORDNAME V, %INTEGER R) %SHORTROUTINE %RECORDSPEC V(VARFM) %INTEGER A, X, CODE %BYTEINTEGER RFLAG %IF V_TYPE = 0 %AND V_ADDRESS = 0 %START ! ZERO PROTECT(4) %IF R = 1 %IF V_INDEX = 0 %THEN DRR(X'1F',R,R) %ELSE %START RELEASE REGISTER(V_INDEX) %C %AND DRR(X'18',R,V_INDEX) %UNLESS R = V_INDEX %FINISH V_ADDRESS = R -> SET TYPE %FINISH RFLAG = 0 %IF V_TYPE&B'1000' # 0 %THEN R = R<<1 %AND RFLAG = 1 CODE = LOADCODE(V_TYPE); ! GIVES 'LA' FOR SMALL CONSTANTS A = V_ADDRESS; X = V_INDEX; V_ADDRESS = R; V_INDEX = 0 FAULT(-CODE) %AND CODE = X'58' %IF CODE < 0 ! GIVES FAULTS 42 , 23 , 64 %IF V_FORM&2 # 0 %START; ! INDIRECT %IF V_FORM&128 # 0 %START RELEASE REGISTER(A) A = A<<12 %FINISH %ELSE %START DRX(X'58',15,X,A) RELEASE REGISTER(X) %UNLESS R = X %AND RFLAG = 0 TEST UAV(4,15) %UNLESS A&X'F000' = X'D000' A = X'F000'; X = 0 %FINISH %FINISH %ELSE %START %IF V_FORM&128 # 0 %START %IF X # 0 %START FAULT(208) %IF RFLAG # 0 %IF R = X %OR R = A %START %IF R = X %THEN X = A RELEASE REGISTER(X) DRR(X'1A',R,X) -> SET INFO %FINISH DRX(X'41',R,X,A<<12) RELEASE REGISTER(X); RELEASE REGISTER(A) -> SET INFO %FINISH %IF R # A %START %IF R = 2 %AND RFLAG = 1 %START PROTECT(8); FPR2 = ADDR(V) %FINISH %ELSE %START %IF R = 1 %AND RFLAG = 0 %AND A > 1 %START PROTECT(4); GPR1 = ADDR(V) %FINISH %FINISH %IF CODE = X'41' %THEN CODE = X'18' %ELSE %START %IF CODE = X'7A' %THEN CODE = X'38' %FINISH DRR(CODE&63,R,A) %IF RFLAG = 0 %THEN RELEASE REGISTER(A) %C %ELSE %START FPR2 = 0 %IF A = 2 %FINISH %FINISH -> SET INFO %FINISH %FINISH %IF R = 1 %AND X # 1 %AND A # X'1000' %START PROTECT(4) GPR1 = ADDR(V) %FINISH %ELSE %START %IF R = 2 %AND RFLAG = 1 %START PROTECT(8) FPR2 = ADDR(V) %FINISH %FINISH DRR(X'2B',R,R) %IF CODE = X'7A';! SRD_R,R FOR NORMAL REALS DRX(CODE,R,X,A); ! LOAD THE VAR RELEASE REGISTER(X) %UNLESS R = X %AND RFLAG = 0 DRX(X'54',R,13,6<<2) %IF CODE = X'43' ! & OFF BOTTOM BYTE TESTUAV(V_TYPE,R) %UNLESS A&X'F000' = X'D000' SET TYPE: V_TYPE = LOADTYPE(V_TYPE); ! EG SHORT => INTEGER SET INFO: V_FORM = 128 %END %ROUTINE LOADADDR(%RECORDNAME V, %INTEGER REG) %SHORTROUTINE %RECORDSPEC V(VARFM) %IF V_FORM&128 # 0 %START FAULT(82) %UNLESS V_FORM&2 # 0 %IF V_INDEX = 0 %START %IF REG # V_ADDRESS %START PROTECT(4) %AND GPR1 = ADDR(V_ADDRESS) %C %IF REG < 2 RELEASE REGISTER(V_ADDRESS) DRR(X'18',REG,V_ADDRESS) V_ADDRESS <- REG %FINISH V_FORM = 128 %RETURN %FINISH V_FORM = 128; V_TYPE = 0 %FINISH %ELSE %START FAULT(82) %IF V_FORM&3 = 0 V_TYPE = 0 %IF V_FORM&6 = 2 %START V_FORM = 1 V_TYPE = B'100' %FINISH %FINISH LOAD(V,REG) %END %ROUTINE EXPRN(%RECORDNAME LHS) %SHORTROUTINE %ROUTINESPEC OPERAND(%RECORDNAME R, %INTEGER REG) %ROUTINESPEC OPERATE %RECORDSPEC LHS(VARFM) %INTEGERARRAY OLDOP(1 : 2) %RECORDARRAY TEMP(1 : 3)(VARFM) %RECORDNAME RHS(VARFM) %CONSTBYTEINTEGERARRAY PRIORITY(0 : 16) = 0,1,1,2,1,1, 3,3,3,2,2,2,2,1,1,4,1 %INTEGER OP, NEXTOP, P, R, STACK, PT, ESAVE, NSAVE RP = RP+1; NEXTOP = REC(RP+1)+12; ! (PLUS) R = 1; ! FOR (PLUS) LOAD INTO GR1 RHS == TEMP(1) STACK = 0; PT = 0; ESAVE = EFREE; NSAVE = VNAME 1: OP = NEXTOP RP = RP+2; P = REC(RP); ! POINTER TO (REST OF EXPRN) NEXTOP = 0 %IF REC(P) = 1 %THEN NEXTOP = REC(P+1) %IF PRIORITY(NEXTOP) > PRIORITY(OP) %START R = 2; ! NEXT RHS TO REGISTER 2 PT = PT+1 OLDOP(PT) = ADDR(LHS); ! SAVE LHS LHS == TEMP(PT); RHS == TEMP(PT+1) OPERAND(LHS,1) STACK = STACK<<8!OP; ! SAVE OPERATOR RP = RP+1 -> 1 %FINISH OPERAND(RHS,R); RP = RP+1;! SKIP PAST (REST OF EXPRN) 2: OPERATE %IF STACK # 0 %START OP = STACK&255 %IF PRIORITY(OP) >= PRIORITY(NEXTOP) %START STACK = STACK>>8 RHS == LHS LHS == RECORD(OLDOP(PT)) PT = PT-1 -> 2 %FINISH %FINISH %IF NEXTOP # 0 %THEN R = 2 %AND -> 1 EFREE = ESAVE; VNAME = NSAVE %RETURN %ROUTINE OPERAND(%RECORDNAME R, %INTEGER REG) %RECORDSPEC R(VARFM) %SWITCH OTYPE(1 : 4) %INTEGER CODE %BYTEINTEGER SAVE RP = RP+1; CODE = REC(RP) -> OTYPE(CODE) ! OTYPE(2): ! VAR ! ZERO EXP = ZERO EXP!2; ! INHIBIT ZERO EXPRNS. VAR(R) %IF R_TYPE&B'1110' = B'1110' %C %THEN FAULT2(23,VNAME) %AND R_TYPE = B'100' %C %ELSE %START %IF R_TYPE = 7 %START; ! RECORD FAULT(64) %UNLESS EXPRN TYPE = 7 %FINISH %ELSE %START %IF R_TYPE = 16 %C %THEN FAULT(42) %AND R_TYPE = 4 %ELSE %START %IF R_TYPE&B'1000' # 0 %START %IF EXPRNTYPE&B'1000' = 0 %C %THEN FAULT(24) %C %ELSE EXPRN TYPE = B'1010' ! FOR COND EXPRNS %FINISH %FINISH %FINISH %FINISH %IF R_FORM&B'1100' # 0 %THEN FAULT2(19,VNAME) %RETURN ! OTYPE(1): ! CONSTANT ! CCONST(R); ! SETS TYPE FOR 'LA' IF POSSIBLE %IF R_TYPE = B'1011' %AND R_ADDRESS = 0 %START ! REAL ZERO REG = REG<<1 PROTECT(8) %AND FPR2 = ADDR(R) %IF REG = 2 DRR(X'2B',REG,REG) R_TYPE = B'1010' R_FORM = 128 R_ADDRESS = REG %RETURN %FINISH FAULT(42) %AND R = DUMMY NAME %IF R_TYPE&16 # 0 ! STRINGS %IF R_TYPE&B'1000' # 0 %START %IF EXPRNTYPE&B'1000' = 0 %THEN FAULT(24) %C %ELSE EXPRN TYPE = B'1010' ! FOR COND EXPRNS %FINISH %RETURN ! OTYPE(3): ! '(' (EXPRN) ')' OTYPE(4): ! '!' (EXPRN) '!' ! SAVE = EXPRNTYPE %IF SAVE&B'1000' # 0 %THEN EXPRNTYPE = B'1100' EXPRN(R) EXPRN TYPE = SAVE %IF R_TYPE&B'1000' # 0 %C %THEN EXPRN TYPE = B'1010' %ELSE %START ! NOW FLOAT AS NESC. BUT REMEMBER NOT TO IN THE CASE OF ! REAL = ???** (INTEGER EXPRN) %IF EXPRN TYPE&B'100' = 0 %AND OP # 8 %C %THEN FLOAT(R,REG<<1) %FINISH %IF CODE = 4 %START LOAD(R,REG) CODE = X'10' %IF R_TYPE = B'1010' %THEN CODE = X'20' DRR(CODE,R_ADDRESS,R_ADDRESS) %FINISH %END %ROUTINE OPERATE %INTEGER R %SWITCH OPT(1 : 16) R = 1; ! LHS REGISTER ZERO EXP = ZERO EXP!2 %UNLESS OP = 16 ! DISABLE ZERO EXPRNS -> OPT(OP) ! ASSN: %IF RHS_TYPE = 4 %C %THEN LHS_ADDRESS = 1 %AND GPR1 = ADDR(LHS) %C %ELSE LHS_ADDRESS = 2 %AND FPR2 = ADDR(LHS) -> COPY OPT(16): ! OPT(13): ! '+' PASSN: %IF RHS_TYPE > 1 %AND RHS_TYPE&EXPRNTYPE = 0 %C %THEN FLOAT(RHS,0) LHS_ADDRESS <- RHS_ADDRESS %IF GPR1 = ADDR(RHS) %THEN GPR1 = ADDR(LHS) %C %ELSE %START %IF FPR2 = ADDR(RHS) %THEN FPR2 = ADDR(LHS) %FINISH COPY: LHS_TYPE = RHS_TYPE LHS_FORM = RHS_FORM LHS_LEVEL = RHS_LEVEL LHS_DIMENSION = RHS_DIMENSION LHS_LENGTH = RHS_LENGTH LHS_FLAGS = RHS_FLAGS LHS_INDEX = RHS_INDEX %RETURN ! OPT(14): ! '-' ! AVAILABLE(R,RHS_TYPE); ! FIND A SAFE REGISTER: GR1 IF FREE LOAD(RHS,R) R = RHS_TYPE<<2&B'110000'!3; ! LCR / LCDR DRR(R,RHS_ADDRESS,RHS_ADDRESS) -> PASSN ! OPT(15): ! '\' ! FAULT(24) %IF RHS_TYPE&B'1000' # 0 AVAILABLE(R,4) LOAD(RHS,R) DRX(X'57',R,13,16); ! R = R!!(-1) -> PASSN ! OPT(10): ! '//' ! R = 0 ! OPT(3): ! '&' OPT(4): ! '!!' OPT(5): ! '!' OPT(6): ! '<<' OPT(7): ! '>>' ! FAULT(24) %IF LHS_TYPE&B'1000' # 0 %C %OR RHS_TYPE&B'1000' # 0 DOP: ! OPT(1): ! '+' OPT(2): ! '-' OPT(9): ! '*' ! EQUATETYPES(LHS,RHS) LOAD(RHS,2) %IF RHS_TYPE&B'1000' # 0 %START R = 1 OP = OP+12 %FINISH LOAD(LHS,R) %IF R = 0 %THEN PROTECT(4) %AND PLANT(X'8E000020') %IF OP = 9 %AND LHS_TYPE&B'1000' = 0 %START ! '*' SPLANT(X'1C02') ! SLDA TO PROVOKE OVERFLOW IF TOO BIG PLANT(X'8F000020'); SPLANT(X'1810') LHS_ADDRESS <- 1 GPR1 = ADDR(LHS) -> ASSN %FINISH %IF OP # 6 %AND OP # 7 %C %THEN DRR(OPCODE(OP),LHS_ADDRESS,RHS_ADDRESS) %C %ELSE DRX(X'8F'-OP,LHS_ADDRESS,0,RHS_ADDRESS<<12) RELEASE REGISTER(RHS_ADDRESS) %IF RHS_TYPE&B'100' # 0 %IF R = 0 %START %IF OP # 10 %START SPLANT(X'1200'); ! TEST REMAINDER PLANT(X'477C0000'+13<<2); ! NON-INTEGER QUOTIENT %FINISH GPR1 = ADDR(LHS) LHS_ADDRESS = 1 %FINISH -> ASSN ! OPT(12): ! '.' ! FAULT(42) OP = 1 -> DOP ! OPT(11): ! '/' ! %IF EXPRNTYPE&B'1000' # 0 %START; ! REAL EXPRN EXPRNTYPE = B'1010'; ! MAKE THE EXPRN REAL (CONDS) R = 1 %IF RHS_TYPE&B'1000' = 0 %THEN FLOAT(RHS,4) -> DOP %FINISH R = 0 %IF EXPRNTYPE&B'100' # 0 -> DOP ! OPT(8): ! '**' ! %IF RHS_TYPE&B'1000' # 0 %START; ! REAL %IF RHS_TYPE&1 = 0 %THEN FAULT(39) %ELSE %START ! RHS HAS BEEN FLOATED BY CCONST SO UN-FLOAT IT R = RHS_ADDRESS %IF R = 0 %THEN RHS_TYPE = B'100' %ELSE %START GLA = GLA-8; R = INT(LONGREAL(GLA)) FAULT(39) %UNLESS R>>12 = 0 RHS_TYPE = 0; RHS_ADDRESS = R %FINISH %FINISH %FINISH LOAD(RHS,2) R = LOADTYPE(LHS_TYPE) RHS_TYPE = R %IF EXPRNTYPE&B'1000' # 0 %START; ! REAL EXPRN EXPRNTYPE = B'1010'; ! MAKE THE EXPRN REAL (CONDS) %IF R # B'1010' %C %THEN FLOAT(LHS,2) %AND RHS_TYPE = B'1010' %C %ELSE LOAD(LHS,1) R = 0; ! TO FORCE A REAL EXPONENTIATION %FINISH %ELSE LOAD(LHS,1) OP = X'45FC0000'+11<<2 %IF R # B'100' %THEN OP = X'45FC0000'+12<<2 PLANT(OP) -> ASSN %END %END %ROUTINE STORE(%RECORDNAME VAR, DEST) %SHORTROUTINE %RECORDSPEC VAR(VARFM) %RECORDSPEC DEST(VARFM) %INTEGER R, CODE, MASK, A, X, L1, L2, PERM; %BYTEINTEGER TYPE X = DEST_INDEX; TYPE = DEST_TYPE %IF TYPE = 7 %AND (VAR_TYPE = 7 %OR ZERO EXP = 1) %START ! RECORD=RECORD L2 = R V LEN(LHS INDEX);! LENGTH OF LHS L1 = L2 L1 = R V LEN(OLD INDEX) %IF ZERO EXP = 1 FAULT(84) %IF L1 <= 0 %OR L2 <= 0 %C %OR (STUDENT # 0 %AND LHS INDEX # OLD INDEX) %IF L1 # L2 %START L1 = L2 %IF L2 > L1; ! MOVE IN MINIMUM FAULT(46) %IF ASSOP # 3 %OR L1 > 4096 %FINISH DEST_TYPE = 4 DEST_FORM = DEST_FORM!2 %IF DEST_FLAGS&4 = 0 LOAD ADDR(DEST,2); ! @ LHS %IF ZERO EXP = 1 %THEN PERM = X'45FC0000'+32<<2 %C %ELSE %START PERM = X'45FC0000'+30<<2 VAR_TYPE = 4 VAR_FORM = VAR_FORM!2 %IF VAR_FLAGS&4 = 0 LOAD ADDR(VAR,1); ! @ RHS %FINISH PLANT(X'41000000'+L1); ! LENGTH PLANT(PERM); ! BULK MOVE %RETURN %FINISH %IF DEST_FORM&2 # 0 %START %IF DEST_FORM&128 = 0 %START LOAD ADDR(DEST,14) ! X RELEASED IN 'LOAD ADDR' (I HOPE !) X = 0 %FINISH %FINISH RELEASE REGISTER(X) %IF VAR_FORM&128 = 0 %OR VAR_FORM&2 # 0 %C %THEN LOAD(VAR,3) ! ALWAYS SAFE IN GPR3 %OR FPR6 R = VAR_ADDRESS %IF R < 2 %AND VAR_TYPE&B'1000' = 0 %THEN GPR1 = 0 %C %ELSE %START %IF R = 2 %AND VAR_TYPE = B'1010' %THEN FPR2 = 0 %FINISH CODE = STORECODE(TYPE) FAULT(-CODE) %AND CODE = X'43' %IF CODE < 0 A = DEST_ADDRESS RELEASE REGISTER(A) %AND A = A<<12 %IF DEST_FORM&128 # 0 RELEASE REGISTER(R) %UNLESS CODE&X'F0' > X'50' DRX(CODE,R,X,A) %IF SNLEN # 0 %START; ! PLUG IN STRING MAX LENGTH %IF X # 0 %START AVAILABLE(L1,4); RELEASE REGISTER(L1) DRX(X'41',L1,X,A) L1 = L1<<12 %FINISH %ELSE L1 = A DSI(X'92',L1,SNLEN) SNLEN = 0 %FINISH %IF (TYPE = B'101' %OR TYPE = B'110') %C %AND ASSOP = 2 %AND TUAV # 0 %START %IF TYPE = B'101' %START MASK = 2; CODE = X'55'; A <- X'D018' X = 0 %FINISH %ELSE %START MASK = 7 CODE = X'49' %FINISH DRX(CODE,R,X,A) DRX(X'47',MASK,12,4<<2) %FINISH %END %ROUTINE ASSIGN(%RECORDNAME LHS, %INTEGER ASSOP) !* RP ON P(ASSOP) %SHORTROUTINE %RECORDSPEC LHS(VARFM) %RECORD RHS, TEMP(VARFM) %SWITCH ATYPE(0 : 4), NTYPE(0 : 3) %INTEGER A, B, F, X, N, DV %BYTEINTEGER SLEN, VTYPE TEMP = LHS LHS INDEX = OLD INDEX -> ATYPE(ASSOP) %ROUTINE SJAM; ! FIDDLES R3 FOR MINIMUM LENGTH IN STRING <- %IF TEMP_DIMENSION = 7 %START DRX(X'58',15,0,DOPE VECTOR+8) B = X'4330F003' -> 1 %FINISH %IF SLEN # 0 %START DSI(X'95',X'1000',SLEN) PLANT(X'474A0000'+FORWARD ADDRESS(8)) PLANT(X'41300000'+SLEN) %FINISH %ELSE %START DRX(X'41',15,X,B); B = X'4330F000' 1: PLANT(X'D5001000'); SPLANT(B) PLANT(X'474A0000'+FORWARD ADDRESS(8)) PLANT(B) %FINISH PLANT(X'443D0002'+20<<2); ! MOVE IN STRING ! NOW JAM IN LENGTH PLANT(X'42320000'); !STC_3,0(2) %END ! ASSOP = 1 FOR '==' ! = 2 FOR '=' ! = 3 FOR '<-' ! = 4 FOR '->' ATYPE(2): ! '=' ATYPE(3): ! '<-' ! EXPRN TYPE = LHS_TYPE %IF EXPRN TYPE&B'10000' = 0 %START; ! NUMERICAL EXPRNS EXPRN(RHS); STORE(RHS,LHS) %FINISH %ELSE %START SLEN <- LHS_LENGTH LHS_TYPE = B'100' B = LHS_ADDRESS; X = LHS_INDEX LHS_FORM = LHS_FORM&B'11111101' %C %UNLESS B = 1 %AND LHS_FORM&128 # 0 DV = DOPE VECTOR; C S EXPRN(A); DOPE VECTOR = DV %IF LHS_FLAGS&4 # 0 %THEN LOADADDR(LHS,2) %C %ELSE LOAD(LHS,2) SLOAD(A,1); S CPE(TEMP,X'1000') %IF ASSOP # 3 PLANT(X'43310000'); ! PICK UP ACTUAL LENGTH OF STRING %IF ASSOP = 3 %THEN SJAM %C %ELSE PLANT(X'443D0002'+20<<2) %FINISH -> 1 ! ATYPE(0): ! ????? FAULT(210); SKIP EXPRN; -> 1 ATYPE(1): ! '==' ! %IF LHS_ADDRESS&X'F000' # X'B000' %THEN F = 83 %C %ELSE F = 22 %IF REC(RP+2) # 4 %OR REC(RP+4) # 2 %C %OR REC(REC(RP+3)) # 2 %START %IF F = 83 %THEN F = 81 %ELSE F = 22 FAULT(F) SKIP EXPRN -> 1 %FINISH N = LHS_FORM>>5&3 RP = RP+4 FAULT2(19,REC(RP+2)) %IF N=3 %AND REC(RP+3) # 2 VAR(RHS); RP = RP+1 FAULT(33) %IF STUDENT # 0 %AND RHS_LEVEL > LHS_LEVEL %IF LHS_FORM&16 = 0 %THEN FAULT(82) -> NAME TYPE %IF LHS_TYPE = 13 %IF RHS_FORM&PARMMASK(N) # PATTERN(N) %C %OR LHS_TYPE # RHS_TYPE %START FAULT(F) RELEASE REGISTER(RHS_INDEX) -> 1 %FINISH -> NTYPE(N) NAME TYPE: ! %NAME TYPE PARAMETERS (VERY ODD !) ! ! WORD 1 : FLAGS<<24 ! ADDR(VAR) ! WORD 2 : LENGTH OF EACH ITEM ! VTYPE = RHS_TYPE N = ROUND(VTYPE) X = RHS_ADDRESS LOAD ADDR(RHS,1); GPR1 = 0 A = LHS_ADDRESS DRX(X'50',1,0,A) DSI(X'92',A,NAME FLAG(VTYPE)) %IF VTYPE # 16 %THEN PLANT(X'41100000'+N) %ELSE %START %IF TEMP_DIMENSION = 7 %START DRX(X'58',1,0,DOPE VECTOR+8) X = X'1003'; -> NT1 %FINISH N = RHS_LENGTH %IF N = 0 %START SPLANT(X'1F11') NT1: DRX(X'43',1,0,X); ! PICK UP MAX LENGTH %FINISH %ELSE PLANT(X'41100000'+N) %FINISH DRX(X'50',1,0,A+4); ! PLUG IT IN -> 1 ! NTYPE(2): ! %NAME ! VTYPE = RHS_TYPE %IF VTYPE = B'10000' %START SNLEN = RHS_LENGTH RHS_FORM = RHS_FORM!2 %IF SNLEN = 0 %FINISH %IF VTYPE # B'111' %START LOAD ADDR(RHS,1) %IF VTYPE = B'10000' %AND RHS_LENGTH = 255 %C %THEN PLANT(X'5610D000'+29<<2) %FINISH %ELSE %START FAULT(83) %IF STUDENT # 0 %AND LHS INDEX # OLD INDEX RHS_TYPE = B'100' RHS_FORM = RHS_FORM!2 %IF RHS_FLAGS&4 = 0 LOAD ADDR(RHS,1) %FINISH LHS_FORM = LHS_FORM!!2; LHS_TYPE = B'100' STORE(RHS,LHS) -> 1 ! NTYPE(1): ! %ARRAYNAME ! X = RHS_INDEX; A = RHS_ADDRESS RELEASE REGISTER(A) %AND A = A<<12 %IF RHS_FORM&128 # 0 LOAD ADDR(LHS,3) %IF LHS_INDEX # 0 B = LHS_ADDRESS RELEASE REGISTER(B) %AND B = B<<12 %IF LHS_FORM&128 # 0 DSS(X'D2',16,B,A); ! MOVE IN HEADER %IF X # 0 %START DRX(X'98',14,15,B); ! R14 = @A(0), R15 = @A(F) DRR(X'1A',14,X); DRR(X'1A',15,X) DRX(X'90',14,15,B); ! UPDATE THEM RELEASE REGISTER(X) %FINISH -> 1 ! NTYPE(3): ! ROUTINE/FN/MAP %NAME ! FAULT(82) %AND -> 1 %IF RHS_LEVEL = 0 N = (LHS_DIMENSION+7)<<4+X'41F0D000' PLANT(N) N = RHS_ADDRESS&X'FFFF' %IF RHS_FLAGS>>4&3 = 3 %START PLANT(X'58E00000'+N) DSS(X'D2',12,X'F000',X'E000') %FINISH %ELSE %START PLANT(X'41E00000'+N) PLANT(X'D20FF000'); SPLANT(X'E000') %FINISH PLANT(X'50B0F00C') PLANT(X'50F00000'+LHS_ADDRESS&X'FFFF') ! ! NOW CHECK FOR CONSISTENT PARAMETERS ! COMPARE RT(WORK,OLD INDEX) ! -> 1 ! ATYPE(4): ! '->' ! CRES(RESFLOP,7) 1: %END %ROUTINE CUI(%INTEGER UTYPE) ! ! COMPILE UNCONDITIONAL INSTRUCTION ! %SHORTROUTINE %SWITCH UI(1 : 11) %RECORD X, V(VARFM) %INTEGER J, K, L, NAME, P, ASSP -> UI(UTYPE) ! UI(1): ! (HOLE)(VAR)(MARK)(RUI1')(AUI') ! ! P(RUI1') ::= (ASSOP)(EXPRN): ! P(AUI') ::= %AND(UI): ! P(ASSOP) ::= '==' : '=' : '<-' : '->' RP = RP+1; P = REC(RP); ! ONTO (ASSOP) ASSOP = 0 %IF REC(P) = 1 %THEN ASSOP = REC(P+1) ASSP = ASSOP; VAR(LHS) RP = RP+1 %IF ASSP = 0 %START; ! ROUTINE/FN/MAP FAULT2(19,VNAME) %C %UNLESS LHS_FORM&B'1100' = 0 %OR V_LEVEL = 255 -> PRED %IF LHS_TYPE = 14 %AND REC(RP+1) = 2 ! NO (AUI) FAULT2(17,VNAME) %IF LHS_TYPE # 15 %AND LHS_LEVEL # 255 -> AUI %FINISH ! ASSIGNMENT ASSOP = ASSP LHS = DUMMY NAME %AND FAULT2(29,VNAME) %C %IF ASSOP # 1 %AND LHS_FORM&3 = 0 %AND V_LEVEL # 255 ZERO EXP = 0 MAPV = 0; ! CONTROL FOR %MAPNAME PARMS %IF ASSOP = 1 %AND LHS_FORM&B'1000' = 0 %THEN MAPV = 1 RP = RP+1 ASSIGN(LHS,ASSOP) ! AUI: ! TEST FOR '%AND'(UI) ! RP = RP+1 %IF REC(RP) = 1 %START RP = RP+1; UTYPE = REC(RP) -> UI(UTYPE) %FINISH -> 1 ! UI(3): ! '->'(LABEL) ! P(LABEL) ::= (INTEGER) : (NAME)(OP PARM') ! P(OP PARM') ::= '(' (EXPRN) ')' : ! ACCESS = 0 RP = RP+1 J = REC(RP); ! TYPE OF LABEL %IF J = 1 %START; ! (INTEGER) RP = RP+1; GET4(NAME) %FINISH %ELSE %START; ! (NAME) RP = RP+1; NAME = REC(RP) %FINISH %IF J = 2 %AND REC(RP+1) = 1 %START; ! SWITCH %IF INTEGER(NAME+DICTHEAD+4) = 0 %START FAULT2(4,NAME); ! SWITCH VECTOR NOT SET V = DUMMY NAME %FINISH %ELSE GETINFO(NAME,V) FAULT2(5,NAME) %UNLESS V_TYPE = B'1000000' FAULT2(4,NAME) %UNLESS V_LEVEL = LEVEL RP = RP+1 EXPRN TYPE = B'100'; ! INTEGER PARM EXPRN(X) LOAD(X,1) DRX(X'41',2,10,V_ADDRESS); ! @ VECTOR PLANT(X'45FC0000'+8<<2); GPR1 = 0 ! FORGET IT -> 1 %FINISH ! NORMAL LABEL %IF J = 1 %START; ! CONSTANT LABEL %IF NAME>>16 # 0 %THEN FAULT(44) %AND -> 1 NAME = \NAME %FINISH %IF LEVEL # 1 %THEN JUMP TO(NAME,15) %C %ELSE FAULT(-11) %AND PRINT LABEL(NAME) -> 1 ! UI(2): ! '%PRINTTEXT' (TEXT) ! RP = RP+1; ! SKIP TYPE SET TEXT(1) -> AUI ! UI(6): ! '%MONITOR'(MSTOP') ! P(MSTOP') ::= '%STOP' : (INTEGER) : ! RP = RP+1 J = REC(RP) ACCESS = 0 %UNLESS J = 3 L = (4+J)<<2+X'45FC0000' %IF J = 2 %START; ! %MONITOR 'N' RP = RP+1; ! SKIP TYPE GET4(K) FAULT(44) %IF K>>7 # 0 PLANT(X'41000000'+K) %FINISH PLANT(L) ! ->AUI %IF J = 3 !***** ALTER ***** -> 1 ! UI(7): ! '%STOP' ! SPLANT(X'05FC'); ! TO STOP SEQUENCE ACCESS = 0 -> 1 ! UI(4): ! '%RETURN' ! BACK: FAULT(UTYPE+26) %UNLESS BLOCK TYPE&127 = UTYPE BACK2: DSS(X'D2',4,X'D014',BASE REG<<12) PLANT(X'984F0010'+BASE REG<<12) SPLANT(X'07FF') *XC_GPR1(8),GPR1 -> 1 ! UI(5): ! '%RESULT='(=EXPRN) ! RP = RP+1 %IF REC(RP) = 1 %START; ! ==(VAR) FAULT(29) %IF BLOCK TYPE&128 = 0 VAR(X) FAULT2(19,VNAME) %IF X_FORM&B'1100' # 0 FAULT(83) %IF X_TYPE # FNTYPE2 LOAD ADDR(X,1); -> BACK %FINISH ! ! STOP STUDENTS FROM USING '=' IN MAPS ! FAULT(82) %IF STUDENT # 0 %AND BLOCKTYPE&128 # 0 %IF FNTYPE&B'10000' # 0 %START; ! %STRINGFN C S EXPRN(P); S LOAD(P,2) DRR(X'18',1,BASE REG); ! POINTER TO SAVE AREA (FOR RESULT) PLANT(X'984F0010'+BASE REG<<12); ! RESTORE CONTEXT DSS(X'D2',4,X'D014',X'1000') ! NOW SHIFT IN RESULT. PLANT(X'43320000'); PLANT(X'443D0000'+24<<2) SPLANT(X'07FF'); ! %RETURN *XC_GPR1(8),GPR1; -> 1 %FINISH EXPRN TYPE = FN TYPE EXPRN(X) LOAD(X,1) -> BACK ! UI(8): ! %EXIT UI(9): ! %CONTINUE ! FIND CYCLE(P) %IF P = 0 %THEN FAULT(54) %ELSE %START %IF UTYPE = 8 %START; ! %EXIT ! SHOW ELSE LABEL HAS BEEN USED BYTEINTEGER(P+3) = BYTEINTEGER(P+3)!64 P = INTEGER(P+8); ! ELSE LABEL %FINISH %ELSE P = INTEGER(P+4); ! CYCLE LABEL FOR CONTINUE JUMP TO(P,15) %FINISH ACCESS = 0 -> 1 ! UI(10): ! '%TRUE' ! P = X'19BB'; ! CR FOR CC = 8 TF: SPLANT(P); ! SET CONDITION CODE PRED: FAULT(27) %UNLESS BLOCK TYPE = 6 -> BACK2 ! UI(11): ! '%FALSE' ! P = X'14BB'; ! NR FOR CC = 7 -> TF 1: %END; ! OF CUI ! !****************** C MAIN PROGRAM *********************** ! SET ERROR:! PUT DOWN A LAYER OF SIGNALS !! LINE ENTRY = 0; ! TO BRING IN A NEW LINE MON LOCK = 0; DIAG HEAD == DIAG BASE ! RESUME COMPILATION: ! ENTRY FROM IGNORED INTQ ! *L_1,SAVEAREA *ST_1,J *STM_4,14,16(1) *LA_2, *ST_2,60(1) *MVI_60(1),8; ! ??????????????? SIGNAL(0,J+16,0,K) INTQ FLAG = 0 %AND SIGNAL(5,SIGAREA,0,K) %IF INTQ FLAG = 1 ! ! CO-ROUTINE ENTRY JOINS MAIN LOOP HERE FROM EXT BREAK ! EXT BREAK0: *LA_11,2048(11); ! TO LEAVE SPACE FOR DIAGS ! %BEGIN %SHORTROUTINE %CYCLE COMP MODE = 0; COMPILE BLOCK; BASE REG = 9 ! JUST IN CASE %IF COMP MODE&16 # 0 %THEN DEFINE RT %ELSE %START %IF CODEIN > CODE START %AND FAULTY = 0 %START COMP MODE = 0; SELECTOUTPUT(IOUT) %IF IOUT # 0 SELECTINPUT(INSTREAM) %IF INSTREAM # 0 *BCR_0,0; ! FORCE THE COMPILER TO FORGET EXECUTE CODE SELECTINPUT(0) %IF IOFLAG = 0 RUNNING = 'N'; SELECTOUTPUT(SYSOUT) ! FORCE ANY OUTPUT %FINISH %FINISH COMP MODE = 0 %REPEAT %END !********************************************************************* ! %INTEGERFN FOR CLAUSE; ! COMPILES (VAR) = A,B,C %SHORTROUTINE %INTEGER J, K, L, RSAVE %RECORD V, V1, V2(VARFM) RP = RP+1; ! SKIP P(F CLAUSE) VAR(V) V_TYPE = 4 %AND FAULT(25) %IF V_TYPE # 4 REG USE(4) = 'L'; ! CLAIM REG 4 GET CYCLE SPACE(K); ! SAVE AREA FOR PARMS EXPRN TYPE = B'100'; ! INTEGER PARMS RSAVE = RP+1; RP = REC(RSAVE)-1 EXPRN(V1); ! INCR EXPRN(V2); ! FINAL L = RP RP = RSAVE LOAD ADDR(V,4); LOAD(V1,2); LOAD(V2,3) PLANT(X'90240000'+K&X'FFFF'); ! STM 2,4,SAVE AREA J = K+8 EXPRN(V); LOAD(V,1); GPR1 = 0;! FORGET IT RP = L CYC NUM = CYC NUM+1 DSI(X'92',J,CYC NUM); ! SET CYCLE FLAG DRX(X'41',2,0,K); PLANT(X'45FC0000'+10<<2) ! TEST IVC REG USE(4) = 0; ! RELEASE REGISTER 4 PLANT(X'47FA0000'+FORWARD ADDRESS(32)) ! JUMP ROUND ! NOW PLANT CODE FOR THE REPEAT ! THIS IS DONE HERE TO ENABLE ALL FORMS OF ! CYCLE/REPEAT BLOCKS TO BE DEALT WITH IN THE SAME MANNER CYCLE LABEL = ILAB-1 ELSE LABEL = CYCLE LABEL-1 ILAB = ELSE LABEL LABEL FOUND(CYCLE LABEL) DSI(X'95',J,CYCNUM); ! TEST VALID DESCRIPTOR PLANT(X'477C000C'); ! UNASSIGNED VARIABLE IF NOT PLANT(X'98240000'+K&X'FFFF'); ! PICK UP PARMS PLANT(X'58140000'); ! LOAD CONTROL VARIABLE SPLANT(X'1913'); JUMP TO(ELSE LABEL,8) SPLANT(X'1A12') !*** FILL IN INITIAL JUMP TO HERE *** PLANT(X'50140000'); ! STORE CONTROL VARIABLE %RESULT = K<<16+32 %END %ROUTINE C FINISH ! ! SFINF_TYPE : 1 - THENSTART ! : 2 - ELSESTART ! : 3 - START ! %SHORTROUTINE %RECORDNAME SFINF(BLOCKFM) %INTEGER J, L %IF START HEAD = 0 %START; ! NO START F51: FAULT(51); -> 1 %FINISH SFINF == RECORD(START HEAD) -> F51 %IF SFINF_TYPE&15 = 0; ! CYCLE WANTED RP = RP+1 %IF REC(RP) = 1 %START; ! %ELSE GIVEN ! WAS THE START A 'THENSTART' ? NASTY = 1 %IF SFINF_TYPE # 1 %THEN FAULT(47) %AND -> NE RP = RP+1 %IF REC(RP) = 1 %START; ! ...%ELSESTART L = FORWARD REF(15) REMOVE LABEL(SFINF_ELSE); ! %ELSE IS HERE SFINF_ELSE = L SFINF_TYPE = 2; ! NO CONDITION -> 1 %FINISH L = FORWARD REF(15); ! JUMP PAST ELSE REMOVE LABEL(SFINF_ELSE) PUT LINE RP = RP+1; CUI(REC(RP)) REMOVE LABEL(L); ! FILL IN JUMP AROUND %FINISH %ELSE %START; ! NO ELSE REMOVE LABEL(SFINF_ELSE) %UNLESS SFINF_TYPE = 3 %FINISH NE: J = START HEAD; START HEAD = SFINF_LINK COMP MODE = COMP MODE&B'11110111' %IF START HEAD = 0 SFINF_LINK = ASL; ASL = J;! REMOVE CELL 1: %END %ROUTINE PUT LINE %SHORTROUTINE ! PLANT A 'MVI' INSTRUCTION TO UPDATE THE LINE NUMBER ! FOR DIAGS. %INTEGER L, U %OWNINTEGER LL, UL = 0 %IF LINE NUM # 1 %AND DIAGS&6 # 0 %START U = LINE NUM>>8 L = LINENUM&255 %IF L # LL %OR NASTY # 0 %START LL = L DSI(X'92',X'D017',LL) UL = U %AND DSI(X'92',X'D016',UL) %C %IF UL # U %OR NASTY # 0 NASTY = 0 %FINISH %FINISH %END !????? %ROUTINE WARNING(%STRING (15) S) %PRINTTEXT ' The syntax of this command has been changed. Please use the new form in future. The new form is: ' PRINTSTRING('$'.S.' NAME ') %END %ROUTINE CSS(%INTEGER SST) %SHORTROUTINE %SWITCH SS(1 : 32) %INTEGER K, L, N, NEXT, RSAVE, MARK %BYTEINTEGER COND TYPE %RECORDNAME TV(VARFM) %RECORDNAME SFINF(BLOCKFM) *XC_GPR1(8),GPR1; SUSPEND = 'N' -> SS(SST) ! TA: *CLI_ACCESS,0 *BCR_7,15 *ST_15,K FAULT(100) *L_15,K *BCR_15,15 ! SS(1): ! (UI)(R SS1) ! *BAL_15, PUT LINE COND TYPE = 0; ! NO CONDITION AS YET RP = RP+1; MARK = REC(RP);! PAST (UI) NEXT = REC(MARK); ! (OP COND') %IF NEXT # 3 %START; ! CONDITION GIVEN RSAVE = RP; RP = MARK; ! ONTO CONDITION %IF NEXT = 1 %START; ! (IUWU) RP = RP+1 CONDTYPE = REC(RP); ! IF/UNLESS/WHILE/UNTIL C COND(CONDTYPE) %FINISH %ELSE K = FOR CLAUSE RP = RSAVE %FINISH RP = RP+1 CUI(REC(RP)) %IF NEXT = 2 %OR COND TYPE > 2 %C %THEN JUMP TO(CYCLE LABEL,15) %C %AND REMOVE LABEL(CYCLE LABEL) ACCESS = 1 %AND REMOVE LABEL(ELSE LABEL) %IF NEXT # 3 ! FOR JUMP AROUND -> 1 ! SS(2): ! (IU)(COND)(R IU) ! *BAL_15, PUT LINE RP = RP+1; C COND(REC(RP)); RP = RP+2 %IF REC(RP) = 2 %START; ! '%THEN' (UI) RP = RP+1; CUI(REC(RP)) RP = RP+1 %IF REC(RP) = 1 %START; ! %ELSE RP = RP+1 %IF REC(RP) = 2 %START; ! UI L = FORWARD REF(15); ! JUMP ROUND REMOVE LABEL(ELSE LABEL) RP = RP+1; CUI(REC(RP)) REMOVE LABEL(L) %FINISH %ELSE %START;! '%START' L = FORWARD REF(15) REMOVE LABEL(ELSE LABEL) PUSH(STARTHEAD,2,0,L); ! PRESERVE INFO COMPMODE = COMP MODE!8 -> STERR; ! SEE IF IT'S OK TO BE LEFT %FINISH %FINISH %ELSE REMOVE LABEL(ELSE LABEL) %FINISH %ELSE %START LINE NUM = 1 %IF LINE NUM = 0 PUSH(START HEAD,1,0,ELSE LABEL) COMPMODE = COMPMODE!8 STERR: C FINISH %IF FAULTY # 0 %AND LEVEL = 1 ! REMOVE '%START' %FINISH ACCESS = 1 -> 1 ! SS(3): ! (WU)(COND)(R WU) ! *BAL_15, NASTY = 1 RP = RP+1 %IF REC(RP) = 2 %THEN K = FOR CLAUSE %ELSE %START K = 0 RP = RP+1; C COND(REC(RP)+2) %FINISH RP = RP+2 %IF REC(RP) = 2 %START; ! '%THEN' (UI) RP = RP+1; CUI(REC(RP)); JUMP TO(CYCLE LABEL,15) REMOVELABEL(CYCLE LABEL); REMOVELABEL(ELSE LABEL) ACCESS = 1 %FINISH %ELSE %START; ! '%CYCLE' PUSH(START HEAD,K,CYCLE LABEL,ELSE LABEL) COMPMODE = COMPMODE!8 -> CYCERR %FINISH -> 1 ! SS(4): ! %CYCLE(CPARM')(S): ! ! P(CPARM') ::= (VAR)'='(EXPRN)','(EXPRN)','(EXPRN): *BAL_15, RP = RP+1 %IF REC(RP) = 2 %START CYCLE LABEL = ILAB-1 ELSE LABEL = CYCLE LABEL-1; ILAB = ELSE LABEL LABEL FOUND(CYCLE LABEL) PUSH(START HEAD,16,CYCLE LABEL,ELSE LABEL) COMPMODE = COMPMODE!8 -> 1 %FINISH PUT LINE; NASTY = 1 K = FOR CLAUSE PUSH(START HEAD,K,CYCLE LABEL,ELSE LABEL) COMPMODE = COMPMODE!8 CYCERR: -> 1 %UNLESS FAULTY # 0 %AND LEVEL = 1 ! REMOVE %CYCLE ! SS(5): ! '%REPEAT'(S) ! *BAL_15, %IF START HEAD # 0 %START SFINF == RECORD(START HEAD) %IF SFINF_TYPE&15 = 0 %START K = START HEAD; START HEAD = SFINF_LINK COMP MODE = COMP MODE&B'11110111' %IF STARTHEAD = 0 SFINF_LINK = ASL; ASL = K PUT LINE JUMP TO(SFINF_CYCLE,15) REMOVELABEL(SFINF_CYCLE) REMOVELABEL(SFINF_ELSE) %UNLESS SFINF_TYPE = 16 %IF SFINF_TYPE&32 # 0 %START DISP = SFINF_ADDR %IF LEVEL = 1 DSI(X'92',SFINF_ADDR+8,0); ! CLEAR FLAG %FINISH NASTY = 1 -> 1 %FINISH %FINISH FAULT(1); ! SPURIOUS REPEAT -> 1 ! SS(6): ! '%FINISH'(ELSE')(S) ! ACCESS = 1 C FINISH; -> 1 ! SS(7): ! (TYPE)(DECLN)(S) ! *BAL_15, UAV FLAG = 15 VTYPE(NEWNAME) -> 1 %IF FAULTY # 0 %AND LEVEL = 1; ! STRING LENGTH FAULTY NEW NAME_FLAGS = 0 NEW NAME_INDEX = 0 NEW NAME_DIMENSION = 0 FMLEN = NEWNAME_LENGTH FORMATP = 0 DECLARE; -> 1 ! SS(8): ! '%END'(OF')(S) ! C END; -> 1 ! SS(9): ! '%BEGIN'(S) ! RT NAME = 0 DISP = (DISP+3)&(\3) NEW BLOCK(0); ! BEGIN PLANT(X'90AB0000'+DISP&X'FFFF') NEW DIAG(DISP+8); SPLANT(X'05A0') R10 = CODEIN DISP = DISP+12; ! LEAVING SPACE FOR DIAGS LINE NUM = 1 %IF LINE NUM = 0 FN TYPE = 3; BLOCK TYPE = 0 BLOCK ENTRY = -1 %IF LEVEL = 2 -> 1 ! SS(10): ! (EXTERNAL')(RFM)(SPEC')(NAME)(FPDEFN')(S) ! C RFM DEC; -> 1 ! SS(11): ! '%COMPILE'(CFILE)(S) ! WARNING('COMPILE') SPECIAL(2); -> 1 ! SS(13): ! '%SPEC'(NAME)(FPDEFN')(S) ! RP = RP+1; N = REC(RP) TV == RECORD(GET NAME(N)); MARK = TV_INDEX ! FOR LATER MARK = -1 %IF TV_FORM&128 = 0; ! IT'S NEW %IF TV_FLAGS&1 = 0 %OR TV_TYPE = 7 %C %THEN FAULT2(3,N) %AND -> 1 FPMODE = 0; SPEC = 1; C FPDEFN(TV) TV_FLAGS = TV_FLAGS&B'11111110' COMPARE RT(TV,MARK) %IF MARK >= 0; ! CHECK FOR CONSISTENCY -> 1 ! SS(14): ! '%START'(S) ! PUSH(START HEAD,3,0,0) COMPMODE = COMPMODE!8; -> 1 ! SS(15): ! '%LIST'(S) ! LIST = 'Y' PRINTED = 0 %IF IOFLAG = 0 -> 1 ! SS(16): ! '$RESTART'(S) ! RESTART = 2 SIGNAL(2,240,0,K); ! FORCE SIG WT 240 TO RESTART ! SS(17): ! '%EDIT'(NAME)(S) ! WARNING('EDIT') SPECIAL(1); -> 1 ! SS(18): ! '%SENDTO'(NAME)(S) ! WARNING('SEND') RP = RP-1; ! BACK AS 'TO' IS NOT OPTIONAL WITH THIS FORM SPECIAL(3); -> 1 ! SS(19): ! '%RECORD'(REC DEC)(S) ! DEC FLAG = 1 RP = RP+1 C REC DEC(REC(RP)); -> 1 ! SS(20): ! '%CONTROL'(INTEGER)(S) ! RP = RP+1; ! PAST TYPE GET4(N); ! INTEGER SET CONTROL(N) %IF STUDENT = 0 -> 1 ! SS(21): ! '%SWITCH'(NAMELIST)(CBPAIR)(R SW LIST)(S) ! C SWITCH; -> 1 ! SS(22): ! (NUMBER)':' ! ACCESS = 1 RP = RP+1; ! SKIP TYPE OF CONSTANT. MUST BE B'100' NASTY = 1 GET4(N); ! LABEL %IF N>>16 # 0 %THEN FAULT(4) %ELSE %START %IF LEVEL = 1 %THEN FAULT(32) %ELSE LABEL FOUND(\N) %FINISH ! RP = RP+1; -> SS(REC(RP)) ! SS(23): ! '$'(SPECIAL)(S) ! RP = RP+1 SPECIAL(REC(RP)) -> 1 ! SS(24): ! '%REALS'(LN)(S) ! DEC FLAG = 1 REALS <- 6-REC(RP+1); -> 1 ! SS(25): ! (NAME)(SW PARM')':'(SS) ! ACCESS = 1 NASTY = 1 SW REF RP = RP+1; -> SS(REC(RP)) ! SS(27): ! '%EXTRINSICRECORD' ! EXTRINSIC = 1; DEC FLAG = 1 RP = RP+1; C REC DEC(REC(RP)+2) -> 1 ! SS(26): ! '%OWN'(OWN DEC) ! DEC FLAG = 1 C OWN DEC %IF C LIST # 2; C LIST = 0 -> 1 ! SS(29): ! #(EXPRN)(R # LIST') ! HASH EXPRNS -> 1 ! SS(30): ! '.'(HOLE)(VAR)(MARK)(R UI')(AUI'): ! DOT NAME -> 1 ! SS(31): ! '*'(MCINST) ! FAULT(33) %IF LEVEL <= 1 CUCI -> 1 SS(12): ! (COMMENT) SS(28): ! %SHORTROUTINE SS(32): ! (S) ! ! FAULT & GET OUT QUICK (VIA $CANCEL) IF NO SPACE LEFT 1: FAULT(110) %AND SPECIAL(15) %IF CODEIN > DEC START %END; ! OF CSS %ROUTINE COMPILE BLOCK %SHORTROUTINE %INTEGER J %BYTEINTEGER FLAG FLAG = 0 LINE NUM = 0 MAX DISP = DISP FAULTY = 0; ACCESS = 1 CODE START = CODE TOP+12; CODEIN = CODE START R10 = CODEIN; TEXTIN = TEXT HEAD; -> 1 %INTEGERFN PARSE(%INTEGER MP) %SHORTROUTINE %SWITCH BIP(0 : 15) %INTEGER TSYM, TRP, ALT, S, HOLE, SP, ALTNUM, L, P ALTNUM = MP ALT = RP; ! HOLE FOR ALTERNATIVE RP = RP+1 TSYM = SYM; ! SAVE TEXT POINTER TRP = RP; ! SAVE ANALYSIS RECORD POINTER ! BIP(11): ! DUMMY - ALWAYS FAILS ! FAILURE: ! RESET PARAMS SM = SYM %IF SYM > SM SYM = TSYM RP = TRP MP = MP+1; ! ONTO NEXT ALTERNATIVE SP = MAIN(MP) %RESULT = 1 %IF SP = 0; ! CONTEXT MUST BE SAFE !!! SUCCESS: SP = SP+1 S = SUB(SP); ! NEXT ATOM %IF S = 0 %START; ! SUCCESS REC(ALT) = MP-ALTNUM;! SET WHICH ALTERNATIVE FOUND %RESULT = 0 %FINISH -> BIP(S>>12&15) ! BIP(0): ! LITERAL ! P = LITERAL(S) %CYCLE P = S+1,1,S+P -> FAILURE %IF LINE(SYM) # LITERAL(P) SYM = SYM+1 %REPEAT -> SUCCESS ! BIP(1): ! SUB-PHRASE ! -> SUCCESS %IF PARSE(S&X'FFF') = 0 -> FAILURE ! BUILT IN PHRASES ! BIP(6): ! (HOLE) ! HOLE = RP RP = HOLE+1 -> SUCCESS ! BIP(7): ! (MARK) ! REC(HOLE) = RP; ! FILL IN HOLE -> SUCCESS ! BIP(14): ! (NAME) ! -> SUCCESS %IF NAME = 0 -> FAILURE ! BIP(5): ! (CONSTANT) ! -> SUCCESS %IF CONSTANT(B'11111') = 0 -> FAILURE ! BIP(4): ! (NUMBER) ! -> FAILURE %UNLESS '0' <= LINE(SYM) <= '9' ! BIP(3): ! (INTEGER) ! -> SUCCESS %IF CONSTANT(B'100') = 0 -> FAILURE ! BIP(8): ! (NAME LIST) ! P = RP; RP = RP+1; ! HOLE FOR NUMBER OF NAMES -> FAILURE %IF NAME # 0 L = 1; ! NAME COUNT NLIST1: %IF LINE(SYM) = ',' %START SYM = SYM+1 %IF NAME = 0 %THEN L = L+1 %AND -> NLIST1 SYM = SYM-1 %FINISH REC(P) = L -> SUCCESS ! BIP(9): ! (STRING) ! -> SUCCESS %IF CONSTANT(B'10000') = 0 -> FAILURE ! BIP(10): ! (C TEXT) ! SYM = SYM+1 %WHILE LINE(SYM) # NL PROMPTCH = ':'; ! TO IGNORE QUOTES -> SUCCESS ! BIP(15): ! (S) ! -> SUCCESS %UNLESS NL # LINE(SYM) # ';' -> FAILURE ! BIP(12): ! (C LIST) ! REC(ALT) = 1; ! FILL IT IN NOW !!! C OWN DEC -> SUCCESS %IF C LIST # 0 -> FAILURE BIP(2):!**MCODE -> FAILURE %IF STUDENT # 0 -> FAILURE %IF MCODE(S&15) = 0 -> SUCCESS ! BIP(13): ! SPARE BIPS *** BLOOP *** BLOP *** ! -> FAILURE %END; ! OF PARSE %ROUTINE FETCH AR %INTEGER LAST LINE 1: %IF LINE ENTRY = 0 %START; ! LAST LINE EXHAUSTED OLD TEXT = TEXTIN FIRST CHAR = OLD TEXT RECONSTRUCT; ! PICK UP A NEW LINE LINE ENTRY = 1 %FINISH DEC1 = OLD TEXT DEC2 = TEXTIN RP = 1; SYM = LINE ENTRY; SM = SYM LINE START = SM %IF PARSE(0) # 0 %START;! FAILURE LAST LINE = LINE NUM LAST LINE = LAST LINE-1 %IF LINE ENTRY = 1 FAULT(0) TEXTIN = OLD TEXT %IF COMPMODE&2 = 0 PROMPTCH = ':' LINE NUM = LAST LINE FAULTY = 0 %IF COMP MODE&2 = 0;! DON'T IGNORE WHEN EDITING FLAG = 1 %AND %RETURN %C %IF COMPMODE&2 # 0 %AND LINENUM = 0 -> 1 %FINISH LINE ENTRY = 0 %IF LINE(SYM) = ';' %START OLD TEXT = FIRST CHAR+LINE(SYM+1) LINE ENTRY = SYM+2; ! MORE HERE DEC2 = OLD TEXT %FINISH %END 1: %UNTIL COMP MODE&B'1100' = 0 %AND LINE ENTRY = 0 %CYCLE DEC FLAG = 0; PRINTED = PRINTED&2 C START = CODEIN FETCH AR; %RETURN %IF FLAG # 0 RP = 1; CSS(REC(1)) %IF FAULTY = 1 %AND LEVEL = 1 %AND REC(1) # 8 %START ! VERY DUBIOUS !!!!! FAULTY = 0 CODEIN = C START TEXTIN = OLD TEXT LINE NUM = LINE NUM-1 %IF LINE ENTRY = 0 %FINISH %ELSE %START %IF DEC FLAG # 0 %AND LEVEL = 1 %C %AND TEXTIN-OLDTEXT+DECFILE < DEC LIMIT %START %CYCLE J = DEC1,1,DEC2-1 DEC FILE = DEC FILE+1 BYTEINTEGER(DEC FILE) = BYTEINTEGER(J) %REPEAT BYTEINTEGER(DEC FILE) = NL %C %IF BYTEINTEGER(DEC FILE) # NL %FINISH %FINISH %IF DCOMP = 1 %AND CODEIN > CSTART %START DECODE(CSTART,CODEIN,R10) PRINT USE %IF USE # 0 %FINISH %REPEAT %END %ROUTINE EXECUTE CODE RIM(0,PSTRING) RUNNING = 'Y' EFREE = X'B000'; ! SET UP FOR NEXT R11 *ST_11,A STACK SHORTINTEGER(CODEIN) <- X'05FC';! %STOP *LM_9,13,STACKTOP; ! CONTROL REGISTERS FOR CODE *MVC_24(40,9),24(8); ! MAKE THE RETURN ADDRESS OF THE CODE ! AND ITS SAVED REGISTERS THE SAME ! AS THIS ROUTINE, SO THAT IT WILL ! RETURN FROM WHENCE 'EXECUTE..' ! WAS CALLED ! *XC_20(4,13),20(13); ! CLEAR DIAGS POINTERS *BCR_15,10; ! ENTER CODE %END; ! NEVER REACHED !!!!! ! !******* CODE PLANTING ROUTINES ******* ! %ROUTINE PLANT(%INTEGER N) ! CODEIN NOT NESC. WORD ALLIGNED !!!! *L_1,CODEIN *MVC_0(4,1),N; ! INTEGER(CODEIN) = N *LA_1,4(1) *ST_1,CODEIN; ! CODEIN=CODEIN+4 %END %ROUTINE SPLANT(%INTEGER N) *L_1,CODEIN *MVC_0(2,1),N+2; ! SHORTINTEGER(CODEIN) = N *LA_1,2(1) *ST_1,CODEIN; ! CODEIN=CODEIN+2 %END %ROUTINE DRR(%INTEGER OPCODE, R1, R2) SHORTINTEGER(CODEIN) <- (OPCODE<<4!R1)<<4!R2 CODEIN = CODEIN+2 %END %ROUTINE DRX(%INTEGER OPCODE, R1, X, AD) SHORTINTEGER(CODEIN) <- (OPCODE<<4!R1)<<4!X SHORTINTEGER(CODEIN+2) <- AD CODEIN = CODEIN+4 %END %ROUTINE DSS(%INTEGER OPCODE, LENGTH, AD1, AD2) SHORTINTEGER(CODEIN) <- OPCODE<<8!LENGTH-1 SHORTINTEGER(CODEIN+2) <- AD1 SHORTINTEGER(CODEIN+4) <- AD2 CODEIN = CODEIN+6 %END %ROUTINE DSI(%INTEGER OPCODE, ADDR, IM) SHORTINTEGER(CODEIN) <- OPCODE<<8!IM SHORTINTEGER(CODEIN+2) <- ADDR CODEIN = CODEIN+4 %END ! !* * * * * * * * * * * * * * * * * * * * * ! %INTEGERFN FIND(%INTEGER NAME) %SHORTROUTINE %INTEGER ENTRY, STR, INDEX ENTRY = (BYTEINTEGER(NAME)*FIRST*LAST)&(\7) ! HASH ENTRY %CYCLE ENTRY = ENTRY,8,ENTRY+4088 INDEX = ENTRY&4095; ! WRAP AROUND STR = INTEGER(INDEX+DICTHEAD) %RESULT = \INDEX %IF STR = 0;! NOT YET IN %RESULT = INDEX %IF STRING(STR) = STRING(NAME) %REPEAT FAULT(104); ! DICTIONARY FULL %RESULT = INDEX; ! JUST TO KEEP GOING %END %INTEGERFN CONSTANT(%BYTEINTEGER TYPE) %SHORTROUTINE %CONSTLONGREAL MAX INTEGER = 2.14748364699999@9 %LONGREALFNSPEC NUMBER %LONGREALFNSPEC FRACTION %LONGREAL RR,NR %INTEGER IR, N, K %BYTEINTEGER S, SIGN S = LINE(SYM) %IF '0' <= S <= '9' %START;! INTEGER -> FLT %IF TYPE = B'10000'; ! STRING WANTED RR = NUMBER ->FRAC %IF LINE(SYM) = '.' %IF LINE(SYM) = '@' %START SYM = SYM+1 SIGN = LINE(SYM) SYM = SYM+1 %UNLESS '-' # SIGN # '+' K = SYM NR = NUMBER; -> FLT %IF K = SYM NR = 0 %AND FAULT(38) %IF NR > MAX INTEGER N = INT(NR) RR = RR*10.0**(-N) %AND -> REAL %IF SIGN = '-' RR = RR*10.0**N %FINISH ->REAL %IF RR > MAX INTEGER IR = INT(RR) INT: REC(RP) = B'100'; RP = RP+1 PUT4(IR) %RESULT = 0 %FINISH %IF S = '.' %START RR = 0 FRAC: %UNLESS TYPE&B'1000' # 0 %START FLT: %RESULT = 1 %FINISH RR = FRACTION+RR %IF LINE(SYM) = '@' %START SYM = SYM+1 SIGN = LINE(SYM) SYM = SYM+1 %UNLESS '-' # SIGN # '+' K = SYM NR = NUMBER; -> FLT %IF K = SYM NR = 0 %AND FAULT(38) %IF NR > MAX INTEGER N = INT(NR) N = -N %IF SIGN = '-' RR = RR*10.0**N %FINISH REAL: REC(RP) = B'1010'; RP = RP+1 PUT8(RR) %RESULT = 1 %IF TYPE&8 = 0; ! DID NOT WANT A REAL %RESULT = 0 %FINISH %IF S = ''''+128 %START -> FLT %IF TYPE&B'10000' = 0 %C %AND LINE(SYM+1) # ''''+128 # LINE(SYM+2) N = SYM IR = N %UNTIL S = ''''+128 %CYCLE SYM = SYM+1; S = LINE(SYM) RECONSTRUCT %IF S = NL %REPEAT N = SYM-N-1 %IF N < 2 %AND TYPE&B'100' # 0 %START ! POSSIBLE SYMBOL N = LINE(IR+1) %UNLESS N = 0 REC(RP) <- B'10100'; RP = RP+1; SYM = SYM+1 PUT4(N); %RESULT = 0 %FINISH SYM = SYM+1 REC(RP) <- B'10000' REC(RP+1) <- N REC(RP+2) <- IR RP = RP+3 %RESULT = 0 %FINISH %IF LINE(SYM+1) = ''''+128 %START SYM = SYM+1 IR = 0 %IF S = 'X' %START; ! HEX %CYCLE K = 1,1,8 SYM = SYM+1; S = LINE(SYM) -> FOUND %IF S = ''''+128 %IF '0' <= S <= '9' %THEN S = S-'0' %ELSE %START -> FLT %UNLESS 'A' <= S <= 'F' S = S-'A'+10 %FINISH IR = IR<<4!S %REPEAT %FINISH %ELSE %START %IF S = 'B' %START; ! BINARY %CYCLE K = 1,1,32 SYM = SYM+1; S = LINE(SYM) -> FOUND %IF S = ''''+128 -> FLT %IF '1' # S # '0' IR = IR<<1!(S-'0') %REPEAT %FINISH %ELSE %START %RESULT = 1 %UNLESS S = 'M';! MULTI CHAR %CYCLE K = 1,1,4 SYM = SYM+1; S = LINE(SYM) RECONSTRUCT %IF S = NL -> FOUND %IF S = ''''+128 IR = IR<<8!S %REPEAT %FINISH %FINISH SYM = SYM+1; -> FLT %UNLESS LINE(SYM) = ''''+128 FOUND: SYM = SYM+1; -> INT %FINISH ! THE ONLY POSSIBILITY LEFT IS 'PI' %IF S = '$' %THEN RR = $ %AND SYM = SYM+1 %AND ->REAL %RESULT = 1; ! FAILURE %LONGREALFN NUMBER %LONGREAL R %BYTEINTEGER S R = 0 %CYCLE S = LINE(SYM) %RESULT = R %UNLESS '0' <= S <= '9' R = R*10.0+ (S-'0') SYM = SYM+1 %REPEAT %END %LONGREALFN FRACTION %LONGREAL R, POINT %BYTEINTEGER S R = 0 POINT = 1 1: SYM = SYM+1 S = LINE(SYM) %RESULT = R %UNLESS '0' <= S <= '9' POINT = POINT/10 R = (S-'0')*POINT+R -> 1 %END %END %INTEGERFN NAME %SHORTROUTINE %INTEGER SPT, N %BYTEINTEGER S S = LINE(SYM) %RESULT = 1 %UNLESS 'A' <= S <= 'Z' FIRST = S; ! SAVE FIRST SYMBOL FOR HASHING SPT = DICT FREE %UNTIL S < '0' %OR 'A' > S > '9' %OR S > 'Z' %CYCLE LAST = S; ! SAVE LAST SYMBOL FOR HASHING SPT = SPT+1 BYTEINTEGER(SPT) <- S SYM = SYM+1 S = LINE(SYM) %REPEAT BYTEINTEGER(DICT FREE) <- SPT-DICT FREE ! SET LENGTH N = FIND(DICT FREE); ! LOOK FOR IT %IF N < 0 %START ! NOT IN YET FAULT(103) %AND ABORT %IF DICTFREE > DICT MAX N = \N INTEGER(N+DICTHEAD) = DICT FREE DICT FREE = SPT+1; ! ONTO FREE SPACE %FINISH REC(RP) = N; RP = RP+1 FAULT(102) %AND %RESULT = 1 %IF RP > 290 %RESULT = 0; ! SUCCESS %END %ROUTINE RECONSTRUCT %SHORTROUTINE %ROUTINESPEC SET LINE %INTEGERFNSPEC INPUT SYMBOL %OWNINTEGER P, SL %BYTEINTEGER S LINE NUM = LINE NUM+1 -> QMORE %IF PROMPTCH = ''''; ! CALLED FROM 'CONSTANT' PROMPTCH = ':' P = 0; L = 0; ! COUNTER FOR NUMBER OF SYMBOLS READ IN NLOOP: SET LINE LOOP: S = INPUTSYMBOL PLOOP: -> LOOP %IF S = ' ' %IF S = NL %START; ! END OF LINE TEXTIN = TEXTIN-1 %AND -> LOOP %IF P = 0 FAULT(101) %AND -> NL1 %IF P > 297 %IF LINE(P) = 'C'+32 %START; ! CONTINUATION PROMPTCH = 'C' P = P-1; ! REMOVE '%C' -> NLOOP %FINISH P = P+1 LINE(P) = S NL1: LINE LENGTH <- P %RETURN %FINISH %IF S = '''' %START %IF LINE(P) = ''''+128 %START LINE(P) = '''' -> QLOOP %FINISH P = P+1 LINE(P) = ''''+128 QLOOP: S = INPUTSYMBOL %IF S = '''' %START S = INPUTSYMBOL %IF S # '''' %START P = P+1 DIS106: LINE(P) = ''''+128 SL = 0 -> PLOOP %FINISH %FINISH P = P+1; SL = SL+1 FAULT(106) %AND -> DIS106 %IF SL > 255 LINE(P) = S %IF S = NL %START FAULT(101) %AND -> NL1 %IF P > 297 PROMPTCH = ''''; -> NL1 QMORE: SET LINE PROMPTCH = ':' %FINISH -> QLOOP %FINISH %IF S = '%' %START PCLOOP: S = INPUTSYMBOL -> PLOOP %UNLESS 'A' <= S <= 'Z' P = P+1 LINE(P) = S!32 -> PCLOOP %FINISH P = P+1 LINE(P) = S %IF S = ';' %START P = P+1 LINE(P) = TEXTIN-OLD TEXT %FINISH -> LOOP %INTEGERFN INPUTSYMBOL ! GET THE NEXT SYMBOL OF THE INPUT FILE ! AND SAVE IT AT TEXTIN %SHORTROUTINE %INTEGER S %IF COMP MODE&1 = 0 %THEN READSYMBOL(S) %ELSE %START ! INSIDE THE EDITOR, SO THE TEXT IS IN CORE ! AT 'TEXTP' TERMINATED BY A ZERO (NULL) CHARACTER S = BYTEINTEGER(TEXTP); TEXTP = TEXTP+1 ! PRODUCE A LISTING IF IN THE EDITOR %IF S = 0 %THEN READSYMBOL(S) %C %AND COMPMODE = COMPMODE&254 %FINISH BYTEINTEGER(TEXTIN) <- S; TEXTIN = TEXTIN+1 PRINTSYMBOL(S) %IF COMPMODE&2 # 0 %AND LIST = 'Y' %RESULT = S %END %ROUTINE SET LINE %CONSTSHORTINTEGER ONE = 1 %CONSTINTEGER NPAT1 = X'3F3F3F3F' %CONSTINTEGER NPAT2 = X'3F33FFFF' %LONGREAL WORK, WORK2 %IF COMP MODE&2 # 0 %START %IF LIST = 'Y' %OR DCOMP # 0 %START %IF TESTINT(0,'NO') # 0 %START ! INHIBIT OUTPUT LIST = 'N'; DCOMP = 0; PRINTED = 2 %FINISH %ELSE %START WRITE(LINENUM,4) %IF PROMPTCH = ':' %C %THEN %PRINTTEXT ' ' %C %ELSE PRINTSYMBOL(PROMPTCH) %PRINTTEXT ' ' %FINISH %FINISH %FINISH %ELSE %START ! CONVERT 'LINE NUM' INTO A STRING WITH THE ! CORRECT TERMINATOR *L_1,LINE NUM *CH_1,ONE *BC_7, *SLR_1,1 OK: *CVD_1,WORK *OI_WORK+7,1 *MVC_WORK2(5),PAT1 *ED_WORK2+1(4),WORK+6 *BC_7, *MVC_WORK2+4(1),PROMPTCH NZ: *NC_WORK2(4),NPAT1 RIM(0,STRING(ADDR(WORK2))) %FINISH %END %END %ROUTINE DEC CONST ARRAY(%INTEGER LEN) ! SETS UP THE DOPE-VECTOR AND HEADERS FOR CONSTANT BOUNDED ARRAYS ! SUCH AS ARE FOUND IN RECORDS AND OWN ARRAYS ! THE SPACE FOR THESES HEADERS+DOPE VECTORS IS TAKEN FROM GLA %SHORTROUTINE %INTEGER L, U, NP, N, A, SAVE, TGLA %STRING (8) EXNAME %INTEGER FLAG %RECORDNAME V(VARFM) NEWNAME_FLAGS = 0 AMORE: GLA = (GLA+3)&(\3) TGLA = GLA; DIAG FLAG = 0 N = 1 %IF EXTRINSIC = 0 %START NP = RP; N = REC(RP+1); RP = 1+RP+N %FINISH CBPAIR(L,U) LEN = LEN+1 %IF NEWNAME_TYPE = B'10000' INTEGER(TGLA) = LEN!X'00010000' INTEGER(TGLA+4) = L; INTEGER(TGLA+8) = U INTEGER(TGLA+12) = U-L+1 NEWNAME_FORM = B'111'; NEWNAME_DIMENSION = 1 A = NEWNAME_ADDRESS NEWNAME_ADDRESS <- (TGLA-GLA HEAD)+X'D010' %IF EXTRINSIC # 0 %START; ! OWN/EXTRINSIC ARRAY NEWNAME_LEVEL = LEVEL NP = OWNNAME+DICTHEAD FAULT2(7,OWNNAME) %AND %RETURN %C %IF INTEGER(NP+4) # 0 %C %AND BYTEINTEGER(INTEGER(NP+4)+4) = LEVEL %IF EXTRINSIC # 1 %THEN A = OWN HEAD %ELSE %START ! ! TRY TO LOAD EXTRINSICS ! EXNAME <- STRING(INTEGER(NP)) A = 0; ! JUST IN CASE FDP(DATA FDP,EXNAME,FDP DATA REF,ADDR(A),FLAG) %IF FLAG # 0 %START PRINTSTRING('* cannot load '.EXNAME.' ') %RETURN %FINISH FLAG = COMREG(7); ! UNSAT REF LIST CREATE DUMMY REFS(FLAG) %IF FLAG # 0 %FINISH V == RECORD(NEWCELL) V = NEW NAME V_LINK = INTEGER(NP+4); INTEGER(NP+4) = ADDR(V) %FINISH %ELSE %START SAVE = RP; RP = NP C L NAMELIST(16); ! FOR HEADERS IN GLA %FINISH ! NOW FILL HEADERS U = LEN*(U-L+1); ! TOTAL LENGTH OF THE ARRAY L = -L*LEN; ! DISP OF @A(0) FROM @A(FIRST) !! NP = ROUND(NEWNAME_TYPE) !! NP = 0 %IF NEWNAME_TYPE = B'10000' A = (A+7)&(\7) %IF EXTRINSIC # 1 %CYCLE N = GLA+16,16,GLA+N<<4 INTEGER(N) = A+L INTEGER(N+4) = A INTEGER(N+8) = GLA INTEGER(N+12) = OWN LIST BYTEINTEGER(N) <- LEN-1 A = A+U %REPEAT GLA = N+16 %IF EXTRINSIC = 0 %START NEWNAME_ADDRESS <- A RP = SAVE+1; -> AMORE %IF REC(RP) = 1 %FINISH ! %END %ROUTINE PRINT LABEL(%INTEGER LABEL) %SHORTROUTINE %IF LABEL < 0 %THEN WRITE(\LABEL,3) %ELSE %START SPACES(2) PRINTSTRING(STRING(INTEGER(LABEL+DICT HEAD))) %FINISH NEWLINE %END %ROUTINE FIND CYCLE(%INTEGERNAME P) ! SEARCH THE START/CYCLE LIST (HEADED BY 'START HEAD') FOR ! THE LAST CYCLE ENCOUNTERED. ! P WILL HAVE THE VALUE ZERO IF THERE ARE NO CYCLES. ! THIS IS USED BY '%EXIT' AND '%CONTINUE' TO FIND THE ! LABEL TO WHICH THEY MUST JUMP. %SHORTROUTINE P = START HEAD %WHILE P # 0 %CYCLE %RETURN %IF BYTEINTEGER(P+3)&15 = 0 !FOR A CYCLE/REPEAT BLOCK P = INTEGER(P+12); ! LINK %REPEAT %END %ROUTINE GET RESLN VAR(%INTEGERNAME ENTRY) %SHORTROUTINE -> FLT74 %IF REC(RP+2) # 4 %OR REC(RP+4) # 2 RP = RP+4 VAR(LHS) RP = RP+1 %IF REC(RP) # 2 %START FLT74: FAULT(74) RP = ENTRY ENTRY = 0 SKIP EXPRN %FINISH %END %ROUTINE FLOAT(%RECORDNAME VAR, %INTEGER REG) ! THE METHOD OF FLOATING AN INTEGER IS AS FOLLOWS : ! !*L_14,N PICK UP THE INTEGER !*LPR_15,14 ABSOLUTE VALUE TO R15 !*N_14,=X'80000000' MASK OFF THE SIGN BIT !*O_14,=X'4E000000' OR IN THE EXPONENT !*STM_14,15,STACK DUMP THEM SOMEWHERE SAFE !*SDR_2,2 CLEAR THE FLOATING POINT REGISTER !*AD_2,STACK PICK UP THE TWO WORDS AND NORMALIZE %RECORDSPEC VAR(VARFM) PROTECT(8) %AND FPR2 = ADDR(VAR) %IF REG = 2 LOAD(VAR,14) SPLANT(X'10FE') PLANT(X'54ED0000'!17<<2) PLANT(X'56ED0000'!18<<2) EFREE = (EFREE+7)&(\7); ! GET SPACE PLANT(X'90EF0000'+EFREE&X'FFFF'); !SAFE ENOUGH HERE (METHINKS !) DRR(X'2B',REG,REG) DRX(X'6A',REG,0,EFREE) VAR_TYPE = B'1010' VAR_FORM = 128 VAR_ADDRESS <- REG %END %ROUTINE TEMPREAL(%INTEGERNAME ADDRESS) ! TAKES 8 BYTES OF LOCALS FOR INTERMEDIATE EXPRNS. %INTEGERNAME PT %IF MON LOCK # 0 %START ADDRESS = (EFREE+7)&(\7) EFREE = ADDRESS+8 %FINISH %ELSE %START PT == DISP %IF LEVEL = 1 %THEN PT == MAX DISP ADDRESS <- (PT+7)&(\7) PT <- PT+8 %FINISH %END %ROUTINE CRES(%INTEGER LABEL, MASK) %SHORTROUTINE ! COMPILES A -> B . ( C ) . D . ( E ) . F ETC. ! THIS CAN BE VERY HAIRY ESP. IN CONDITIONS, IN WHICH ! CASE 'LABEL' IS SET TO AN INTERNAL LABEL TO BE JUMPED ! TO IF THE RESOLUTION FAILS ! PERM RETURNS A CONDITION CODE OF 8 FOR SUCCESS ! AND 7 FOR FAILURE. %INTEGER A, P, TLAB, ENTRY %RECORD V(VARFM) %BYTEINTEGER F, BASE, SLEN ! 'LHS' SET ON 'A' : RP ON 'ASSOP' : ASSOP=4 BASE = 1 %IF LABEL = RESFLOP %THEN BASE = 0 F = 0 ENTRY = 15<<2+X'45FC0000'; ! FIRST ENTRY INTO PERM TLAB = LABEL %IF MASK # 7 %THEN TLAB = ILAB-1 %AND ILAB = TLAB REG USE(4) = 'S' FAULT(73) %UNLESS LHS_TYPE = B'10000' LHS_FORM = LHS_FORM&B'11111101' LHS_TYPE = 4 %IF LHS_FLAGS&4 # 0 %THEN LHS_TYPE = 0 LOAD(LHS,14); STUAV(14) P = RP R14 = 1 RP = P+2 -> FLT74 %IF REC(RP) # 4; ! NULL (PLUS) R1: %IF REC(RP+2) = 3 %START; ! 'B' MISSING F = 2 -> EXP %FINISH RP = RP+1 -> FLT74 %UNLESS REC(RP+1) = 2; ! OPERAND TYPE 2 = VARIABLE GETSVAR(V); SLEN = CPE LEN RP = RP+1 %IF REC(RP) = 2 %START; ! END OF EXPRN -> FLT74 %IF F = 0 ! ! ASSIGN FINAL STRING ! V_FORM = V_FORM&B'11111101' DRX(X'42',4,0,EFREE) %IF TUAV # 0 V_LENGTH = SLEN S CPE(V,EFREE) LOAD(V,1); GPR1 = 0; ! FORGET IT PLANT(X'444D0000'!19<<2); PLANT(X'42410000') ! RMOV: MVC_0(0,1),0(14) ! JUMP TO(LABEL,15) %UNLESS MASK = 7 -> 10 %FINISH RP = RP+1 -> FLT74 %UNLESS REC(RP) = 12 %AND REC(RP+2) = 3 ! '.(' EXP: RP = RP+2 CSEXPRN(A) RP = RP+1 %IF REC(RP) = 2 %THEN F = F!4 %ELSE %START -> FLT74 %UNLESS REC(RP+1) = 12; ! '.' %FINISH S LOAD(A,1) %IF F&2 # 0 %THEN SPLANT(X'1F00') %ELSE %START %IF V_FLAGS&4 # 0 %THEN DSI(X'92',X'D03B',SLEN) %C %ELSE %START %IF V_INDEX = 0 %THEN A = V_ADDRESS %ELSE %START DRX(X'41',15,V_INDEX,V_ADDRESS); A = X'F000' %FINISH DSS(X'D2',1,X'D03B',A) %FINISH V_FORM = V_FORM&B'11111101' LOAD(V,0) %FINISH PLANT(ENTRY) ENTRY = 16<<2+X'45FC0000'; ! SECOND AND SUBSEQUENT ENTRY POINT GPR1 = 0; ! NOW FORGET IT %IF BASE = 0 %THEN DRX(X'47',7,0,TLAB) %C %ELSE JUMP TO(TLAB,7) %IF F&4 # 0 %START SPLANT(X'1244') !*LTR_4,4 %IF BASE = 0 %THEN DRX(X'47',7,0,TLAB) %C %ELSE JUMP TO(TLAB,7) F = 1 -> 10 %FINISH F = 1 RP = RP+1 -> R1 FLT74: RP = P SKIPEXPRN FAULT(74) 10: REGUSE(4) = 0 %IF F = 1 %AND MASK # 7 %THEN REMOVE LABEL(TLAB) R14 = 0 %END %ROUTINE SET CONST(%INTEGER WTYPE, SLEN, PLUS) ! THIS ROUTINE PICKS UP THE CONSTANT FROM 'REC' AND STORES ! IT AT 'GLAP', FAULTING IF THE SIZE OR TYPE IS WRONG. %SHORTROUTINE %BYTEINTEGER CTYPE, TYPE HOLD %LONGREAL WORK %CONSTINTEGER M1 = X'80000000' %CONSTINTEGER SWLIST = X'0C040800' %CONSTINTEGER SWL2 = X'10001400' %CONSTINTEGER M2 = X'4E000000' %CONSTINTEGER C255 = X'000000FF' ! *CLI_PLUS+3,0; ! PLUS = 0 => NO CONSTANTS *BC_7, *MVI_CTYPE,255; ! SHOW OK *XC_WORK(8),WORK; ! WORK = 0 -> ZZ NZ: *L_4,K; ! RP *LA_6,0(4,4) *A_6,REC *IC_0,1(6); ! TYPE OF CONSTANT FOUND *STC_0,CTYPE *MVC_WORK(8),2(6); ! MOVE IN INFO (NOW DOUBLE WORD ALLIGNED !) *CLI_CTYPE,4; ! \INTEGER ? *BC_7,<1>; ! NO, SO I'VE GOT AN INTEGER *TM_WTYPE+3,8 *BC_8,<1>; ! NO, SO I WANT A REAL, THEREFORE FLOAT IT *MVI_CTYPE,10; ! SET TYPE TO REAL *BCTR_4,0 *BCTR_4,0; ! KNOCK R4 BACK 2 AS 'REAL' WILL UP ITBY 2 *L_14,WORK; ! SEE ALSO ROUTINE FLOAT *LPR_15,14 *N_14,M1 *O_14,M2 *STM_14,15,WORK *SDR_0,0 *AD_0,WORK *STD_0,WORK 1: *LA_4,2(4); ! RP PAST CONST (2 SHORTS) *MVC_TYPE HOLD(1),CTYPE; ! PRESERVE OLD TYPE *NC_CTYPE(1),WTYPE+3 *NI_CTYPE,B'11100'; ! CLEARS 'CTYPE' IF TYPES DIFFER ZZ: *TR_WTYPE+3(1),SWLIST-4; ! GET SWITCHING INDEX *SLR_5,5 *IC_5,WTYPE+3 *L_1,GLAP; ! WHERE TO PLUG THE CONSTANT *BC_15,<2>(5); ! SWITCH ON TYPE ICOMP: *L_2,WORK; ! ROUTINE TO GET AN INTEGER + SIGN *CLI_PLUS+3,2; ! '-' *BCR_7,15 *LCR_2,2; ! NEGATE IT *BCR_15,15; ! RETURN 2: *BC_15, *BC_15, *BC_15, *BC_15, *BC_15, !LONGREAL: *LA_4,2(4); ! REAL USES TWO SHORTS EXTRA *LD_0,WORK *CLI_PLUS+3,2; ! '-' *BC_7,<11> *LCDR_0,0; ! NEGATE IT 11: *STD_0,0(1); ! STORE IT -> 6; ! RETURN REAL: *LA_4,2(4) *LD_0,WORK *CLI_PLUS+3,2 *BC_7,<12> *LCDR_0,0 12: *STE_0,0(1) -> 6 INT: *BAL_15,; ! GET VALUE *ST_2,0(1) -> 6 SHORT: *BAL_15, *STH_2,0(1) *XC_WORK(1),WORK+1 *MVC_CTYPE(1),WORK *XI_CTYPE,255 -> 6 BYTE: *BAL_15, *STC_2,0(1) *CL_2,C255; ! > 255 ? *BC_13,<6> *MVI_CTYPE,0; ! CAPACITY EXCEEDED MOVE: *MVC_0(0,1),0(2) STR: *CLI_TYPE HOLD,B'10100'; ! POSSIBLE SYMBOL *BC_7, *MVI_0(1),1; ! LENGTH 1 *MVC_1(1,1),WORK+3; ! MOVE IN SYMBOL *CLI_1(1),0; ! NULL STRING ? *BC_7,<6> *MVI_0(1),0; ! SET LENGTH TO ZERO -> 6 NSYM: *CLC_SLEN+3(1),WORK+1; ! TOO BIG ? *BC_11,<5> *MVI_CTYPE,0; ! CAPACITY EXCEEDED *MVC_WORK+1(1),SLEN+3; ! SET TO MINIMUM LENGTH 5: *IC_5,WORK+1 *LH_2,WORK+2; ! INDEX INTO LINE FOR TEXT *A_2,LINE; ! NOW @ TEXT *STC_5,0(2) *EX_5,; ! MOVE IN TEXT *TM_PLUS+3,3; ! '+' OR '-' *BC_9,<6> *MVI_CTYPE,0; ! INVALID OPERATOR 6: *ST_4,K; ! UPDATE 'TEMP' RP FAULT(44) %IF CTYPE = 0 %END %ROUTINE C OWN DEC ! THIS ROUTINE DEALS WITH ALL %OWN/%CO !!! %SHORTROUTINE %INTEGER LL, UU, M, S, LENV %INTEGER BP, CW, CG, REP, ML, GP %INTEGER L, T, Z, R, N, PLUS, ZZ DECFLAG = 1; ! SAVE OWN DECLARATIONS RP = 2; ! SKIP OWN/CONST/EXTERNAL/EXTRINSIC EXTRINSIC = REC(RP) EXTRINSIC = 3 %IF EXTRINSIC # 1 NEWNAME = 0 VTYPE(NEWNAME) NEWNAME_LEVEL = LEVEL L = NEWNAME_LENGTH T = NEWNAME_TYPE %IF EXTRINSIC = 1 %OR NEWNAME_TYPE = 16 %C %THEN DIAGFLAG = DIAGFLAG!128 %C %AND NEWNAME_FORM = 3 %ELSE NEWNAME_FORM = 1 R = ROUND(T) Z = L; ZZ = Z; LENV = ZZ %IF T = 16 %START FAULT(70) %AND -> FAIL %IF Z = 0 Z = Z+1; ZZ = 4 %FINISH RP = RP+1 %IF REC(RP) = 2 %START; ! SCALARS GLAP = (GLA+R)&(\R) GLA = GLAP %UNTIL REC(RP) = 2 %CYCLE RP = RP+1; N = REC(RP) C NAME LIST(N,ZZ) %IF T = 16 %AND EXTRINSIC # 1 %START ! STRINGS TO ARRAY SPACE S = A SPACE %CYCLE GLAP = GLAP,4,GLAP+N<<2 INTEGER(GLAP) = S; S = S+Z BYTEINTEGER(GLAP) <- L %REPEAT GLAP = A SPACE %FINISH PLUS = 0 RP = RP+1 %IF EXTRINSIC = 1 %START RP = RP+4 %AND FAULT(45) %IF REC(RP) = 1 %FINISH %ELSE %START %IF REC(RP) = 1 %C %THEN RP = RP+1 %AND PLUS = REC(RP) K = RP+1 SET CONST(T,L,PLUS); ! BRING IN THE CONSTANT RP = K %IF PLUS # 0 MOVE((N-1)*Z,GLAP,GLAP+Z) %IF N > 1 ! DUPLICATE IT A SPACE = S %IF T = 16 %FINISH GLAP = GLA RP = RP+1 %REPEAT %IF T = 16 %AND EXTRINSIC # 1 %C %THEN ASPACE = (ASPACE+7)&(\7) CLIST = 1 -> EX %FINISH ! OWN ARRAYS '%ARRAY'(NAME)(CBPAIR)(C LIST): FAULT(40) %AND -> FAIL %IF COMP MODE&B'1000' # 0 %IF OWN DISP = 0 %START GLA = (GLA+3)&(\3) OWN DISP = GLA GLA = OWN DISP+4 %FINISH CLIST = 2; ! FLAG TO STOP CSS FROM CALLING THIS ROUTINE ! AGAIN, ALSO FLAG FOR PARSE RP = RP+1; OWN NAME = REC(RP) BP = RP; ! SAVE IT FOR DEC CONST ARRAY C B PAIR(LL,UU); ! GET THE BOUNDS CG = 0 -> DEC %IF EXTRINSIC = 1; ! CANNOT GIVE CONSTANTS CW = UU-LL+1; ! CONSTANTS WANTED M = CW*Z; ! TOTAL LENGTH OF THE ARRAY %IF LEVEL = 1 %START; ! TREAT AS NORMAL GLAP = (A SPACE+7)&(\7) FAULT(98) %AND -> FAIL %IF GLAP+M > OWN TOP ! TOO BIG %FINISH %ELSE %START; ! THE ARRAY WILL HAVE TO BE ! MOVED UP TO THE ROUTINE BLOCK AT END GLAP = (OWN TOP-M)&X'FFFFF8';! UP FROM THE BOTTOM FAULT(98) %AND -> FAIL %IF GLAP < A SPACE ! TOO BIG %FINISH OWN HEAD = GLAP; ! ABSOLUTE TOP OF THE ARRAY %UNLESS NL # LINE(SYM) # ';' %START; ! NO CONSTANTS => ZERO INTEGER(GLAP) = 0; MOVE(M-4,GLAP,GLAP+4) GLAP = GLAP+M -> DEC %FINISH -> FAIL %UNLESS LINE(SYM) = '=' CG = -CW; SYM = SYM+1 1: RP = 20; PLUS = 3; S = LINE(SYM) %IF S = '+' %OR S = '-' %START SYM = SYM+1; PLUS = 2 %IF S = '-' %FINISH -> FAIL %IF CONSTANT(T) # 0 REP = 1; K = 20; SET CONST(T,L,PLUS) %IF LINE(SYM) = '(' %START SYM = SYM+1; RP = 20 -> FAIL %IF CONSTANT(4) # 0 RP = 20; GET4(REP) ->FFAIL %IF REP&X'FFFF0000' # 0 -> FAIL %UNLESS LINE(SYM) = ')' SYM = SYM+1 %FINISH CG = CG+REP -> FFAIL %IF CG > 0 ML = (REP-1)*Z MOVE(ML,GLAP,GLAP+Z) %IF ML > 0 GLAP = GLAP+ML+Z -> DEC %IF LINE(SYM) # ',' SYM = SYM+1 %IF LINE(SYM) = NL %START; ! END OF THIS LINE SM = 0 RECONSTRUCT; ! BRING IN NEXT LINE SYM = 1 DEC2 = TEXTIN; ! TO SAVE DECLARATION %FINISH -> 1 FFAIL: FAULT(45) FAIL: SM = SYM %IF SYM > SM C LIST = 0 -> EX DEC: -> FAIL %IF NL # LINE(SYM) # ';' -> FFAIL %IF CG # 0 RP = BP; GP = GLA-GLAHEAD+X'D010' OWN LIST = OWN HEAD-OWN END DEC CONST ARRAY(LENV) -> EX %IF EXTRINSIC = 1 %IF LEVEL = 1 %START A SPACE = (GLAP+7)&(\7) %FINISH %ELSE OWN TOP = OWN HEAD %IF BASE REG # 9 %START !*LM_14,1,HEADER !*SR_14,15 !*LA_10,0(1,10) !*A_15,??(13) !*AR_14,15 !*STM_14,15,HEADER DRX(X'98',14,1,GP) SPLANT(X'1BEF') PLANT(X'41F1A000'); ! R15 = R1+R10 PLANT(X'5AFD0000'-GLAHEAD+OWN DISP) ! DISP OF ARRAY SPLANT(X'1AEF') DRX(X'90',14,15,GP) %FINISH EX: EXTRINSIC = 0; ! RESTORE IT %END %ROUTINE DUMP SIGNAL(%INTEGER L) %SHORTROUTINE %INTEGER J %PRINTTEXT ' REGISTERS ' %CYCLE J = 0,1,15; NEWLINE %IF J&3 = 0 WRITE(J,3); SPACES(3) HEX(INTEGER(SIGAREA+J<<2+8)) SPACES(2) %REPEAT %PRINTTEXT ' CODE ' L = (L+7)&X'FFFFF8' IIDUMP(L-80,L+56) NEWLINES(3) %END %ROUTINE CREATE DIAG LIST(%INTEGERNAME NLINK) %SHORTROUTINE %RECORDNAME DVAR(VARFM) %INTEGER VNUM, J %BYTEINTEGER FLAG %CYCLE %WHILE INTEGER(DPT) > 0 %CYCLE DVAR == RECORD(NEW CELL) FLAG = BYTEINTEGER(DPT); ! TYPE & FORM FLAG VNUM = D TAB MAP(FLAG>>1&15) VNUM = VNUM+6 %IF FLAG&X'40' # 0 ! NAME TYPE DVAR = DIAG VAR(VNUM); ! COPY IN VAR INFO *L_1,DPT; **2,@DVAR_ADDRESS *MVC_0(2,2),1(1); ! MOVE IN ADDRESS FIRST = BYTEINTEGER(DPT+4); ! FIRST CHAR FOR HASHING LAST = BYTEINTEGER(DPT+BYTEINTEGER(DPT+3)+3) ! LAST CHAR J = FIND(DPT+3); ! LOOK FOR NAME IN DICTIONARY %IF J < 0 %START; ! NOT IN J = \J; ! POSITION OF FREE CELL INTEGER(J+DICT HEAD) = DICTFREE STRING(DICTFREE) = STRING(DPT+3) DICTFREE = DICTFREE+BYTEINTEGER(DICTFREE)+1 FAULT(104) %AND ABORT %IF DICTFREE > DICT MAX %FINISH SHORTINTEGER(ADDR(DVAR_LEVEL)) = J ! NAME INFO FORMAT LIST NLINK = ADDR(DVAR) NLINK == DVAR_LINK DPT = (DPT+BYTEINTEGER(DPT+3)+7)&(\3) %REPEAT %EXIT %IF INTEGER(DPT) # -2 DPT = DPT+4 %REPEAT NLINK = 0; ! MARK THE END OF THE LIST %END ! %ROUTINE DEFINE DIAGS(%INTEGER AGLA, BLOCK) %SHORTROUTINE %INTEGER P DIAG HEAD == DIAG BASE DPT = INTEGER(AGLA+28)+INTEGER(AGLA+12) %WHILE DIAG HEAD_LINK # 0 %CYCLE DIAG HEAD == RECORD(DIAG HEAD_LINK) %RETURN %IF DIAG HEAD_DIAGS = DPT %C %AND DIAG HEAD_LINE = BLOCK %REPEAT ! NOT IN SO PUT IT IN P = NEWCELL DIAG HEAD_LINK = P; DIAG HEAD == RECORD(P) DIAG HEAD_DIAGS = DPT %CYCLE %RETURN %IF INTEGER(DPT) = X'E2E2E2E2' ! END OF DIAGS %EXIT %IF INTEGER(DPT) = X'C2C2C2C2' %C %AND SHORTINTEGER(DPT+4) = BLOCK DPT = DPT+4 %REPEAT DIAG HEAD_LINE = BLOCK DIAG HEAD_NAME = DPT-DIAG HEAD_DIAGS+7 %IF BYTEINTEGER(DPT+7) = 0 %START; ! BEGIN BLOCK DPT = DPT+12 %FINISH %ELSE %START DPT = (DPT+11+BYTEINTEGER(DPT+7))&(\3) %FINISH CREATE DIAG LIST(DIAG HEAD_INDEX) %END %ROUTINE SET UP MONITOR(%BYTEINTEGER MODE) %SHORTROUTINE %ROUTINESPEC POP %ROUTINESPEC PUSH %RECORDFORMAT HFM(%RECORDNAME HEAD, %INTEGER FRAME, L, B, GLA) %RECORDSPEC HFM_HEAD(MON DIAG HEAD FM) %OWNRECORDARRAY HOLD(1 : 8)(HFM) %OWNINTEGER PPS %INTEGER PT, R, OLD GLA %STRING (31) NAME ! %IF MODE = 0 %START; ! INITIAL CALL NEWLINE OLD CODE TOP SAVE = CODE TOP ! ! PROTECT THE CALLING CODE FROM THE INTERPRETER ! CODE TOP = (CODEIN+31)&(\7) MON ENTRY = MON FRAME MONITORGLA = MON INFO PPS = 0 MONITOR BLOCK = SHORTINTEGER(MONITORGLA+20) MONITOR LINE = SHORTINTEGER(MONITORGLA+22) %FINISH %ELSE %START PT = DIAG HEAD_DIAGS+DIAG HEAD_NAME-1 %IF MODE = '-' %START; !BACK ALONG FRAME OLD GLA = MONITOR GLA PUSH; ! PRESERVE INFO %IF OLD GLA # MONITOR GLA %START %IF MONITOR GLA = GLA HEAD %THEN POP %C %ELSE %START MONITOR BLOCK = SHORTINTEGER(MONITOR GLA+20) MONITOR LINE = SHORTINTEGER(MONITOR GLA+22) %FINISH %FINISH %ELSE %START %IF BYTEINTEGER(PT+1) = 0 %START ! BLOCK MONITOR LINE = MONITOR BLOCK MONITOR BLOCK = INTEGER(PT+2) %FINISH %ELSE %START R = BYTEINTEGER(PT)<<2 MON FRAME = INTEGER(MON FRAME+R) MONITOR BLOCK = SHORTINTEGER(MONFRAME) MONITOR LINE = SHORTINTEGER(MON FRAME+2) %FINISH %FINISH %FINISH %ELSE POP; ! FORWARD ALONG FRAME %FINISH ! DEFINE DIAGS(MONITORGLA,MONITOR BLOCK) ! INTEGER(GLA HEAD) = MON FRAME ! %IF DIAG HEAD_LINE = 0 %THEN NAME = '?' %ELSE %START NAME = STRING(DIAG HEAD_DIAGS+DIAG HEAD_NAME) %FINISH NAME = 'BLOCK' %IF NAME = '' PRINTSTRING('break: '.NAME.' (') WRITE(MONITOR BLOCK,1) %PRINTTEXT ' ) line' WRITE(MONITOR LINE,1) NEWLINE %RETURN %ROUTINE POP %RECORDNAME T(HFM) %RETURN %IF PPS <= 0 T == HOLD(PPS); PPS = PPS-1 DIAG HEAD == T_HEAD MON FRAME = T_FRAME MONITOR GLA = T_GLA MONITOR LINE = T_L MONITOR BLOCK = T_B %END %ROUTINE PUSH %RECORDNAME T(HFM) POP %IF PPS >= 8 PPS = PPS+1; T == HOLD(PPS) T_HEAD == DIAG HEAD T_FRAME = MON FRAME T_GLA = MONITOR GLA T_L = MONITOR LINE T_B = MONITOR BLOCK MONITOR GLA = INTEGER(MON FRAME+52) %END %END %INTEGERFN ASL LENGTH *SR_2,2 *L_1,ASL *LA_3, *BC_15, LOOP: *L_1,12(1) IN: *LTR_1,1 *BC_8, *BCTR_2,3 OUT: *LCR_1,2 *LM_4,14,16(8) *BCR_15,15 %END %ROUTINE SET FILE(%BYTEINTEGER FLAG, %STRING (3) STREAM) %BYTEINTEGER DOT STREAM = 'ST'.STREAM %IF FLAG # 0 %THEN RP = RP+1 %AND DOT = REC(RP) %C %ELSE DOT = 0 RP = RP+1; IOFILE <- STRING(INTEGER(REC(RP)+DICTHEAD)) IOFILE <- '.'.IOFILE %IF DOT = 1 CLEAR(STREAM) DEFINE(STREAM.','.IOFILE) %END %ROUTINE DEFINE TRACE %SHORTROUTINE %STRING (8) RTNAME %INTEGER N, J %BYTEINTEGER ON ! RP = RP+1; ON = REC(RP); ! 1 = ON, 2 = OFF %IF ON = 2 %START; ! OFF, SO DUMP NAME LIST %RETURN %IF MON FILE CREATED = 0; ! NO MONITOR FILE RT MON ENABLE = 0; ! STOP SPECIAL RT ENTRY %CYCLE N = 0,1,127; ! LOOK FOR ROUTINES %IF R ENTRY(N) = 255 %START; ! ROUTINE ENTRY ACTIVE RTNAME <- STRING(INTEGER(DICTHEAD+MONNAME(N))) STRING(RT MON NAMES+9*N) = RTNAME %FINISH %REPEAT ! ! NOW SET UP HEADER ! INTEGER(RT MON FILE) = INTEGER(STACKTOP+12)- %C RT MON FILE BYTEINTEGER(RT MON FILE) = 0 INTEGER(RT MON FILE+12) = RT MON HEAD-RT MON FILE BYTEINTEGER(STACKTOP+11) = 0;! DYNAMIC OFF %FINISH %ELSE %START %IF MON FILE CREATED = 0 %START N = 64; ! FOUR SEGMENTS SHOULD BE ENOUGH IIGEN('II#DATA',N,J); ! CREATE IT %IF J # 0 %START %PRINTTEXT '* cannot create II#DATA ' %RETURN %FINISH MON FILE CREATED = 1 RT MON FILE = N RT MON NAMES = RT MON FILE+16; ! PAST HEADER RT MON HEAD = RT MON NAMES+9*128 INTEGER(STACKTOP+12) = RT MON HEAD %FINISH BYTEINTEGER(STACKTOP+11) = 128; ! DYNAMIC ON RT MON ENABLE = 1 %FINISH %END %ROUTINE SET CONTROL(%INTEGER N) ! ! RESETS THE VALUE OF THE CONTROL VARIABLES ! A HEX DIGIT OF 'F' LEAVES THE CURRENT VALUE OF THAT VARIABLE ! %OWNINTEGER M1, M2 = X'0F0F0F0F' %OWNINTEGER T1, T2, T3 = 0, T4 = 15 %OWNINTEGER MIN1,MIN2=-1 %LONGREAL WORK1, WORK2 ! *UNPK_WORK1(9),N(5) *NC_WORK1(8),M1 *MVC_WORK2(8),WORK1 *TR_WORK2(8),T1 *NC_DCOMP(8),WORK2 *XC_WORK2(8),MIN1 *NC_WORK1(8),WORK2 *OC_DCOMP(8),WORK1 ! %END %ROUTINE COMPARE RT(%RECORDNAME V, %INTEGER LIST) %SHORTROUTINE %RECORDSPEC V(VARFM) %IF V_FORM&128 = 0 %START; ! NOT YET DEFINED V_INDEX = LIST; ! SET IT FROM THE FIRST USE V_FORM = V_FORM!128; ! DEFINED NOW %RETURN %FINISH COMP P LIST(-V_INDEX,LIST);! DON'T DESTROY THE LIST %END %ROUTINE SPECIAL(%INTEGER ST) %SHORTROUTINE %SWITCH SPS(0 : 29) %INTEGER GLA WORD %INTEGERNAME P, NAME %BYTEINTEGER FIND %RECORDNAME VAR(VARFM) %RECORDNAME RT(RTFM) %RECORDNAME TB(RBFM) %INTEGER LINE, J, N -> SPS(ST) ! SPS(29): ! TRACE (ON/OFF) ! DEFINE TRACE -> END ! ! SPS(28): ! $LOOK ! EDIT(2); -> END ! SPS(1): ! 'EDIT' [NAME] ! EDIT(0); -> END ! SPS(2): ! 'COMPILE' [NAME] ! FAULT(33) %AND -> END %IF IOFLAG # 0 %OR COMP MODE # 0 SELECTINPUT(0) SET FILE(0,'78') SELECTINPUT(78) PRINTED = 2 IOFLAG = 1; COMP MODE = COMP MODE!64 -> END ! SPS(3): ! 'SENDTO' [NAME] ! %IF COMP MODE # 0 %START FAULT(33); -> END %FINISH SELECTOUTPUT(0) RP = RP+1; ! SKIP OPTIONAL 'TO' SET FILE(0,'79') ! SPS(0): ! SEND TO FROM ABORT ! SELECT OUTPUT(79) SEND TO; -> END ! SPS(24): ! $FIND [NAME]':'[NUMBER] ! FIND = 1 LINE = REC(RP+4); ! LINE NUMBER WANTED LINE = LINE-1 %IF LINE > 1 LIST = 'N' -> P LIST ! SPS(23): ! $LIST NAME ! FIND = 0 LIST = 'Y' P LIST: FAULT(33) %AND -> END %IF LEVEL # 1 %OR COMP MODE # 0 RP = RP+1; N = REC(RP)+DICT HEAD; ! NAME VAR == RECORD(INTEGER(N+4)) %IF ADDR(VAR) = 0 %OR VAR_TYPE = 31 %C %OR VAR_FORM&8 = 0 %OR VAR_FLAGS&34 # 0 %C %OR VAR_LEVEL = 0 %START PRINTSTRING('* cannot list '.STRING(INTEGER(N)).' ') -> END %FINISH %IF FIND = 0 %START RP = RP+1 %IF REC(RP) = 1 %START SELECTOUTPUT(0) SET FILE(1,'79') SELECTOUTPUT(79) FIND = 3 %FINISH %FINISH RT == RTS(VAR_DIMENSION) TB == RECORD(RT_ENVIR) NEWLINE COMP MODE = 3 TEXTP = TB_TEXT N = TB_LENGTH+TEXTP-1; ! END OF TEXT LINE NUM = 0 %CYCLE LIST = 'Y' %AND FIND = 2 %C %IF FIND = 1 %AND LINE NUM = LINE-1 RECONSTRUCT %EXIT %IF COMP MODE&1 = 0 %OR TEXTP >= N %C %OR (FIND = 2 %AND LINE NUM-1 > LINE) %REPEAT %IF FIND = 1 %THEN %PRINTTEXT 'line not found' NEWLINE PROMPTCH = ':'; ! IN CASE OF UNFINISHED STRINGS !!! COMP MODE = 0 %IF FIND = 3 %START SELECTOUTPUT(0) CLOSESTREAM(79) CLEAR('ST79') %FINISH -> END ! SPS(17): ! $UP ! FIND = '-'; -> UD ! SPS(18): ! $DOWN ! FIND = '+' UD: -> END %IF MON LOCK = 0 N = 1 RP = RP+1 %IF REC(RP) = 1 %START RP = RP+1; ! OVER TYPE GET4(N); N = N&15 %FINISH %WHILE N > 0 %CYCLE SET UP MONITOR(FIND) N = N-1 %REPEAT -> END ! SPS(22): ! $WHERE SPS(16): ! $MONITOR ! GLA WORD = INTEGER(MONITOR GLA+20) INTEGER(MONITOR GLA+20) = INTEGER(ADDR(MONITOR BLOCK)) PDIAG(MON FRAME-4,0,0) %IF MON LOCK # 0 INTEGER(MONITOR GLA+20) = GLA WORD -> END ! SPS(19): ! $RESUME ! %PRINTTEXT 'nothing to resume ' %AND -> END %C %IF MON LOCK = 0 RP = RP+1 %IF REC(RP) = 1 %START RP = RP+1; GET4(N) N = 1 %AND UNTRAP %IF N <= 0 MON REP = N-1 %FINISH MON LOCK = 0 DIAG HEAD == DIAG BASE CODE TOP = OLD CODE TOP SAVE; ! RELEASE CALLING CODE J = MON ENTRY RUNNING = 'Y' *L_1,J *LM_4,15,16(1) *BCR_15,15 ! SPS(20): ! $TRAP (NUMBER)(BDEF') ! MON REP = 0 RP = RP+1; ! SKIP TYPE GET4(J) N = 0 RP = RP+1 %IF REC(RP) = 1 %START RP = RP+1; ! SKIP TYPE GET4(N) %FINISH ITRAP(N,J) -> END ! SPS(21): ! $IGNORE ! MON REP = 0 UNTRAP -> END ! SPS(15): ! $CANCEL ! FAULTY = 1 SIGNAL(2,244,0,J); ! FIRE OFF SIGNAL WT 244 -> END ! SPS(14): ! MLEVEL (LEV) ! RP = RP+1 %IF REC(RP) = 1 %THEN MLEVEL = X'FFFF' %C %ELSE MLEVEL = REC(RP+3) -> END ! SPS(13): ! DELETE (NAME) ! %IF LEVEL # 1 %START NO: %PRINTTEXT 'no ! ' -> END %FINISH N = REC(RP+1); ! NAME NAME == INTEGER(N+DICTHEAD+4) FAULT2(16,N) %AND -> END %IF NAME = 0 VAR == RECORD(NAME) %IF VAR_LEVEL = 0 %THEN -> NO %IF VAR_TYPE = 31 %START; ! RECORDFORMAT SO REMOVE RECORDS J = VAR_INDEX!X'80000000'; ! FORMAT LIST %CYCLE N = DICTHEAD,8,DICTHEAD+4088 P == INTEGER(N+4) %IF P # 0 %START VAR == RECORD(P) TIDY(P) %IF VAR_INDEX = J %FINISH %REPEAT %FINISH %ELSE %START %IF VAR_FORM&B'1000' # 0 %START; ! ROUTINE %IF VAR_FLAGS>>4&3 # 2 %AND VAR_FLAGS&2 = 0 %START ! DELETE ORDINARY ROUTINE EDIT(1); -> END %FINISH J = VAR_ADDRESS&X'FFF'+GLAHEAD RELEASE RT(VAR_DIMENSION) *L_15,J; *MVC_0(12,15),APERM %FINISH %ELSE %START J = DIAGPT %WHILE SHORTINTEGER(J) # 0 %CYCLE BYTEINTEGER(J+4) = '?' %AND %EXIT %C %IF SHORTINTEGER(J+2) = N ! DISABLE DIAG TABLE ENTRY J = J+6; ! TRY NEXT ENTRY %REPEAT %FINISH %FINISH TIDY(NAME) -> END ! SPS(9): ! INPUT (FILE NAME) ! SELECTINPUT(0) SET FILE(1,'78') SELECTINPUT(78) -> END ! SPS(10): ! OUTPUT (FILE NAME) ! -> END %IF STUDENT # 0 SELECTOUTPUT(0) SET FILE(1,'79') SELECTOUTPUT(79) SYSOUT = 79 -> END ! SPS(11): ! SYNTAX ! SYNTAX = 'Y'; -> END ! SPS(12): ! NOSYNTAX ! SYNTAX = 'N'; -> END ! SPS(26): ! SYSOUT ! -> END %IF STUDENT # 0 RIM(0,'sysout:'); READ(SYSOUT); SKIPSYMBOL SELECTOUTPUT(SYSOUT) -> END ! SPS(4): ! INFO NAME ! RP = RP+1; N = REC(RP)+DICT HEAD; NAME INFO(N) -> END ! SPS(6): ! NAMES ! %CYCLE J = DICT HEAD,8,DICTHEAD+4088 NAME INFO(J) %UNLESS INTEGER(J) = 0 %REPEAT -> END ! SPS(25): ! FORCE ! ->END %IF STUDENT # 0 -> END %IF SIGAREA = 0; ! NO INTERRUPTS HANDLED RUNNING = 'Y'; ! TO ALLOW INT:Q WT = BYTEINTEGER(SIGAREA+3); ! SIGNAL WT N = INTEGER(SIGAREA+4); ! ADDRESS OF ERROR %PRINTTEXT ' $ SIGNAL WT'; WRITE(WT,1) %PRINTTEXT ' at '; HEX(N) DUMP SIGNAL(N) RUNNING = 'N' -> END ! SPS(27): ! CLEAR ! *L_1,AREG; *XC_0(5,1),0(1); ! CLEAR REGUSE -> END ! SPS(7): ! DUMP ! INT DUMP STOP ! SPS(8): ! MAP ! N = 0 %CYCLE J = 0,1,127 N = N+1 %IF RENTRY(J) # 255 %REPEAT %PRINTTEXT 'asl '; HEX(ASL) WRITE(ASL LENGTH,7); NEWLINE %PRINTTEXT 'routines ' HEX(GLAHEAD+RTBASE&X'FFF'); WRITE(N,7); NEWLINE %PRINTTEXT 'code top '; HEX(CODETOP); NEWLINE %PRINTTEXT 'astack '; HEX(ASTACK); NEWLINE %PRINTTEXT 'text head '; HEX(TEXT HEAD); NEWLINE %PRINTTEXT 'perm '; HEX(APERM); NEWLINE %PRINTTEXT 'gla ' HEX(GLAHEAD); WRITE(4096-GLA+GLAHEAD,7); NEWLINE -> END ! SPS(5): ! CODE ! IIDUMP(GLAHEAD,GLAHEAD+320) END: %END %ROUTINE UN CLAIM %SHORTROUTINE %INTEGER J %CYCLE J = 4,1,8 REG USE(J) = 0 %UNLESS REG USE(J) = 'L' %REPEAT SUSPEND = 'Y' %END %ROUTINE ABORT ! SOMETHING VERY NASTY HAS HAPPENED, SO TRY TO COLLAPSE ! IN A GRACEFULL MANNER RESET IO %PRINTTEXT ' ************ ABORT ************ ABORT ************ ABORT ************ ' SELECTOUTPUT(0); CLEAR('ST79') IOFILE = 'II#ABORT' DEFINE('ST79,II#ABORT') SPECIAL(0); ! SAVE ROUTINES IF POSSIBLE DECODE(CODESTART,CODEIN,R10) PRINT USE SPECIAL(7) %END ! THE NEXT THREE ROUTINES ARE ONLY USED FOR DEBUGGING ! OBSCURE COMPILER FAULTS AND CAN BE REMOVED IF NESC. ! !****************************************************** %ROUTINE PRINT USE %SHORTROUTINE %INTEGER N; %BYTEINTEGER P %CYCLE N = 4,1,8 P = REG USE(N) %IF P # 0 %START WRITE(N,1); SPACES(3) %IF P = 'C' %THEN %PRINTTEXT 'claimed' %ELSE %START %IF P = 'L' %THEN %PRINTTEXT 'locked' %C %ELSE %START %IF P = 'S' %C %THEN %PRINTTEXT 'string wk' %C %ELSE %PRINTTEXT 'unknown' %FINISH %FINISH NEWLINE %FINISH %REPEAT %END %ROUTINE NAME INFO(%INTEGER NAME) %SHORTROUTINE %INTEGER P, S P = INTEGER(NAME+4) %RECORDNAME V(VARFM) %STRINGNAME SN V == RECORD(P) %RETURN %IF P = 0 %OR V_LEVEL = 0 SN == STRING(INTEGER(NAME)) S = LENGTH(SN) S = 12 %IF S > 12 PRINTSTRING(SN) SPACES(12-S) %CYCLE PRINT RECORD(V); NEWLINE P = INTEGER(P+12); %EXIT %IF P = 0 V == RECORD(P); SPACES(12) %REPEAT %END %ROUTINE PRINT RECORD(%RECORDNAME N) %SHORTROUTINE %RECORDSPEC N(VARFM) WRITE(N_TYPE,3) %AND SPACE %IF SHORT FORM # 0 %IF N_TYPE = B'100' %THEN %PRINTTEXT 'INTEGER' %C %ELSE %START %IF N_TYPE = B'101' %THEN %PRINTTEXT 'BYTE ' %C %ELSE %START %IF N_TYPE = B'110' %C %THEN %PRINTTEXT 'SHORT ' %ELSE %START %IF N_TYPE = B'1000' %C %THEN %PRINTTEXT 'REAL ' %ELSE %START %IF N_TYPE = B'1010' %C %THEN %PRINTTEXT 'LONG ' %ELSE %START %IF N_TYPE = B'10000' %C %THEN %PRINTTEXT 'STRING ' %ELSE %START %IF N_TYPE = B'111' %C %THEN %PRINTTEXT 'RECORD ' %C %ELSE %START %IF N_TYPE = 31 %C %THEN %PRINTTEXT 'FORMAT ' %C %ELSE %START %IF N_TYPE = 64 %C %THEN %PRINTTEXT 'SWITCH ' %C %ELSE %START %IF N_LEVEL = 0 %C %THEN %PRINTTEXT %C 'PRE-DEC' %C %ELSE %PRINTTEXT 'UNKNOWN' %FINISH %FINISH %FINISH %FINISH %FINISH %FINISH %FINISH %FINISH %FINISH WRITE(N_FORM,3) %AND SPACE %IF SHORT FORM # 0 %IF N_FORM&B'100' # 0 %THEN %PRINTTEXT 'ARRAY' %C %ELSE %START %IF N_FORM&B'1000' # 0 %THEN %PRINTTEXT ' RFM' %C %ELSE %PRINTTEXT ' ' %FINISH %IF N_FORM&B'10000' # 0 %C %OR (N_FORM&2 # 0 = N_FORM&B'1100') %C %THEN %PRINTTEXT 'NAME' %ELSE %PRINTTEXT ' ' %IF SHORT FORM # 0 %START WRITE(N_ADDRESS&X'FFF',4) %PRINTTEXT '(' WRITE(N_ADDRESS>>12&15,2) %PRINTTEXT ')' %PRINTTEXT ' D=' WRITE(N_DIMENSION,2) %PRINTTEXT ' L=' WRITE(N_LENGTH,2) %PRINTTEXT ' X=' HEX(N_INDEX) %PRINTTEXT ' TL=' WRITE(N_LEVEL,1) %PRINTTEXT ' F=' WRITE(N_FLAGS,1) %FINISH %END !****************************************************** ! %ROUTINE I8DIAG(%INTEGER EP) %SHORTROUTINE ! THIS ROUTINE CALLS S#I8DIAG FOR A MONITOR FOLLOWING A SIGNAL. ! THE CONTEXT OF THE ERROR MUST BE RESET ! TO ALLOW THE STACK TO BE UNWOUND BY THE MONITOR ! THE RETURN ADDRESS IS CORRUPTED TO BRING THE MONITOR BACK ! TO 'INT RETURN' TO RESET THE SIGNAL. %OWNINTEGER R12, R13, R14 %INTEGER FLAG RUNNING = 'N' %IF R12 = 0 %START; ! FIRST CALL TO LOAD S#I8DIAG FDP(LOAD FDP,'S#I8DIAG',FDP REF,ADDR(R12),FLAG) %IF FLAG # 0 %START %PRINTTEXT '*** cannot load I8DIAGS' WRITE(FLAG,1); %PRINTTEXT ' *** ' R12 = 0 %FINISH %RETURN %FINISH *L_1,SIGAREA; ! OLD REG SAVE AREA *L_11,52(1); ! OLD REG 11 *MVC_16(44,11),24(1); ! SET SAVE AREA TO ERROR REGS *MVC_64(4,11),EP; ! PLUG IN PARAMETER *L_1,STACKTOP; ! SAVE AREA IF RETURNS FROM PDIAG *L_15,MON LABEL; ! TO RESET SIGNAL *ST_15,60(8); ! CHANGE RETURN ADDRESS *MVC_16(48,1),16(8); ! DUPLICATE THEM ON CODE'S STACK *ST_8,16(11); ! REG4 TO RETURN OLD REG 8 *LM_12,14,R12; ! ENTRY INFO FOR S#I8DIAG *BALR_15,14; ! CALL IT *LR_8,4; ! RESTORE BASE REGISTER %END %ROUTINE C SWITCH %SHORTROUTINE %INTEGER J, K, L, M, N, MARK, RSAVE, LOWER, UPPER FAULT(32) %AND -> 1 %IF LEVEL = 1 EXTRINSIC = 0 N = FORWARD REF(15); ! JUMP ROUND SWITCH TABLE NEWNAME = 0 NEWNAME_TYPE = B'1000000' NEWNAME_LEVEL = LEVEL SW1: NEWNAME_ADDRESS = CODEIN-R10 RP = RP+1; MARK = REC(RP);! NUMBER OF NAMES RSAVE = RP; RP = MARK+RP; ! TO CBPAIR CBPAIR(LOWER,UPPER) J = RP; RP = RSAVE; M = (UPPER-LOWER+1)<<1 L = M+4; ! LENGTH OF HEADER+VECTOR DIAG FLAG = 0; C NAME LIST(MARK,L) %CYCLE K = 1,1,MARK SHORTINTEGER(CODEIN) <- LOWER SHORTINTEGER(CODEIN+2) <- UPPER L = CODEIN+4 CODEIN = L+M %CYCLE L = L,2,CODEIN SHORTINTEGER(L) = 0 %REPEAT %REPEAT RP = J+1 -> SW1 %IF REC(RP) = 1; ! REST OF SW LIST REMOVE LABEL(N) 1: %END %ROUTINE SW REF %SHORTROUTINE %INTEGER N, M, J %RECORD V(VARFM) %BYTEINTEGER B N = REC(RP+1); ! NAME RP = RP+2 %IF REC(RP) = 1 %START; ! PARMS B <- REC(RP+1); ! PLUS' RP = RP+2; ! SKIP TYPE GET4(M); ! INTEGER %IF B = 2 %THEN M = -M %ELSE %START %IF B = 3 %THEN M = \M %FINISH FAULT2(4,N) %AND -> 1 %IF INTEGER(N+DICTHEAD+4) = 0 GETINFO(N,V) %IF V_TYPE # B'1000000' %THEN FAULT2(3,N) %ELSE %START J = V_ADDRESS+R10; ! ADDR OF VECTOR %UNLESS SHORTINTEGER(J) <= M <= SHORTINTEGER(J+2 %C ) %THEN FAULT2(5,N) %ELSE %START J = (M-SHORTINTEGER(J))<<1+J %IF SHORTINTEGER(J+4) = 0 %C %THEN SHORTINTEGER(J+4) <- CODEIN-R10 %C %ELSE FAULT2(6,N) %FINISH %FINISH %FINISH %ELSE %START %IF LEVEL = 1 %THEN FAULT(32) %ELSE LABEL FOUND(N) %FINISH 1: %END %ROUTINE CREATE DUMMY REFS(%INTEGER LIST) %SHORTROUTINE %INTEGER K COMREG(7) = 0; ! DESTROY LIST %UNTIL LIST = 0 %CYCLE K = INTEGER(LIST+4) INTEGER(K) = K INTEGER(K+4) = D LOAD ENV INTEGER(K+8) = MISSING EP LIST = INTEGER(LIST) %REPEAT %END %ROUTINE INT DUMP %EXTERNALSTRING (8) DUMP FILE = '.LP' %DYNAMICROUTINESPEC SETMARGINS(%INTEGER J, K, L) %DYNAMICROUTINESPEC LPDUMP(%INTEGER J, K) %INTEGER J, K %STRING (40) FILE %SHORTROUTINE DEFINE('ST79,'.DUMP FILE) FILE = ' '.DATE.' '.TIME PRINTSTRING('*** DUMP STARTED'.FILE.' *** ') SELECTOUTPUT(79); SET MARGINS(79,1,132) SHORT FORM = 15 NEWPAGE %PRINTTEXT ' IMP INTERPRETER VERSION 8A *** DUMP ***' PRINTSTRING(FILE) NEWLINES(3) %PRINTTEXT 'GLA === ' LPDUMP(GLA HEAD,GLA+16) NEWPAGE %PRINTTEXT 'CODE ==== ' LPDUMP(CODE,CODEIN+300) NEWPAGE %PRINTTEXT 'STATIC STACK ============ ' LPDUMP(STACK,ASPACE+60) NEWPAGE %PRINTTEXT 'NAMES ===== ' %CYCLE J = DICT HEAD,8,DICTHEAD+4088 %IF INTEGER(J) # 0 %START HEX(J-DICTHEAD); SPACES(4) FILE <- STRING(INTEGER(J)); PRINTSTRING(FILE) SPACES(44-LENGTH(FILE)); HEX(INTEGER(J+4)) NEWLINE %FINISH %REPEAT NEWLINES(5); SPECIAL(6) NEWPAGE %PRINTTEXT 'LISTS ===== ' J = 1 J = J+1 %WHILE ADDR(LISTS(J))&15 # 0 %CYCLE K = J,4,LIST SIZE-4+J J = K %AND %EXIT %IF LISTS(K+7) # ADDR(LISTS(K)) %REPEAT LPDUMP(ADDR(LISTS(J)),ADDR(LISTS(LIST SIZE))) NEWPAGE %PRINTTEXT 'ENTRY LIST ========== ' %CYCLE J = 0,1,127; NEWLINE %IF J&7 = 0 WRITE(J,5) K = R ENTRY(J) %IF K = 255 %THEN %PRINTTEXT ' -*-' %ELSE WRITE(K,3) %REPEAT NEWLINES(5); SPECIAL(8) NEWPAGE %PRINTTEXT ' LOCALS ====== ' *ST_9,J; LPDUMP(J,J+2280) NEWPAGE SPECIAL(25); ! DUMP LAST SIGNAL *ST_11,J %IF SIGAREA # 0 %START K = INTEGER(SIGAREA+52);! FAILING R11 J = K %IF J > K %PRINTTEXT ' DYNAMIC STACK ============= ' LPDUMP(J,K) %FINISH NEWPAGE %PRINTTEXT ' INTERPRETER GLA =============== ' *ST_13,J LPDUMP(J,J+4095) %END %INTEGERFN MCODE(%INTEGER S) %SHORTROUTINE %CONSTSHORTINTEGERARRAY EP(0 : 14) = 0, 18, 64, 66, 69, 71, 83, 85, 92, 94, 106, 108, 116, 118, 120 %INTEGER P, L L = 0 %CYCLE P = 1,1,4 %EXIT %UNLESS 'A' <= LINE(SYM) <= 'Z' L = L<<8!LINE(SYM) SYM = SYM+1 %REPEAT %RESULT = 0 %IF L = 0 %OR LINE(SYM) # '_' SYM = SYM+1 %IF S = 0 %START; ! RR %IF BYTEINTEGER(ADDR(L)+3) = 'R' %START L = L>>8 %CYCLE P = 2,1,48 -> RR %IF L = NEM(P) %REPEAT %RESULT = 0 %FINISH %CYCLE P = 0,1,2 -> RR %IF L = NEM(P) %REPEAT %RESULT = 0 RR: REC(RP) = OPC(P)&63 RP = RP+1 %RESULT = 1 %FINISH %CYCLE P = EP(S),1,EP(S+1) %IF L = NEM(P) %START REC(RP) = OPC(P) RP = RP+1 %RESULT = 1 %FINISH %REPEAT %RESULT = 0 %END %ROUTINE CNOP(%INTEGER A, B) FAULT(33) %AND %RETURN %C %IF B&1 # 0 %OR (A&B = 0 %AND A # 0) B = B-1 SPLANT(X'0700') %WHILE CODEIN&B # A %END %ROUTINE CUCI %SHORTROUTINE %INTEGER J, K, N %INTEGERNAME LAB REF %INTEGER CODE, OPCODE %RECORD V(VARFM) %SWITCH MC(1 : 12) %INTEGER REG, INDEX, LENGTH, BASE, DISP %INTEGERFNSPEC GET(%INTEGER LIMIT) %ROUTINESPEC DXB %ROUTINESPEC DLB %ROUTINESPEC DB %ROUTINESPEC CUCS LAB REF == N; ! DUMMY VALUE RP = RP+1; CODE = REC(RP) RP = RP+1; OPCODE = REC(RP) ! -> MC(CODE) ! MC(1): ! [INTEGER]','[INTEGER] ! %IF OPCODE = 0 %THEN CNOP(GET(4096),GET(4096)) %C %ELSE DRR(OPCODE,GET(15),GET(15)) %RETURN ! MC(2): ! [INTEGER]','(DXB) MC(3): ! [INTEGER]','[INTEGER]','(DB) MC(5): ! [INTEGER]','(DB) ! REG = GET(15) %IF CODE = 2 %THEN DXB %ELSE %START %IF CODE = 5 %THEN INDEX = 0 %ELSE INDEX = GET(15) DB %FINISH DRX(OPCODE,REG,INDEX,BASE<<12!DISP) LR: LABREF = CODEIN-8; ! UPDATE LABEL LIST REFERENCE %RETURN ! MC(4): ! (DB)(VAL') ! DB RP = RP+1; %IF REC(RP) = 2 %THEN N = 0 %ELSE N = GET(255) DSI(OPCODE,BASE<<12!DISP,N) -> LR ! MC(6): ! (DLB)','(DB) MC(7): ! (DLB)','(DLB) ! DLB J = BASE<<12!DISP K = LENGTH; K = 1 %IF K = 0 LAB REF = CODEIN+2 %IF CODE = 6 %THEN DB %ELSE %START DLB; LENGTH = 1 %IF LENGTH = 0 K = (K-1)<<4!LENGTH %FINISH DSS(OPCODE,K,J,BASE<<12!DISP) -> LR ! MC(8): ! [INTEGER] ! %IF OPCODE = X'80' %THEN DSI(OPCODE,GET(255),0) %C %ELSE %START %IF OPCODE = 10 %THEN SPLANT(X'0A00'!GET(255)) %C %ELSE DRR(OPCODE,GET(15),0) %FINISH %RETURN ! ! MC(9):!*PUT_ ! SPLANT(REC(RP+2)); ! BOTTOM SHORT ONLY %RETURN ! MC(10):!**,(@')(VAR) ! RP = RP-1; ! BACK FROM 'OPCODE' REG = GET(15) RP = RP+1; J = REC(RP); ! ADDR OR NOT VAR(V) %IF J = 1 %THEN %START V_TYPE = 4 %AND V_FORM = V_FORM!2 %C %IF V_TYPE = 16 %AND V_FLAGS&4 # 0 V_TYPE = 4 %IF V_TYPE = 7; ! RECORDS LOAD ADDR(V,REG) %FINISH %ELSE %START %IF V_TYPE&B'1000' # 0 %START; ! REAL FAULT(44) %UNLESS REG&1 = 0 %AND REG <= 6 REG = REG>>1 %FINISH LOAD(V,REG) %FINISH RELEASE REGISTER(REG) %RETURN %INTEGERFN GET(%INTEGER LIMIT) %INTEGER N RP = RP+1; ! SKIP TYPE GET4(N) FAULT(33) %UNLESS 0 <= N <= LIMIT %RESULT = N %END %ROUTINE DXB %INTEGER NUM INDEX = 0 RP = RP+1 %IF REC(RP) = 1 %START CUCS RP = RP+1; %IF REC(RP) = 1 %THEN INDEX = GET(15) %FINISH %ELSE %START DISP = GET(4095); BASE = 0 RP = RP+1; NUM = REC(RP) %IF NUM = 1 %THEN INDEX = GET(15) %IF NUM <= 2 %THEN BASE = GET(15) %FINISH FAULT(99) %IF DISP > 4095 %END %ROUTINE DLB RP = RP+1 %IF REC(RP) = 1 %START DISP = GET(4095) LENGTH = GET(255) BASE = GET(15) %FINISH %ELSE %START CUCS; LENGTH = GET(255) %FINISH FAULT(99) %IF DISP > 4095 %END %ROUTINE DB RP = RP+1 %IF REC(RP) = 1 %THEN CUCS %ELSE %START DISP = GET(4095) RP = RP+1 %IF REC(RP) = 2 %THEN BASE = 0 %ELSE BASE = GET(15) %FINISH FAULT(99) %IF BASE > 4095 %END %ROUTINE CUCS %RECORD V(VARFM) %INTEGER X, ALT, LABEL RP = RP+1; ALT = REC(RP) %IF ALT = 2 %START; ! LABEL ???? BASE = 10; DISP = 0 RP = RP+1; LABEL = REC(RP) %IF LABEL = 1 %START RP = RP+1; GET4(LABEL) FAULT(44) %AND %RETURN %IF LABEL>>16 # 0 LABEL = \LABEL %FINISH %ELSE %START RP = RP+1; LABEL = REC(RP) RP = RP+1 FAULT2(33,LABEL) %AND SKIPEXPRN %IF REC(RP) # 2 %FINISH JUMP TO(LABEL,0) CODEIN = CODEIN-8 DISP = SHORTINTEGER(CODEIN+6) %IF SHORTINTEGER(CODEIN) # X'41DD' %C %THEN CODEIN = CODEIN+4 %C %ELSE LAB REF == INTEGER(LAST ASL) FAULT(99) %IF DISP>>12&15 # 0 %FINISH %ELSE %START RP = RP+1; VNAME = REC(RP) GET INFO(VNAME,V) FAULT2(33,VNAME) %C %IF 64 # V_TYPE >= 31 %OR V_FORM&8 # 0 DISP = V_ADDRESS BASE = DISP>>12&15 DISP = DISP&X'0FFF' RP = RP+1; ALT = REC(RP) %IF ALT # 3 %START X = GET(4095) %IF ALT = 1 %THEN DISP = DISP+X %C %ELSE DISP = DISP-X %FINISH %FINISH %END %END %ENDOFPROGRAM