%external %routine %spec close output %external %routine %spec close input %external %routine %spec open output(%integer i, %string(255) s) %external %routine %spec open input(%integer i, %string(255) s) %recordformat impcomfm(%integer statements, flags, code, gla, diags, perm, %string(31) file, %string(63) Option) %externalrecord(impcomfm) IMPCOM ! ! On EMAS all shorts should be changed to integers. ! Also, the INCLUDE facility will need to be modified. ! ! !################################################### ! Copyright: 1 January 1980 # ! Interactive Datasystems (Edinburgh) Ltd. # ! 32 Upper Gilmore Place # ! Edinburgh EH3 9NJ # ! All Rights Reserved # !################################################### %BEGIN %CONSTSTRING(4) version = "8.4" !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 = 800; !max no. of tags %CONSTINTEGER max dict = 6000; !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, include level= 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 %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 = 1; !<= to enable %OWNINTEGER control = 0 %OWNINTEGER diag = 0; !diagnose flags %SHORTINTEGERARRAY hash(0:max names) %RECORD(tagfm)%ARRAY tag(0:max tag) %SHORTINTEGERARRAY dict(1:max dict) %BYTEINTEGERARRAY buff(1:512) %OWNINTEGER bp = 0 !*** start of generated tables *** %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", "REALSLN","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=719 %owninteger gmax=719 %constinteger imp phrase =25 %ownshortintegerarray phrase(200:255) = %C 0, 564, 565, 567, 569, 571, 573, 562, 614, 203, 200, 602, 478, 480, 624, 298, 206, 308, 318, 433, 426, 437, 444, 458, 453, 461, 467, 482, 402, 627, 629, 603, 521, 511, 486, 502, 575, 527, 528, 543, 550, 578, 397, 287, 197, 636, 516, 621, 167, 0, 0, 0, 640, 693, 701, 709 %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 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, 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, -32551, 0, 0, 0, 0, 13, 0, 14, 4, -32557, 16, -32550, 0, 0, 5, 6, 3, 12, 15, 8, 7, 9, 10, 11, -32558, -32554, -32559, -32552, -32553, 18, 22, 17, 21, 19, 0, 0, 0, -32562, -32560, 0, 0, 0, -32561, 0, 0, 0, 0, 0, 0, 0, 1, 2, 0, -32556, 0, -32555, 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, -28588, -12270, -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-719) %ownshortintegerarray glink(0:max grammar) = %c -1, 71, 72, 38, 46, 47, 67, 67, 75, 67, 0, 67, 51, 76, 79, 53, 55, 80, 67, 81, 82, 83, 67, 84, 26, 41, 85, 86, 57, 57, 89, 93, 96, 97, 102, 103, 104, 107, 46, 67, 67, 0, 110, 110, 111, 52, 49, 0, 61, 67, 62, 0, 67, 0, 111, 112, 112, 58, 113, 114, 115, 64, 67, 66, 116, 117, 68, 0, 67, 122, 67, 0, 73, 123, 123, 67, 77, 67, 40, 77, 67, 67, 0, 124, 127, 128, 87, 86, 0, 90, 131, 89, 0, 94, 93, 0, 132, 98, 137, 100, 97, 0, 138, 67, 105, 104, 0, 108, 107, 0, 67, 67, 67, 139, 140, 141, 0, 118, 120, 116, 142, 116, 67, 71, 125, 67, 0, 67, 129, 85, 0, 143, 133, 144, 135, 145, 0, 156, 157, 59, 158, 67, 119, 91, 159, 146, 145, 148, 146, 151, 0, 153, 153, 154, 146, 0, 99, 160, 67, 134, 161, 162, 165, 161, 141, 162, 162, 168, 172, 174, 175, 176, 177, 178, 179, 182, 185, 188, 189, 180, 190, 190, 183, 191, 191, 186, 191, 191, 0, 188, 192, 193, 194, 0, 196, 0, 0, 198, 197, 0, 201, 200, 0, 204, 205, 0, 228, 232, 219, 234, 235, 0, 236, 237, 238, 0, 232, 226, 244, 245, 221, 248, 249, 250, 251, 245, 0, 252, 229, 249, 250, 251, 253, 0, 0, 188, 254, 260, 239, 269, 269, 242, 191, 191, 270, 246, 272, 272, 229, 273, 274, 275, 276, 0, 255, 266, 266, 258, 267, 267, 261, 266, 266, 264, 267, 267, 232, 268, 232, 0, 277, 0, 278, 232, 273, 232, 282, 283, 279, 285, 253, 0, 0, 286, 0, 232, 0, 288, 0, 290, 0, 292, 294, 0, 0, 297, 0, 0, 299, 301, 0, 303, 0, 305, 0, 307, 0, 0, 310, 313, 314, 315, 0, 0, 316, 311, 314, 0, 332, 332, 328, 349, 350, 351, 351, 351, 351, 330, 282, 352, 358, 0, 333, 341, 347, 359, 360, 361, 362, 363, 0, 342, 343, 345, 0, 346, 0, 269, 269, 0, 0, 366, 353, 371, 372, 373, 374, 0, 375, 376, 377, 383, 384, 364, 385, 385, 367, 269, 269, 269, 269, 389, 390, 391, 392, 393, 0, 378, 360, 361, 362, 341, 0, 379, 380, 386, 363, 341, 0, 353, 354, 355, 375, 395, 0, 396, 0, 400, 269, 269, 401, 0, 411, 411, 406, 417, 407, 418, 419, 420, 0, 412, 418, 419, 420, 421, 0, 409, 406, 424, 417, 422, 425, 425, 408, 415, 427, 430, 431, 0, 426, 432, 428, 434, 436, 0, 433, 269, 269, 441, 442, 282, 443, 0, 446, 451, 447, 446, 452, 451, 0, 449, 448, 454, 453, 457, 0, 455, 459, 458, 0, 269, 464, 465, 282, 466, 0, 469, 469, 470, 471, 472, 473, 474, 475, 476, 477, 0, 479, 269, 481, 0, 483, 485, 485, 205, 490, 488, 496, 497, 491, 494, 490, 0, 491, 491, 0, 498, 499, 501, 0, 0, 504, 506, 510, 499, 508, 0, 506, 506, 504, 512, 513, 514, 515, 0, 517, 518, 519, 520, 0, 522, 523, 524, 525, 522, 0, 528, 529, 531, 536, 532, 534, 0, 532, 0, 537, 538, 539, 541, 542, 542, 0, 544, 546, 0, 547, 548, 549, 533, 551, 553, 558, 554, 556, 0, 554, 0, 559, 560, 557, 0, 563, 205, 0, 566, 564, 568, 565, 570, 567, 572, 569, 574, 571, 576, 575, 0, 579, 580, 592, 593, 584, 205, 585, 588, 588, 588, 590, 205, 594, 594, 595, 596, 597, 581, 600, 598, 601, 0, 205, 205, 205, 606, 606, 607, 608, 609, 605, 610, 612, 0, 193, 193, 193, 193, 193, 193, 193, 193, 0, 623, 623, 192, 626, 626, 0, 626, 626, 631, 633, 282, 282, 634, 282, 282, 637, 638, 639, 0, 650, 677, 684, 666, 655, 205, 205, 205, 205, 650, 659, 668, 685, 666, 0, 662, 686, 666, 662, 668, 685, 0, 670, 674, 689, 666, 205, 0, 205, 0, 674, 689, 205, 0, 666, 205, 0, 680, 692, 680, 659, 668, 685, 0, 650, 687, 662, 688, 205, 690, 691, 666, 680, 697, 697, 697, 697, 698, 699, 700, 0, 703, 703, 704, 706, 707, 708, 708, 700, 711, 711, 712, 713, 719, 719, 719, 719, 719, 719, 0, 0(max grammar-719) %constshortintegerarray kdict(32:607) = %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, 2044, 2240, 2272, 128, 2312, 128, 128, 128, 2331, 2339, 2371, 2379, 2399, 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, 2407, 131, 2379, -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, -32301, 16412, 33, -31924, 10190, 9938, 9793, 16468, 1, 10063, 71, 16468, 4, -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 !*** end of generated tables *** %ROUTINE flush buffer %INTEGER j %IF faulty = 0 %START select output(object) %FOR j = 1, 1, bp %CYCLE printsymbol(buff(j)) %REPEAT select output(listing) %FINISH bp = 0 %END %ROUTINE print ident(%INTEGER p, mode) %INTEGER j, ad p = tag(p)_text %IF p = 0 %START bp = bp+1 %AND buff(bp) = '?' %if Mode # 0 %RETURN %FINISH ad = addr(dict(p+1)) %IF mode = 0 %THEN printstring(string(ad)) %ELSE %START %FOR j = ad+1, 1, ad+byteinteger(ad) %CYCLE bp = bp+1 buff(bp) = byteinteger(j) %REPEAT %FINISH %END %ROUTINE abandon(%INTEGER n) %SWITCH reason(0:9) %INTEGER stream stream = listing %CYCLE newline %IF sym # nl printsymbol('*'); write(lines,4); space ->reason(n) 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 reason(5):printstring("input ended: ") %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 !IMP80 BUG??? %SIGNAL 15,15 %IF diag&4096 # 0 %STOP %END %ROUTINE op(%INTEGER code, param) buff(bp+1) <- code buff(bp+2) <- param>>8 buff(bp+3) <- param bp = bp+3 %END %ROUTINE set const(%INTEGER m) buff(bp+1) <- 'N' buff(bp+5) <- m; m = m>>8 buff(bp+4) <- m; m = m>>8 buff(bp+3) <- m; m = m>>8 buff(bp+2) <- m bp = bp+5 %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 access; access = 1; !non-zero if accessible %INTEGER inhibit; inhibit = 0; !non-zero inhibits declaratons %SHORTINTEGERNAME 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(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 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(-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 "); Print Ident(x, 0); ->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 %if n >= 0 %start !IMP80 BUG??? %signal 15,15 %if diag&4096 # 0 %stop %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 %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 flush buffer %IF bp >= 128 %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 > 0 %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) %RECORD(tagfm)%NAME v %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) %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 %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 = x'3000', order bit = x'1000' %CONSTINTEGER escape = x'1000' %INTEGER strp, mark, flags, prot err, k, s, c %OWNINTEGER key = 0 %SHORTINTEGER node %SHORTINTEGERNAME z %RECORD(arfm)%NAME arp !emas: %INTEGER node !emas: %INTEGERNAME z %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 get sym readsymbol(sym) pos = pos+1 %IF pos # 133 char(pos) = sym printsymbol(sym) %IF list <= 0 column = column+1 %END %ROUTINE read sym %owninteger Last = 0 %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 Last = 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 !IMP80 BUG??? !! char(1) = error sym byteinteger(addr(char(0))+1) = error sym sym = error sym; error sym = 0 ->s5 %FINISH %FINISH %FINISH s2: symtype = 1 %FINISH s3:readsymbol(sym) pos = pos+1 %IF pos # 133 char(pos) = sym printsymbol(sym) %IF list <= 0 column = column+1 s5:%IF sym # nl %START Last = Sym %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 sym ->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 nextsymbol = nl %START; !%C... getsym; cont = '+'; ->s1 %FINISH %ELSE symtype = key&3-2 %FINISH %RETURN %FINISH s4:symtype = quote ->S1 %if last = 0 %and Quote = 0 Cont = '+' %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 !emas: %LONGINTEGER k0 %INTEGER new !first locate the text of the name new = addr(dict(dmax+1)) !******** Machine code to inhibit overflow test ******** ! *LI_1,magic ! * M_0,hash value ! *ST_1,K2 {K2 = hash value*magic} K2 = hash value*magic ;! requires NOCHECK option ! we could fix this properly by a shift+add loop !******************************************************* k2 = k2>>(32-2*name bits)!1 !emas: k0 = magic !emas: k1 = (k0*hash value)&X'7FFFFFFF' !emas: k2 = k1>>(32-2*name bits)!1 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; !don't 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 <- t_Flags-Spec %RETURN %FINISH %IF 7 <= decl&15 <= 10 %AND decl&spec = 0 %START !procedure definition after spec %IF (decl!!atom flags)&b'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 = x %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 %OR %C Level = Include Level !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; atom flags = 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' <= nextsymbol <= '9' %FINISH !locate atom in fixed dict k = key>>2; read sym %CYCLE j = kdict(k) %EXIT %IF j&x'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)&x'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 nextsymbol # 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)!x'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 nextsymbol # 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 pt = pt+1; byteinteger(pt) = '_' 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; n = base; base = 0; get(n) %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)!x'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 bp = bp+1; buff(bp) = n&7+'0' %end atom1 = error %AND %RESULT=0 %UNLESS symtype = -2; !starts with letter flush buffer %IF bp >= 128 bp=bp+1 %AND buff(bp)='w' %CYCLE bp=bp+1 %AND buff(bp)=sym read sym %EXIT %IF symtype >= 0; !pull in letters and digits %REPEAT bp=bp+1 %AND buff(bp)='_' %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 %if atom1 = 104 {label} %and %C Tag(Subatom)_Flags&Closed = 0 %start This = Subatom; Atom1 = Error+21 %result = 0 %finish op(' ', tag(subatom)_index) %FINISH %ELSE %START atom1 = error; %result=0 %FINISH %FINISH %FINISH %ELSE %START bp=bp+1 %AND buff(bp)=sym; read sym %FINISH %REPEAT %FINISH bp=bp+1 %AND buff(bp)=';' %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):->Fail2 %if Type # 0 %and Type # Integer %and %C Type # Real 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; !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 {or added?} 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 {fault record comparisons} ->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 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) %FINISH ->act(class); !only actions left 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 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): !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 !IMP80 BUG??? %SIGNAL 13,15 %STOP %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, x'100B', x'100D', x'140C', x'140E', 3, 4, x'1007', x'1008', x'1009', x'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 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 !IMP80 BUG??? %SIGNAL 15,15 %IF p < tbase %STOP %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 < 0 %START pos1 = 0; next = link; fault(11) ub = lb %FINISH set const(lb); set const(ub) bp=bp+1 %AND buff(bp)='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)} bp=bp+1 %AND buff(bp)=';' bp=bp+1 %AND buff(bp)=';' %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; !******Mouses specific****** %END %ROUTINE def(%INTEGER p) !dump a descriptor %INTEGER t, f, type %RECORD(tagfm)%NAME v flush buffer %if bp # 0 defs = defs+1 v == tag(p) t = 0 %UNLESS v_index < 0 %START; !no index for subnames id = id+1 %AND v_index = id %IF v_index = 0 last def = v_index t = last def %FINISH op('$', t) print ident(p, 1); !output the name t = v_flags type = t type = type&(\(7<<4)) %IF type&(7<<4) >= 6<<4;!routine & pred op(',', type&b'1111111'); !type & form f = v_format f = tag(f)_index %IF t&x'70' = record<<4 f = v_index %IF f < 0 op(',', f); !format f = otype+t>>4&b'1111000' f = f!8 %IF class = 125; !add spec from %DUP dim = v_app; !dimension dim = 0 %unless 0 < dim <= dim limit op(',', 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 t == tag(x) op('@', t_index) access = 0 %IF t_flags&closed # 0; !never comes back bp=bp+1 %AND buff(bp)='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) %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&b'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&b'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!closed; ->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):bp=bp+1 %AND buff(bp)='}'; ->top; !%POUT c(126):bp=bp+1 %AND buff(bp)='{'; ->top; !%PIN c(174):set bp; !rangerb c(171): !fmlb c(172): !fmrb c(173):bp=bp+1 %AND buff(bp)='~'; bp=bp+1 %AND buff(bp)=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):bp=bp+1 %and buff(bp)='U' %IF x = 36; ->top; !sign c(46):bp=bp+1; buff(bp)='\'; ->top; !uop c(47): !mod c(48): !dot c(42): !op1 c(43): !op2 c(44):bp=bp+1; buff(bp)=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 n = 0 n = x'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 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):bp=bp+1 %AND buff(bp)='C'; ->cop; !acomp c(49): bp = bp+1 %IF next # 0 %START; !comparator buff(bp)='"'; push(0); !double sided %FINISH %ELSE %START buff(bp)='?' %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): bp=bp+1 %AND buff(bp)=x; ->top; !monitor c(65): pop lit; op('e', lit); ->atop; !signal c(51): bp=bp+1 %AND buff(bp)='S'; ->top; !eq c(53): bp=bp+1 %AND buff(bp)='j'; ->top; !jam transfer c(52): bp=bp+1 %AND buff(bp)='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 bp=bp+1 %AND buff(bp)='H'; %RETURN c(77):perm = 0; lines = 0; stats = 0; !endofperm close input select input(source) list = list-1 tbase = tmax; tstart = tmax %RETURN c(76):%IF include # 0 %AND x = 0 %START; !end of ... lines = include; sstype = 0; !include close input list = include list include level = 0 include = 0; select input(source); %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&x'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-x'4000'+stbase) %begin %on 9 %start; Abandon(9); %finish open input(3, include file) %end include = lines; lines = 0 include list = list; include level = level select input(3) ->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) 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 %return %if Level < 0 {spec about} c(90): def(x); ->top; !ident c(131): !cident %IF tag(x)_flags&(b'1111111'+const bit) = iform+const bit %START tag(x)_format = lit %FINISH %ELSE %START set const(lit) %IF pending # 0 def(x) op('A', 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):bp=bp+1; buff(bp)='G'; ->pstr; !aconst (alias) c(const): !const %IF x < 0 %START; !constinteger set const(tag(-x)_format); ->top %FINISH %IF x&x'4000' # 0 %START; !strings bp=bp+1 %AND buff(bp)='''' pstr: x = x-x'4000'+stbase k = byteinteger(x) bp=bp+1 %AND buff(bp)=k k = k+x %CYCLE ->top %IF x = k x = x+1; bp=bp+1 %AND buff(bp)=byteinteger(x) %REPEAT %FINISH %IF x&x'2000' # 0 %START; !real x = x-x'2000'+stbase k = byteinteger(x) op('D', k); bp=bp+1 %AND buff(bp)=',' k = k+x %CYCLE ->top %IF x = k x = x+1; j = byteinteger(x) %IF j = '@' %START op('@', litpool(byteinteger(x+1))); ->top %FINISH bp=bp+1 %AND buff(bp)=j %REPEAT %FINISH set const(lit pool(x)) ->top c(137):bp=bp+1 %AND buff(bp)='i'; ->top; !asep c(141):bp=bp+1 %AND buff(bp)='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 op('A', ocount) %IF ocount > 0 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) op('A', 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 def s lab(j) flush buffer %IF bp >= 128 %REPEAT %FINISH inhibit = 1 %RETURN c(140):bp=bp+1 %AND buff(bp)='p'; ->top; !psep c(144):buff(bp+1)='p'; buff(bp+2)='E'; bp=bp+2; ->top; !prb !constant expressions c(155): !pconst %IF x < 0 %THEN lit = tag(-x)_format %c %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):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(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):Fault(4) %if IMPCOM_Option # "" IMPCOM_Option = String(x-x'4000'+Stbase); !Option string ->Top !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 bp=bp+1 %AND buff(bp)='P'; ->top %END %END; !of compile block %ON 9 %START abandon(5) %FINISH impcom_flags = 0 impcom_option = "" list = 15 %IF Impcom_Flags&x'1000' # 0 open output(2, "LISTING"); open input(2, "prims.inc"); select input(2); selectoutput(listing) tag(max tag) = 0; !%BEGIN defn tag(0) = 0; tag(0)_flags = 7; !%BEGIN tag! Hash(x) = 0 %FOR x = 0, 1, max names printstring(" Edinburgh IMP77 Compiler - Version ") printstring(version); newlines(2) op('l', 0) compile block(0, 0, max dict, 0, 0) bp=bp+1 %AND buff(bp)=nl {for bouncing off} flush buffer Impcom_Statements = stats Impcom_Statements = -faulty %IF faulty # 0 %ENDOFPROGRAM