%externalroutinespec debug(%string(255)s) ! Computer Science IMP77 Compiler - Version 8 First pass ! 23rd March 1981 ! %control 0 %external %string (15) %fn %spec date %external %string (15) %fn %spec time %externalintegerfn pass1(%integer object tank) %externalroutinespec put(%integer n) %externalroutinespec putword(%integer n) %externalroutinespec putlong(%integer n) %externalroutinespec putblock(%integer len, %bytename b) %externalroutinespec select output tank(%integer n) %systemroutinespec exit %alias "exit" (%integer status) %externalstring(63)%spec error message %externalstring(72)%fnspec sysmess(%integer n) %externalstring(127)%fnspec infilename %externalstring(6) version = "V08.02" %externalintegerspec command %constinteger warnbit = 8_200 %constinteger listbit = 8_400 !configuration parameters %CONSTINTEGER max int = ((-1)>>1)//10 %CONSTINTEGER max dig = (-1)>>1-maxint*10 %CONSTINTEGER byte size = 8; !bits per byte %CONSTINTEGER max tag = 1200; !max no. of tags %CONSTINTEGER max dict = 9000; !max extent of dictionary %CONSTINTEGER name bits = 11 %CONSTINTEGER max names = 1<0 strings, <0 chars %owninteger end mark = 0; !%end flag %OWNINTEGER cont = ' ', csym = ' '; !listing continuation marker %OWNINTEGER decl = 0; !current declarator flags %OWNINTEGER dim = 0; !arrayname dimension %OWNINTEGER spec given = 0 %OWNINTEGER escape class = 0; !when and where to escape %OWNINTEGER protection=0, atom flags=0 %OWNINTEGER otype = 0; !current 'own' type %OWNINTEGER reals ln = 1; ! =4 for %REALSLONG %OWNINTEGER last1 = 0; !previous atom class %OWNINTEGER gen type = 0 %OWNINTEGER ptype = 0; !current phrase type %OWNINTEGER papp = 0; !current phrase parameters %OWNINTEGER pformat = 0; !current phrase format %OWNINTEGER force = 0; !force next ptype %OWNINTEGER g = 0, gg = 0, map gg = 0; !grammar entries %OWNINTEGER fdef = 0; !current format definition %OWNINTEGER this = -1; !current recordformat tag %OWNINTEGER nmin = 0; !analysis record atom pointer %OWNINTEGER nmax = 0; !analysis record phrase pointer %OWNINTEGER rbase = 0; !record format definition base %OWNINTEGER stbase = 0; !constant work area base %OWNINTEGER gmin = max grammar; !upper bound on grammar %OWNINTEGER dmax = 1 %OWNINTEGER tmin = max tag; !upper bound on tags %OWNINTEGER ss = 0; !source statement entry %STRING(63) include file %OWNINTEGER include list = 0 %OWNINTEGER include = 0; !=0 unused, #0 being used %OWNINTEGER perm = 1; !1 = compiling perm, 0 = program %OWNINTEGER progmode= 0; !-1 = file, 1 = begin/eop %OWNINTEGER sstype = 0; !-1:exec stat ! 0: declaration ! 1: block in ! 2: block out %OWNINTEGER spec mode = 0; !>=0: definition ! -1: proc spec ! -2: recordformat %OWNINTEGER ocount = -1; !own constants wanted %OWNINTEGER limit = 0; !lookup limit %OWNINTEGER copy = 0; !duplicate name flag %OWNINTEGER order = 0; !out of sequence flag %OWNINTEGER for warn = 0; !non-local flag %OWNINTEGER dubious = 0; !flag for dubious statements %OWNINTEGER dp = 1 %OWNINTEGER pos1 = 0, pos2 = 0; !error position %OWNINTEGER pos = 0; !input line index %OWNINTEGER dimension = 0; !current array dimension %OWNINTEGER local = 0; !search limit for locals %OWNINTEGER fm base = 0; !entry for format decls %OWNINTEGER search base = 0; !entry for record_names %OWNINTEGER format list = 0; !size of current format list %INTEGER recid %ownbyteintegername current char %OWNBYTEINTEGERARRAY char(0:133)=nl(134); !input line %INTEGERARRAY lit pool(0:lit max) %OWNINTEGER lit = 0; !current literal (integer) %OWNINTEGER lp = 0; !literals pointer %OWNINTEGER block x = 0; !block tag %OWNINTEGER list = 2; !<= to enable %OWNINTEGER control = 0 %OWNINTEGER diag = 0; !diagnose flags %SHORTINTEGERARRAY hash(0:max names) %RECORD(tagfm)%ARRAY tag(0:max tag) {GT:%SHORT}%INTEGERARRAY dict(1:max dict) !*** start of generated tables *** !! %include "tables.imp" !! %endoflist %conststring(8)%array text(0:255) = %c "Z","VDEC","OWNVDEC","EXTVSPEC","ADEC","OWNADEC", "EXTASPEC","PROC","PROCSPEC","FORMDEC","SWDEC","LDEC", "FORMSPEC","","","","","", "OPTION","COMMA","T","COLON","COMMENT","LB", "ALIAS","RB","SUB","ARRAYD","STYPE","ARRAY", "NAME","PROCD","FNMAP","SWITCH","OWN","EXTERNAL", "STRING","RECORD","FORMAT","SPEC","MCODE","LABEL", "OP1","OP2","OP3","SIGN","UOP","MOD", "DOT","COMP","ACOMP","EQ","EQEQ","JAM", "JUMP","RESOP","AND","OR","NOT","WHILE", "UNTIL","FOR","CWORD","EXIT","ON","SIGNAL", "THEN","START","ELSE","FINISH","FELSE","CYCLE", "REPEAT","PROGRAM","BEGIN","END","ENDPROG","ENDPERM", "FRESULT","MRESULT","BACK","MONITOR","STOP","LIST", "","CONTROL","INCLUDE","MASS","RTYPE","ADDOP", "IDENT","V","N","CONST","FM","", "R","F","M","P","RP","FP", "MP","PP","L","S","A","AN", "NA","NAN","","","","", "","","","","","", "%MSTART","%CLEAR","%PRED","","%DUBIOUS","%DUP", "%PIN","%POUT","%EDUP","","PIDENT","CIDENT", "OIDENT","FNAME","SWID","DOTL","DOTR","ASEP", "CSEP","OSEP","PSEP","ARB","BPLRB","ORB", "PRB","CRB","RCRB","RECRB","RECLB","LAB", "MLAB","SLAB","XNAME","OWNT","DBSEP","PCONST", "CMOD","CSIGN","CUOP","COP1","COP2","COP3", "INDEF","XELSE","CRESOP","NLAB","RUNTIL","ACONST", "ORRB","FMANY","OSTRING","FMLB","FMRB","FMOR", "RANGERB","FSID","","","","", "","%DUMMY","%DECL","%TYPE","%ZERO","%APPLY", "%PROT","%SETPROT","%PTYPE","%GAPP","%LOCAL","%GUARD", "%MCODE","%CDUMMY","%SETTYPE","%OPER","%PARAM","%BLOCK", "%OTHER","%COMPILE","APP","BASEAPP","APP2","APP3", "APP4","APP5","APP6","ADEFN","NPARM","SWDEF", "SWIDS","CIEXP","RCONST","SCONST","ARRAYP","XIMP", "IMP","COND","SCOND","EXP1","EXP2","SEXP", "IEXP","IEXP1","IEXP2","ISEXP","SEQ","FDEF", "EXP","NARRAYP","STRUCT","RESEXP","BPL","CONSTB", "FITEM","MOREA","CLIST","FPP","FPP0","FPP1", "FPP2","INITVAR","RECEXP","EIMP","IDENTS","RANGE", "RCONSTB","VARP","INITDEC","","","", "ESCDEC","ESCPROC","ESCARRAY","ESCREC" %constinteger gmax1=718 %owninteger gmax=718 %constinteger imp phrase =24 %ownshortintegerarray phrase(200:255) = %C 0, 563, 564, 566, 568, 570, 572, 561, 613, 202, 199, 601, 477, 479, 623, 297, 205, 307, 317, 432, 425, 436, 443, 457, 452, 460, 466, 481, 401, 626, 628, 602, 520, 510, 485, 501, 574, 526, 527, 542, 549, 577, 396, 286, 196, 635, 515, 620, 166, 0, 0, 0, 639, 692, 700, 708 %constbyteintegerarray atomic(130:179) = %c 90, 90, 90, 90, 90, 48, 48, 19, 19, 19, 19, 25, 25, 25, 25, 25, 25, 25, 23, 104, 104, 105, 30, 20, 21, 93, 47, 45, 46, 42, 43, 44, 40, 68, 55, 104, 60, 93, 25, 40, 93, 23, 25, 57, 25, 90, 176, 177, 178, 179 ! FLAG<1> 0<1> SS<2> 0<3> T<1> LINK<8> %constshortintegerarray initial(0:119) = %c 23, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 22, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 20, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -32552, 0, 0, 0, 0, 13, 0, 14, 4, -32558, 16, -32551, 0, 0, 5, 6, 3, 12, 15, 8, 7, 9, 10, 11, -32559, -32555, -32560, -32553, -32554, 18, 0, 17, 21, 19, 0, 0, 0, -32563, -32561, 0, 0, 0, -32562, 0, 0, 0, 0, 0, 0, 0, 1, 2, 0, -32557, 0, -32556, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ! MORE<1> 0<1> ORDER<2> TYPE<4> CLASS<8> %ownshortintegerarray gram(0:max grammar) = %c 0, -28523, -28521, -28602, -32706, -28509, -28603, -24502, -24503, -20405, -20404, -28595, -32697, -32709, -16323, -28600, -32704, -28587, -28589, -32681, -16344, -28586, -16366, -32586, 216, -12287, -16380, -8185, -8184, -12285, -12286, -12283, -12282, -12279, -12276, -16373, 20490, -32706, -32701, 216, -16364, -28610, -28613, -28612, 16445, 217, -16364, 62, -32701, 16450, -16364, 5346, -16364, 166, -16344, 4332, 130, -16360, -16361, 126, 217, -32701, 216, -16364, 16450, -32700, 16404, -32701, -32706, 216, 16405, 16407, -16222, 8414, 130, 217, -32697, 16450, 1250, 4307, 4318, 192, 93, 170, 90, 207, -16365, 16404, 90, -16360, -16365, 16404, 241, -16365, 16404, 132, 132, -16360, 4329, -16365, 16404, 133, 175, 90, -16365, 16404, 209, -16365, 16404, 4313, 217, 16451, 4263, 16384, 16384, 120, 216, -32700, 16404, -32706, 16404, 243, 16409, 454, -32685, 16404, 454, 248, -16365, 16404, 4263, 194, -16360, 4329, -32717, 16404, 4263, 16407, 454, 237, 127, 215, 454, 4263, 16384, -16364, 1502, -32629, -16361, 153, -32606, 222, 143, -32629, 153, 454, 126, 16409, 454, 16384, 234, -16365, -32595, 147, -32678, 234, 193, -32677, -32676, -32661, 109, -32717, 53, 52, 52, 52, 194, 194, 194, -28581, 4188, 194, -28566, 4203, 194, -28564, 4205, 4580, 16429, 183, 183, 186, 186, -28583, 0, 9437, 90, -16365, 0, 134, -16365, 0, 210, 4329, 199, -32677, -32672, -32676, -32688, -32690, -32705, -32661, -32659, -32689, -32686, -32687, -16330, 65, -32716, 186, -28583, -32717, -32715, -32713, 52, -32664, 4201, 186, -32717, -32715, 55, -16328, 0, 197, 197, 52, 52, 197, -28581, -28580, 186, -28581, 4188, 4318, 194, -28581, 4188, 9437, 194, 194, 454, 16407, 216, 194, -28566, -28565, 186, -28566, 4203, 194, -28564, -28563, 186, -28564, 4205, 183, 183, 186, 183, -16365, 0, 183, 4580, 16429, 5095, 9444, 5348, 186, -28583, -16328, 0, 16409, -16365, 0, 9437, 5348, 217, -32701, 16450, -32701, 216, -32700, 0, -32701, -32706, 216, 243, 217, -16318, 0, -32552, 0, -32700, 0, -32706, 0, 215, -32550, 228, -28616, -28615, 0, 4096, 218, 218, -28616, 0, -32677, -32676, -16361, -32710, -32669, -32662, -32661, -32660, -32659, 740, -32039, 740, -32719, 4096, 194, -32719, -32718, -32604, -32726, -32725, -32724, -32720, 4096, 710, 6116, -32719, 0, 710, 6116, -28581, 4188, 218, 122, 50, 16409, -32726, -32725, -32724, -32719, 4096, 710, 454, 195, 195, 195, 454, -28581, 4188, 194, -28566, -28565, -28564, 4205, 195, 195, 195, 710, 4836, 5095, 4829, -32726, -32725, -32724, -32719, 4096, 4827, 4828, 454, -32720, -32719, 4096, 4829, 4827, 4828, 194, -32719, 0, 710, 4836, -16291, -32677, 92, 184, 121, -28581, -28580, -32722, -32723, 4317, -32726, -32725, -32724, 0, 183, -32726, -32725, -32724, -32720, 0, 4316, 195, 195, 195, 454, -28581, 4188, 4315, 183, 4317, -32726, -32725, 0, 195, 195, 4315, 4317, -32726, 0, 195, -32677, -32676, -16361, 16431, 228, 228, 47, -32610, -32611, 5345, -32609, -32608, -32607, 0, 4320, 4319, 5345, -32609, -32608, 0, 4319, 5345, -32609, 0, -32613, -16361, 16431, 222, 222, 156, -32677, 92, 183, 186, 1222, 16435, 228, 16403, 4324, 138, 8420, -32723, 4189, 93, 454, 148, -32674, 16546, 16409, -32597, 182, -16383, 16388, 234, -16365, -32595, 172, -32678, 234, 90, 244, 246, -16365, 0, 235, -32678, 234, -16365, 246, -16365, 0, -32678, 234, 90, 16407, 222, 16405, 222, 145, 16407, 222, 16405, 222, 146, 16407, 1252, 154, 5348, -16365, 142, 126, 182, -16383, 16391, 90, -16365, 127, -32678, 238, 90, 125, 239, -16365, 8319, 8430, 128, 126, -16361, 127, 190, 240, 189, 16409, 182, -16383, 16391, 90, -16365, 0, -32678, 240, 90, 16623, -16365, 0, 244, 232, 1252, 1252, 137, 1252, 137, 1252, 137, 1252, 137, 1252, 137, 222, -16365, 0, 131, 194, -16360, -16333, -16332, 124, 181, -16292, -16277, 16493, -31802, 5342, -28581, 4188, 4263, 181, 186, 454, 16475, 183, -28583, 199, 5598, 9438, 222, -32677, -32676, 16407, 186, 228, 135, 16409, -32632, 0, -32677, 92, -32677, -32676, -32662, -32661, -32660, -32659, 165, -32677, 92, 188, -32662, 107, 188, -32660, 109, -32732, 37, -16344, 4318, 148, -32674, 16424, 222, 16405, 222, 174, -28644, -32734, -32680, -28641, -32733, -32730, -32735, -32727, -32738, 4326, -32738, -32739, -32741, -32736, 199, -28644, -32680, -28641, 4326, -32739, -32741, 199, -32738, -32739, -32741, -32736, -32729, 199, -32616, 199, -32739, -32741, -32729, 199, -32616, -32729, 199, -28644, -32680, 4326, -32738, -32739, -32741, 199, 245, 4318, 245, 16409, 152, 4318, 16409, 152, 245, -32672, -32671, -32670, 99, 16407, 200, 144, 185, -32677, 92, 16407, -32582, 200, 200, 187, 141, -32677, 92, 16410, 191, -32677, -32676, -32662, -32661, -32660, 109, 198, 0(max grammar-718) %ownshortintegerarray glink(0:max grammar) = %c -1, 70, 71, 37, 45, 46, 66, 66, 74, 66, 0, 66, 50, 75, 78, 52, 54, 79, 66, 80, 81, 82, 83, 25, 40, 84, 85, 56, 56, 88, 92, 95, 96, 101, 102, 103, 106, 45, 66, 66, 0, 109, 109, 110, 51, 48, 0, 60, 66, 61, 0, 66, 0, 110, 111, 111, 57, 112, 113, 114, 63, 66, 65, 115, 116, 67, 0, 66, 121, 66, 0, 72, 122, 122, 66, 76, 66, 39, 76, 66, 66, 0, 123, 126, 127, 86, 85, 0, 89, 130, 88, 0, 93, 92, 0, 131, 97, 136, 99, 96, 0, 137, 66, 104, 103, 0, 107, 106, 0, 66, 66, 66, 138, 139, 140, 0, 117, 119, 115, 141, 115, 66, 70, 124, 66, 0, 66, 128, 84, 0, 142, 132, 143, 134, 144, 0, 155, 156, 58, 157, 66, 118, 90, 158, 145, 144, 147, 145, 150, 0, 152, 152, 153, 145, 0, 98, 159, 66, 133, 160, 161, 164, 160, 140, 161, 161, 167, 171, 173, 174, 175, 176, 177, 178, 181, 184, 187, 188, 179, 189, 189, 182, 190, 190, 185, 190, 190, 0, 187, 191, 192, 193, 0, 195, 0, 0, 197, 196, 0, 200, 199, 0, 203, 204, 0, 227, 231, 218, 233, 234, 0, 235, 236, 237, 0, 231, 225, 243, 244, 220, 247, 248, 249, 250, 244, 0, 251, 228, 248, 249, 250, 252, 0, 0, 187, 253, 259, 238, 268, 268, 241, 190, 190, 269, 245, 271, 271, 228, 272, 273, 274, 275, 0, 254, 265, 265, 257, 266, 266, 260, 265, 265, 263, 266, 266, 231, 267, 231, 0, 276, 0, 277, 231, 272, 231, 281, 282, 278, 284, 252, 0, 0, 285, 0, 231, 0, 287, 0, 289, 0, 291, 293, 0, 0, 296, 0, 0, 298, 300, 0, 302, 0, 304, 0, 306, 0, 0, 309, 312, 313, 314, 0, 0, 315, 310, 313, 0, 331, 331, 327, 348, 349, 350, 350, 350, 350, 329, 281, 351, 357, 0, 332, 340, 346, 358, 359, 360, 361, 362, 0, 341, 342, 344, 0, 345, 0, 268, 268, 0, 0, 365, 352, 370, 371, 372, 373, 0, 374, 375, 376, 382, 383, 363, 384, 384, 366, 268, 268, 268, 268, 388, 389, 390, 391, 392, 0, 377, 359, 360, 361, 340, 0, 378, 379, 385, 362, 340, 0, 352, 353, 354, 374, 394, 0, 395, 0, 399, 268, 268, 400, 0, 410, 410, 405, 416, 406, 417, 418, 419, 0, 411, 417, 418, 419, 420, 0, 408, 405, 423, 416, 421, 424, 424, 407, 414, 426, 429, 430, 0, 425, 431, 427, 433, 435, 0, 432, 268, 268, 440, 441, 281, 442, 0, 445, 450, 446, 445, 451, 450, 0, 448, 447, 453, 452, 456, 0, 454, 458, 457, 0, 268, 463, 464, 281, 465, 0, 468, 468, 469, 470, 471, 472, 473, 474, 475, 476, 0, 478, 268, 480, 0, 482, 484, 484, 204, 489, 487, 495, 496, 490, 493, 489, 0, 490, 490, 0, 497, 498, 500, 0, 0, 503, 505, 509, 498, 507, 0, 505, 505, 503, 511, 512, 513, 514, 0, 516, 517, 518, 519, 0, 521, 522, 523, 524, 521, 0, 527, 528, 530, 535, 531, 533, 0, 531, 0, 536, 537, 538, 540, 541, 541, 0, 543, 545, 0, 546, 547, 548, 532, 550, 552, 557, 553, 555, 0, 553, 0, 558, 559, 556, 0, 562, 204, 0, 565, 563, 567, 564, 569, 566, 571, 568, 573, 570, 575, 574, 0, 578, 579, 591, 592, 583, 204, 584, 587, 587, 587, 589, 204, 593, 593, 594, 595, 596, 580, 599, 597, 600, 0, 204, 204, 204, 605, 605, 606, 607, 608, 604, 609, 611, 0, 192, 192, 192, 192, 192, 192, 192, 192, 0, 622, 622, 191, 625, 625, 0, 625, 625, 630, 632, 281, 281, 633, 281, 281, 636, 637, 638, 0, 649, 676, 683, 665, 654, 204, 204, 204, 204, 649, 658, 667, 684, 665, 0, 661, 685, 665, 661, 667, 684, 0, 669, 673, 688, 665, 204, 0, 204, 0, 673, 688, 204, 0, 665, 204, 0, 679, 691, 679, 658, 667, 684, 0, 649, 686, 661, 687, 204, 689, 690, 665, 679, 696, 696, 696, 696, 697, 698, 699, 0, 702, 702, 703, 705, 706, 707, 707, 699, 710, 710, 711, 712, 718, 718, 718, 718, 718, 718, 0, 0(max grammar-718) %constshortintegerarray kdict(32:596) = %c 0, 511, 131, 531, 131, 551, 559, 131, 567, 575, 583, 603, 623, 631, 663, 671, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 691, 698, 707, 751, 795, 131, 131, 824, 900, 960, 1076, 1120, 1280, 128, 128, 1392, 128, 128, 1460, 1556, 1592, 1660, 1748, 128, 1828, 2000, 2196, 2228, 128, 2268, 128, 128, 128, 2287, 2295, 2327, 2335, 2355, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, 2363, 131, 2335, -32351, 16428, 25, 16428, 29, -32349, 16433, 1, 16434, 1, -16127, 0, 16427, 21, 16407, 0, 16409, 0, -32323, -10840, 40, 16471, 0, -32341, -10580, 32, 16473, 117, 16384, 19, -31955, -32322, -10580, 36, -9290, 0, 16473, 113, 16432, 13, -32337, 16427, 46, 16427, 17, 16405, 0, 16404, 0, -31556, -31939, -32322, -9551, 2, 16433, 1, 16433, 5, 16426, 5, -31606, -32323, -9807, 0, -32374, -9678, 0, 16436, 0, 16435, 0, -31939, -32322, 16433, 4, 16426, 9, 16433, 3, -30772, -31666, 10578, 11457, -32344, 16413, 2, 16411, 2, 68, -32374, 16440, 0, 16440, 0, 8393, 83, 16408, 0, -31291, 10841, 69, -32311, 16412, 18, 10830, 9157, 10565, 16412, 18, 9415, 78, 16458, 0, -32049, 8665, 8908, 16455, 0, -30131, 78, -31277, 84, -32055, 10194, 76, 16469, 0, 10958, 69, 16447, 32, 84, -32319, 16418, 2, 10830, 16418, 2, 8909, 10830, 16406, 0, -31927, 10073, 9921, 8649, 16419, 5, 9153, 10190, 8915, 16469, 1, -27956, -31282, 88, -31927, 8916, 10066, 9793, 16419, 3, 84, 16447, 4, 68, -32305, 16459, 2, 70, -30650, -31284, 80, -31931, 10194, 10567, 9921, 16460, 1, 9938, 16461, 0, 10697, 84, 16467, 3, 9801, 69, 16460, 0, 8915, 16452, 0, -29631, -30903, -31282, -31793, 10069, 10819, 10185, 78, 16416, 9, 82, 16445, 0, 16416, 9, 9422, 9299, -32315, 16453, 0, 10700, 69, 16454, 0, 10700, 69, 16464, 1210, -30778, 78, -31549, 8916, 8903, 82, -32344, 16412, 17, 16472, 17, 10956, 8900, 16470, 0, 16446, 44, -30143, -30647, 10063, 71, -31671, -32302, 16412, 20, 8389, 76, 16412, 36, 10830, 9157, 10565, 16412, 20, 10835, 16467, 1, 8898, 76, 16425, 6, -31935, 10063, 10825, 10575, 16465, 109, 80, 16416, 10, -32191, 10831, 16442, 0, 8909, -32314, 16414, 1, -31794, 10069, 10819, 10185, 78, 16416, 10, 16416, 10, -30770, -31408, -32174, 10071, 16418, 1, -32374, 16441, 2, 16441, 2, 9428, 10063, 16402, 0, -32315, 16448, 0, 8918, 10830, 16448, 0, -30523, 82, -31419, -31927, 9167, 8402, 77, 16457, 0, 77, 16419, 6, 9412, 8387, 8916, 16415, 123, 9938, 16419, 7, -31931, 10959, 9428, 8910, 16415, 104, -28351, -30397, -31024, -32045, 10964, 10066, 16464, 1319, 9813, 7892, -32323, 16462, 1384, 16463, 1241, 8389, 84, 16456, 0, 10575, 68, -32314, 16421, 64, 10575, 8397, 84, -32301, 16422, 9, 8912, 67, 16422, 12, 76, 16412, 33, -27704, -28983, -29488, -31276, -31913, 10713, 8916, 77, 16419, 4, 10825, 9283, 16417, 12, -31423, -31921, 9426, 9166, 40, 16420, 48, 80, 16466, 115, 10834, 16451, 0, 8645, 16423, 0, 10055, 9793, -32315, 16449, 0, 8918, 10830, 16449, 0, 10575, 84, -32311, 16412, 19, 10830, 9157, 10565, 16412, 19, -32056, 10962, 69, 16464, 1354, 10053, 16450, 0, 78, -32052, 9428, 76, 16444, 182, 10693, 83, 16446, 46, 9416, 8908, 16443, 180, 16407, 0, -31939, -32292, -10454, 51, 16426, 13, 16433, 1, 16409, 0, -32290, -10454, 51, 16426, 13, 16410, 0, 16431, 14, -32323, 16430, 51, 16433, 1 !! %list !!%endoffile !*** end of generated tables *** %routine print ident(%integer p, mode) %INTEGER j, ad p = tag(p)_text %IF p = 0 %START %IF mode = 0 %THEN printsymbol('?') %C %ELSE put('?') %RETURN %FINISH ad = addr(dict(p+1)) %IF mode = 0 %THEN printstring(string(ad)) %ELSE %START putblock(byteinteger(ad),byteinteger(ad+1)) %finish %END %ROUTINE abandon(%INTEGER n) %SWITCH reason(0:9) %INTEGER stream stream = listing %CYCLE newline %IF sym # nl printsymbol('*'); write(lines,4); space printsymbol('[') write(n,0) printsymbol(']') ->reason(n) reason(*):debug("* Switch label not set: reason(".itos(n,0).")"); %stop reason(0):printstring("compiler error!"); ->more reason(1):printstring("switch vector too large"); ->more reason(2):printstring("too many names"); ->more reason(3):printstring("program too complex"); ->more reason(4):printstring("feature not implemented"); ->more {GT: reason(5):printstring(error message.sysmess(event_extra)) %and -> more %if event_sub # 1 reason(5): %if event_sub # 1 %start printstring("error message=""".error message.""" event_event=".itos(event_event,0)." event_sub=".itos(event_sub, 0)) {printstring("sysmess(event_extra)=""".sysmess(event_extra)."""") -> more %finish %IF quote # 0 %START %IF quote < 0 %THEN printsymbol(cquote) %C %ELSE printsymbol(squote) %ELSE printstring("%endof") %IF progmode >= 0 %THEN printstring("program") %C %ELSE printstring("file") %FINISH printstring(" missing?"); ->more reason(6):printstring("too many faults!"); ->more reason(7):printstring("string constant too long"); ->more reason(8):printstring("dictionary full"); -> more reason(9): printstring("Included file ".include file." does not exist") more: newline printstring("*** compilation abandoned ***"); newline %EXIT %IF stream = report close output stream = report select output(report) %REPEAT %monitor %IF diag&4096 # 0 exit(16_1000002c) {1000002c is SS$_ABORT with the inhibit message bit set - could just use EXIT_FAILURE} %END %routine op(%integer code, param) put(code); putword(param) %end %routine set const(%integer m) %integer v v = m; v = -m %if v < 0 put('N'); putlong(v) put('U') %if m < 0 %end %ROUTINE compile block(%INTEGER level, block tag, dmin, tmax, id) %INTEGERFNSPEC gapp %ROUTINESPEC delete names(%INTEGER quiet) %ROUTINESPEC analyse %ROUTINESPEC compile %INTEGER open; open = closed; !zero if can return from proc %INTEGER dbase; dbase = dmax; !dictionary base %INTEGER tbase; tbase = tmax; !tag base %INTEGER tstart; tstart = tmax %INTEGER label; label = 4; !first internal label %INTEGER last array; last array = 0 %INTEGER access; access = 1; !non-zero if accessible %INTEGER inhibit; inhibit = 0; !non-zero inhibits declaratons {GT:%SHORT}%INTEGERNAME bflags; bflags == tag(block tag)_flags %INTEGER block type; block type = bflags>>4&7 %INTEGER block form; block form = bflags&15 %INTEGER block fm; block fm = tag(block tag)_format %INTEGER block otype; block otype = otype %INTEGERNAME block app; block app == tag(block tag)_app %INTEGER l, new app %ROUTINE fault(%INTEGER n) ! -5 : -1 - warnings ! 1 : 22 - errors %SWITCH fm(-5:22) %INTEGER st %ROUTINE print ss %INTEGER s, p %RETURN %IF pos = 0 space p = 1 %CYCLE printsymbol(marker) %IF p = pos1 %EXIT %IF p = pos s = char(margin+p); p = p+1 %EXIT %IF s = nl %OR (s='%' %AND p = pos) %IF s < ' ' %START; !beware of tabs %IF s = ff %THEN s = nl %ELSE s = ' ' %FINISH printsymbol(s) %REPEAT pos = 0 %IF list <= 0 %END pos1 = pos2 %IF pos2 > pos1 %if n >=0 %or command&warnbit # 0 %start newline %IF sym # nl st = report st = listing %IF n = -3; !don't report unused on the console %cycle SELECT OUTPUT(st) %if n < 0 %then printsymbol('?') %and pos1 = 0 %else printsymbol('*') %if st # report %start %if list <= 0 %and pos1 # 0 %start spaces(pos1+margin); PRINTSTRING(" ! ") %finish %finish %else %start PRINTSTRING(include file) %if include # 0 write(lines, 4); printsymbol(csym); space %finish ->fm(n) %if -5 <= n <= 22 PRINTSTRING("fault"); write(n, 2); ->ps fm(*):debug("* Switch label not set: fm(".itos(n,0).")"); %stop fm(-5):PRINTSTRING("Dubious statement"); dubious = 0; ->psd fm(-4):PRINTSTRING("Non-local") pos1 = for warn; for warn = 0; ->ps fm(-3):print ident(x, 0); PRINTSTRING(" unused"); ->nps fm(-2):PRINTSTRING("""}"""); ->miss fm(-1):PRINTSTRING("access"); ->psd fm(0): PRINTSTRING("form"); ->ps fm(1): PRINTSTRING("atom"); ->ps fm(2): PRINTSTRING("not declared"); ->ps fm(3): PRINTSTRING("too complex"); ->ps fm(4): PRINTSTRING("duplicate"); ->ps fm(5): PRINTSTRING("type"); ->ps fm(6): PRINTSTRING("match"); ->psd fm(7): PRINTSTRING("context"); ->psd fm(21):PRINTSTRING("context "); print ident(this, 0); ->ps fm(8): PRINTSTRING("%cycle"); ->miss fm(9): PRINTSTRING("%start"); ->miss fm(10):PRINTSTRING("size"); WRITE(lit, 1) %if pos1 = 0;->ps fm(11):PRINTSTRING("bounds") WRITE(ocount, 1) %unless ocount < 0; ->ps fm(12):PRINTSTRING("index"); ->ps fm(13):PRINTSTRING("order"); ->psd fm(14):PRINTSTRING("not a location"); ->ps fm(15):PRINTSTRING("%begin"); ->miss fm(16):PRINTSTRING("%end"); ->miss fm(17):PRINTSTRING("%repeat"); ->miss fm(18):PRINTSTRING("%finish"); ->miss fm(19):PRINTSTRING("result"); ->miss fm(22):PRINTSTRING("format"); ->ps fm(20):printsymbol('"'); print ident(x, 0); printsymbol('"') miss: PRINTSTRING(" missing"); ->nps psd: pos1 = 0 ps: print ss nps: NEWLINE %exit %if st = listing st = listing %repeat %finish %if n >= 0 %start %monitor %if diag&4096 # 0 %if n # 13 %start; !order is fairly safe ocount = -1 gg = 0 copy = 0; quote = 0 search base = 0; escape class = 0 gg = 0 %finish faulty = faulty+1 !check that there haven't been too many faults fault rate = fault rate+3; abandon(6) %IF fault rate > 30 fault rate = 3 %IF fault rate <= 0 %FINISH tbase = tstart %IF list <= 0 %AND sym # nl %START error margin = column error sym = sym; sym = nl %FINISH %END dmin = dmin-1; dict(dmin) = -1; !end marker for starts & cycles abandon(2) %IF dmax = dmin %IF list > 0 %AND level > 0 %START write(lines, 5); spaces(level*3-1) %IF block tag = 0 %START printstring("Begin") %FINISH %ELSE %START printstring("Procedure "); print ident(block tag, 0) %FINISH newline %FINISH !deal with procedure definition (parameters) %IF block tag # 0 %START; !proc analyse; compile %IF ss # 0 %IF block otype # 0 %START; !external-ish %IF bflags&spec = 0 %START; !definition %IF progmode <= 0 %AND level = 1 %THEN progmode = -1 %C %ELSE fault(7) !!!!! %FINISH %ELSE %START; !external spec !!!!! bflags = bflags-spec; !definition elsewhere %FINISH %FINISH new app = gapp; !generate app grammar %IF spec given # 0 %START; !definition after spec fault(6) %IF new app # block app; !different from spec %FINISH block app = new app; !use the latest %IF level < 0 %START; !not procedure definition delete names(0) %RETURN %FINISH %FINISH %ELSE %START open = 0; !can return from a block? %FINISH %CYCLE analyse %CONTINUE %IF ss = 0 compile fault(-5) %IF dubious # 0 %IF sstype > 0 %START; !block in or out %EXIT %IF sstype = 2; !out compile block(spec mode, block x, dmin, tmax, id) %EXIT %IF ss < 0; !endofprogram %FINISH %REPEAT %IF list > 1 %AND level > 0 %START write(lines, 5); spaces(level*3-1) printstring("End") newline %FINISH delete names(0) %RETURN %INTEGERFN gapp; !generate app grammar (backwards) %CONSTINTEGER comma = 140; !psep %ROUTINESPEC set cell(%INTEGER g, tt) %ROUTINESPEC class(%RECORD(tagfm)%NAME v); !imp77: %RECORD(tagfm)%NAME v; !imp77: %INTEGER p, link, tp, c, ap, t %RESULT = 0 %IF tmax = local; !no app needed p = gmax1; link = 0; t = tmax %CYCLE v == tag(t); t = t-1 class(v); !deduce class from tag %IF c < 0 %START; !insert %PARAM c = -c set cell(196, tp) tp = -1 %FINISH set cell(c, tp) %EXIT %IF t = local; !end of parameters set cell(comma, -1); !add the separating comma %REPEAT abandon(3) %IF gmax > gmin %RESULT = link %ROUTINE set cell(%INTEGER g, tt) !add the cell to the grammar, combining common tails %WHILE p # gmax %CYCLE p = p+1 %IF glink(p) = link %AND gram(p) = g %START %IF tt < 0 %OR (gram(p+1) = tt %AND glink(p+1)=ap) %START link = p; !already there %RETURN %FINISH %FINISH %REPEAT !add a new cell gmax = gmax+1 gram(gmax) = g glink(gmax) = link link = gmax %IF tt >= 0 %START; ! set type cell gmax = gmax+1 gram(gmax) = tt glink(gmax) = ap %FINISH p = gmax %END %ROUTINE class(%RECORD(tagfm)%NAME v); !imp77: %CONSTINTEGER err = 89 %CONSTINTEGER rtp = 100 %CONSTINTEGER fnp = 101 %CONSTINTEGER mapp = 102 %CONSTINTEGER predp = 103 %CONSTINTEGERARRAY class map(0:15) = %C err,1764, 247, err(4), -rtp, -fnp, -mapp, -predp, err, 214, err, 229, err %INTEGER tags, type, form ap = 0 tags = v_flags type = tags>>4&7; form = tags&15 tp = v_format<<3!type c = class map(form) c = 208 %AND tp = 0 %IF type = 0 %AND form = 2; !%NAME ap = v_app %IF tags¶meters # 0 %END %END %ROUTINE delete names(%INTEGER quiet) %INTEGER flags %RECORD(tagfm)%NAME tx; !imp77: %WHILE tmax > tbase %CYCLE x = tmax; tmax = tmax-1 tx == tag(x) flags = tx_flags fault(20) %IF flags&spec # 0 %and flags&own bit = 0 {spec with no definition & not external} %IF flags&used bit = 0 %AND level > 0 %AND list <= 0 %START fault(-3) %IF quiet = 0; !unused %FINISH dict(tx_text) = tx_link %REPEAT %END %ROUTINE analyse %CONSTINTEGER order bits = 16_3000, order bit = 16_1000 %CONSTINTEGER escape = 16_1000 %INTEGER strp, mark, flags, prot err, k, s, c %OWNINTEGER key = 0 {GT:%SHORT}%INTEGER node; !imp77: {GT:%SHORT}%INTEGERNAME z; !imp77: %RECORD(arfm)%NAME arp; !imp77: %SWITCH act(actions:phrasal), paction(0:15) %ROUTINE trace analysis !diagnostic trace routine (diagnose&1 # 0) %INTEGER a %ROUTINE show(%INTEGER a) %IF 0 < a < 130 %START space printstring(text(a)) %FINISH %ELSE write(a, 3) %END %OWNINTEGER la1=0, la2=0, lsa=0, lt=0 newline %IF mon pos # pos %AND sym # nl mon pos = pos write(g, 3) space printstring(text(class)) printsymbol('"') %IF gg&trans bit # 0 a = gg>>8&15 %IF a # 0 %START printsymbol('{') write(a, 0) printsymbol('}') %FINISH %IF atom1 # la1 %OR atom2 # la2 %OR lsa # subatom %C %OR lt # type %START printstring(" [") la1 = atom1 show(la1) la2 = atom2 show(la2) lsa = subatom write(lsa, 3) lt = type write(lt, 5) printsymbol(']') %FINISH newline %END %ROUTINE read sym %routine get next source char %externalroutinespec readrecord(%integername len, %bytename b) %owninteger len=0 %if sym = nl %start current char == char(1) readrecord (len, current char) ;! BUG??? readrecord reads from tanks but there are none to be read from in pass1. len = len + 1 char(len) = nl pos = 0 column = 0; !??????????????????????????????????? %finish pos = pos + 1 sym = current char !! current char == BYTEINTEGER(ADDR(current char)+1) ; !! WAS ++ 1 current char == current char++1 printsymbol(sym) %if list <= 0 column = column + 1 %end %CONSTBYTEINTEGERARRAY mapped(0:127) = %C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, nl, 0, 3 , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,'!','"','#', '$', 1 ,'&', 39, '(',')','*','+', ',','-','.','/', '0','1','2','3', '4','5','6','7', '8','9',':',';', '<','=','>','?', '@','A','B','C', 'D','E','F','G', 'H','I','J','K', 'L','M','N','O', 'P','Q','R','S', 'T','U','V','W', 'X','Y','Z','[', '\',']','^','_', '`','A','B','C', 'D','E','F','G', 'H','I','J','K', 'L','M','N','O', 'P','Q','R','S', 'T','U','V','W', 'X','Y','Z', 2 , '|','}','~', 0 !! 0 = space !! 1 = % !! 2 = { !! 3 = ff !! other values represent themselves %IF sym = nl %START s1: lines = lines+1 printsymbol(end mark) %if end mark # 0 s11: pos = 0; pos1 = 0; pos2 = 0; margin = 0; column = 0 end mark = 0 %IF list <= 0 %START %IF include # 0 %START printstring(" &"); write(lines, -4) %FINISH %ELSE write(lines, 5) csym = cont; printsymbol(csym) space %IF error margin # 0 %START lines = lines-1 spaces(error margin) error margin = 0 %IF error sym # 0 %START printsymbol(error sym) pos = 1; char(1) = error sym sym = error sym; error sym = 0 ->s5 %FINISH %FINISH %FINISH s2: symtype = 1 %FINISH s3:get next source char s5:%IF sym # nl %START %RETURN %IF quote # 0; !dont alter strings sym = mapped(sym&127) %IF sym <= 3 %START; !special symbol ->s2 %IF sym = 0; !space (or dubious control) symtype = 2 %AND ->s3 %IF sym = 1; !% cont = '+' %AND ->s11 %IF sym = 3; !ff !must be { %CYCLE get next source char ->s3 %IF sym = '}' ->s4 %IF sym = nl %REPEAT %FINISH key = kdict(sym) %IF key&3 = 0 %AND symtype = 2 %START; !keyword %IF sym = 'C' %AND current char = nl %START; !%C... get next source char; cont = '+'; ->s1 %FINISH %ELSE symtype = key&3-2 %FINISH %RETURN %FINISH s4:cont = '+' symtype = quote %END %INTEGERFN format selected format list = tag(format)_app; !number of names %IF format list < 0 %START; !forward ref atom1 = error+22 %RESULT = 0 %FINISH %IF sym = '_' %START escape class = esc rec search base = tag(format)_format %FINISH %RESULT = 1 %END %ROUTINE code atom(%INTEGER target) %INTEGER dbase, da %INTEGER base, n, mul, pend quote %INTEGER j,k,l, pt %ROUTINE lookup(%INTEGER d) %CONSTINTEGER magic = 6700421 %INTEGER new name, vid, k1, k2, form %RECORD(tagfm)%NAME t; !imp77: %INTEGER new !first locate the text of the name new = addr(dict(dmax+1)) K2 = hash value*magic !******************************************************* k2 = k2>>(32-2*name bits)!1; !IMP77: k1 = k2>>name bits; !giving name bits %CYCLE newname = hash(k1) %EXIT %IF newname = 0; !not in ->in %IF string(addr(dict(newname+1))) = string(new) k1 = (k1+k2)&max names %REPEAT ! not found spare names = spare names-1 abandon(2) %IF spare names <= 0 hash(k1) = dmax; !put it in dict(dmax) = -1 newname = dmax; dmax = dp; ->not in in: search base = rbase %IF this >= 0 %AND d # 0; !record elem defn %IF search base # 0 %START; !record subname new = -1 x = search base %CYCLE ->not in %IF x < format list %EXIT %IF tag(x)_text = new name x = x-1 %REPEAT %FINISH %ELSE %START; !hash in for normal names x = dict(newname) ->not in %IF x <= limit; !wrong level %FINISH subatom = x; !name found, extract info t == tag(x) atom flags = t_flags format = t_format; app = t_app protection = atom flags&prot type = atom flags>>4&7; atom1 = amap(atom flags&15) %IF diag&8 # 0 %START printstring("lookup:") write(atom1, 3) write(type, 1) write(app, 3) write(format, 5) write(atom flags, 3) newline %FINISH %IF d = 0 %START; !old name wanted t_flags <- t_flags!used bit search base = 0 %IF atom flags&subname # 0 %AND format # 0 %START; !a record %RETURN %IF format selected = 0 %FINISH %IF atom flags¶meters # 0 %START; !proc or array %IF app = 0 %START; !no parameters needed atom2 = atom1 atom1 = atom1-4 %IF 97 <= atom1 <= 98 %START map gg = atom1; atom1 = var %FINISH %FINISH %ELSE %START %IF sym = '(' %START search base = 0; !ignore format for now %IF atom1 >= 106 %START; !arrays app = phrase(app+200) escape class = esc array atom1 = (atom1-106)>>1+91; !a,an->v na,nan->n %FINISH %ELSE %START; !procedures escape class = esc proc atom1 = atom1-4 %FINISH phrase(200) = app %FINISH %FINISH pos2 = pos; %return %FINISH !deal with constintegers etc %IF atom flags&const bit # 0 %AND atom1 = var %START map gg = const; atom2 = const subatom = -subatom %IF type = integer %FINISH %RETURN %FINISH !new name wanted ->not in %IF tbase # tstart; !dont fault proc parm-parm %IF d = lab+spec+used bit %START t_flags = t_flags!used bit %RETURN %FINISH %IF atom flags&spec # 0 %START; !a spec has been given %IF d = lab %START; !define label t_flags <- lab!used bit %RETURN %FINISH %IF 7 <= decl&15 <= 10 %AND decl&spec = 0 %START !procedure definition after spec %IF (decl!!atom flags)&2_1111111 = 0 %START; !correct type? t_flags = t_flags-spec spec given = 1 %RETURN %FINISH !note that an external procedure must be speced as a !non-external procedure. %FINISH %IF decl&15 = recfm %START; !recordformat t_flags = record<<4+recfm t_format = fdef %RETURN %FINISH %FINISH %RETURN %IF last1 = jump %AND atom1 = swit copy = pos1 %IF copy = 0 notin:app = 0; vid = 0 atom1 = error+2 %return %if d = 0; !old name wanted type = d>>4&7; form = d&15; atom1 = amap(form) %IF this < 0 %START; !normal scope new = newname tmax = tmax+1; x = tmax %FINISH %ELSE %START; !recordformat scope new = -1 recid = recid-1; vid = recid tmin = tmin-1; x = tmin format list = tmin %FINISH %IF 11 <= form <= 14 %START; !arrays dim = 1 %IF dim = 0; !set dim for owns app = dim %FINISH d = d!used bit %IF (otype > 2 %AND d&spec = 0) %OR perm # 0 !external definitions need not be used in the file in which !they are defined, so inhibit a useless unused warning. t == tag(x) %IF form = lab %START id = id+1; vid = id %FINISH t_index = vid t_text = new name t_flags <- d t_app = app t_format = fdef; format = fdef subatom = x %IF new >= 0 %START; !insert into hash table t_link = dict(new); dict(new) = x %IF gmin = max grammar %START; !proc param params tmin = tmin-1; subatom = tmin tag(tmin) = t %FINISH %FINISH abandon(3) %IF tmax >= tmin %END top: pos1 = pos subatom = 0; pend quote = 0 !app and format must be left for assigning to papp & pformat ->name %IF symtype = -2; !letter ->number %IF symtype < 0; !digit %IF symtype = 0 %START atom1 = termin; atom2 = 0 %RETURN %FINISH %IF symtype # 2 %START; !catch keywords here ->text %IF quote # 0; !completion of text ->strings %IF sym = squote; !start of string ->symbols %IF sym = cquote; !start of symbol ->number %IF sym = '.' %AND '0' <= current char <= '9' %FINISH !locate atom in fixed dict k = key>>2; read sym %CYCLE j = kdict(k) %EXIT %IF j&16_4000 # 0 %IF j&127 # sym %OR symtype < 0 %START ->err %UNLESS j < 0 k = k+1 %FINISH %ELSE %START l = j>>7&127; read sym %IF j > 0 %START %IF l # 0 %START ->err %IF l # sym %OR symtype < 0 read sym %FINISH l = 1 %FINISH k = k+l %FINISH %REPEAT atom1 = j&127 %IF atom1 = 0 %START; !comma atom1 = 19; subatom = 19; atom2 = 0 %IF sym = nl %START %RETURN %IF ocount >= 0 !special action needs to be taken with as !const array lists can be enormous read sym %FINISH %RETURN %FINISH atom2 = j>>7&127 subatom = kdict(k+1)&16_3fff !!!!!cont = ' ' %RETURN !report an error. adjust the error marker (pos1) to point !to the faulty character in an atom, but care needs to be taken !to prevent misleading reports in cases like ...????? err: atom1 = error+1; atom2 = 0 pos1 = pos %IF pos-pos1 > 2 %RETURN !take care with strings and symbol constants. !make sure the constant is valid here before sucking it in !(and potentially loosing many lines) symbols:atom1 = var; atom2 = const; type = integer map gg = const; protection = prot subatom = lp; abandon(3) %IF lp >= lit max quote = \pend quote %RETURN !an integer constant is acceptable so get it in and !get the next atom chars:n = 0; cont = cquote %CYCLE read sym %IF sym = cquote %START %EXIT %IF current char # cquote read sym %FINISH %IF n&(\((-1)>>byte size)) # 0 %START; ! overflow pos1 = pos; atom1 = error+10; %RETURN %FINISH ->err %IF quote = 0 n = n<top !sniff the grammar before getting the string strings:atom1 = var; atom2 = const; type = stringv subatom = (strp-stbase)!16_4000 map gg = const; protection = prot quote = subatom text line = lines; !in case of errors %RETURN !a string constant is ok here, so pull it in and get !the next atom text: ->chars %IF quote < 0; !character consts l = strp; n = strp j = addr(glink(gmin-1)); !absolute limit k = l+256; !string length limit k = j %IF j < k; !choose lower %CYCLE cont = squote; quote = 1 %CYCLE read sym %IF sym = squote %START; !terminator? %EXIT %IF current char # squote; !yes -> read sym; ! skip quote %FINISH l = l+1; byteinteger(l) = sym lines = text line %AND abandon(7) %IF l >= k; !too many chars %REPEAT byteinteger(n) = l-n; !plug in length strp = l+1; !ready for next string quote = 0; cont = ' '; read sym code atom(target) %RETURN %UNLESS atom1 = 48 %AND sym = squote; !fold "???"."+++" %REPEAT %ROUTINE get(%INTEGER limit) %INTEGER s, shift shift = 0 %IF base # 10 %START %IF base = 16 %START shift = 4 %FINISH %ELSE %START %IF base = 8 %START shift = 3 %FINISH %ELSE %START %IF base = 2 %START shift = 1 %FINISH %FINISH %FINISH %FINISH n = 0 %CYCLE %IF symtype = -1 %START; !digit s = sym-'0' %FINISH %ELSE %START %IF symtype < 0 %START; !letter s = sym-'A'+10 %FINISH %ELSE %START %RETURN %FINISH %FINISH %RETURN %IF s >= limit pt = pt+1; byteinteger(pt) = sym %IF base = 10 %START; !check overflow %IF n >= max int %AND (s > max dig %OR n > max int) %START !too big for an integer, !so call it a real base = 0; type = real; n = 0 %FINISH %FINISH %IF shift = 0 %START n = n*base+s %FINISH %ELSE %START n = n<= lit max pt = strp; mul = 0 %CYCLE get(base) %EXIT %UNLESS sym = '_' %AND base # 0 %AND pend quote = 0; !change of base read sym base = n %REPEAT %IF pend quote # 0 %START ->err %IF sym # cquote readsym %FINISH %IF sym = '.' %START; !a real constant pt = pt+1; byteinteger(pt) = '.' read sym type = real; base = 0; get(10) %FINISH %IF sym = '@' %START; !an exponent pt = pt+1; byteinteger(pt) = '@'; k = pt readsym type = integer; base = 10 %IF sym = '-' %START read sym; get(10); n = -n %FINISH %ELSE %START get(10) %FINISH pt = k+1; byteinteger(pt) = lp; litpool(lp) = n; lp = lp+1 atom1 = error+10 %IF base = 0 type = real; !exponents force the type %FINISH %IF type = real %START byteinteger(strp) = pt-strp subatom = (strp-stbase)!16_2000; strp = pt+1 %FINISH %ELSE %START litpool(lp) = n lp = lp+1 %FINISH %RETURN name: atom1 = 0 %AND %RETURN %IF 27 <= target <= 41 hash value = 0 !***************************** !*machine dependent for speed* !***************************** dp = dmax+1 da = addr(dict(dp)); dbase = da %CYCLE hash value = hash value+(hash value+sym); !is this good enough? da = da+1; byteinteger(da) = sym read sym %EXIT %IF symtype >= 0 %REPEAT %IF sym = cquote %START pend quote = 100 ->symbols %IF hash value = 'M' read sym %IF hash value = 'X' %THEN base = 16 %AND ->bxk %IF hash value = 'K' %C %OR hash value = 'O' %THEN base = 8 %AND ->bxk %IF hash value = 'B' %THEN base = 2 %AND ->bxk ->err %FINISH n = da-dbase byteinteger(dbase) = n dp = dp+(n+2)>>1 abandon(8) %IF dp >= dmin atom2 = 90; !ident %IF last1 = 0 %AND sym = ':' %START; !label limit = local; lookup(lab); %RETURN %FINISH %IF last1 = jump %START; !->label limit = local; lookup(lab+spec+used bit); %RETURN %FINISH %IF decl # 0 %AND target = 90 %START; !identifier search base = fm base limit = local; lookup(decl) search base = 0 %FINISH %ELSE %START limit = 0; lookup(0) %FINISH %END %INTEGERFN parsed machine code ! *opcode_?????????? %routine octal(%integer n) %integer m m = n>>3 octal(m) %if m # 0 put(n&7+'0') %end atom1 = error %AND %RESULT=0 %UNLESS symtype = -2; !starts with letter put('w') %CYCLE put(sym) read sym %EXIT %IF symtype >= 0; !pull in letters and digits %REPEAT put('_') %IF symtype # 0 %START; !not terminator atom1 = error %AND %result=0 %UNLESS sym = '_' read sym %WHILE symtype # 0 %CYCLE %IF symtype < 0 %START; !complex code atom(0); %result=0 %IF atom1&error # 0 %IF atom2 = const %AND type = integer %START %IF subatom < 0 %THEN octal(tag(-subatom)_format) %C %ELSE octal(litpool(subatom)) %FINISH %ELSE %START %IF 91 <= atom1 <= 109 %START put(' '); octal(tag(subatom)_index) %FINISH %ELSE %START atom1 = error; %result=0 %FINISH %FINISH %FINISH %ELSE %START put(sym); read sym %FINISH %REPEAT %FINISH put(';') %RESULT=1 %END cont = ' ' %IF gg = 0 last1 = 0; mapgg = 0 s = 0; ss = 0; sstype = -1; fdef = 0 fm base = 0 app = 0 !deal with alignment following an error in one statement !of several on a line margin = column; !start of statement pos = 0 stbase = addr(glink(gmax+1)); strp = stbase; lp = 0 tbase = tstart; !?????????????? local = tbase %IF gg = 0 %or ocount >= 0 %START; !data or not continuation(z) again:%WHILE sym type = 0 %CYCLE; !skip redundant terminators c = cont cont = ' '; cont = '+' %IF ocount >= 0 read sym cont = c %REPEAT ->skip %IF sym = '!'; !comment this = -1 code atom(0) %IF atom1 = comment %START skip: quote = 1 c = cont read sym %AND cont = c %WHILE sym # nl; !skip to end of line quote = 0; symtype = 0 ->again %FINISH %FINISH decl = 0; mark = 0 gentype = 0; force = 0 dim = 0; prot err = 0 node = 0; nmax = 0; nmin = rec size+1 order = 1; gmin = max grammar+1 sstype = 0 %AND ->more %IF gg # 0; !continuation ptype = 0; spec given = 0 stats = stats+1; op('O', lines) %IF perm = 0 ->fail1 %IF atom1&error # 0; !first atom faulty %IF escape class # 0 %START; !enter the hard way after g = imp phrase; sstype = -1; ->a3 %FINISH g = initial(atom1); !pick up entry point %IF g = 0 %START; !invalid first atom g = initial(0); sstype = 0; ->a3; !declarator? %FINISH %IF g < 0 %START; !phrase imp g = g&255 nmax = 1 ar(1)_class = 0; ar(1)_link = 0; ar(1)_sub = imp phrase %FINISH gg = gram(g); class = gg&255; sstype = gg>>12&3-1 ->a1 act(194): ptype = type; papp = app; pformat = format; ->more act(196):k =g+1; ->a610 act(188):k = ar(nmax)_sub+1 a610: papp = glink(k) k = gram(k) ->more %IF k = 0; !%NAME ptype = k&7; pformat = k>>3 act(183):k = type; gentype = k %IF gentype = 0 %OR k = real %IF pformat < 0 %START; !general type app = papp; format = pformat k = real %IF ptype = real %AND type = integer k = force %AND force = 0 %IF force # 0 %FINISH ->fail2 %UNLESS papp = app %AND (ptype = k %OR ptype = 0) ->more %IF pformat=format %OR pformat = 0 %OR format = 0 ->fail2 act(197):arp == ar(nmin) k = arp_sub ->fail3 %UNLESS block form = k&15 arp_sub = k>>4 type = block type ptype = block type; pformat = block fm; papp = app pformat = -1 %IF ptype # record ->more act(195):arp == ar(nmin) k = arp_sub arp_sub = k>>2 k = k&3 !1 = check integer !2 = check real !3 = check real + int ->more %IF k = 0; !no action %IF k = 1 %START force = integer ->more %IF type = integer %OR type = 0 ->fail2 %FINISH ->fail2 %UNLESS ptype = real %or ptype = 0 force = integer %IF k = 3 ->more act(198):!%OTHER k = gg>>8&15 %IF k = 0 %START; !restore atom atom1 = last1 ->more %FINISH %IF k = 1 %START; !test string ->fail2 %UNLESS type = stringv ->more %FINISH %if k = 2 %start ->fail2 %if type = record -> more %finish %if k = 3 %start; !check OWN variable coming code atom(0) ->A7 %if atom flags&own bit = 0 ->more %finish for warn = pos1 %IF x <= local; !%FORTEST ->more paction(1):%IF type = record %THEN g = phrase(242) %ELSE pformat = -1 ->a3 paction(2):ptype = real; pformat = -1; ->a3 paction(3):ptype = stringv; pformat = -1; ->a3 paction(4):ptype = integer; pformat = -1; ->a3 paction(5):->a3 %if ptype = integer g = phrase(212) %AND pformat=-1 %IF ptype = real g = phrase(213) %IF ptype = stringv ->a3 paction(6):ptype = gram(ar(nmax)_sub+1)&7; pformat = -1; ->a3 paction(7):ptype=real %IF ptype = integer; pformat=-1; ->a3 a1: last1 = class; atom1 = 0; s = subatom a2: %IF gg&trans bit = 0 %START; !insert into analysis record z == node %CYCLE; !insert cell in order k = z %EXIT %IF gg&order bits = 0 %OR k = 0 gg = gg-order bit; z == ar(k)_link %REPEAT gg = map gg %IF map gg # 0 %AND gg&255 = var nmin = nmin-1; ->fail0 %IF nmin = nmax z = nmin arp == ar(nmin) arp_sub = s; arp_class = (gg&255)!mark arp_link = k %FINISH mark = 0; map gg = 0 more: g = glink(g); !chain down the grammar paction(0): a3: gg = gram(g); class = gg&255 ;! <------------------------------ gg set to -1... THIS CAUSES MISSING SWITCH LABEL paction(15) BELOW debug("gg = gram(g) = -1 ... g=".itos(g,0)." gg=".itos(gg,0)) %if gg = -1 trace analysis %IF diag&1 # 0 ->a5 %IF class = 0; !end of phrase %IF class < actions %START; !not a phrase or an action class = atomic(class) %IF class >= figurative ->a2 %IF class >= manifest code atom(class) %IF atom1 = 0 %IF escape class # 0 %START; !escape to new grammar class = escape class; escape class = 0 g = g+escape !note that following an escape the next item is !forced to be transparent! esc: gg = 0 arp == ar(nmax+1) arp_papp = papp; arp_x = x; ->a4 %FINISH ->a1 %IF class = atom1 %OR class = atom2 a7: ->fail1 %IF gg >= 0; !no alternative g = g+1 ->a3 %FINISH %IF class >= phrasal %START; !a phrase a4: nmax = nmax+1; ->fail0 %IF nmax = nmin arp == ar(nmax) arp_ptype = ptype arp_pos = pos1 arp_pformat = pformat arp_link = gentype arp_class = node arp_sub = g node = 0 g = phrase(class) ptype = force %AND force = 0 %IF force # 0 gentype = 0 ->paction(gg>>8&15) ;! <----------------- CAUSES CRASH paction(*):debug("* Switch label not set: paction(".itos(gg>>8&15,0).") {gg=".itos(gg,0)."}"); %stop {avoid executing random code} %FINISH ->act(class); !only actions left act(*):debug("* Switch label not set: act(".itos(class,0).")"); %stop a5: !reverse links s = 0 %WHILE node # 0 %CYCLE z == ar(node)_link k = z; z = s; s = node; node = k %REPEAT ss = s a6: %IF nmax # 0 %START k = gentype; !type of phrase arp == ar(nmax); nmax = nmax-1 node = arp_class gentype = arp_link ptype = arp_ptype pformat = arp_pformat g = arp_sub %IF g&escape # 0 %START g = g-escape papp = arp_papp mark = 255 subatom = s ->a3 %FINISH gentype = k %IF gentype = 0 %OR k = real type = gen type k = gg; !exit-point code %CYCLE gg = gram(g) ->a2 %IF k = 0 ->fail1 %IF gg >= 0; !no alternative phrase k = k-order bit g = g+1; !sideways step %REPEAT %FINISH pos1 = copy %AND fault(4) %IF copy # 0 fault(13) %IF order = 0 fault(-4) %IF for warn # 0 pos1 = 0 fault rate = fault rate-1 %RETURN act(193):gg = 0 %AND ->a5 %UNLESS sym = '=' %or sym = '<'; !cdummy act(181):atom1 = amap(decl&15); !dummy ->more act(182):class = escdec; g = glink(g)!escape decl = 0; otype = 0; ->esc; !decl act(199): !reverse links; !compile s = 0 %WHILE node # 0 %CYCLE z == ar(node)_link k = z; z = s; s = node; node = k %repeat ss = s code atom(28) %IF quote # 0; !expend compile; ->more %IF atom1&error = 0 ->fail1 act(184):->fail4 %UNLESS type = integer %IF subatom < 0 %THEN lit = tag(-subatom)_format %C %ELSE lit = lit pool(subatom) ->fail4 %IF lit # 0 ->more act(185): !apply parameters s = 0 %WHILE node # 0 %CYCLE z == ar(node)_link k = z; z = s; s = node; node = k %REPEAT ss = s atom1 = ar(s)_class; atom2 = 0 atom1 = var %IF atom1 = 97 %OR atom1 = 98 arp == ar(nmax) x = arp_x pos1 = arp_pos pos2 = 0 app = 0 format = tag(x)_format flags = tag(x)_flags type = flags>>4&7 protection = flags&prot protection = 0 %IF flags&aname # 0 %IF flags&subname # 0 %AND format # 0 %START ->fail1 %if format selected = 0 %FINISH ->a6 act(187):protection = prot; ->more; !%SETPROT act(186):->more %if protection&prot = 0 prot err = nmin -> a7 act(191):k = protection; !%GUARD code atom(0) protection = k %IF atom flags&aname = 0 ->more act(192):->fail1 %IF parsed machine code=0 ->more act(189):k = gapp; !%GAPP delete names(1) tmax = tbase; tbase = gram (gmin); !restore tmax local= tbase gmin = gmin+1 x = ar(ar(nmax)_class)_sub tag(x)_app = k; !update app ->more act(190):gmin = gmin-1; !%LOCAL abandon(2) %IF gmin <= gmax gram (gmin) = tbase; tbase = tmax local = tbase ->more ! errors fail4:k = error+10; ->failed; !*size fail3:k = error+7; ->failed; !*context fail2:k = error+5; pos2 = 0; ->failed; !*type fail0:k = error+3; ->failed; !*too complex fail1:k = atom1; pos2 = 0 failed: %IF diag&32 # 0 %START printstring("Atom1 =") write(atom1, 3) printstring(" Atom2 =") write(atom2, 3) printstring(" subatom =") write(subatom, 3) newline printstring("Type =") write(type, 1) printstring(" Ptype =") write(ptype, 1) newline printstring("App =") write(app, 1) printstring(" Papp =") write(papp, 1) newline printstring("Format =") write(format, 1) printstring(" Pformat =") write(pformat, 1) newline %monitor %FINISH quote = 0 %AND readsym %WHILE sym # nl %AND sym # ';' %IF k&error # 0 %START fault(k&255) %FINISH %ELSE %START %IF prot err = nmin %THEN fault(14) %ELSE fault(0) %FINISH gg = 0; ss = 0; symtype = 0 %END; !of analyse %ROUTINE compile %CONSTINTEGER then = 4, else = 8, loop = 16 %SWITCH c(0:actions), litop(1:12) %CONSTBYTEINTEGERARRAY operator(1:14) = %C '[', ']', 'X', '/', '&', '!', '%', '+', '-', '*', 'Q', 'x', '.', 'v' %CONSTBYTEINTEGERARRAY cc(0 : 7) = '#','=',')','<','(','>', 'k','t' %CONSTBYTEINTEGERARRAY anyform(0:15) = 1,0,1,1(4),1,0,1,1,0,1,1,1,1 %CONSTSHORTINTEGERARRAY decmap(0:15) = %C 1, 2, 16_100B, 16_100D, 16_140C, 16_140E, 3, 4, 16_1007, 16_1008, 16_1009, 16_100A, 6, 0, 0, 0 %OWNBYTEINTEGERARRAY cnest(0:15) %INTEGER lmode, clab, dupid %INTEGER resln %OWNINTEGER last def = 0 %OWNINTEGER lb, ub %INTEGER cp, ord %INTEGER next, link, j, k, n, done %INTEGER class %INTEGER lit2, defs, decs, cident %INTEGER pending; %OWNINTEGERARRAY pstack(1:40) %OWNSTRING(8) name = "" %OWNINTEGER count = 0 %ROUTINE def lab(%INTEGER l) op(':', l) access = 1 %END %ROUTINE get next %RECORD(arfm)%NAME p; !imp77: gn: %IF next = 0 %START; !end of phrase class = 0 %AND %RETURN %IF link = 0; !end of statement p == ar(link) next = p_link link = p_sub %FINISH %CYCLE p == ar(next) x = p_sub class = p_class %EXIT %IF class < actions; !an atom %IF x = 0 %START; !null phrase next = p_link; ->gn %FINISH %IF p_link # 0 %START; !follow a phrase p_sub = link; link = next %FINISH next = x %REPEAT next = p_link %IF diag&2 # 0 %START spaces(8-length(name)) %UNLESS name = "" name = text(class) write(x, 2) space printstring(name) space count = count-1 %IF count <= 0 %START count = 5 name = "" newline %FINISH %FINISH %END %ROUTINE set subs(%INTEGER n) !update the app field in n array descriptors %INTEGER p p = tmax %WHILE n > 0 %CYCLE %SIGNAL 15,15 %IF p < tbase tag(p)_app = dimension p = p-1; n = n-1 %REPEAT %END %ROUTINE set bp !define a constant bound pair from the last stacked constants pending = pending-2 lb = pstack(pending+1); ub = pstack(pending+2) %IF ub < lb-1 %START pos1 = 0; next = link; fault(11) ub = lb %FINISH set const(lb); set const(ub) put('b') %UNLESS class = 146 %END %ROUTINE compile end(%INTEGER type) ! type = 0:eof, 1:eop, 2:end %IF access # 0 %START open = 0 fault(19) %IF block form > proc; !can reach end %FINISH %WHILE dict(dmin) >= 0 %CYCLE; !finishes & repeats fault(17+dict(dmin)&1) dmin = dmin+1 %REPEAT {delete names(0)} put(';') put(';') %IF type = 1; !endofprogram bflags = bflags!open; !show if it returns def lab(0) %IF block tag # 0 %AND level # 1; !for jump around %IF type # 2 %START; !eop, eof fault(16) %IF level # type; !end missing %FINISH %ELSE %START %IF level = 0 %START fault(15); !spurious end %FINISH %FINISH !end mark = 11; !IMP77 %END %ROUTINE def(%INTEGER p) !dump a descriptor %INTEGER t, f, type %RECORD(tagfm)%NAME v; !imp77: defs = defs+1 v == tag(p) t = 0 put('$') %UNLESS v_index < 0 %START; !no index for subnames id = id+1 %AND v_index = id %IF v_index = 0 last def = v_index putword(lastdef) %FINISH %else putword(0) print ident(p, 1); !output the name t = v_flags type = t type = type&(\(7<<4)) %IF type&(7<<4) >= 6<<4;!routine & pred put(','); put(type&2_1111111); !type & form f = v_format f = tag(f)_index %IF t&16_70 = record<<4 f = v_index %IF f < 0 op(',', f); !format f = otype+t>>4&2_1111000 f = f!8 %IF class = 125; !add spec from %DUP dim = v_app; !dimension dim = 0 %unless 0 < dim <= dim limit put(','); putlong(f+dim<<8); !otype & spec & prot defs = 0 %IF t¶meters = 0 f = t&15 %IF v_flags&spec # 0 %START v_flags = v_flags&(\spec) %UNLESS 3 <= f <= 10 ocount = -1; ! external specs have no constants %FINISH dimension = 0 %if otype = 2 %and (f=2 %or f=12 %or f=14) %start v_flags = v_flags-1; !convert to simple %finish %END %ROUTINE def s lab(%INTEGER n) !define a switch label, x defines the switch tag %INTEGER p, l, b, w, bit p = tag(x)_format; !pointer to table l = dict(p); !lower bound %IF l <= n <= dict(p+1) %START b = n-l w = b>>4+p bit = 1<<(b&15) %IF dict(w+2)&bit # 0 %START; !already set fault(4) %IF pending # 0 %RETURN %FINISH dict(w+2) <- dict(w+2)!bit %IF pending # 0 set const(n) op('_', tag(x)_index) %FINISH %ELSE %START fault(12) %FINISH access = 1 %END %ROUTINE call %RECORD(tagfm)%NAME T; !IMP77: t == tag(x) op('@', t_index) access = 0 %IF t_flags&closed # 0; !never comes back put('E') %IF t_app = 0; !no parameters %END %ROUTINE pop def set const(pstack(pending)); pending = pending-1 %END %ROUTINE pop lit %IF pending = 0 %THEN lit = 0 %ELSE %START lit = pstack(pending); pending = pending-1 %FINISH %END %IF sstype < 0 %START; !executable statement %IF level = 0 %START; !outermost level fault(13); !*order %FINISH %ELSE %START %IF access = 0 %START access = 1; fault(-1); !only a warning %FINISH %FINISH %FINISH %IF diag&2 # 0 %START newline %IF sym # nl printstring("ss =") write(ss, 1) newline count = 5 name = "" %FINISH next = ss pending = 0; lmode = 0 link = 0; decs = 0 defs = 0; resln = 0; done = 0 ord = level ord = 1 %IF this >= 0; !recordformat declarations c(0): top: %IF next # link %START get next; ->c(class) c(*):debug("* Switch label not set: c(".itos(class,0).")"); %stop %FINISH !all done, tidy up declarations and jumps newline %IF diag&2 # 0 %AND count # 5 %IF lmode&(loop!then!else) # 0 %START; !pending labels and jumps op('B', label-1) %IF lmode&loop # 0; !repeat def lab(label) %IF lmode&then # 0; !entry from then def lab(label-1) %IF lmode&else # 0; !entry from else %FINISH %RETURN %IF decs = 0 atom1 = error %AND %RETURN %IF atom1 # 0; !%INTEGERROUTINE order = ord decl = decl&(\15)+decmap(decl&15); !construct declarator flags atom1 = atoms(decl&15); !generate class %IF otype # 0 %START; !own, const etc. atom1 = atom1+1 %IF atom1 # proc %IF otype = 2 %START; !const n = decl&15 %if n&1 # 0 %start decl = decl!prot decl = decl!const bit %IF decl&2_1111111 = iform %finish %else decl = decl!own bit %FINISH %FINISH sstype = 1 %IF sstype = 0 %AND atom1 = proc atom1 = atom1+1 %IF decl&spec # 0; !onto spec variant ocount = 0 %AND cont = '+' %IF atom1 = 5; !own array %IF anyform(decl&15) = 0 %START; !check meaningful %IF decl>>4&7 = record %START this = fdef %IF tag(fdef)_flags&spec # 0 atom1 = error+21 %IF fdef = this; !*context for format %FINISH atom1 = error+10 %IF fdef = 0; !*size %FINISH %RETURN atop: access = 0; ->top ! declarators c(88): !rtype c(28): decl = x&(\7); !stype fdef = x&7; !precision fdef = reals ln %IF x&2_1110001 = real<<4+1; !convert to long decs = 1; ->top c(34): !own c(35): otype = x; ord = 1; ->top; !external c(152):decl = decl+x<<1; ->top; !xname c(31): !proc c(32): spec mode = level+1; !fn/map decl = decl!prot %IF x = 9; !function c(29): ord = 1; !array dim = 0 c(30): decl = decl+x; !name decs = 1 ->top c(27): lit = 0; ! arrayd %IF pending # 0 %START pop lit %UNLESS 0 top c(37): x = x!subname; !record c(36): lit = 0; !string %IF pending # 0 %START pop lit %UNLESS 0 < lit <= 255 %START; !max length wrong atom1 = error+10; %RETURN %FINISH %FINISH fdef = lit; !format or length c(33): decl = x; !switch decs = 1 ->top c(39): decl = decl!spec; !spec ocount = -1; !no initialisation spec mode = -1 ->top c(38): decl = 64+4; !recordformat (spec) order = 1 atom1 = x decl = decl!spec %if atom1 = 12; !formatspec fdef = tmax+1; !format tag %return c(175):id = id+1; tag(x)_index = id; %return; !FSID c(41): decs = 1; decl = x!spec; ->top; !label c(133):recid = 0; rbase = tmin-1; !fname this = x fm base = fdef; format list = tmin def(this); ->top c(148):fdef = 0 %AND ->top %IF next = 0; !reclb get next; !skip name fdef = x ->top c(127):put('}'); ->top; !%POUT c(126):put('{'); ->top; !%PIN c(174):set bp; !rangerb c(171): !fmlb c(172): !fmrb c(173):put('~'); put(class-171+'A'); ->top; !fmor c(168):rbase = -rbase; !orrb sstype = 0; spec mode = 0 c(147):search base = 0; !recrb tag(this)_app = tmin tag(this)_format = rbase ->top c(45):put('U') %IF x = 36; ->top; !sign c(46):put('\'); ->top; !uop c(47): !mod c(48): !dot c(42): !op1 c(43): !op2 c(44):put(operator(x)); ->top; !op3 !conditions & jumps %ROUTINE push(%INTEGER x) %IF cnest(cp)&2 # x %START cnest(cp) = cnest(cp)!1; x = x+4 %FINISH clab = clab+1 %IF cnest(cp)&1 # 0 cnest(cp+1) = x; cp = cp+1 %END %ROUTINE pop label(%INTEGER mode) lmode = dict(dmin) %IF lmode < 0 %OR lmode&1 # mode %START fault(mode+8) %FINISH %ELSE %START dmin = dmin+1; label = label-3 %FINISH %END c(56): !and c(57):push(x); ->top; !or c(58):cnest(cp) = cnest(cp)!!2; ->top; !not c(138):x = 128+32+16+4; !csep: treat like %WHILE c(59): !while c(60):%IF class = 138 %THEN op('f', label-1) %C %ELSE def lab(label-1); !until c(166): !runtil c(62):lmode = (lmode&(else!loop)) !(x>>3); !cword clab = label; cp = 1; cnest(1) = x&7 ->top c(72):pop label(0); !repeat def lab(label+1) %IF lmode&32 # 0; ->atop c(69):pop label(1); ->top; !finish c(163): !xelse c(70):pop label(1); !finish else ... fault(7) %IF lmode&3 = 3; !dangling else c(68):lmode = (lmode&else)!3; !...else... %IF access # 0 %START op('F', label-1); lmode = else!3 %FINISH def lab(label) ->top %IF next # 0 c(120): !%MSTART c(67): !start c(71): !cycle stcy: def lab(label-1) %AND lmode = loop %IF lmode = 0;!cycle dmin = dmin-1; abandon(3) %IF dmin <= dmax dict(dmin) = lmode label = label+3 %RETURN c(64):fault(13) %IF dict(dmin) >= 0 %OR inhibit # 0; !on event inhibit = 1 last array = tmax-1 n = 0 n = 16_FFFF %IF pending = 0; !* = all events %WHILE pending > 0 %CYCLE pop lit; fault(10) %IF lit&(\15) # 0;!too big j = 1<stcy c(104):op('J', tag(x)_index); !l inhibit = 1; ->atop c(149):stats = stats-1; !lab access = 1; inhibit = 1 fault(13) %IF x < last array; !jump round array dec op('L', tag(x)_index); ->top c(63):j = dmin; l = label-3; !exit, continue %CYCLE fault(7) %AND ->top %IF dict(j) < 0 %EXIT %IF dict(j)&1 = 0 j = j+1; l = l-3 %REPEAT l = l+1 %IF x = 32; !continue op('F', l) dict(j) = dict(j)!x; !show given ->atop c(50):put('C'); ->cop; !acomp c(49): %IF next # 0 %START; !comparator put('"'); push(0); !double sided %FINISH %ELSE %START put('?') %FINISH cop: x = x!!1 %IF cnest(cp)&2 # 0; !invert the condition j = cp; l = clab %WHILE cnest(j)&4 = 0 %CYCLE j = j-1; l = l-cnest(j)&1 %REPEAT op(cc(x), l) def lab(clab+1) %IF cnest(cp)&1 # 0 cp = cp-1 clab = clab-cnest(cp)&1 ->top c(78): !fresult c(79): !mresult c(80): open = 0; !return, true, false c(82): access = 0; !stop c(89): !addop c(81): put(x); ->top; !monitor c(65): pop lit; op('e', lit); ->atop; !signal c(51): put('S'); ->top; !eq c(53): put('j'); ->top; !jam transfer c(52): put('Z'); ->top; !eqeq c(74):%IF level = 0 %START; !begin %IF progmode <= 0 %THEN progmode = 1 %ELSE fault(7) {Permit BEGIN after external defs} %FINISH spec mode = level+1 block x = 0 put('H'); %RETURN c(77):perm = 0; lines = 0; stats = 0; !endofperm debug("close input {input stream=".itos(input stream,0)."}") close input debug("select input(source=".itos(source,0).")") select input(source); sym = nl list = list-1 list = list -1 %if command & listbit # 0 tbase = tmax; tstart = tmax %RETURN c(76):%IF include # 0 %AND x = 0 %START; !end of ... lines = include; sstype = 0; !include debug("close input {input stream=".itos(input stream,0)."}") close input list = include list include = 0; debug("select input(source=".itos(source,0).")") select input(source); sym = nl; %RETURN %FINISH ss = -1; !prog/file c(75):compile end(x); %RETURN; !%END c(85):%IF x=0 %THEN control=lit %ELSE %START; !control diag = lit&16_3FFF %IF lit>>14&3 = 1 %FINISH op('z'-x, lit) ->top c(83):list = list+x-2; ->top; !%LIST/%ENDOFLIST c(84):reals ln = x; ->top; !%REALS long/normal c(86):%IF include # 0 %START; !include "file" fault(7); %RETURN %FINISH get next; !sconst include file = string(x-16_4000+stbase) open input(3, include file) include = lines; lines = 0 include list = list debug("select input(3)") select input(3); sym = nl ->top c(154):dimension = dimension+1; !dbsep fault(11) %IF dimension = dim limit+1 ->top c(145):set bp; ->top; !crb c(146):set bp; !rcrb c(142): !bplrb dimension = 1 %IF dimension = 0 op('d', dimension); op(',', defs) %IF class # 146 %START set subs(defs) last array = tmax-1 fault(13) %IF dict(dmin) >= 0 %OR inhibit # 0 %OR level=0 %FINISH dimension = 0; defs = 0 ->top c(128):id = dupid; ->top; !EDUP c(130):block x = x op('F', 0) %IF decl&spec = 0 %AND level # 0; !jump round proc c(125):dupid = id; !%DUP c(90): def(x); ->top; !ident c(131): !cident %IF tag(x)_flags&(2_1111111+const bit) = iform+const bit %START tag(x)_format = lit %FINISH %ELSE %START set const(lit) %IF pending # 0 def(x) put('A'); putlong(1) %FINISH cident = x ->top c(124):dubious = 1 %IF tag(cident)_flags&prot # 0; !%DUBIOUS ->top c(97): !f c(98): !m c(99): !p c(96): call; ->top; !r c(165): !nlab c(100): !rp c(101): !fp c(102): !mp c(103): !pp c(91): !v c(92): !n c(106): !a c(107): !an c(108): !na c(109): !nan k = tag(x)_index %IF k < 0 %THEN op('n', -k) %ELSE op('@', k) ->top c(121):set const(0); ->top; !special for zero c(167):put('G'); ->pstr; !aconst (alias) c(const): !const %IF x < 0 %START; !constinteger set const(tag(-x)_format); ->top %FINISH %IF x&16_4000 # 0 %START; !strings put('''') pstr: x = x-16_4000+stbase k = byteinteger(x) putblock(k+1, byteinteger(x)) -> top %FINISH %IF x&16_2000 # 0 %START; !real x = x-16_2000+stbase k = byteinteger(x) op('D', k); put(',') k = k+x %CYCLE ->top %IF x = k x = x+1; j = byteinteger(x) %IF j = '@' %START op('@', litpool(byteinteger(x+1))); ->top %FINISH put(j) %REPEAT %FINISH set const(lit pool(x)) ->top c(137):put('i'); ->top; !asep c(141):put('a'); ->top; !arb !own arrays c(132):ocount = ub-lb+1 def(x); !oident dimension = 1; set subs(1) %IF next = 0 %START; !no initialisation %IF ocount > 0 %start put('A'); putlong(ocount) %finish ocount = -1 %FINISH %ELSE %START; !initialisation given get next %FINISH ->top c(162):lit = ocount; ->ins; !indef c(143):pop lit; !orb ins: fault(10) %AND lit = 0 %IF lit < 0 get next ->inst c(139): !osep (x=19) c(153):lit = 1 inst: pop def %IF pending # 0; !ownt (x=0) put('A'); putlong(lit) ocount = ocount-lit %IF ocount >= 0 %START ->top %IF x # 0; !more coming ocount = -1 %AND %RETURN %IF ocount = 0; !all done %FINISH fault(11); %RETURN c(swit):op('W', tag(x)_index); inhibit = 1; ->atop c(134):def(x); !swid n = ub-lb+1 n = (n+15)>>4; !slots needed (includes zero) j = dmax; dmax = dmax+n+2 abandon(1) %IF dmax >= dmin tag(x)_format = j dict(j) = lb; dict(j+1) = ub %CYCLE n = n-1 ->top %IF n < 0 j = j+1; dict(j+1) = 0 %REPEAT c(151):stats = stats-1; !slab fault(7) %AND %RETURN %IF x < tbase %IF pending # 0 %START; !explicit label def s lab(pstack(1)) %FINISH %ELSE %START fault(4) %AND %RETURN %IF tag(x)_app # 0 tag(x)_app = 1 n = tag(x)_format %FOR j = dict(n), 1, dict(n+1) %CYCLE; !imp77: def s lab(j); !imp77: %REPEAT; !imp77: %FINISH inhibit = 1 %RETURN c(140):put('p'); ->top; !psep c(144):put('p'); put('E'); ->top; !prb !constant expressions c(155): !pconst %IF x < 0 %THEN lit = tag(-x)_format %ELSE lit = lit pool(x) pending = pending+1; pstack(pending) = lit; ->top c(156):lit = pstack(pending); lit = -lit %IF lit < 0 pstack(pending) = lit; ->top; !cmod c(157):-> top %if X#36 { JGH fix to %const %integer X = +1 => -1 bug } lit = -pstack(pending); pstack(pending) = lit; ->top; !csign c(158):lit = \pstack(pending); pstack(pending) = lit; ->top; !cuop c(159): !cop1 c(160): !cop2 c(161):pending = pending-1; !cop3 lit2 = pstack(pending+1); lit = pstack(pending) ->litop(x>>2) litop(*):debug("* Switch label not set: litop(".itos(x>>2,0).") {x=".itos(x,2)."}"); %stop litop(10):lit = lit*lit2; ->setl litop(12): litop(3):n = 1; !lit = lit\\lit2 fault(10) %IF lit2 < 0 %WHILE lit2 > 0 %CYCLE lit2 = lit2-1 n = n*lit %REPEAT lit = n; ->setl litop(1):lit = lit<setl litop(2):lit = lit>>lit2; ->setl litop(5):lit = lit&lit2; ->setl litop(11): litop(4):%IF lit2 = 0 %THEN fault(10) %ELSE lit = lit//lit2 ->setl litop(8):lit = lit+lit2; ->setl litop(9):lit = lit-lit2; ->setl litop(6):lit = lit!lit2; ->setl litop(7):lit = lit!!lit2 setl: pstack(pending) = lit; ->top c(170): !option string put('~'); put('D') ->pstr !string resolution c(135):resln = 2; ->top; !dotl c(136):resln = resln+1; ->top; !dotr c(55): op('r', resln); resln = 0; ->top; !resop c(164):op('r', resln+4); resln = 0; !cresop c(122):x = 6; ->cop; !%PRED c(87):set const(pstack(1)); !mass put('P'); ->top %END %END; !of compile block debug("ENTERED PASS1 object tank=".itos(object tank,0)." *************") %ON 9 %START debug("[3]%ON 9 %START:") abandon(5) %FINISH selectoutput(listing) ;!!!!!!!!!!!!!!!! THIS FAILS !debug("A: object tank=".itos(object tank,0)) %if command & list bit # 0 %start printstring(" Computer Science VAX-11 IMP77 Compiler. Version 8.02 Compiled on ".date." at ".time) newlines(2) debug("select input(1)") select input(1) printstring(" Source file: ".infilename) newline; newline !debug("B: object tank=".itos(object tank,0)) %finish !debug("C: object tank=".itos(object tank,0)) debug("select input(prims=".itos(prims,0).")") select input(prims) debug("select output tank(object tank=".itos(object tank,0).")") select output tank(object tank) tag(max tag) = 0; !%BEGIN defn tag(0) = 0; tag(0)_flags = 7; !%BEGIN tag! %FOR x = 0, 1, max names %CYCLE; !imp77: hash(x) = 0; !imp77: %REPEAT; !imp77: include file = "" put('l'); putword(0) compile block(0, 0, max dict, 0, 0) %result = -faulty %IF faulty # 0; !imp77: %ENDOFPROGRAM %result = stats %end %endoffile