%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 *
!* *
!* *
!***********************************************************************
!
!
!
!****************************************************************
!* *
!* 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'60000000' 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 *
!* *
!*********************************************
!
!
!
!
!******************************************************
!* *
!* 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'
!
! 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
!
!######################## START OF MAIN PROGRAM ########################
!
%BEGIN
%RECORDFORMAT DIAGFM(%INTEGER DICT, REG9, %INTEGERNAME DIAG)
%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
%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 SIGNAL(%INTEGER EP, PARM, X, %INTEGERNAME FLAG)
!
!*** LOCAL SPECS ***
!
%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)
%INTEGERFNSPEC ASL LENGTH
%ROUTINESPEC SET FILE(%BYTEINTEGER FLAG, %STRING (10) STREAM)
%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, EXTRA)
%ROUTINESPEC C SWITCH
%ROUTINESPEC SW REF
%ROUTINESPEC INT DUMP
%INTEGERFNSPEC MCODE(%INTEGER J)
%ROUTINESPEC CNOP(%INTEGER A, B)
%ROUTINESPEC CUCI
!
! ANALYSIS RECORD ARRAY
!
%SHORTINTEGERARRAY REC(0 : 300)
%INTEGERARRAY LISTS(1 : LIST SIZE), DICT(0 : 2048), DIAG TAB(-2048 : 0)
%BYTEINTEGERARRAY LINE(0 : 301), REGUSE(4 : 8)
%BYTEINTEGERARRAY RENTRY(0 : 127)
%INTEGER RTP, BLOCK NAME, BLOCK ENTRY
!
!
!
! INTERRUPT HANDLING BUFFERS
!
%OWNINTEGER MONITOR CONTEXT
%OWNINTEGERARRAY MON RECOVERY(0:15)
%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
%INTEGERNAME COMREG36
%OWNBYTEINTEGER INTQ INFO, INTQ SYM
!
! 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
!
%RECORD DIAG INFO(DIAGFM)
%INTEGER DIAGPT,DIAGEND,DIAGSAVE,MONLABEL,PERMERROR,DIAGFLAG,DIAGBASE
!
! 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
!
!
!
%INTEGER CYC NUM, LINE NUM, RTNAME
!
!
!
%BYTEINTEGER LIST,SYNTAX,FAULTY,REALS,SUSPEND,RUNNING,PRINTED,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 ,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
%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
%EXTERNALBYTEINTEGER COMP MODE = 0, IOFLAG = 0
%EXTRINSICBYTEINTEGER MONLOCK
!
!
*ST_11,INITIAL STACK
!
!
RELOAD:!************ RETURN HERE TO RESTART THE PROCESS ************
!
!
*L_11,INITIAL STACK
L = (INTSIZE+24)<<12; K = L-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,<SVCX>
*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
!
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')
!
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)
**1, @DIAG INFO
*ST_1, 4(2)
*MVI_4(2), X'60'
*LA_15, <RECOVER>
*L_2, MON RECOVERY
*STM_0, 15, 0(2)
*ST_2, MONITOR CONTEXT
LOAD PERM
!
! 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
!
!
RTFAULTY = 25<<2+APERM
PERM ERROR = APERM+31<<2
!
!
!
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 BASE = ADDR(DIAG TAB(0))
DIAG SAVE = DIAG BASE; DIAG END = DIAG SAVE
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,<DZER>
!
! 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
DIAG INFO_DICT = DICT HEAD
DIAG INFO_DIAG == DIAGPT
DIAG INFO_REG9 = REG9
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 LOADING 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
!
COMREG36 == COMREG(36)
COM36 = COMREG36; COMREG36 = STACKTOP!X'80000000'
%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
RESTART = 1; ! SHOW RUNNING ONCE
%PRINTTEXT '
IMP Interpreter'
%IF STUDENT = 0 %THEN %PRINTTEXT ' Version 8e' %C
%ELSE %PRINTTEXT ' Student Version 8e'
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
!
! SET TRAP FOR DOUBLE CONTINGENCY
!
DCONT: *L_1,DCONTAREA; ! J = ADDR(DCONTAREA(0))
*ST_1,J
*LA_15,<DCTRAP>; ! 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
RECOVER: COMREG36 = STACKTOP!X'80000000'
-> SET ERROR
!
! TOP LEVEL SIGNALS COME HERE
!
ERROR:
*ST_1,SIGAREA; ! SAVE THE ADDRESS OF FAILURE SAVE AREA
*STC_2,WT; ! SAVE THE WEIGHT
*SRL_3,16
*STH_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 = 'Y' %THEN P STRING = STRING(COMREG(50)) %C
%ELSESTART
%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
%PRINTTEXT '
' %AND -> SETERROR %IF WT=128 %AND (INTQ SYM='H' %OR INTQ SYM='H'+32)
I8DIAG(35, WT)
%FINISH
%IF WT = 140 %START; ! INPUT FILE ENDED
I8DIAG(9, 0) %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(35,WT) %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 '
'
!
! GIVE A DUMP OF THE CONTEXT OF THE ERROR
!
DUMP SIGNAL(FAIL INFO) %IF DUMP # 0; -> SET ERROR
!
!
!
!
%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 EXTERNAL(%STRING(15) NAME,%INTEGER T,A, %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC LOAD(%STRING(15) S, %INTEGER T, A, %C
%INTEGERNAME L, U, FLAG)
%INTEGER L, U
LOAD(NAME, T, A, L, U, FLAG)
%END
%ROUTINE LOAD PERM
%SHORTROUTINE
%INTEGER F, R12, R13, R14
LOAD EXTERNAL('S#I8PERM', 'E', 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 ::
! <NAME NUMBER>, <LENGTH>,<SYM1>,<SYM2>,.....,<SYM?>
! 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 ( <ENTRY POINT>,<@ 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
LOAD EXTERNAL(EXNAME, 'D', GLA, FLAG)
! LOOK UP NAME
%IF FLAG # 0 %START
PRINTSTRING('* cannot load '.EX NAME.'
')
-> E1
%FINISH
BYTEINTEGER(GLA) <- FMLEN; ! STRINGS ??
%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
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)
LOAD EXTERNAL(XNAME, 'E', XPT, XFLAG)
%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,<M2>
*MVC_0(256,3),0(2)
*LA_2,256(2); *LA_3,256(3)
*S_1,CC
*BC_15,<M1>
M2: *LTR_1,1; *BC_8,<M3>
*BCTR_1,0
*EX_1,<M4>
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
%AND RESTORE ENTRIES %C
%IF COMP MODE&16 # 0
E START = TEXT HEAD
TEXT P = A SPACE
! *** MOVED UP ??? 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+2
DIAG END = SHORTINTEGER(DIAG END)+DIAG BASE
! 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,<OK>; 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-2; SHORTINTEGER(DIAGPT) = DIAGEND-DIAGBASE
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)
%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 = 2;! **TESTING** WAS 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'411D0018') %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,<SET>
**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 : 55) = %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,0
%ROUTINESPEC CIOCP(%INTEGER R)
%SWITCH CN(0 : 56)
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
CN(56):! SPECIAL FOR READSTRING
-> 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)
-> SF19 %IF REC(RP) # 2
->F19
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 = 56; 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)
RFLAG = 4 %AND -> 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,<NNS>; ! 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 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')
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 <STRINGS>, 23 <ROUTINES>, 64 <RECORDS>
%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): ! <N>
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
INTEGER(STACKTOP+16) = COMREG(50);! TEMP @ CURPROMPT
INTEGER(STACKTOP+20) = ADDR(P STRING)
!
RESUME COMPILATION: ! ENTRY FROM IGNORED INTQ
!
*L_1,SAVEAREA; *LA_15, <ERROR>
*ST_1,J
*STM_4,15,16(1)
*MVI_60(1),8; ! ???????????????
SIGNAL(0,J+16,0,K)
INTQ FLAG = 0 %AND SIGNAL(5,SIGAREA,0,K) %IF INTQ FLAG = 1
!
*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,<TA>
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,<TA>
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,<TA>
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,<TA>
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,<TA>
%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,<TA>
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; DEC2 = TEXTIN
%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,<OK>
*SLR_1,1
OK: *CVD_1,WORK
*OI_WORK+7,1
*MVC_WORK2(5),PAT1
*ED_WORK2+1(4),WORK+6
*BC_7,<NZ>
*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
LOAD EXTERNAL(EXNAME, 'D', ADDR(A), FLAG)
%IF FLAG # 0 %START
PRINTSTRING('* cannot load '.EXNAME.'
')
%RETURN
%FINISH
%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, USED
! 'LHS' SET ON 'A' : RP ON 'ASSOP' : ASSOP=4
BASE = 1
%IF LABEL = RESFLOP %THEN BASE = 0
F = 0; USED = 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)
!
-> 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 USED = 1 %AND 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 USED = 1 %AND JUMP TO(TLAB,7)
-> 10
%FINISH
F = 1
RP = RP+1
-> R1
FLT74: RP = P
SKIPEXPRN
FAULT(74)
10: REGUSE(4) = 0
JUMP TO(LABEL, 15) %UNLESS MASK = 7
REMOVE LABEL(TLAB) %IF USED # 0 %AND TLAB # LABEL
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,<NZ>
*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 IT BY 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,<STR>
*BC_15,<BYTE>
*BC_15,<SHORT>
*BC_15,<INT>
*BC_15,<REAL>
!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,<ICOMP>; ! GET VALUE
*ST_2,0(1)
-> 6
SHORT: *BAL_15,<ICOMP>
*STH_2,0(1)
*XC_WORK(1),WORK+1
*MVC_CTYPE(1),WORK
*XI_CTYPE,255
-> 6
BYTE: *BAL_15,<ICOMP>
*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,<NSYM>
*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>; ! 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
%INTEGERFN ASL LENGTH
*SR_2,2
*L_1,ASL
*LA_3,<LOOP>
*BC_15,<IN>
LOOP: *L_1,12(1)
IN: *LTR_1,1
*BC_8,<OUT>
*BCTR_2,3
OUT: *LCR_1,2
*LM_4,14,16(8)
*BCR_15,15
%END
%ROUTINE SET FILE(%BYTEINTEGER FLAG, %STRING (10) 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 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(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(29):
SPS(17):
SPS(18):
SPS(22):
SPS(14):
SPS(16):
SPS(19):
SPS(20):
SPS(21):
PRINTSTRING('*** THIS FEATURE HAS BEED REMOVED ***
')
->END
SPS(15): ! $CANCEL
!
FAULTY = 1
SIGNAL(2,244,0,J); ! FIRE OFF SIGNAL WT 244
-> 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 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 ' '
%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, EXTRA)
%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.
%SYSTEMROUTINESPEC MDIAG(%INTEGER ADDR, ERNUM, EXTRA)
RUNNING = 'N'
COMREG36 = MONITOR CONTEXT!X'80000000'
! ***NOTE** SIGAREA -> (INFO), (PC), (R0), ....
*L_1, SIGAREA; *L_11,52(1);! USE USER'S STACK
MDIAG(SIGAREA+4, EP, EXTRA)
*L_1,COMREG36
*L_8,0(1)
%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 INT DUMP
%DYNAMICROUTINESPEC SETMARGINS(%INTEGER J, K, L)
%SYSTEMROUTINESPEC LPDUMP(%INTEGER J, K)
%INTEGER J, K
%STRING (40) FILE
%SHORTROUTINE
DEFINE('ST79,.LP')
PRINTSTRING('*** Dump started ***
')
SELECTOUTPUT(79); SET MARGINS(79,1,132)
SHORT FORM = 15
NEWPAGE
%PRINTTEXT ' IMP INTERPRETER VERSION 8d *** DUMP ***'
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_ <N>
!
SPLANT(REC(RP+2)); ! BOTTOM SHORT ONLY
%RETURN
!
MC(10):!**<N>,(@')(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