! IMP77 compiler first pass !to create an EMAS version: ! ! d*//* ! m-0 (f/!imp77:/ l* i/!imp77:/ m)* ! On EMAS all shorts should be changed to integers. ! ! Also, the INCLUDE facility will need to be modified. ! ARRAYS CHAR,MAPPED,ANYFORM,CNEST BECOME INTEGER ! ! !#########%c ##########%c ################################ ! Copyright: 1 January%c 1980 # ! INTERACTIVE DATASYSTEMS%c (EDINBURGH) LTD. # ! Peter S. Robertson%c # ! 32 Upper Gilmore Place%c # ! Edinburgh EH3 9NJ%c # ! all rights reserved%c # !#########%c ##########%c ################################ %external %integer %fn pass1 %const %integer temporary= x'40000000'; !EMAS %external %string (30) %fn %spec imp11version ! %external %routine %spec ssmess %alias "S#SSMESS"(%integer n) %external %routine %spec ssmess(%integer n) !EMAS %external %routine %spec move %alias "S#MOVE"(%integer length,from,to) %external %integer %map %spec comreg %alias "S#COMREGMAP"(%integer n) !EMAS: %external %routine %spec setwork %alias "S#SETWORK"(%integer %name ad,f) !EMAS: %record %format rfm(%integer conad,a,b,c,d,e,f,g,h,j,k,l) !EMAS: %record %format chdrform(%integer conad,filetype,datastart,dataend) %external %routine %spec connect %alias "S#OLDCONNECT"(%string (255) file, %integer mode,hole,prot, %record (chdrform) %name r, %integer %name flag) !EMAS: %external %routine %spec out file %alias "S#OUTFILE"(%string (255) file, %integer size,hole,prot, %integer %name conad,flag) !EMAS: %const %integer fw only=b'1000000000' !configuration parameters %const %integer MAX INT=214748364; !EMAS !EMAS: %constinteger max int = ((-1)>>1)//10 %const %integer MAX DIG=7; !EMAS !EMAS: %constinteger max dig = (-1)>>1-maxint*10 %const %integer BYTE SIZE= 8; !bits per byte %const %integer MAX TAG= 700; !max no. of tags %const %integer MAX DICT= 4000; !max extent of dictionary %const %integer NAME BITS= 11 %const %integer MAX NAMES= 1<0 strings, <0 chars %own %integer CONT= ' ', CSYM = ' '; !listing continuation marker %own %integer DECL= 0; !current declarator flags %own %integer DIM= 0; !arrayname dimension %own %integer SPEC GIVEN= 0 %own %integer ESCAPE CLASS= 0; !when and where to escape %own %integer PROTECTION=0, ATOM FLAGS=0 %own %integer OTYPE= 0; !current 'own' type %own %integer REALS LN= 1; ! =4 for %realslong %own %integer LAST1= 0; !previous atom class %own %integer GEN TYPE= 0 %own %integer PTYPE= 0; !current phrase type %own %integer PAPP= 0; !current phrase parameters %own %integer PFORMAT= 0; !current phrase format %own %integer FORCE= 0; !force next ptype %own %integer G= 0, GG = 0, MAP GG = 0; !grammar entries %own %integer FDEF= 0; !current format definition %own %integer THIS= -1; !current recordformat tag %own %integer NMIN= 0; !analysis record atom pointer %own %integer NMAX= 0; !analysis record phrase pointer %own %integer RBASE= 0; !record format definition base %own %integer STBASE= 0; !constant work area base %own %integer GMIN= MAX GRAMMAR; !upper bound on grammar %own %integer DMAX= 1 %own %integer TMIN= MAX TAG; !upper bound on tags %own %integer SS= 0; !source statement entry %string (63) INCLUDE FILE %own %integer INCLUDE LIST= 0 %own %integer INCLUDE= 0; !=0 unused, #0 being used %own %integer PERM= 1; !1 = compiling perm, 0 = program %own %integer PROGMODE= 0; !-1 = file, 1 = begin/eop %own %integer SSTYPE= 0; !-1:exec stat ! 0: declaration ! 1: block in ! 2: block out %own %integer SPEC MODE= 0; !>=0: definition ! -1: proc spec ! -2: recordformat %own %integer OCOUNT= -1; !own constants wanted %own %integer LIMIT= 0; !lookup limit %own %integer COPY= 0; !duplicate name flag %own %integer ORDER= 0; !out of sequence flag %own %integer FOR WARN= 0; !non-local flag %own %integer DUBIOUS= 0; !flag for dubious statements %own %integer DP= 1 %own %integer POS1= 0, POS2 = 0; !error position %own %integer POS= 0; !input line index %own %integer DIMENSION= 0; !current array dimension %own %integer LOCAL= 0; !search limit for locals %own %integer FM BASE= 0; !entry for format decls %own %integer SEARCH BASE= 0; !entry for record_names %own %integer FORMAT LIST= 0; !size of current format list %integer RECID %own %integer %array CHAR(0:133)=nl(134); !input line %integer %array LIT POOL(0:LIT MAX) %own %integer LIT= 0; !current literal (integer) %own %integer LP= 0; !literals pointer %own %integer BLOCK X= 0; !block tag %extrinsic %integer permad; !EMAS* %external %integer LIST= 1; !<= to enable - SHOULD BE OWN %own %integer CONTROL= 0 ! CONTROL&1 = <1> NO TYPE CHECKS ON RECORD ASSIGNMENT. ! CONTROL&2 = <1> PERMIT %return IN FUNCTIONS AND MAPS %own %integer DIAG= 0; !diagnose flags %integer %array HASH(0:MAX NAMES) %record (TAGFM) %array TAG(0:MAX TAG) !IMP77: %record(tagfm)%array tag(0:max tag) %integer %array DICT(1:MAX DICT) %own %integer buffsize; !EMAS: %byte %integer %array %name BUFF; !EMAS: %byte %integer %array %format bufffm(1:x'200000'); !EMAS: !EMAS: %byteintegerarray buff(1:512) %own %integer BP= 0 !*** start of generated tables *** ! %endoflist %const %string (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" %const %integer GMAX1= 718 %own %integer GMAX= 718 %const %integer IMP PHRASE= 25 %own %integer %array PHRASE(200:255)= %c 0, 563, 564, 566, 568, 570, 572, 561, 613, 203, 200, 601, 477, 479, 623, 302, 206, 312, 322, 432, 425, 436, 443, 457, 452, 460, 466, 481, 401, 626, 628, 602, 520, 510, 485, 501, 574, 526, 527, 542, 549, 577, 396, 291, 197, 635, 515, 620, 167, 0, 0, 0, 639, 692, 700, 708 %const %byte %integer %array 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> %const %integer %array 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> %own %integer %array 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, -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, 194, -28581, 4188, 16407, 216, 194, -28566, -28565, 186, -28566, 4203, 194, -28564, -28563, 186, -28564, 4205, 183, 183, 186, 183, -16365, 0, 183, -28583, -16328, 0, 4580, 16429, 5095, 183, 9444, 5348, 9437, 186, 16409, -16365, 0, 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, 6116, -32719, 0, 6116, -28581, 4188, 218, 122, 50, 16409, -32726, -32725, -32724, -32719, 4096, 4836, 454, 195, 195, 195, 454, -28581, 4188, 194, -28566, -28565, -28564, 4205, 195, 195, 195, 194, -32719, 0, 5095, 4829, -32726, -32725, -32724, -32719, 4096, 4827, 4828, 454, -32720, -32719, 4096, 4829, 4827, 4828, 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( 1002) %own %integer %array 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, 252, 0, 255, 229, 249, 250, 251, 256, 0, 0, 188, 257, 263, 239, 272, 272, 242, 191, 191, 273, 246, 275, 275, 229, 279, 280, 281, 253, 282, 282, 283, 0, 258, 269, 269, 261, 270, 270, 264, 269, 269, 267, 270, 270, 232, 271, 232, 0, 284, 0, 276, 285, 256, 0, 232, 279, 232, 286, 287, 288, 232, 276, 0, 290, 0, 0, 292, 0, 294, 0, 296, 298, 0, 0, 301, 0, 0, 303, 305, 0, 307, 0, 309, 0, 311, 0, 0, 314, 317, 318, 319, 0, 0, 320, 315, 318, 0, 336, 336, 332, 351, 352, 353, 353, 353, 353, 334, 287, 354, 360, 0, 337, 345, 349, 361, 362, 363, 364, 365, 0, 346, 348, 0, 0, 272, 272, 0, 0, 368, 355, 373, 374, 375, 376, 0, 377, 379, 380, 386, 387, 366, 388, 388, 369, 272, 272, 272, 272, 392, 393, 394, 360, 395, 0, 0, 381, 362, 363, 364, 345, 0, 382, 383, 389, 365, 345, 0, 355, 356, 357, 0, 399, 272, 272, 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, 272, 272, 440, 441, 287, 442, 0, 445, 450, 446, 445, 451, 450, 0, 448, 447, 453, 452, 456, 0, 454, 458, 457, 0, 272, 463, 464, 287, 465, 0, 468, 468, 469, 470, 471, 472, 473, 474, 475, 476, 0, 478, 272, 480, 0, 482, 484, 484, 205, 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, 205, 0, 565, 563, 567, 564, 569, 566, 571, 568, 573, 570, 575, 574, 0, 578, 579, 591, 592, 583, 205, 584, 587, 587, 587, 589, 205, 593, 593, 594, 595, 596, 580, 599, 597, 600, 0, 205, 205, 205, 605, 605, 606, 607, 608, 604, 609, 611, 0, 193, 193, 193, 193, 193, 193, 193, 193, 0, 622, 622, 192, 625, 625, 0, 625, 625, 630, 632, 287, 287, 633, 287, 287, 636, 637, 638, 0, 649, 676, 683, 665, 654, 205, 205, 205, 205, 649, 658, 667, 684, 665, 0, 661, 685, 665, 661, 667, 684, 0, 669, 673, 688, 665, 205, 0, 205, 0, 673, 688, 205, 0, 665, 205, 0, 679, 691, 679, 658, 667, 684, 0, 649, 686, 661, 687, 205, 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( 1002) %const %integer %array 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 *** !EMAS: %routine flush buffer !EMAS: %integer j !EMAS: %if faulty = 0 %start !EMAS: select output(object) !IMP77: %for j = 1, 1, bp %cycle; !imp77: !IMP77: PRINTSYMBOL(buff(j)); !imp77: !IMP77: %repeat; !imp77: !EMAS: %if bp > 0 %start !EMAS: %cycle j = 1,1,bp !EMAS: print ch(buff(j)) !EMAS: %repeat !EMAS: %finish !EMAS: select output(listing) !EMAS: %finish !EMAS: bp = 0 !EMAS: %end %routine PRINT IDENT(%integer P,MODE) %integer J,AD P = TAG(P)_TEXT %if P=0 %start %if MODE=0 %then printsymbol('?') %else BP = BP+1 %and BUFF(BP) = '?' %return %finish AD = addr(DICT(P+1)) %if MODE=0 %then printstring(string(AD)) %else %start !IMP77: %for j = ad+1, 1, ad+BYTEINTEGER(ad) %cycle; !imp77: !IMP77: bp = bp+1; !imp77: !IMP77 buff(bp) = BYTEINTEGER(j); !imp77: !IMP77 %repeat; !imp77: %cycle J = AD+1,1,AD+byteinteger(AD) BP = BP+1 BUFF(BP) = byteinteger(J) %repeat %finish %end %routine ABANDON(%integer N) %switch REASON(0:12) %integer STREAM STREAM = LISTING %cycle newline %if SYM#nl printsymbol('*') %if N=10 %or N=12 %start; !EMAS write(LINES,4); space %finish; !EMAS ->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) %else printsymbol(SQUOTE) %finish %else %start printstring("%endof") %if PROGMODE>=0 %then printstring("program") %else %c 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 REASON(10):printstring("cannot create IMP#INT file ") ssmess(flag) ->MORE REASON(11):printstring(" program too large ") ->MORE REASON(12):printstring("cannot set workfile T#WRK") ssmess(flag) MORE: newline printstring("*** compilation abandoned ***"); newline %exit %if STREAM=REPORT STREAM = REPORT select output(REPORT) %repeat ! %signal 15,15 %if diag&4096 # 0 ;! INVALID EVENT %stop %end %routine PADDR(%integer M) !!! %integer n !!! n = m>>3 !!! paddr(n) %if n # 0 !!! put(m&7+'0') BUFF(BP+4) = M&255; M = M>>8 BUFF(BP+3) = M&255; M = M>>8 BUFF(BP+2) = M&255; M = M>>8 BUFF(BP+1) = M BP = BP+4 %end %routine OP(%integer CODE,PARAM) !!! put(code) !!! paddr(param) BUFF(BP+1) = CODE BUFF(BP+2) = PARAM>>8 BUFF(BP+3) = PARAM&255 BP = BP+3 %end %routine SET CONST(%integer M) !!! %integer v !!! v = m !!! v = -m %if v < 0 !!! put('N') !!! paddr(v) !!! put('U') %if m < 0 BUFF(BP+1) = 'N' BUFF(BP+5) = M&255; M = M>>8 BUFF(BP+4) = M&255; M = M>>8 BUFF(BP+3) = M&255; M = M>>8 BUFF(BP+2) = M BP = BP+5 %end %routine COMPILE BLOCK(%integer LEVEL,BLOCK TAG,DMIN,TMAX,ID) %integer %fn %spec GAPP %routine %spec DELETE NAMES(%integer QUIET) %routine %spec ANALYSE %routine %spec 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 %integer %name 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 %integer %name 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 !EMAS: 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"); ->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 ! %signal 15,15 %if diag&4096 # 0 ;! INVALID EVENT NUMBER %if N#13 %start; !order is fairly safe OCOUNT = -1 GG = 0 COPY = 0; QUOTE = 0 SEARCH BASE = 0; ESCAPE CLASS = 0 %finish FAULTY = FAULTY+1 !check that there haven't been too%c ! 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%c (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 %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 froma block? %finish %cycle ANALYSE %continue %if SS=0 COMPILE FAULT(-5) %if DUBIOUS#0 !EMAS: 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 %integer %fn GAPP; !generate app grammar (backwards) %const %integer COMMA= 140; !psep %routine %spec SET CELL(%integer G,TT) !IMP77: %routinespec class(%record(tagfm)%name v); !imp77: ! IMP77: %record(tagfm)%name v; !imp77: %routine %spec 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,%c 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 !EMAS: %routine class(%record(tagfm)%name v); !imp77: %routine CLASS(%record (tagfm) %name V) !NOTIMP80 %recordspec v(tagfm) %const %integer ERR= 89 %const %integer RTP= 100 %const %integer FNP= 101 %const %integer MAPP= 102 %const %integer PREDP= 103 %const %integer %array 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&PARAMETERS#0 %end %stop %end %routine DELETE NAMES(%integer QUIET) %integer FLAGS !IMP77: %record(tagfm)%name tx; !imp77: %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 but no definition %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 %const %integer ORDER BITS= x'3000', ORDER BIT = x'1000' %const %integer ESCAPE= x'1000' %integer STRP,MARK,FLAGS,PROT ERR,K,S,C %own %integer KEY= 0 !IMP77: %integer node; !imp77: !IMP77: %integername z; !imp77: !IMP77: %record(arfm)%name arp; !imp77: %integer NODE %integer %name Z %record (ARFM) %name ARP %switch ACT(ACTIONS:PHRASAL),PACTION(0:15) %routine TRACE ANALYSIS !diagnostic trace routine (diagnose&1%c # 0) %integer A %routine SHOW(%integer A) %if 0>8&15 %if A#0 %start printsymbol('{') write(A,0) printsymbol('}') %finish %if ATOM1#LA1 %or ATOM2#LA2 %or LSA#SUBATOM %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 !EMAS: readsymbol(sym) %if sptr>=send %then ABANDON(5); !EMAS: SYM = byteinteger(sptr); !EMAS: sptr = sptr+1; !EMAS: nextsym = byteinteger(sptr); !EMAS: POS = POS+1 %if POS#133 CHAR(POS) = SYM printsymbol(SYM) %if LIST<=0 COLUMN = COLUMN+1 %end %routine READ SYM %const %integer %array 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 S11: POS = 0; POS1 = 0; POS2 = 0; MARGIN = 0; COLUMN = 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: !EMAS: readsymbol(sym) %if sptr>=send %then ABANDON(5); !EMAS: SYM = byteinteger(sptr); ! EMAS sptr = sptr+1; !EMAS: nextsym = byteinteger(sptr); !EMAS: POS = POS+1 %if POS#133 CHAR(POS) = SYM printsymbol(SYM) %if LIST<=0 COLUMN = COLUMN+1 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 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 nextsym=nl %start; !%c... GETSYM; CONT = '+'; ->S1 %finish %finish %else %start SYMTYPE = KEY&3-2 %finish %return %finish S4: CONT = '+' SYMTYPE = QUOTE %end %integer %fn 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) %const %integer MAGIC= 6700421 %integer NEW NAME,VID,K1,K2,FORM !IMP77: %record(tagfm)%name t; !imp77: %record (TAGFM) %name T %long %integer K0 %integer NEW !first locate the text of the name NEW = addr(DICT(DMAX+1)) !IMP77: k2 = (hash value*magic)>>(32-2*name bits)!1; !IMP77: K0 = MAGIC K1 = (K0*HASH VALUE)&x'7FFFFFFF' 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 XNOT 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&PARAMETERS#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; ! ready for analysis %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=INTEGERX %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)&b'1111111'=0 %start !correct type? T_FLAGS = T_FLAGS-SPEC SPEC GIVEN = 1 %return %finish !note that an external procedure must%c 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 %or APP<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%c used in the file in which !they are defined, so inhibit a%c 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%c 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'<=nextsym<='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%c 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%c marker (pos1) to point !to the faulty character in an atom,%c but care needs to be taken !to prevent misleading reports in%c cases like ...????? ERR: ATOM1 = ERROR+1; ATOM2 = 0 POS1 = POS %if POS-POS1>2 %return !take care with strings and symbol%c constants. !make sure the constant is valid here%c before sucking it in !(and potentially loosing many lines) SYMBOLS: ATOM1 = VAR; ATOM2 = CONST; TYPE = INTEGERX MAP GG = CONST; PROTECTION = PROT SUBATOM = LP; ABANDON(3) %if LP>=LIT MAX QUOTE = \PEND QUOTE %return !an integer constant is acceptable so%c get it in and !get the next atom CHARS: N = 0; CONT = CQUOTE %cycle READ SYM %if SYM=CQUOTE %start %exit %if nextsym#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%c 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%c 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 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 = INTEGERX; 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))&x'0FFFFFFF' !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' %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 %integer %fn 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 !EMAS: 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=INTEGERX %start %if SUBATOM<0 %then OCTAL(TAG(-SUBATOM)_FORMAT) %else %c OCTAL(LITPOOL(SUBATOM)) %finish %else %start %if 91<=ATOM1<=109 %start 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 !deal with alignment following an%c error in one statement !of several on a line MARGIN = COLUMN; !start of statement POS = 0 APP = 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=INTEGERX 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 %or CONTROL&1#0 ->FAIL2 ACT(197):ARP == AR(NMIN) K = ARP_SUB ARP_SUB = K>>4 ->FAIL3 %unless BLOCK FORM=K&15 %or CONTROL&2#0 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 = INTEGERX ->MORE %if TYPE=INTEGERX %or TYPE=0 ->FAIL2 %finish ->FAIL2 %unless PTYPE=REAL FORCE = INTEGERX %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=3 %start; ! check for 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 = INTEGERX; PFORMAT = -1; ->A3 PACTION(5):->A3 %if PTYPE=INTEGERX 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=INTEGERX; 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=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%c 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 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=INTEGERX %if SUBATOM<0 %then LIT = TAG(-SUBATOM)_FORMAT %else %c 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):PROT ERR = NMIN %and ->A7 %if PROTECTION&PROT#0; !%prot ->MORE 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 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 %signal 13,15 %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 %const %integer THEN= 4, ELSE = 8, LOOP = 16 %switch C(0:ACTIONS),LITOP(1:12) %const %byte %integer %array OPERATOR(1:14)= %c '[', ']', 'X', '/', '&', '!', '%', '+', '-', '*', 'Q', 'x', '.', 'v' %const %byte %integer %array CC(0:7)= '#','=',')','<','(','>', 'k','t' %const %integer %array ANYFORM(0:15)= 1,0,1,1(4),1,0,1,1,0,1,1,1,1 %const %integer %array 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 %own %integer %array CNEST(0:15) %integer LMODE,CLAB,DUPID %integer RESLN %own %integer LAST DEF= 0 %own %integer LB,UB %integer CP,ORD %integer NEXT,LINK,J,K,N,DONE %integer CLASS %integer LIT2,DEFS,DECS,CIDENT %integer PENDING; %own %integer %array PSTACK(1:40) %own %string (8) NAME= "" %own %integer COUNT= 0 %routine DEF LAB(%integer L) OP(':',L) ACCESS = 1 %end %routine GET NEXT !IMP77: %record(arfm)%name p; !imp77: %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 CLASSGN %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%c descriptors %integer P P = TMAX %while N>0 %cycle ! %signal 15,15 %if p < tbase ;!INVALID EVENT TAG(P)_APP = DIMENSION P = P-1; N = N-1 %repeat %end %routine SET BP !define a constant bound pair from%c 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 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 !IMP77: PRINTSYMBOL(11); !IMP77: %end %routine DEF(%integer P) !dump a descriptor %integer T,F,TYPE !IMP77: %record(tagfm)%name v; !imp77: %record (TAGFM) %name V 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 DIM = 0 %unless 0>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 !IMP77: %record(tagfm)%name T; !IMP77: %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 %finish %else %start 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; DIM = 0; !array C(30): DECL = DECL+X; !name DECS = 1 ->TOP C(27): LIT = 0; ! arrayd %if PENDING#0 %start POP LIT %unless 0TOP C(37): X = X!SUBNAME; !record C(36): LIT = 0; !string %if PENDING#0 %start POP LIT %unless 0TOP 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; ! fsid TAG(X)_INDEX = ID %return 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): 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 %and BUFF(BP) = '\'; ->TOP; !uop C(47): !mod C(48): !dot C(42): !op1 C(43): !op2 C(44): BP = BP+1 %and 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) %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 = 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 FAULT(13) %if XTOP 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) %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 !EMAS: close input !EMAS: select input(source) sptr = com46+32; !EMAS: send = com46+integer(com46); !EMAS: LIST = LIST-1 TBASE = TMAX; TSTART = TMAX %return C(76): %if INCLUDE#0 %and X=0 %start; !end of ... LINES = INCLUDE; SSTYPE = 0; !include !EMAS: close input LIST = INCLUDE LIST INCLUDE = 0 !EMAS: select input(source) sptr = oldsptr; !EMAS: send = oldsend; !EMAS: bp = bp+1; buff(bp) = '~' bp = bp+1; buff(bp) = 'E' %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) !EMAS: open input(3, include file) ABANDON(9) %if comreg(0)#0 connect(INCLUDE FILE,0,0,0,r,flag); !EMAS: %if flag#0 %then ABANDON(9); !EMAS oldsptr = sptr; oldsend = send; !EMAS: sptr = r_conad+32; !EMAS: send = r_conad+integer(r_conad); ! EMAS: INCLUDE = LINES; LINES = -1 INCLUDE LIST = LIST bp = bp+1; buff(bp) = '~' bp = bp+1; buff(bp) = 'D' bp = bp+1 move(length(include file)+1,addr(include file),addr(buff(bp))) bp = bp+length(include file) !EMAS: 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) 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&(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 %and 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 GG = 0 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= 128 !IMP77: %repeat; !imp77: %cycle J = DICT(N),1,DICT(N+1); !EMAS: DEF S LAB(J); !EMAS: %repeat; !EMAS: %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 %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): !option string BUFF(BP+1) = '~'; BUFF(BP+2) = 'D'; BP = BP+2 ->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 BP = BP+1 %and BUFF(BP) = 'P'; ->TOP %end %end; !of compile block !!!!! %on 9 %start !!!!! abandon(5) !!!!! %finish !IMP77: list = 15 %if comreg(14)&x'1000' # 0; !IMP77: !EMAS: selectinput(2) X = comreg(14); !EMAS: %if X=0 %start; !EMAS: setwork(X,flag); !EMAS: %if flag#0 %then ABANDON(12); !EMAS: %finish; !EMAS: buffsize = integer(X+8)-32; !EMAS: outfile("IMP#INT",buffsize+32,0,temporary,outconad,flag) !EMAS: ABANDON(10) %if FLAG#0 outptr = outconad+32; !EMAS: outend = outconad+x'40000'; !EMAS: BUFF == array(outptr,bufffm); !EMAS: com46 = comreg(46); !EMAS: ABANDON(5) %if com46=0; !EMAS: sptr = permad+32; !EMAS: send = permad+integer(permad); !EMAS: %if comreg(27)&2#0 %then LIST = 2; !EMAS: selectoutput(LISTING) TAG(MAX TAG) = 0; !%begin defn TAG(0) = 0; !%begin tag! TAG(0)_FLAGS = 7 !IMP77: %for x = 0, 1, max names %cycle; !imp77: !IMP77: hash(x) = 0; !imp77: !IMP77: %repeat; !imp77: %cycle X = 0,1,MAX NAMES HASH(X) = 0 %repeat printstring(" Edinburgh IMP77 Compiler - Version ") printstring(imp11VERSION); newlines(2) OP('l',1) COMPILE BLOCK(0,0,MAX DICT,0,0) BP = BP+1 %and BUFF(BP) = nl; !for bouncing off !EMAS: flush buffer integer(outconad) = BP+32; !EMAS: comreg(46) = outconad; !EMAS: %result = STATS %if FAULTY=0; !EMAS: %result = -FAULTY; !EMAS: %end %end %of %file