Edinburgh IMP77 Compiler - Version 8.4 1 !IMP syntax checker - based on M68000 IMP compiler 2 ! (qv for fuller annotation) 3 ! Hamish Dewar Computer Science Edinburgh University 1983 4 ! 5 %constinteger MAXNAME=127 6 %recordformat EDFILE(%integer start1,lim1, {part 1} 7 start2,lim2, {part2} 8 lim, {VMLIM} 9 lbeg,fp,change,flag, 10 line {line number of current pos}, 11 diff {diff between LINE and ROW}, 12 shift {right shift of window on file}, 13 %byteinteger top {top row of sub_window}, 14 win {floating top}, 15 bot {bottom row +1 of sub_window}, 16 min {minimum window size}, 17 row {last row position}, 18 col {last col position}, 19 %string(maxname) name) 20 ! 21 %external%routine%spec EDI(%record(edfile)%name main,sec, 22 %string(255) message) 23 %external%routine%spec CONNECT EDFILE(%record(edfile)%name f) 24 %external%routine%spec DISCONNECT EDFILE(%record(edfile)%name f) 25 ! 26 !$IF VAX 27 %conststring(13) permfile="ECCE_PERM" 28 !$IF AMDAHL 29 {%conststring(18) permfile="ERCLIB:VECCE.IPERM" 30 !$FINISH 31 32 !! control 33 %constinteger logbit= 16_00040000 {print log}, 34 warnbit= 16_00020000 {print warnings}, 35 nonsbit= 16_00010000 {print nonstandard reports}, 36 DICTLIST= 16_00001000 {list dict entries}, 37 EXPLIST= 16_00000800 {list EXP entries} 38 %owninteger control=warnbit+nonsbit 39 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 40 %externalroutine ECCECI(%record(edfile)%name main) 41 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 42 %ownstring(maxname) extraname 43 %ownrecord(edfile) extra=0,null=0 44 %integer curstart,curlim 45 %integer nonstop 46 %owninteger change=0 47 !! Fault numbers 48 %constinteger FORMERR=0, ATOMERR=1, NAMERR=2, CATERR=3, SIZERR=4, 49 ASSERR=5, TYPERR=6, DUPERR=7, 50 NOSTART=8, NOCYCLE=9, 51 ORDERERR=10, MATCHERR=11, RANGERR=12, NONLITERAL=13, 52 BOUNDSERR=14, ACCESSERR=15, NOTINLOOP=16, 53 NOTINROUT=17, NOTINFUN=18, NOTINPRED=19, 54 PLEXERR=20, NOIF=21, NONSTAND=22, NOTIN=23, 55 INDEXERR=24, 56 MOPERR=27, NOTERM=28, NONSTARTER=29, 57 NONVAR=30, NONREF=31, TOOMANY=32, TOOFEW=33, 58 UNWANTED=34, NOPARM=35, UNENDING=37, 59 SELFREF=38 60 %constinteger NOEND=40, NOBEGIN=41, 61 IDMISSING=42, NOFINISH=43, NOREPEAT=44, 62 COUNTERR=45, NORESULT=46 63 %constinteger ERRMAX=46 64 %constinteger POINT=64,WARN=128 65 %owninteger FAULTNUM=0 66 %owninteger FAULTS=0; !fault count 67 ! 68 %constinteger MAXINT=16_7FFFFFFF, MININT=\MAXINT, 69 MAX10=maxint//10, MAXDIG=maxint-max10*10 70 %constinteger FALSE=0, TRUE=1 71 %integer I 72 ! 73 !! Program statistics 74 %owninteger STATEMENTS=0; !statement count 75 !%owninteger ATOMS=0; !atom count 76 !%owninteger IDENTATOMS=0; !identifier count 77 !%owninteger NUMATOMS=0; !numeric atom count 78 !%owninteger MISSES=0; !ident mismatches 79 !%owninteger ZAPS=0 80 ! 81 !!!!!!!!!!!!!!!! Operand Representation !!!!!!!!!!!!!!!!!!! 82 83 %constinteger SMALLMIN=-1000, SMALLMAX=1000, 84 LITMIN=smallmax+1, LITMAX=smallmax+1000, 85 D0=litmax+1, D1=d0+1, D2=d0+2, D6=d0+6, D7=d0+7, 86 A0=d0+8, A1=a0+1, A6=a0+6, A7=a0+7, 87 INDA0=a0+8, 88 POSTA0=inda0+8, POSTA7=posta0+7, 89 PREA0=posta0+8, PREA7=prea0+7, 90 DICTMIN=prea0+8, DICTMAX=prea0+1200, 91 LABMIN=dictmax+1, LAB1=labmin+1, LABMAX=labmin+20, 92 EXPMIN=labmax+1, EXPMAX=labmax+300, 93 UNDEF=expmax+1, AD=16_4000 94 %constinteger MAXDREG=d0+4, MAXAREG=a0+3 95 %constinteger D0B=1, D1B=2, D2B=4, 96 A0B=16_100, A1B=16_200, A2B=16_400 97 %constinteger ALLREGS=2_0000111100011111; !a3:a0 & d4:d0 98 %owninteger FREE=allregs 99 %constinteger NULLTYPE=dictmin, 100 RECY=nulltype+1, ARRY=recy+1, STRINGY=arry+1, 101 REALY=stringy+1, INTY=realy+1, 102 CHARTYPE=inty+1, BOOLTYPE=chartype+1, 103 FALSECONST=booltype+1, TRUECONST=booltype+2, 104 INTTYPE=trueconst+1, SHORTTYPE=inttype+1, 105 HALFTYPE=shorttype+1, BYTETYPE=halftype+1, 106 MITETYPE=bytetype+1, BITTYPE=MITETYPE+1, 107 LONGINTTYPE=bittype+1, 108 REALTYPE=longinttype+1, LONGREALTYPE=realtype+1 109 %constinteger PURETYPE=8191, DIRECT=8192, INDIRECT=16384 110 %constinteger ANYINT=inty+direct, ANYINTVAR=inty+indirect, 111 ANYSTRING=stringy+direct, ANYSTRINGVAR=stringy+indirect 112 %constinteger ANYNAME=nulltype+indirect 113 114 ! 115 %owninteger dictshown=dictmin 116 117 !!!!!!!!!!!!!!!!!!!!!!! Big Literals !!!!!!!!!!!!!!!!!!!!!!! 118 %owninteger LITPOS=litmin, SLITPOS=litmax 119 %integerarray LITSTORE(litmin:litmax) 120 ! 121 !!!!!!!!!!!!!!!!!!!!!!!!!! MODE VALUES !!!!!!!!!!!!!!!!!!!!!!!!! 122 !Size codes: 123 %constinteger bytesize=1, wordsize=2, longsize=3 124 %constinteger sizemask=16_C0, sizeshift=6 125 !Address modes: 126 %constinteger dmode=0, amode=2_001000, 127 indmode=2_010000, postmode=2_011000, premode=2_100000, 128 dispmode=2_101000, indexmode=2_110000, absmode=2_111000, 129 pcmode=2_111010, litmode=2_111100 130 %constinteger ownmode=dispmode+6; !d(A6) 131 ! 132 !!!!!!!!!!!!!!!!!!!!!!!! Identifiers !!!!!!!!!!!!!!!!!!!!!!!! 133 ! 134 %recordformat OBJINFO %C 135 (%integer flags,type, 136 (%integer extra, %byteinteger spare,mode %or %integer low), 137 %integer val) 138 %recordformat IDENTINFO %C 139 ((%integer flags,type, 140 (%integer extra, %byteinteger spare,mode %or %integer low), 141 %integer val %or %record(objinfo) details), 142 %integer text,link) 143 ! 144 ! Significance of FLAGS: 145 %constinteger VAR=16_0001, LAB=16_0002, PROC=16_0004, STATIC=16_0008, 146 SPEC=16_0010, EXT=16_0020, PARM=16_0040, MORE=16_0080, 147 TYPEID=16_0100, OKFLAG=16_0200, ALT=16_0800, 148 RFLAG=16_1000,WFLAG=16_2000 149 ! 150 ! Significance of VAL: 151 ! for literal : the actual value 152 ! for variable : machine address (displacement) 153 ! for undefined label : reference chain 154 ! for undefined procedure : " 155 ! for base type : (index to) range 156 ! for record type : size of record in bytes 157 ! 158 ! Identifier dictionary: 159 %record(identinfo)%array DICT(d0:labmax) 160 ! indexing DICT: 161 %owninteger DLIM=trueconst+1; !dict limit (up) 162 %owninteger DLIM0 163 %owninteger PERMLIM=dictmin 164 %owninteger DMIN=dictmax-1; !dict upper limit (down) 165 166 ! Text of identifiers (indexed by _TEXT): 167 %constinteger CHARBOUND=6000 168 %byteintegerarray CHAR(0:charbound) 169 %integer CHARBASE,CHARLIM,CHARMIN; !pointers 170 %integer NEWLEN 171 172 ! Hash index to DICT: 173 %integerarray HASHINDEX(0:255) 174 %integername HEAD; !head of ident search list 175 ! 176 !!!!!!!!!!!!!!!!!!!!! Complex operands !!!!!!!!!!!!!!!!!!!!!!! 177 !%recordformat EXPINFO(%integer act,x,y) 178 !%record(expinfo)%array EXP(expmin:expmax) 179 %owninteger EXPLO=expmax+1, OLDEXPLO=expmax+1 180 %constinteger NP0=expmin 181 %owninteger NP,CONDNP,INSTNP 182 183 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 184 !!!!!!!!!!!!!!!!!! Keywords and operators !!!!!!!!!!!!!!!!!!!! 185 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 186 !*!!!!!!! Keyword codes -- used by KEYGEN to produce tables !! 187 %constinteger END=1 {end}, 188 REPEAT=2 {repeat}, 189 FINISH=3 {finish}, 190 ELSE=4 {else}, 191 BEGIN=5 {begin}, 192 EXIT=6 {exit_1,continue_0}, 193 RETURN=7 {return}, 194 TF=8 {true_1,false_0}, 195 RESULT=9 {result}, 196 STOP=10 {stop}, 197 GOTO=11 {goto}, 198 SIGNAL=12 {signal}, 199 MONITOR=13 {monitor}, 200 ON=15 {on}, 201 IU=16 {if_0,unless_1}, 202 WHILE=17 {while}, 203 UNTIL=18 {until_1}, 204 FOR=19 {for}, 205 THEN=20 {then}, 206 START=21 {start}, 207 CYCLE=22 {cycle}, 208 KEYLABEL=23 {label}, 209 PREFIX=24 {const_9,constant_9,own_8,external_40,system_40,dynamic_40}, 210 KRANGE=25 {short_1,half_2,byte_3,mite_4,bit_5}, 211 KEYLONG=26 {long}, 212 KEYINTEGER=27 {integer}, 213 KEYREAL=28 {real}, 214 KEYSTRING=29 {string}, 215 KEYRECORD=30 {record}, 216 KEYFORMAT=31 {format}, 217 FNMAP=32 {fn_0,function_0,map_1}, 218 RPRED=33 {routine_0,predicate_1}, 219 KEYSPEC=34 {spec}, 220 KEYARRAY=35 {array}, 221 KEYNAME=36 {name}, 222 KEYSWITCH=37 {switch}, 223 OF=38 {of}, 224 KEYFILE=39 {file}, 225 PROGRAM=40 {program}, 226 KEYLIST=41 {list}, 227 KEYCONTROL=42 {control}, 228 COMMENT=43 {comment}, 229 KEYEVENT=44 {event}, 230 INCLUDE=45 {include}, 231 ALIAS=46 {alias}, 232 KEYNOT=47 {not}, 233 KEYAND=64 {and}, 234 KEYOR=65 {or} 235 %CONSTintegerARRAY SYMINIT(97:122) = %C 236 2, 15, 27, 57, 64, 87,118,122,126, 1, 1,141,154,168,175,184, 237 1,199,230,270,278, 1,288, 1, 1, 1 238 239 %CONSTBYTEINTEGERARRAY SYMBOL(1:292) = %C 240 128,114,114, 97,121,163,108,105, 97,115,174,110,100,192,101,103, 241 105,110,133,121,116,101,153,105,116,153,111,110,116,105,110,117, 242 101,134,121, 99,108,101,150,109,109,101,110,116,171,115,116, 97, 243 110,116,152,152,114,111,108,170,121,110, 97,109,105, 99,152,110, 244 100,129,108,115,101,132,120,105,116,134,118,101,110,116,172,116, 245 101,114,110, 97,108,152,105,110,105,115,104,131, 97,108,115,101, 246 136,111,114,109, 97,116,159,110,160,117,110, 99,116,105,111,110, 247 160,147,108,101,167,111,116,111,139, 97,108,102,153,102,144,110, 248 116,101,103,101,114,155, 99,108,117,100,101,173, 97, 98,101,108, 249 151,111,110,103,154,105,115,116,169,111,110,105,116,111,114,141, 250 105,116,101,153, 97,112,160, 97,109,101,164,111,116,175,110,143, 251 119,110,152,102,166,114,193,114,101,100,105, 99, 97,116,101,161, 252 111,103,114, 97,109,168,101,112,101, 97,116,130,111,117,116,105, 253 110,101,161,116,117,114,110,135,115,117,108,116,137, 97,108,156, 254 99,111,114,100,158,116,111,112,138,105,103,110, 97,108,140,121, 255 115,116,101,109,152,104,111,114,116,153,112,101, 99,162,119,105, 256 116, 99,104,165, 97,114,116,149,114,105,110,103,157,114,117,101, 257 136,104,101,110,148,110,108,101,115,115,144,116,105,108,146,104, 258 105,108,101,145 259 260 %CONSTBYTEINTEGERARRAY ALTDISP(1:292) = %C 261 0, 5, 0, 0, 0, 0, 5, 0, 0, 0, 0, 0, 0, 0, 5, 0, 262 0, 0, 0, 4, 0, 0, 3, 0, 0, 5, 8, 12, 17, 23, 0, 0, 263 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 264 0, 0, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 40, 3, 265 0, 0, 4, 0, 0, 0, 4, 8, 0, 1, 0, 0, 0, 0, 0, 0, 266 0, 0, 0, 0, 0, 40, 6, 27, 0, 0, 0, 0, 5, 0, 0, 0, 267 0, 6, 0, 14, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 268 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 2, 0, 0, 269 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5, 0, 0, 0, 270 0, 4, 0, 0, 0, 0, 0, 0, 0, 7, 0, 0, 0, 0, 0, 0, 271 4, 0, 0, 4, 0, 0, 1, 4, 0, 0, 0, 0, 0, 0, 2, 0, 272 3, 0, 8, 2, 0, 0, 0, 0, 8, 0, 0, 0, 0, 0, 0, 1, 273 0, 0, 0, 0, 0, 0, 6, 12, 0, 0, 0, 0, 0, 0, 0, 0, 274 0, 0, 0, 5, 0, 0, 0, 0, 5, 0, 0, 0, 0, 3, 0, 0, 275 0, 0, 0, 0, 0, 4, 30, 0, 0, 6, 0, 0, 0, 0, 0, 6, 276 0, 0, 0, 0, 40, 5, 0, 0, 0, 1, 4, 0, 0, 0, 0, 0, 277 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 278 1, 0, 0, 0, 0, 0, 5, 0, 0, 0, 1, 0, 0, 0, 1, 0, 279 0, 0, 0, 0 280 281 282 !*!!!!!! end of generated tables !!!!!!!!!!!!!!!!!!!!!!!!!!! 283 ! 284 %constinteger TERMINATOR=52, CONST=53, IDENT=54, 285 AREF=55, RECREF=56, 286 MODSIGN=57, 287 COLON=58, COMMA=59, RIGHT=60, RIGHTBRACKET=61, 288 DUD=63 289 290 !Operators (in banks of 8 acc to rank) 291 %constinteger BOOLAND=64, BOOLOR=65, BOOLNOT=66, 292 FLOAT=67, IMOD=68, FMOD=69 293 %constinteger EQUALS=70, NOTEQ=71, LESSEQ=72, 294 LESS=73, GREATEQ=74, GREATER=75, 295 EQEQ=76, NOTEQEQ=77, RESOLVE=79 296 %constinteger PLUS=80, MINUS=81, LOGOR=82, 297 LOGXOR=83, CONCAT=84 298 %constinteger MULT=88, FDIV=89, IDIV=90, 299 LOGAND=91 300 %constinteger FPOWER=96, IPOWER=97, 301 LSHIFT=100, RSHIFT=101, LOGNOT=102 302 %constinteger FCALL=106, MCALL=107 303 %constinteger ATOMMAX=107 304 305 ! Instruction actions: 306 %constinteger swgoto=35, rcall=mcall+2, 307 assign=41, jamassign=42, plusass=43, 308 compare=44, jump=45, label=46, adecl=47 309 %constinteger actmax=49 310 ! 311 !Branch cases ( = machine condition-code) 312 %constinteger EQ=2_0111, NE=2_0110, 313 GT=2_1110, LE=2_1111, 314 LT=2_1101, GE=2_1100, 315 CC=2_0100, CS=2_0101 316 %constinteger DOUBLE=16 317 318 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 319 ! Perm procedure identifiers which are recognised explicitly and 320 ! either implemented in-line or mapped to system entry-point 321 %constinteger DSHORT=dictmin+6, DLENGTH=dshort+1, DCHARNO=dlength+1, 322 DADDR=dcharno+1, DTOSTR=daddr+1, 323 DREM=dtostr+1, 324 DNEXTSYM=drem+1, DREADSYM=dnextsym+1, 325 DPRINTSTR=dreadsym+3, 326 DREAD=dictmin+27, 327 DNEWLINE=dictmin+41 328 !System entry-points used explicitly 329 %constinteger SIGENTRY=16_1114, SCOMPENTRY=16_1128, 330 BOUNDENTRY=16_1134, AGETENTRY=16_1138, 331 INDEXENTRY=16_113C, IREADENTRY=16_1118 332 333 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 334 335 %owninteger STARTS=0, CYCLES=0 336 %owninteger LOOPLAB=0 337 %owninteger CURLAB=lab1 338 ! 339 %recordformat BLOCKINF(%integer sp, delta, fortemps, flags, type, 340 localdpos, parlim, localtext, localpc, 341 localspc, pidpos, access, forward, events, 342 eventpc, faults, return, shorts) 343 !Flag bits (VAR=1 from D_FLAGS) 344 %constinteger WRONGCC=2, NONLOCALREF=4, DYNARRAY=8 345 %constinteger HADON=16_10, HADINST=16_20 346 347 %constinteger OUTERLEVEL=0, MAXLEVEL=16 348 %owninteger LEVEL=outerlevel; !current block level 349 %record(blockinf) C; !info for current block 350 %record(blockinf)%array HOLD(0:maxlevel-1); !info for global blocks 351 352 ! Final core image 353 %constinteger PUREBOUND=0, OWNBASE=purebound+1, 354 FINALBOUND=ownbase+8191 355 %byteintegerarray FINAL(0:finalbound); !for switch info only 356 %owninteger FINALAD=2, OWNAD=ownbase 357 !%owninteger FIRSTENTRY=finalbound, FIRSTDPOS=dictmax 358 !%ownintegername CONSTAD; !== ownad or finalad 359 !%owninteger CONSTBOUND=purebound; !for const/code 360 ! =finalbound; !for own 361 %owninteger PC=0, SPC=finalbound; !for switch info 362 363 !Recognition:- 364 %constinteger CASEMASK=95, CASEBIT=32; !for case conversion 365 366 !Memo variables for current statement:- 367 %owninteger ITEM=0; !current operand 368 %record(objinfo) T; !full typeinfo for ITEM 369 %record(identinfo)%name DITEM 370 %owninteger ELEMENTS; !range details 371 %owninteger HASH 372 %owninteger SPECCING=0, MCODING=0 373 %owninteger DECLMODE, DSIZE 374 %ownrecord(identinfo) D; !declaration details 375 376 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 377 378 !! Source file input and listing 379 %owninteger ATOM=0; !current lexical atom 380 %owninteger MATCHED=1; !indic that atom has been matched 381 %owninteger SYM=nl; !current input symbol 382 %owninteger LINE=0; !current line number 383 %owninteger MAINLINE=0 384 %owninteger DIAGLINE=-9999 385 %owninteger PROLINE=0 386 %owninteger MODESYM='&'; !space or '+' or '&' or '"' 387 !%owninteger OUTCOL=0; !output line position 388 ! Pointers to source file: 389 %owninteger LINESTART=0 390 %owninteger FP=0; !(file pointer) current position 391 %owninteger CHARS=0 392 %owninteger ATOMP=0; !start of current atom 393 %owninteger FAULTP=0; !fault position 394 %owninteger MAINFP 395 %owninteger STRINGP,EXPP 396 %owninteger listout=0 397 ! 398 !! Listing, diagnostic and report routines 399 ! 400 %ownstring(255) rep="" 401 ! 402 %routine NEWLINE 403 print string(rep); print symbol(nl) 404 rep = "" 405 %end 406 ! 407 %routine PUT SYM(%integer k) 408 rep = rep.tostring(k) %if length(rep) < 132 409 %end 410 ! 411 %routine PRINT STRING(%string(255) s) 412 rep = rep.s %if length(rep) < 132 413 %end 414 ! 415 %routine SPACES(%integer n) 416 %while n > 0 %cycle 417 rep = rep." "; n = n-1 418 %repeat 419 %end 420 ! 421 %routine WRITE(%integer val,p) 422 %routine PD(%integer v) 423 p = p-1 424 pd(v//10) %and v = v-v//10*10 %if v <= -10 425 spaces(p) %and p = 0 %if p > 0 426 put sym('0'-v) 427 %end 428 %if val < 0 %start 429 put sym('-'); pd(val) 430 %finish %else pd(-val) 431 %end 432 433 !%routine put ident(%integer t) 434 ! rep = rep.string(charbase+t) 435 !!%integer l 436 ! t = t+charbase 437 ! l = byteinteger(t); l = 11 %if l > 11 438 ! %while l > 0 %cycle 439 ! l = l-1; t = t+1 440 ! put sym(byteinteger(t)) 441 ! %repeat 442 !%end 443 ! 444 !%routine mark at(%integer col) 445 ! put sym(' ') %while outcol < col; put sym('|') 446 !%end 447 ! 448 !%routine show dict(%integer from) 449 !%integer f,i 450 !%record(identinfo) d 451 !%constbyteintegerarray flagsym(0:7) = 452 ! 'V','L','P','O','S','E', 'A', 'M' 453 !%constbyteintegerarray dsym(0:3) = 454 ! ' ','D','I','!' 455 !%conststring(6)%array typetext(0:7) = 456 ! "NULL ", "RECORD", "ARRAY ", "STRING", 457 ! "REALY ", "INTY ", "CHAR ", "BOOL " 458 ! %return %if from >= dlim 459 ! newline %and outcol = 0 %if outcol # 0 460 ! print string(" __identifier___flags___type___extra___value___") 461 ! newline; outcol = 0 462 ! %cycle 463 ! spaces(5); outcol = 5 464 ! pdec(from); mark at(10) 465 ! d = dict(from) 466 ! put sym(' ') 467 ! put ident(d_text) 468 ! mark at(23) 469 ! %for i = 7,-1,0 %cycle 470 ! %if d_flags>>i&1 = 0 %then put sym(' ') %c 471 ! %else put sym(flagsym(i)) 472 ! %repeat 473 ! put sym('|') 474 ! i = d_type-nulltype 475 ! %if 0 <= i <= 7 %then printstring(typetext(i)) %c 476 ! %else putsym(dsym(d_type>>13)) %and pdec(d_type&puretype) 477 ! mark at(39) 478 ! put sym(' '); pdec(d_extra); mark at(47) 479 ! put sym(' '); pdec(d_val); mark at(56) 480 ! newline; outcol = 0 481 ! from = from+1 482 ! %repeat %until from = dlim 483 ! print string(" +----------------------------------------------+") 484 ! newline; outcol = 0 485 !%end 486 ! 487 !%routine show exp(%integer from,to) 488 !![out of date] 489 !%conststring(7)%array acttext(0:63) = 490 ! "?0", "?1", "ADD", "SUB", 491 ! "?4", "LOGAND", "LOGOR", "LOGXOR", 492 ! "NEGATE", "LOGNOT", "LSHIFT", "RSHIFT", 493 ! "IABS", "FABS", "?14", "?15", 494 ! "MULT", "IDIV", "IPOWER", "FPLUS", 495 ! "FMINUS", "FMULT", "FDIV", "FPOWER", 496 ! "FNEGATE", "FLOAT", "CONCAT", "BOOLNOT", 497 ! "BOOLAND", "BOOLOR", "MEMBER", "MODULO", 498 ! "RECREF", "AREF", "INDRECT", "SWJUMP", 499 ! "FCALL", "MCALL", "?38", "RCALL", 500 ! "?40", "ASSIGN", "JAMASS", "PLUSASS", 501 ! "COMPARE", "JUMP", "LABEL", "ADECL", 502 ! "?48", "?49", "?50", "?51", 503 ! "?52", "?53", "?54", "?55", 504 ! "?56", "?57", "?58", "?59", 505 ! "?60", "?61", "?62", "?63" 506 !%routine put operand(%integer i) 507 ! %if dictmin <= i <= dictmax %then put ident(dict(i)_text) %else pdec(i) 508 !%end 509 ! %return %if from >= np 510 ! newline %and outcol = 0 %if outcol # 0 511 ! print string(" __action_____first_______second____") 512 ! newline; outcol = 0 513 ! %cycle 514 ! spaces(5); outcol = 5 515 ! pdec(from); mark at(10) 516 ! put sym(' '); printstring(acttext(exp(from)_act&63)) 517 ! mark at(20); put sym(' ') 518 ! put operand(exp(from)_x) 519 ! mark at(32); put sym(' ') 520 ! put operand(exp(from)_y) 521 ! mark at(44) 522 ! newline; outcol = 0 523 ! from = from+1 524 ! %if from = to %start 525 ! from = explo 526 ! %exit %if from >= oldexplo 527 ! printstring(" |---------------------------------|") 528 ! newline; outcol = 0 529 ! %finish 530 ! %repeat %until from >= oldexplo 531 ! oldexplo = explo 532 ! print string(" +---------------------------------+") 533 ! newline; outcol = 0 534 !%end 535 ! 536 !! Fault reporting 537 ! 538 %routine REPORT(%integer n,joker) 539 %integer mark,start,errline,k,editfp 540 %routine PRINT IDENT(%integer x) 541 put sym('"') 542 print string(string(dict(x)_text+charbase)) 543 put sym('"') 544 %end 545 %routine PRINT TEXT(%integer x,stream) 546 %constinteger esc=27 547 %integer k,p 548 %switch s(0:errmax) 549 put sym(mark) 550 write(line,4) 551 put sym(modesym); put sym(' ') 552 ->s(n&63) 553 s(formerr): printstring("Faulty form"); -> print 554 s(atomerr): printstring("Unknown atom"); -> print 555 s(namerr): printstring("Unknown name"); -> print 556 s(caterr): printstring("Unsuitable"); -> print 557 s(sizerr): printstring("Size"); -> print 558 s(typerr): printstring("Wrong type"); -> print 559 s(boundserr): printstring("Inside out"); -> print 560 s(unending): printstring("Endless loop"); -> print 561 s(indexerr): printstring("Index"); -> print 562 s(accesserr): printstring("Not accessible");-> print 563 s(notinloop): printstring("Not in loop"); -> print 564 s(notinrout): printstring("Not in routine");-> print 565 s(notinfun): printstring("Not in fn/map"); -> print 566 s(notinpred): printstring("Not in pred"); -> print 567 s(plexerr): printstring("Too complex!"); -> print 568 s(duperr): printstring("Duplicate"); -> print 569 s(ordererr): printstring("Out of order"); -> print 570 s(matcherr): printstring("Mismatch"); -> print 571 s(rangerr): printstring("Out of range"); -> print 572 s(nonliteral):printstring("Not literal"); -> print 573 s(nonstand): printstring("Nonstandard"); -> print 574 s(notin): printstring("Not in yet"); -> print 575 s(moperr): printstring("Faulty operand");-> print 576 s(nocycle): printstring("Missing %CYCLE"); -> print 577 s(nostart): printstring("Missing %START"); -> print 578 s(noif): printstring("Missing %IF"); -> print 579 s(noterm): printstring("';' missing"); -> print 580 s(nonstarter):printstring("Non-starter"); -> print 581 s(nonvar): printstring("Not variable"); -> print 582 s(nonref): printstring("Not reference"); -> print 583 s(noparm): printstring("No parameters"); -> print 584 s(toofew): printstring("Too few"); -> print 585 s(unwanted): printstring("Unwanted"); -> print 586 s(toomany): printstring("Too many"); -> print 587 s(selfref): printstring("Self-reference"); -> print 588 s(nobegin): printstring("Extra %END"); -> print 589 print: 590 spaces(21-length(rep)) 591 p = start 592 %if p < faultp-50 %then p = faultp-47 %and printstring("...") %c 593 %else put sym(' ') 594 %cycle 595 k = byteinteger(p); p = p+1 596 %if p = faultp %start 597 !$IF VAX 598 put sym(esc) %and put sym('F') %if stream = 0 599 !$FINISH 600 put sym('~') 601 !$IF VAX 602 put sym(esc) %and put sym('G') %if stream = 0 603 !$FINISH 604 %finish 605 %exit %if k = nl 606 %if ' ' <= k <= '~' %then put sym(k) %c 607 %else put sym('[') %and write(k,-1) %and put sym(']') 608 %repeat 609 %return 610 s(noend): printstring("%END"); ->mend 611 s(noresult): printstring("Result"); ->mend 612 s(nofinish): printstring("%FINISH"); ->mend0 613 s(norepeat): printstring("%REPEAT") 614 mend0: printstring(" etc") %if curlab > lab1+2 615 -> mend 616 s(idmissing): 617 %cycle 618 ! newline %and spaces(8) %and outcol = 8 %if outcol > 50 619 put sym(' ') 620 print ident(x) 621 print string("(?)") %if dict(x)_flags&spec = 0; !switch 622 x = dict(x)_val 623 %repeat %until x = 0 624 mend: 625 printstring(" missing") 626 %if c_type # 0 %start 627 print string(" at END of ") 628 print ident(c_pidpos) 629 %finish %else n = 0 630 %return 631 s(counterr): 632 %if elements < 0 %start 633 write(-elements,0); printstring(" extra") 634 %finish %else %start 635 write(elements,0); printstring(" missing") 636 %finish 637 printstring(" value(s) for ") 638 print ident(x) 639 %return 640 s(asserr): 641 print ident(x) 642 print string(" void") 643 %end 644 645 !Warning or error 646 mark = '?' 647 %if n&warn = 0 %start 648 mark = '*' 649 c_faults = c_faults+1; faults = faults+1 650 %finish 651 faultnum = 0; c_access = -1 652 !Ignore uncorrected earlier error 653 %return %if main_start1 <= fp < change 654 !Track back if before current line 655 start = linestart; errline = line 656 %if n&point = 0 %then faultp = 0 %else %start 657 faultp = joker %if joker > 0 658 %while faultp <= start %cycle 659 start = start-1 660 errline = errline-1 %if byteinteger(start) = nl 661 %repeat 662 start = start-1 %while start # curstart %and byteinteger(start-1) # nl 663 %finish 664 editfp = start; editfp = faultp-1 %if faultp > start 665 editfp = mainfp %if curlim = extra_lim2 666 start = start+1 %while byteinteger(start) = ' ' 667 print text(joker,0) 668 newline %and %return %if n&warn # 0 %or nonstop # 0 669 main_fp = editfp; main_line = line 670 %if change # 0 %then main_change = 16_7FFFFFFE 671 edi(main,null,rep) 672 rep = "" 673 nonstop = 1 %if main_flag = 'I' 674 %stop %if main_flag < 0 675 %signal 12 %if main_change < 16_7FFFFFFE {change made} 676 %end; ?K unused 677 ; !report 677 678 %routine CROAK(%string(255) s) 679 print string("** ".s.". Checking abandoned at line ") 680 write(line,0); newline 681 nonstop = -999 682 %signal 12 683 %end 684 685 %routine FAULT(%integer n) 686 !Note fault number and position of (earliest) fault 687 ! for subsequent reporting (warnings and weak errors) 688 faultnum = n %and faultp = atomp %if faultnum = 0 689 %end 690 %routine EXPFAULT(%integer n) 691 faultnum = n!point %and faultp = expp %if faultnum = 0 %or expp < faultp 692 %end 693 694 %constinteger pred=1, uparr=1<<1, nocomma=1<<2, overload=1<<3, 695 ranges=1<<4, nolength=1<<5, initass=1<<6, kgoto=1<<7, 696 hyphen=1<<8, naming=1<<9, klabel=1<<10, ibmhex=1<<11, 697 oldcycle=1<<12, loop2=1<<13 698 %routine NONSTANDARD(%integer case) 699 %owninteger hadit=0 700 %if control&nonsbit # 0 %and case&hadit = 0 %start 701 hadit = hadit+case 702 fault(nonstand+point+warn) 703 %finish 704 %end 705 706 %routine ERROR(%integer case) 707 report(case,atomp) 708 %signal 14 709 %end 710 711 %routine NAME ERROR 712 !check if the culprit has occurred before 713 !and, if not, add it to the pool of unknowns stored at the 714 !far end of the dictionary. 715 %while item < 0 %c 716 %and string(dict(-item)_text+charbase) # string(charlim) %cycle 717 item = dict(-item)_link 718 %repeat 719 %if item >= 0 %start; !first time 720 report(namerr+point,atomp) 721 %if charmin-newlen-80 >= charlim %start 722 dmin = dmin-1 723 charmin = charmin-newlen-1 724 string(charmin) = string(charlim) 725 dict(dmin)_text = charmin-charbase 726 head == dict(head)_link %while head > 0; !find last link 727 dict(dmin)_link = head; head = -dmin 728 %finish 729 %finish 730 %signal 14 731 %end 732 733 %routine SYNTAX ERROR 734 %integer e 735 e = formerr+point; e = atomerr+point %if atom = dud 736 report(e,atomp) 737 %signal 14 738 %end 739 740 !!!!!!!!!!!!!!!!!!!! CELL CONSTRUCTORS !!!!!!!!!!!!!!!!!!! 741 ! 742 !%integerfn litref(%integer v) 743 !%integer i 744 ! %result = v %if smallmin <= v <= smallmax 745 ! litstore(litpos) = v 746 ! i = litmin-1 747 ! i = i+1 %until litstore(i) = v 748 ! %if i = litpos %start 749 ! litpos = litpos+1 750 ! croak("Too many literals") %if litpos >= slitpos 751 ! %finish 752 ! %result = i 753 !%end 754 755 !%integerfn litval(%integer v) 756 ! %result = v %if v <= smallmax 757 ! %result = litstore(v) 758 !%end 759 760 %integerfn floated(%integer item) 761 %result = 0 %if item = 0 762 %result = explo;!expref(float,item,0) 763 %end 764 765 !%predicate is short (%integer v) 766 ! %true %if -32768 <= v <= 32767 767 ! %false 768 !%end 769 770 !%predicate is mite (%integer v) 771 ! %true %if -128 <= v <= 127 772 ! %false 773 !%end 774 775 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 776 !!!!!!!!!!!!!!!!! CODE GENERATION !!!!!!!!!!!!!!!!!!!!!!!! 777 ! 778 %routine forget 779 %end 780 %routine forget all 781 %integer i,j 782 litpos = litmin; explo = expmax+1; oldexplo = explo 783 %end ?J unused ?I unused 784 ! 785 %routine set label(%integer b) 786 %end; ?B unused 787 ; !set label 787 %routine set user label(%integer dpos) 788 %end ?DPOS unused 789 %routine compile(%integer from,to) 790 ! show exp(from,to) %if control&explist # 0 791 np = np0 792 %end ?TO unused ?FROM unused 793 %routine compile entry 794 %end 795 %routine compile end 796 %end; !compile end 797 !!!!!!!!!!!!!!! end of Code Generation !!!!!!!!!!!!!!!!!!!!!!! 798 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 799 800 %routine PUT3(%integer act,x,y) 801 ! exp(np)_act = act; exp(np)_x = x; exp(np)_y = y 802 ! np = np+1 803 %end ?Y unused ?X unused ?ACT unused 804 ! 805 %routine PUT2(%integer act,x) 806 %end ?X unused ?ACT unused 807 ! 808 %integerfn TEMPVAR 809 %result = dlim 810 %end 811 812 %routine OPEN BLOCK(%integer pidpos) 813 forget; !a bit extreme 814 croak("Too many levels") %if level = maxlevel 815 hold(level) = c; level = level+1 816 c = 0 817 starts = 0; cycles = 0 818 curlab = lab1; looplab = 0 819 forget all 820 c_flags = 0; c_type = d_type 821 c_pidpos = pidpos 822 c_localdpos = dlim; c_parlim = dlim; c_localtext = charlim 823 c_localpc = pc; c_localspc = spc 824 c_access = 1 825 %end; !OPEN BLOCK 826 827 %routine CLOSE BLOCK 828 %integer i 829 %integer miss,dpos 830 %integername p 831 %record(identinfo)%name dp 832 !Check identifier usage 833 miss = 0; p == miss 834 dpos = c_localdpos 835 %while dpos # dlim %cycle 836 dp == dict(dpos) 837 ! %if (dp_xtype = ptrxtype %and dp_type = dpos) 838 %if dp_flags&(proc+lab) # 0 %and dp_flags&(ext+spec) = spec %start 839 p = dpos; p == dp_val; p = 0 840 %finish 841 ! %if hashindex(dp_spare) = dpos %start 842 ! dp_link = dict(dp_link)_link %while dp_link >= c_localdpos 843 ! hashindex(dp_spare) = dp_link 844 ! %finish 845 ! dpos = dp_xtype %if dp_type = 0 %and dp_xtype > dpos; !skip fields 846 dpos = dpos+1 847 %repeat 848 report(idmissing,miss) %if miss # 0 849 compile end 850 pc = c_localpc; spc = c_localspc 851 dlim = c_parlim; charlim = c_localtext 852 %for i = 0,1,255 %cycle 853 hashindex(i) = dict(hashindex(i))_link %while hashindex(i) >= c_localdpos 854 %repeat 855 level = level-1; c = hold(level) 856 starts = 0; cycles = 0 857 %end; !CLOSE BLOCK 858 859 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 860 !!!!!!!!!!!!!!!!!!!! Source input !!!!!!!!!!!!!!!!!!!!!!!!!!!! 861 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 862 ! 863 %routine SWITCH INPUT 864 ! croak("Input ended") %if fp = main_lim2 865 %signal 12 %if fp = main_lim2 866 %if nonstop < 0 %start; !perming 867 nonstop = nonstop+3; permlim = dlim 868 c_localdpos = dlim; c_parlim = dlim 869 statements = 0 870 %finish 871 %if fp # main_lim1 %start 872 nonstop = nonstop-1 873 fp = mainfp; line = mainline 874 curstart = main_start1; curlim = main_lim1 875 %finish %else fp = main_start2 876 %if main_start2 <= fp <= main_lim2 %start 877 curstart = main_start2; curlim = main_lim2 878 %finish 879 modesym = ' '; sym = nl 880 %end 881 882 %routine READ LINE 883 ! Read (or otherwise make available) the next source line 884 ! Skip remnant of previous line if SYM # NL *NB* 885 ! Set LINESTART to point to start of new line 886 report(faultnum,faultp) %if faultnum # 0 887 %while sym # nl %cycle; !Skip remnant 888 sym = byteinteger(fp); fp = fp+1 889 %repeat 890 %while fp = curlim %cycle 891 switch input 892 %repeat 893 line = line+1; linestart = fp 894 sym = 0 895 %end; !READ LINE 896 ! 897 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 898 !!!!!!!!!!!!!!!!!!!! Lexical processing !!!!!!!!!!!!!!!!!!!!!! 899 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 900 901 %owninteger percent=0, subatom=0 902 ! 903 !Aliases: 904 %constinteger ARROW=resolve 905 %constinteger EXCLAM=logor, EXCLAM2=logxor, DOT=concat 906 %constinteger STAR=mult, SLASH=fdiv, SLASH2=idiv, 907 AMPERSAND=logand 908 %constinteger BACKSLASH=fpower, BACKSLASH2=ipower, 909 UPARROW=fpower, UPARROW2=ipower, 910 TILDE=lognot 911 %constinteger LEFT=aref, UNDERLINE=recref, LEFTBRACKET=106 912 913 %constinteger SIMPLE=104, MAJOR=plus, 914 SCOND=equals, COND=keyand 915 ! 916 ! Type compatibility vectors: 917 %constinteger RECOK=1<<0, ARROK=1<<1, STRINGOK=1<<2, 918 REALOK=1<<3, INTOK=1<<4, CHAROK=1<<5, 919 BOOLOK=1<<6, ENUMOK=1<<7, SETOK=1<<8 920 %constinteger ZNOP=1<<9, REFONLY=1<<10, VARONLY=1<<11 921 %constinteger ARITHOK=intok+realok, 922 ORDOK=intok+charok+boolok+enumok, 923 ANY=realok+ordok+stringok+arrok+recok 924 ! 925 %constintegerarray opbits(64:atommax) = 926 {BOOLAND} boolok, 927 {BOOLOR} boolok, 928 0, 0, 0, 0, 929 {EQUALS} any, 930 {NOTEQ} any, 931 {LESSEQ} setok+stringok+ordok+realok, 932 {LESS} stringok+ordok+realok, 933 {GREATEQ} setok+stringok+ordok+realok, 934 {GREATER} stringok+ordok+realok, 935 any, 936 any, 937 0, 938 {RESOLVE} stringok, 939 {PLUS} znop+setok+arithok, 940 {MINUS} znop+setok+arithok, 941 {LOGOR} znop+intok, 942 {LOGXOR} znop+intok, 943 {CONCAT} stringok, 944 0, 0, 0, 945 {MULT} arithok, 946 {FDIV} arithok, 947 {IDIV} intok, 948 {LOGAND} intok, 949 0, 0, 0, 0, 950 {FPOWER} arithok, 951 {IPOWER} intok, 952 0, 0, 953 {LSHIFT} znop+intok, 954 {RSHIFT} znop+intok, 955 {LOGNOT} intok, 956 0, 957 {AREF} arrok, 958 {RECREF} recok, 959 {} 0, 0 960 ! 961 %integerfn NEXT ATOM 962 !Encode next atom from source file 963 ![Time-critical] 964 %switch s(0:255) 965 %constinteger tab=9 966 %integer i,j,p,radix,digits 967 %real rval 968 %constbyteintegerarray map(0:127) = 969 0 ('0'), 970 '0','1','2','3','4','5','6','7','8','9', 971 0, 0, 0, 0, 0, 0, 0, 972 'a','b','c','d','e','f','g','h','i','j','k','l','m', 973 'n','o','p','q','r','s','t','u','v','w','x','y','z', 974 0, 0, 0, 0, 0, 0, 975 'a','b','c','d','e','f','g','h','i','j','k','l','m', 976 'n','o','p','q','r','s','t','u','v','w','x','y','z', 977 0, 0, 0, 0, 0 978 979 %routine assemble real 980 j = 0 981 %cycle 982 %cycle 983 sym = byteinteger(fp); fp = fp+1 984 %repeat %until sym # ' ' 985 i = sym-'0' 986 %return %unless 0 <= i < radix 987 rval = rval*radix+i; j = j+1 988 %repeat 989 %end 990 991 ! atoms = atoms+1 992 matched = 0 993 again: s(tab): 994 read line %if sym = nl 995 %cycle 996 sym = byteinteger(fp); fp = fp+1 997 %repeat %until sym # ' ' 998 atomp = fp; !(actually one after) 999 -> s(sym) 1000 linebreak: s(nl): 1001 %result = terminator %if atom # comma 1002 -> again 1003 1004 s('{'): 1005 %cycle 1006 sym = byteinteger(fp); fp = fp+1 1007 -> linebreak %if sym = nl 1008 %repeat %until sym = '}' 1009 -> again 1010 1011 s('+'): %result = plus 1012 s('-'): fp = fp+1 %and %result = arrow %if byteinteger(fp) = '>' 1013 -> again %if byteinteger(fp) = nl 1014 %result = minus 1015 s('*'): %result = star 1016 s('/'): fp = fp+1 %and %result = slash2 %if byteinteger(fp) = '/' 1017 %result = slash 1018 s('\'): fp = fp+1 %and %result = backslash2 %if byteinteger(fp) = '\' 1019 %result = backslash 1020 s('^'): nonstandard(uparr) 1021 fp = fp+1 %and %result = uparrow2 %if byteinteger(fp) = '^' 1022 %result = uparrow 1023 s('!'): fp = fp+1 %and %result = exclam2 %if byteinteger(fp) = '!' 1024 %result = exclam 1025 s('&'): %result = ampersand 1026 s('.'): %result = dot 1027 s('='): fp = fp+1 %and %result = eqeq %if byteinteger(fp) = '=' 1028 %result = equals 1029 s('#'): fp = fp+1 %and %result = noteqeq %if byteinteger(fp) = '#' 1030 %result = noteq 1031 s('<'): fp = fp+1 %and %result = lesseq %if byteinteger(fp) = '=' 1032 fp = fp+1 %and %result = noteq %if byteinteger(fp) = '>' 1033 fp = fp+1 %and %result = lshift %if byteinteger(fp) = '<' 1034 %result = less 1035 s('>'): fp = fp+1 %and %result = greateq %if byteinteger(fp) = '=' 1036 fp = fp+1 %and %result = rshift %if byteinteger(fp) = '>' 1037 %result = greater 1038 s('_'): %result = underline 1039 s(':'): %result = colon 1040 s(','): %result = comma 1041 s(';'): %result = terminator 1042 s('('): %result = left 1043 s(')'): %result = right 1044 s('|'): %result = modsign 1045 1046 s('E'): s('e'): 1047 fp = fp+1 %and -> stringconst %if byteinteger(fp) = '"' 1048 s('M'): s('m'): s('C'): s('c'): 1049 fp = fp+1 %and -> charconst %if byteinteger(fp) = '''' 1050 s('A'):s('B'):s('D'):s('F'):s('G'):s('H'): 1051 s('I'):s('J'):s('K'):s('L'):s('N'):s('O'):s('P'): 1052 s('Q'):s('R'):s('S'):s('T'):s('U'):s('V'):s('W'):s('X'): 1053 s('Y'):s('Z'):s('a'):s('b'):s('d'):s('f'): 1054 s('g'):s('h'):s('i'):s('j'):s('k'):s('l'):s('n'): 1055 s('o'):s('p'):s('q'):s('r'):s('s'):s('t'):s('u'):s('v'): 1056 s('w'):s('x'):s('y'):s('z'): 1057 -> keyword %if percent # 0 1058 ! identatoms = identatoms+1 1059 newlen = charlim+1; hash = sym!casebit; !lower-case (if letter) 1060 byteinteger(newlen) = hash 1061 %cycle 1062 sym = byteinteger(fp); fp = fp+1 1063 %repeat %until sym # ' ' 1064 !$IF AMDAHL 1065 { %if sym = '''' %start 1066 { radix = 16 %and -> ibm %if hash = 'x' 1067 { radix = 8 %and -> ibm %if hash = 'k' 1068 { radix = 2 %and -> ibm %if hash = 'b' 1069 { %finish 1070 !$FINISH 1071 sym = map(sym) 1072 %if sym # 0 %start 1073 %cycle 1074 newlen = newlen+1; byteinteger(newlen) = sym 1075 hash = hash<<1!!sym 1076 %cycle 1077 sym = byteinteger(fp); fp = fp+1 1078 %repeat %until sym # ' ' 1079 sym = map(sym) 1080 %repeat %until sym = 0 1081 %finish 1082 fp = fp-1 1083 newlen = newlen-charlim; byteinteger(charlim) = newlen 1084 head == hashindex(hash&255) 1085 item = head 1086 %if item > 0 %start 1087 %cycle 1088 %result = ident %if item <= 0 1089 ditem == dict(item) 1090 %exit %if string(ditem_text+charbase) = string(charlim) 1091 ! misses = misses+1 1092 item = ditem_link 1093 %repeat %until item <= 0 1094 %finish 1095 %result = ident 1096 1097 s('%'): 1098 sym = byteinteger(fp) 1099 -> again %unless 'a' <= sym!casebit <= 'z' 1100 fp = fp+1 1101 keyword: 1102 percent = 0 1103 p = syminit(sym!casebit) 1104 %cycle 1105 ! %cycle 1106 ! sym = byteinteger(fp)!casebit 1107 ! %exit %if symbol(p) # sym 1108 %while symbol(p) = byteinteger(fp)!casebit %cycle 1109 p = p+1; fp = fp+1 1110 %repeat 1111 %exit %if symbol(p) >= 128 1112 atom = altdisp(p) 1113 %if atom = 0 %start 1114 %result = dud %unless sym!casebit = 'c' %and byteinteger(fp) = nl 1115 read line 1116 ->again 1117 %finish 1118 p = p+atom 1119 %repeat 1120 percent = 1 %if 'a' <= byteinteger(fp)!casebit <= 'z' 1121 subatom = altdisp(p) 1122 atom = symbol(p)-128 1123 %result = dud %if atom = 0 1124 %result = atom 1125 1126 !$IF AMDAHL 1127 {ibm: 1128 { nonstandard(ibmhex) 1129 { item = -1; t_val = 0 1130 { -> ibm1 1131 !$FINISH 1132 s('0'):s('1'):s('2'):s('3'):s('4'):s('5'):s('6'):s('7'):s('8'):s('9'): 1133 item = 0; t_type = inty 1134 radix = 10; t_val = sym-'0' 1135 ibm1: 1136 %cycle 1137 %cycle 1138 %cycle 1139 sym = byteinteger(fp); fp = fp+1 1140 %repeat %until sym # ' ' 1141 i = sym-'0' 1142 %if radix = 10 %start 1143 %exit %if i < 0 %or i >= 10 1144 %if t_val > max10 %or (t_val=max10 %and i > maxdig) %start 1145 t_type = realy; rval = t_val 1146 assemble real 1147 %exit 1148 %finish 1149 t_val = t_val*10+i 1150 %finish %else %start 1151 i = sym!casebit-'a'+10 %if i >= 10 1152 %exit %if i < 0 %or i >= radix 1153 j = radix 1154 %cycle 1155 i = i+t_val %if j&1 # 0 1156 t_val = t_val<<1; j = j>>1 1157 %repeat %until j = 0 1158 t_val = i 1159 %finish 1160 %repeat 1161 %exit %unless sym = '_' 1162 radix = t_val 1163 %result = dud %if radix = 0 1164 t_val = 0 1165 %repeat 1166 %if sym = '.' %start 1167 t_type = realy %and rval = t_val %if t_type = inty 1168 assemble real 1169 %result = dud %if j = 0 1170 rval = rval/radix\j 1171 %finish 1172 ! %if t_type = realy %start; !vax->ieee 1173 ! t_val = integer(addr(rval)) 1174 ! t_val = t_val<<16+t_val>>16-16_01000000 1175 ! %finish 1176 ! numatoms = numatoms+1 1177 !$IF AMDAHL 1178 { %if item < 0 %start 1179 { %result = dud %if sym # '''' 1180 { item = 0 1181 { %finish %else %start 1182 { fp = fp-1; sym = 0 1183 { %finish 1184 !$IF VAX OR APM 1185 fp = fp-1; sym = 0 1186 !$FINISH 1187 %result = const 1188 1189 s(''''): 1190 charconst: 1191 item = 0; t_type = inty 1192 t_val = 0 1193 %cycle 1194 sym = byteinteger(fp); fp = fp+1 1195 %result = dud %if sym = nl; !?allow 1196 %if sym = '''' %start 1197 %exit %unless byteinteger(fp) = '''' 1198 fp = fp+1 1199 %finish 1200 t_val = t_val<<8+sym 1201 %repeat 1202 %result = const %if t_val # 0 1203 %result = dud 1204 1205 s('"'): 1206 stringconst: 1207 item = 0; t_type = stringy 1208 stringp = atomp; !for include 1209 t_val = 0 1210 i = line; j = linestart 1211 %cycle 1212 sym = byteinteger(fp); fp = fp+1 1213 %if sym = '"' %start 1214 %exit %if byteinteger(fp) # '"' 1215 fp = fp+1 1216 %finish 1217 t_val = t_val+1 1218 %if t_val > 255 %start 1219 sym = 0 1220 fp = atomp; linestart = j 1221 %result = dud 1222 %finish 1223 read line %if sym = nl 1224 %repeat 1225 %result = const 1226 1227 s(*): 1228 %result = dud 1229 %end; 0 nused ?DIGITS unused 1230 ; !NEXT ATOM 1230 1231 %routine LOOKUP FIELD IDENT(%integer list) 1232 item = list; %return %if item = 0 1233 %cycle 1234 ditem == dict(item) 1235 %if ditem_flags&typeid = 0 %start 1236 %return %if string(ditem_text+charbase) = string(charlim) 1237 %exit %if ditem_flags&more = 0 1238 %finish 1239 item = item+1; !misses = misses+1 1240 %repeat 1241 item = 0 1242 %end 1243 1244 %predicate A (%integer k) 1245 !Basic atom-testing predicate 1246 atom = next atom %if matched # 0 1247 %false %if k # atom 1248 matched = 1 1249 %true 1250 %end 1251 1252 %routine GET(%integer k) 1253 atom = next atom %if matched # 0 1254 matched = 1 1255 %return %if atom = k 1256 syntax error %if atom = dud 1257 faultp = atomp; report(formerr+point,-k) 1258 %signal 14 1259 %end 1260 1261 %routine ALLOW(%integer k) 1262 %if a(k) %start 1263 %finish 1264 %end 1265 1266 %routine DECLARE 1267 %if speccing = 0 %start; !not within spec params 1268 %if item >= c_localdpos %start; !there already 1269 %if d_flags&spec = 0 %and d_flags+spec = ditem_flags %c 1270 %and ditem_type = d_type %start 1271 ditem_flags = ditem_flags-spec 1272 %return 1273 %finish 1274 fault(duperr+point) 1275 %finish 1276 d_link = head; head = dlim; !insert in list 1277 ! d_spare = hash&255 1278 %if item > 0 %then d_text = ditem_text %c 1279 %else %start 1280 d_text = charlim-charbase; charlim = charlim+newlen+1 1281 croak("Identifier space exhausted") %if charlim+80 >= charmin 1282 %finish 1283 %finish %else d_text = 0 1284 item = dlim; ditem == dict(item) 1285 ditem = d 1286 dlim = dlim+1; croak("Too many identifiers") %if dlim >= dmin 1287 %end; !DECLARE 1288 1289 %routine DECLARE ANON 1290 d_text = 0; d_link = 0 1291 dict(dlim) = d 1292 dlim = dlim+1; croak("Too many identifiers") %if dlim >= dmin 1293 %end 1294 1295 %owninteger jammy 1296 %predicate A ASSOP 1297 atom = next atom %if matched # 0 1298 %if atom # equals %and atom # eqeq %start 1299 %false %unless atom = less %and byteinteger(fp) = '-' 1300 jammy = 2; fp = fp+1 1301 %finish %else jammy = 0 1302 matched = 1 1303 %true 1304 %end 1305 1306 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1307 !!!!!!!!!!!!!!!!!!!! Expressions !!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1308 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1309 1310 %owninteger literal=0 1311 %routinespec get EXPRESSION(%integer rank,control) 1312 1313 %integerfn COMPAT(%integer control) 1314 %if t_type = inty %start 1315 %if control&intok = 0 %and control&realok # 0 %start 1316 item = floated(item) 1317 t_type = realy 1318 %finish 1319 %result = control&(intok+realok) 1320 %finish 1321 %result = control&(boolok>>(booltype-t_type)) %if t_type <= booltype 1322 %result = control&enumok %if t_type < direct 1323 %result = control&arrok 1324 %end 1325 ! 1326 %integerfn LISTMATCH(%integer alist,blist) 1327 %record(identinfo)%name ap,bp 1328 %result = 1 %if alist = blist 1329 %result = 0 %if alist < dictmin %or blist < dictmin 1330 %cycle 1331 ap == dict(alist); bp == dict(blist) 1332 %result = 0 %if ap_type # bp_type; !for now 1333 alist = alist+1; blist = blist+1 1334 %repeat %until ap_flags&bp_flags&more = 0 1335 %result = 0 %if ap_flags&more # 0 %or bp_flags&more # 0; !for now 1336 %result = 1 1337 %end 1338 ! 1339 %routine GET REFERENCE(%integer reftype) 1340 %integer type,temp 1341 get EXPRESSION(simple,refonly+any) 1342 type = ditem_type&puretype; reftype = reftype&puretype 1343 %return %if reftype = type 1344 %if type < reftype %start 1345 temp = type; type = reftype; reftype = temp 1346 %finish 1347 %return %if reftype = nulltype; !untyped %name 1348 type = dict(type)_type 1349 %return %if type <= inty %and type = reftype 1350 %return %if type >= direct %and type = dict(reftype)_type; !aname 1351 expfault(typerr+point) 1352 %end 1353 ! 1354 %routine GET VALUE(%integer valtype) 1355 %record(identinfo)%name dp,p 1356 get EXPRESSION(major,any) 1357 valtype = valtype&puretype 1358 dp == dict(valtype) 1359 %if t_type # dp_type %start; !base types differ 1360 %return %if item = 0 = t_val; !zero 1361 %if dp_type = realy %and t_type = inty %start 1362 !float 1363 t_type = realy 1364 %return 1365 %finish 1366 %else %if t_type >= inty; !scalar 1367 %if item = 0 %start 1368 %return %if dp_low <= t_val <= dp_val 1369 jammy = jammy!1 %if jammy >= 0 1370 %finish %else %start 1371 %if t_low >= dp_low %start 1372 %return %if t_val <= dp_val 1373 jammy = jammy!1 %if jammy >= 0 1374 %return %if t_low <= dp_val 1375 %finish %else %start 1376 jammy = jammy!1 %if jammy >= 0 1377 %return %if t_val >= dp_low 1378 %finish 1379 %finish 1380 expfault(rangerr+point) %if jammy < 2 1381 %return 1382 %else %if t_type = stringy 1383 %if t_val > dp_val %start; !VALUE = LENGTH* 1384 jammy = jammy!1 %if jammy >= 0 1385 expfault(rangerr+point) %if item = 0 %and jammy < 2 1386 %finish 1387 %return 1388 %else %if t_type = recy 1389 %return %if t_extra = dp_extra 1390 jammy = jammy!1 %and %return %if jammy >= 2 1391 !partial assignment? 1392 %else %if t_type = realy 1393 %return 1394 %finish 1395 expfault(typerr+point) 1396 %end; ?P unused 1397 ; !GET VALUE 1397 ! 1398 %routine GET LITERAL(%integer littype) 1399 literal = literal+1 1400 get VALUE(littype) 1401 literal = literal-1 1402 %end 1403 ! 1404 %routine GET LITINT 1405 literal = literal+1 1406 get EXPRESSION(major,intok) 1407 literal = literal-1 1408 %end 1409 ! 1410 %routine GET LITSTRING 1411 %integer holditem 1412 !Must be quoted string (for %alias and %include) 1413 holditem = item; !preserve 1414 get(const) 1415 error(typerr+point) %if t_type # stringy 1416 item = holditem; !restore 1417 %end 1418 ! 1419 %routine GET PARMLIST 1420 %record(identinfo)%name hp,dp 1421 %integer i,j,headitem,headact,dpos,case,procnp,first 1422 headitem = item; hp == ditem 1423 headact = rcall 1424 !stack procedure ident 1425 ! procnp = np; put3(headact,headitem,0) 1426 i = 0; first = 1 1427 dpos = headitem; dp == hp 1428 %cycle 1429 !Set up expression state from formal param details 1430 error(toomany+point) %if dp_flags&more = 0 1431 dpos = dpos+1 %and dp == dict(dpos) %until dp_flags&parm # 0 1432 %if dp_flags&proc # 0 %start 1433 get(ident) 1434 name error %if item <= 0 1435 fault(typerr+point) %if ditem_flags&proc = 0; !for now 1436 fault(caterr+point) %if item > headitem 1437 %else %if dp_type < indirect; !value 1438 ! %if pp_type&numericmask # 0 %then case = i&7 %and i = i+1 %c 1439 ! %else case = i>>3+8 %and i = i+8 1440 case = i&7; i = i+1 1441 get VALUE(dp_type) 1442 %finish %else %start; !name or proc 1443 case = i>>3+8; i = i+8 1444 get REFERENCE(dp_type) 1445 %finish 1446 ! case = case<<8+headact 1447 ! item = litref(t_val) %if item = 0 1448 ! j = np-1 1449 ! %if first = 0 %start 1450 ! j = np 1451 ! !NB Don't re-order parameters for implicits 1452 ! %if item >= expmin %and headitem > dnewline %start 1453 ! %while j > procnp %and exp(j-1)_y < expmin %cycle 1454 ! exp(j)_act = exp(j-1)_act; exp(j)_y = exp(j-1)_y 1455 ! j = j-1 1456 ! %repeat 1457 ! %finish 1458 ! exp(np)_x = 0; np = np+1 1459 ! %finish 1460 ! exp(j)_act = case; exp(j)_y = item 1461 ! first = 0 1462 %repeat %until %not a(comma) 1463 ! %if hp_type # nulltype %start 1464 ! i = explo 1465 ! %while i <= expmax %cycle 1466 ! %if exp(i)_x = headitem %start; ![enough?] 1467 ! item = i; j = procnp 1468 ! %cycle 1469 ! %exit %if exp(i)_y # exp(j)_y 1470 ! i = i+1; j = j+1 1471 ! ->okf %if j >= np 1472 ! %repeat 1473 ! %finish 1474 ! i = i+1 1475 ! %repeat 1476 ! %cycle 1477 ! explo = explo-1; np = np-1 1478 ! exp(explo) = exp(np) 1479 ! %repeat %until np = procnp 1480 item = explo 1481 !okf:np = procnp 1482 ! %finish 1483 %end; ?PROCNP unused ?J unused 1484 ; !get PARMLIST 1484 1485 %routine GET RESOLUTION 1486 %if %not a(left) %start 1487 get REFERENCE(anystringvar) 1488 get(dot) 1489 get(left) 1490 %finish 1491 get VALUE(anystring) 1492 get(right) 1493 %if a(dot) %start 1494 get REFERENCE(anystringvar) 1495 %finish 1496 %end 1497 ! 1498 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1499 ! 1500 %routine GET EXPRESSION(%integer rank,control) 1501 !Main expression recognition routine 1502 !To bring together the treatment of all binary operators 1503 ! and ensure fast recognition of simple expressions, 1504 ! expressions of different levels are handled by 1505 ! precedence techniques rather than syntactically 1506 !CONTROL defines acceptability 1507 %integer type,f,opok,c1,op,atomp1,item1 1508 %record(objinfo) t1 1509 %record(identinfo)%name dp 1510 1511 %integerfn litval 1512 %switch lit(64:atommax) 1513 -> lit(op) 1514 lit(plus): %result = t1_val+t_val 1515 lit(minus): %result = t1_val-t_val 1516 lit(mult): %result = t1_val*t_val 1517 lit(idiv): %result = t1_val//t_val %if t_val # 0 1518 fault(rangerr) 1519 %result = 0 1520 lit(logand): 1521 lit(booland): %result = t1_val&t_val 1522 lit(logor): 1523 lit(boolor): %result = t1_val!t_val 1524 lit(logxor): %result = t1_val!!t_val 1525 lit(lshift): %result = t1_val<>t_val 1527 lit(boolnot): %result = t_val!!true 1528 lit(lognot): %result = \t_val 1529 !lit(negate): %result = -t_val 1530 lit(equals): %result = true %if t1_val = t_val 1531 %result = false 1532 lit(noteq): %result = true %if t1_val # t_val 1533 %result = false 1534 lit(lesseq): %result = true %if t1_val <= t_val 1535 %result = false 1536 lit(less): %result = true %if t1_val < t_val 1537 %result = false 1538 lit(greateq): %result = true %if t1_val >= t_val 1539 %result = false 1540 lit(greater): %result = true %if t1_val > t_val 1541 %result = false 1542 lit(concat): %result = t1_val+t_val 1543 lit(*): !report(notwhat,-op) 1544 %result = 1 1545 %end 1546 1547 !Get leading operand 1548 atom = next atom %if matched # 0 1549 atomp1 = atomp; !note position for reports 1550 %if atom = ident %start 1551 matched = 1 1552 name error %if item <= 0 1553 fault(selfref+point) %if item >= dlim0 1554 type = ditem_type 1555 %if control&(refonly+varonly) # 0 %start 1556 error(nonvar+point) %if control&varonly # 0 %and f&var = 0 1557 error(nonref+point) %if type < direct 1558 %finish 1559 f = ditem_flags 1560 %if inty <= type <= booltype %and f&proc = 0 %start; !literal 1561 item = 0; t = ditem_details 1562 %else 1563 fault(nonliteral+point) %if literal > 0 1564 %if f&proc # 0 %start 1565 ditem == dict(type) %and type = ditem_type %if f&parm # 0 1566 error(caterr+point) %if type = nulltype; !routine 1567 %if a(left) %start 1568 dp == ditem 1569 get PARMLIST; get(right) 1570 ditem == dp 1571 %else 1572 error(toofew+point) %if ditem_flags&more # 0 1573 item = explo;!expref(f&var+fcall,item,0) 1574 %finish 1575 %finish 1576 %cycle 1577 dp == dict(type&puretype); t = dp_details 1578 atom = next atom %if matched # 0 1579 %exit %if atom # underline %and atom # left 1580 matched = 1 1581 item1 = item 1582 %if atom = left %start 1583 %cycle 1584 syntax error %if t_type < direct; !element type 1585 type = t_type 1586 get VALUE(t_val); !index 1587 item = explo;!expref(aref,item1,item,t_val) 1588 ditem == dp 1589 %exit %if %not a(comma) 1590 dp == dict(type&puretype); t = dp_details 1591 item1 = item 1592 %repeat 1593 get(right) 1594 %else; !rec subfield 1595 syntax error %if t_type # recy 1596 get(ident) 1597 lookup field ident(t_extra) 1598 error(namerr+point) %if item <= 0 1599 type = ditem_type 1600 item = explo;!expref(recref,item,item1) 1601 %finish 1602 %repeat 1603 -> final %if control&(varonly+refonly) # 0 1604 %finish 1605 %else 1606 error(nonvar+point) %if control&varonly # 0 1607 error(nonref+point) %if control&refonly # 0 1608 %if a(const) %start 1609 %else %if atom = minus; !leave unmatched 1610 item = 0; t = 0; t_type = inty 1611 %else %if a(left) 1612 %if rank < major %start; !condition 1613 get EXPRESSION(cond,any) 1614 %finish %else %start 1615 jammy = jammy-4 1616 c1 = control; c1 = c1!intok %if c1&realok # 0 1617 get EXPRESSION(major,c1) 1618 jammy = jammy+4 1619 %finish 1620 get(right) 1621 %else %if a(keynot) 1622 syntax error %if rank >= major 1623 get EXPRESSION(scond,any) 1624 %if item = 0 %then t_val = t_val!!true %c 1625 %else item = explo;!expref(boolnot,item,0) 1626 %else %if atom = backslash 1627 item = 0; t = 0; t_type = inty 1628 atom = tilde 1629 %else %if a(modsign) 1630 fault(typerr+point) %if control&arithok = 0 1631 get EXPRESSION(major,arithok) 1632 get(modsign) 1633 %if item = 0 %start 1634 %if t_val < 0 %start 1635 %if t_val # minint %then t_val = -t_val %else expfault(rangerr) 1636 %finish 1637 %else %if t_type = inty 1638 item = explo;!expref(imod,item,0) 1639 %else %if t_type = realy 1640 item = explo;!expref(fmod,item,0) 1641 %else 1642 error(typerr) 1643 %finish 1644 %else 1645 syntax error 1646 %finish 1647 %finish 1648 atom = next atom %if matched # 0 1649 %while atom >= rank %cycle 1650 op = atom; matched = 1 1651 opok = opbits(op); c1 = compat(opok); ![may change ITEM,T_TYPE] 1652 fault(typerr+point) %if c1 = 0 1653 item1 = item; t1 = t 1654 %if op >= major %start; !non-conditional 1655 %if op = dot %then get EXPRESSION(dot,stringok) {right-associate} %c 1656 %else get EXPRESSION(op&(\7)+8,c1) 1657 %if t_type = realy %and t1_type = inty %start 1658 item1 = floated(item1); t1_type = realy 1659 %finish 1660 ! op = op+? %if t_type = realy %and opok&intok # 0 1661 %else 1662 %if op = resolve %start 1663 get RESOLUTION 1664 %else %if op >= eqeq 1665 get EXPRESSION(simple,any+refonly) 1666 %else %if op >= equals 1667 get EXPRESSION(major,c1) 1668 %if equals <= atom < eqeq %start 1669 op = atom; matched = 1 1670 get EXPRESSION(major,c1) 1671 %finish 1672 %if t_type = realy %and t1_type = inty %start 1673 item1 = floated(item1); t1_type = realy 1674 %finish 1675 %else 1676 get EXPRESSION(scond,any) 1677 %if atom >= cond %start 1678 syntax error %if atom # op 1679 %finish 1680 %finish 1681 t_type = booltype 1682 t_low = 0 %and t_val = 1 %if item # 0 1683 %finish 1684 %if item1 = 0 %start; !first operand literal 1685 %if item = 0 %start; !both literal 1686 t_val = litval 1687 %continue %if item = 0 1688 ! item1 = litref(t1_val) 1689 ! %else %if inverse(op) # 0; !invertable 1690 ! op = inverse(op) 1691 ! temp = t; t = t1; t1 = temp; !standardise order 1692 ! item1 = item; item = 0 1693 %else 1694 ! item1 = litref(t1_val) 1695 %finish 1696 %finish 1697 %if item = 0 %start; !second operand literal 1698 %if op = minus %and t_type = inty %start; !standardise 1699 t_val = -t_val %if t_val # minint; op = plus 1700 %finish 1701 item = item1 %and %continue %if t_val = 0 %and opok&znop # 0 1702 %finish 1703 item = explo;!expref(op,item1,item,t_val) 1704 t_low = minint; t_val = maxint; !?real 1705 %repeat 1706 final: 1707 expp = atomp1; !restore to start 1708 expfault(typerr) %if compat(control) = 0 1709 %end; !get EXPRESSION 1710 1711 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1712 !!!!!!!!!!!!!!!!!!!! Conditions and loops !!!!!!!!!!!!!!!!!!!! 1713 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1714 ! 1715 %routine GET CONDITION 1716 %integer polarity 1717 polarity = subatom 1718 condnp = np 1719 get EXPRESSION(cond,any) 1720 ! put3(jump+polarity,item,0) 1721 %end; !get CONDITION 1722 1723 %routine GET STATEMENTS(%integer stopper) 1724 %integer holdnp,holdlooplab 1725 %switch initial(0:atommax) 1726 1727 %routine GET INSTRUCTION 1728 %integer item1,hold,act 1729 %record(identinfo)%name ditem1 1730 %routine putact 1731 ! put3(act,t_val,hold) 1732 %end 1733 ! 1734 %if c_flags < hadinst %start; !first in block 1735 c_flags = c_flags+hadinst 1736 fault(ordererr) %if level <= outerlevel 1737 %finish 1738 instnp = np 1739 %cycle 1740 %if a(ident) %start 1741 name error %if item <= 0 1742 %if ditem_flags&var # 0 %start 1743 matched = 0 1744 get EXPRESSION(simple,any) 1745 item1 = item; ditem1 == ditem 1746 %if a(equals) %start 1747 get VALUE(ditem1_type) 1748 ! put2(assign,item1) 1749 %else %if a(eqeq) 1750 syntax error %if ditem1_type < indirect 1751 get REFERENCE(ditem1_type) 1752 item = item+ad %if item # 0 1753 ! put2(assign,item1+ad) 1754 %else %if atom = less %and byteinteger(fp) = '-' 1755 fp = fp+1; matched = 1 1756 jammy = 2 1757 get VALUE(ditem1_type) 1758 ! put2(jamassign,item1) 1759 %else 1760 syntax error %if %not a(arrow) 1761 get RESOLUTION 1762 ! put2(resolve,item1) 1763 %finish 1764 %else 1765 error(caterr+point) %if ditem_flags&proc = 0 1766 ditem == dict(ditem_type) %if ditem_flags&parm # 0 1767 error(caterr+point) %if ditem_type # nulltype 1768 %if a(left) %start 1769 get PARMLIST; get(right) 1770 %else; !parameterless routine 1771 error(toofew+point) %if ditem_flags&more # 0 1772 ! put3(rcall,item,0) 1773 %finish 1774 %finish 1775 %finish %else %start 1776 act = atom; hold = subatom; t_val = 0 1777 c_access = 0 1778 %if a(monitor) %start 1779 c_access = 1 1780 ! fault(monitor<<8) 1781 %else %if a(exit); !%exit, %continue 1782 %if looplab = 0 %then fault(notinloop+point) %c 1783 %else t_val = looplab %and putact 1784 %exit 1785 %else %if a(return) 1786 %if c_type # nulltype %then fault(notinrout+point) %c 1787 %else putact 1788 %exit 1789 %else %if a(result) 1790 error(notinfun+point) %if c_type <= nulltype 1791 syntax error %if %not a assop 1792 %if c_type < direct %start; !function 1793 fault(caterr+point) %if atom = eqeq 1794 get VALUE(c_type) 1795 ! put2(result,0) 1796 %else; !map 1797 fault(caterr+point) %if atom # eqeq 1798 get REFERENCE(c_type+(indirect-direct)) 1799 ! put2(result,0) 1800 %finish 1801 %exit 1802 %else %if a(tf); !%true, %false 1803 %if c_type # booltype %then fault(notinpred+point) %c 1804 %else putact 1805 %exit 1806 %else %if a(arrow) %or a(goto) 1807 nonstandard(kgoto) %if atom = goto 1808 get(ident) 1809 %if byteinteger(fp) # '(' %start 1810 %if item < c_localdpos %or ditem_flags&lab = 0 %c 1811 %or ditem_type # nulltype %start 1812 d_flags = spec+lab; d_type = nulltype 1813 declare 1814 %finish 1815 ! put3(jump,item,0) 1816 %finish %else %start 1817 name error %if item < c_localdpos 1818 syntax error %if ditem_flags&lab = 0 %or ditem_type = nulltype 1819 get(left) 1820 get VALUE(ditem_type); !index 1821 get(right) 1822 %finish 1823 %exit 1824 %else %if a(stop) 1825 putact 1826 %exit 1827 %else %if a(signal) 1828 c_access = 1 1829 allow(keyevent) 1830 get LITINT 1831 expfault(rangerr+point) %unless 0 <= t_val <= 15 1832 hold = t_val; t_val = 0 1833 get LITINT %if a(comma) 1834 hold = t_val<<4+hold 1835 item = 0; t_val = 0 1836 get VALUE(anyint) %if a(comma) 1837 ! put2(act,hold) 1838 %exit 1839 %else 1840 syntax error 1841 %finish 1842 %finish 1843 %repeat %until %not a(keyand) 1844 %end; !GET INSTRUCTION 1845 1846 %routine GET FOR CLAUSE 1847 %integer loopvar,k,s,start,sval,i,inc,ival,e,n,temp 1848 %integer eval 1849 %record(identinfo)%name dp 1850 holdnp = np; temp = 0 1851 dict(curlab)_val = 1; !dummy 1852 condnp = np 1853 get(ident) 1854 name error %if item <= 0 1855 fault(typerr+point) %if dict(ditem_type&puretype)_type # inty 1856 fault(caterr+point+warn) %if ditem_type # direct+inttype 1857 loopvar = item; dp == ditem 1858 get(equals) 1859 get VALUE(ditem_type) 1860 start = item; sval = t_val 1861 get(comma) 1862 get VALUE(anyint) 1863 inc = item; ival = t_val 1864 expfault(rangerr+point) %and ival = 1 %if inc = 0 = ival 1865 get(comma) 1866 get VALUE(ditem_type) 1867 !Deal with INC and replace START by START-INC 1868 ! k = undef 1869 ! k = exp(start)_y %if start >= expmin %and exp(start)_act = plus 1870 %if inc = 0 %start; !literal increment 1871 i = 1; !litref(ival) 1872 %if start = 0 %start; !START and INC both literal 1873 sval = sval-ival; s = 1; !litref(sval) 1874 ! %else %if k <= litmax; !START is x+lit 1875 ! k = ival-litval(k) 1876 ! s = exp(start)_x; s = explo;!expref(plus,s,litref(k)) %if k # 0 1877 %else 1878 s = explo;!expref(plus,start,litref(-ival)) 1879 %finish 1880 %finish %else %start; !allocate temp var 1881 ! i = tempvar; put3(assign,i,inc); temp = temp-4 1882 ! %if start = inc %start; !identical 1883 ! s = 0; sval = 0 1884 ! %else %if k = inc; !START is x+INC 1885 ! s = exp(start)_x 1886 ! %else 1887 ! s = start; s = litref(sval) %if s = 0 1888 s = explo;!expref(minus,s,i) 1889 ! %finish 1890 %finish 1891 ! %if item = 0 %start; !literal end-value 1892 ! e = litref(t_val); eval = t_val 1893 ! %finish %else %start 1894 ! e = tempvar; put3(assign,e,item); temp = temp-4 1895 ! %finish 1896 ! put3(assign,loopvar,s) 1897 ! put3(label,curlab,0) 1898 %if start!inc!item = 0 %start; !all literal 1899 k = t_val-sval; n = k//ival 1900 fault(boundserr) %if n < 0 1901 fault(unending) %if n*ival # k 1902 ! %if 0 <= t_val <= 32767 %start 1903 ! temp = loopvar 1904 ! %finish 1905 %finish 1906 ! %if temp <= 0 %start 1907 ! c_fortemps = c_fortemps-temp; !ie increment 1908 ! put3(compare,loopvar,e) 1909 ! put3(eq,0,curlab+1) 1910 ! %finish 1911 ! put3(plusass,loopvar,i) 1912 ! compile(holdnp,np) 1913 %end; ?EVAL unused ?E unused 1914 ; !get FORCLAUSE 1914 1915 %routine GET SWITCH INDEX 1916 %integer item1 1917 %record(identinfo)%name dp 1918 item1 = item; dp == ditem 1919 get(left) 1920 item = 1 1921 %if a(star) %start 1922 fault(duperr+point) %if dp_spare # 0 1923 dp_spare = 1 1924 %else 1925 get LITERAL(dp_type) 1926 !beware faulty declaration or index 1927 %if dp_type > inttype %and faultnum = 0 %start 1928 t_val = t_val-dict(dp_type)_low+dp_val 1929 expfault(duperr+point) %if final(t_val) # 0 1930 ! define jumps(final(t_val)); !in case of lit jumps 1931 final(t_val) = 1 1932 %finish 1933 %finish 1934 get(right) 1935 c_access = 1 1936 %end 1937 1938 ![unsure of efficiency implications of trapping overflow lower down] 1939 %on %event 1,14 %start 1940 !$IF VAX 1941 report(rangerr,0) %if event_event = 1 1942 !$IF AMDAHL 1943 { report(rangerr,0) %if eventinf>>8 = 1 1944 !$FINISH 1945 -> skip 1946 %finish 1947 !!!!!!!!!!!!!!!!!!! Start of new statement !!!!!!!!!!!!!!!!!!! 1948 next: 1949 statements = statements+1 1950 next1: 1951 report(faultnum,faultp) %if faultnum # 0 1952 d = 0; declmode = 0; dsize = 0 1953 dlim0 = dlim; elements = 0 1954 speccing = 0; mcoding = 0 1955 literal = 0; jammy = 0 1956 dict(curlab)_val = 0; dict(curlab+1)_val = 0 1957 np = np0; instnp = np0; condnp = np0 1958 ! constad == finalad; constbound = purebound 1959 %if explo < expmin+50 %or litpos > litmax-50 %start 1960 !zaps = zaps+1; zaps = zaps+999 %if litpos > litmax-50 1961 forget all 1962 %finish 1963 t_val = 0 1964 ! 1965 initial(terminator): 1966 atom = next atom; matched = 1 1967 -> initial(atom) 1968 initial(star): initial(exclam): initial(exclam2): 1969 read line 1970 -> next1 1971 term: 1972 get(terminator) 1973 -> next 1974 1975 skip: 1976 c_access = -1 1977 %if atom # terminator %start 1978 %cycle 1979 subatom = atom; atom = next atom 1980 %repeat %until atom = terminator 1981 starts = starts+1 %if subatom = start 1982 cycles = cycles+1 %if subatom = cycle 1983 %finish 1984 -> next 1985 1986 initial(dud): 1987 syntax error; !ie atom error 1988 1989 initial(*): 1990 error(nonstarter+point) 1991 1992 initial(ident): 1993 %if byteinteger(fp) = ':' %start; !simple label 1994 fp = fp+1 1995 d_flags = lab; d_type = nulltype 1996 declare 1997 set user label(item) 1998 ->next 1999 %finish 2000 name error %if item <= 0 2001 %if ditem_flags&lab # 0 %start 2002 get SWITCH INDEX 2003 get(colon) 2004 ->next 2005 %finish 2006 initial(return): initial(result): initial(tf): 2007 initial(stop): initial(signal): initial(monitor): 2008 initial(exit): initial(goto): initial(arrow): 2009 matched = 0 2010 get INSTRUCTION 2011 -> next %if a(terminator) 2012 c_access = 1 2013 %if a(iu) %start 2014 holdnp = np 2015 get CONDITION 2016 ! compile(holdnp,np) 2017 %else %if a(while) 2018 holdnp = np 2019 ! put3(label,curlab,0) 2020 get CONDITION 2021 ! compile(holdnp,np) 2022 ! put3(jump,curlab,0) 2023 ! put3(label,curlab+1,0) 2024 %else %if a(for) 2025 get FOR CLAUSE 2026 ! put3(jump,curlab,0) 2027 ! put3(label,curlab+1,0) 2028 %else 2029 syntax error %if %not a(until) 2030 get CONDITION 2031 %finish 2032 -> term 2033 2034 initial(iu): !%if, %unless 2035 %cycle 2036 holdnp = np 2037 get CONDITION 2038 ! compile(holdnp,np) 2039 %if a(then) %start 2040 -> fudge %if a(start) 2041 get INSTRUCTION 2042 %finish %else %start 2043 get(start) 2044 fudge: 2045 %cycle 2046 get(terminator) 2047 curlab = curlab+2 2048 get STATEMENTS(else) 2049 curlab = curlab-2 2050 %exit %if atom # else; !%finish -> 2051 get CONDITION %if a(iu) 2052 %repeat 2053 %return %if atom # finish 2054 %finish 2055 %exit %if %not a(else) 2056 -> fudge %if a(start) 2057 get INSTRUCTION %and %exit %if %not a(iu) 2058 %repeat 2059 -> term 2060 2061 initial(cycle): 2062 %if a(terminator) %start 2063 holdlooplab = looplab; looplab = curlab 2064 curlab = curlab+2 2065 get STATEMENTS(repeat) 2066 curlab = curlab-2; looplab = holdlooplab 2067 %return %if atom # repeat 2068 get CONDITION %if a(until) 2069 -> term 2070 %finish 2071 nonstandard(oldcycle) 2072 get FOR CLAUSE 2073 -> for1 2074 initial(while): 2075 holdnp = np 2076 ! put3(label,curlab,0) 2077 get CONDITION 2078 ! compile(holdnp,np) 2079 get(cycle) 2080 get(terminator) 2081 holdlooplab = looplab; looplab = curlab 2082 curlab = curlab+2 2083 get STATEMENTS(repeat) 2084 curlab = curlab-2; looplab = holdlooplab 2085 %return %if atom # repeat 2086 nonstandard(loop2) %and get CONDITION %if a(until) 2087 ! put3(jump,curlab,0) 2088 ! put3(label,curlab+1,0) 2089 ->term 2090 initial(for): 2091 get FOR CLAUSE 2092 get(cycle) 2093 for1: 2094 get(terminator) 2095 holdlooplab = looplab; looplab = curlab 2096 curlab = curlab+2 2097 get STATEMENTS(repeat) 2098 curlab = curlab-2; looplab = holdlooplab 2099 %return %if atom # repeat 2100 ! put3(repeat,0,0) 2101 -> term 2102 2103 initial(on): 2104 fault(ordererr+point) %if c_flags >= hadon %or level <= outerlevel 2105 c_flags = c_flags!hadon 2106 matched = 1 2107 allow(keyevent) 2108 %cycle 2109 get LITINT 2110 expfault(rangerr+point) %unless 0 <= t_val <= 15 2111 c_events = c_events!1< term 2120 ! 2121 initial(else): 2122 -> skip %if starts # 0 2123 %return %if stopper = else 2124 error(noif) %if stopper = finish 2125 initial(finish): 2126 starts = starts-1 %and -> skip %if starts # 0 2127 %return %if stopper = finish %or stopper = else 2128 error(nostart) 2129 initial(repeat): 2130 cycles = cycles-1 %and -> skip %if cycles # 0 2131 %return %if stopper = repeat 2132 error(nocycle) 2133 2134 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2135 !!!!!!!!!!!!!!!!!!!! Declarations !!!!!!!!!!!!!!!!!!!!!!!!!!!! 2136 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2137 ! 2138 %integerfn NEWATYPE(%integer eltype,xtype) 2139 %integer dpos 2140 %record(identinfo)%name dp 2141 %ownrecord(identinfo) d=0 2142 dpos = dictmin 2143 %cycle 2144 dp == dict(dpos) 2145 %result = dpos+direct %if dp_flags&typeid # 0 %c 2146 %and dp_type = eltype %and dp_val = xtype 2147 dpos = dpos+1 2148 %repeat %until dpos = dlim 2149 d_flags = typeid; d_type = eltype; d_val = xtype 2150 dict(dpos) = d 2151 dlim = dlim+1; croak("Too many identifers") %if dlim >= dmin 2152 %result = dpos+direct 2153 %end 2154 ! 2155 %integerfn NEWSTYPE(%integer max) 2156 %integer dpos 2157 %record(identinfo)%name dp 2158 %ownrecord(identinfo) d=0 2159 dpos = dictmin 2160 %cycle 2161 dp == dict(dpos) 2162 %result = dpos %if dp_type = stringy %and dp_val = max 2163 dpos = dpos+1 2164 %repeat %until dpos = dlim 2165 d_flags = typeid; d_type = stringy 2166 d_val = max 2167 dict(dpos) = d 2168 dlim = dlim+1; croak("Too many identifers") %if dlim >= dmin 2169 %result = dpos 2170 %end 2171 ! 2172 %integerfn NEWRANGE(%integer type,lower,upper) 2173 %integer dpos 2174 %record(identinfo)%name dp 2175 %ownrecord(identinfo) d=0 2176 fault(boundserr) %and upper = lower %if lower > upper 2177 elements = maxint 2178 elements = upper-lower %if upper!!lower >= 0 %c 2179 %or minint+upper-lower < 0 2180 elements = elements+1 %if elements # maxint 2181 dpos = dictmin 2182 %cycle 2183 dp == dict(dpos) 2184 %result = dpos %if dp_flags = typeid %and dp_type = type %c 2185 %and dp_low = lower %and dp_val = upper 2186 dpos = dpos+1 2187 %repeat %until dpos = dlim 2188 d_flags = typeid; d_type = type 2189 d_low = lower; d_val = upper 2190 dict(dpos) = d 2191 dlim = dlim+1; croak("Too many identifers") %if dlim >= dmin 2192 %result = dpos 2193 %end 2194 2195 %routine GET LITBOUNDS 2196 %integer lower 2197 get(left) 2198 get LITINT; lower = t_val 2199 get(colon) 2200 get LITINT; 2201 get(right) 2202 t_low = lower 2203 item = newrange(inty,t_low,t_val); !always integer at present 2204 %end 2205 2206 %routine GET IDENT 2207 dlim0 = dlim 2208 get(ident) 2209 declare 2210 get LITSTRING %if d_flags&ext # 0 %and a(alias) 2211 %end 2212 2213 %routine GET IDENTLIST 2214 dlim0 = dlim 2215 %cycle 2216 get(ident) 2217 declare 2218 get LITSTRING %if d_flags&ext # 0 %and a(alias) 2219 %repeat %until %not a(comma) 2220 %end 2221 2222 %routine GET TYPE(%integer flags) 2223 %owninteger fbase 2224 %ownrecord(identinfo)%name formp,fieldp 2225 ! 2226 %routine GET FORMATDEF; !(%integername base) 2227 %integer disp,max,base 2228 %routine GET FIELD IDENT 2229 get(ident) 2230 %if item > 0 %then d_text = ditem_text %c 2231 %else %start 2232 d_text = charlim-charbase; charlim = charlim+newlen+1 2233 croak("Identifier space exhausted") %if charlim+80 >= charmin 2234 %finish 2235 ditem == dict(dlim); fieldp == ditem 2236 ditem = d 2237 %if formp_extra = 0 %then formp_extra = dlim %c 2238 %else %start 2239 ! lookup field ident(formp_extra) 2240 ! fault(duperr+point) %and item = dlim %if item # dlim 2241 %finish 2242 dlim = dlim+1; croak("Too many identifiers") %if dlim >= dmin 2243 %end 2244 %routine get UNIT 2245 %cycle 2246 %if a(left) %start 2247 get FORMATDEF; get(right) 2248 %return %if %not a(comma) 2249 %else 2250 get TYPE(static+more) 2251 %if d_flags&parm = 0 %start; !not array 2252 %cycle 2253 disp = disp+1 %if disp&1 # 0 %and dsize # 1 2254 d_val = disp 2255 disp = disp+dsize 2256 get FIELD IDENT 2257 %return %if %not a(comma) 2258 atom = next atom 2259 %repeat %until atom # ident 2260 %else; !array 2261 d_flags = d_flags-parm 2262 disp = disp+1 %if disp&1 # 0; d_val = disp 2263 get FIELD IDENT 2264 get LITBOUNDS 2265 fieldp_type = newatype(d_type,item) 2266 disp = disp+dsize*elements 2267 %return %if %not a(comma) 2268 %finish 2269 %finish 2270 %repeat 2271 %end 2272 max = 0; base = 0 2273 %cycle 2274 disp = base 2275 get UNIT 2276 max = disp %if max < disp 2277 %repeat %until %not a(keyor) 2278 base = max 2279 %end; !get FORMATDEF 2280 2281 dsize = 0; d_mode = 0; d_val = 0 2282 d_type = nulltype 2283 %if a(rpred) %start; !%routine,(%integerfn) 2284 flags = flags&(\static) %if flags&ext # 0 2285 syntax error %if flags&static # 0 2286 nonstandard(pred) %and d_type = booltype %if subatom # 0 2287 d_flags = flags+proc; declmode = declmode+pcmode 2288 %return 2289 %finish 2290 %if a(krange) %start; !%byte,%short,%half,%mite 2291 d_type = inttype+subatom; dsize = 1 2292 dsize = 2 %if d_type = shorttype %or d_type = halftype 2293 nonstandard(ranges) %if d_type >= mitetype 2294 allow(keyinteger) 2295 %else %if a(keyinteger); !%integer 2296 d_type = inttype; dsize = 4 2297 atom = next atom 2298 %if atom = left %start 2299 get LITBOUNDS 2300 d_type = item 2301 dsize = 2 %if elements <= 65536 %and t_low >= -32768 2302 dsize = 1 %if elements <= 256 %and t_low >= -128 2303 %finish 2304 %else %if a(keylong); !%long 2305 d_type = longinttype; dsize = 8 2306 d_type = longrealtype %and get(keyreal) %if %not a(keyinteger) 2307 %else %if a(keyreal); !%real 2308 d_type = realtype; dsize = 4 2309 %else %if a(keystring); !%string 2310 d_type = stringy 2311 t_val = 255; dsize = 256 2312 %if a(left) %start 2313 t_val = 0 2314 %if %not a(star) %start 2315 get LITINT 2316 expfault(rangerr+point) %and t_val = 255 %unless 0 < t_val <= 255 2317 %finish 2318 get(right) 2319 %finish %else nonstandard(nolength) 2320 %if t_val # 0 %start 2321 d_type = newstype(t_val) 2322 dsize = (t_val+2)&(\1); !+1 & evened up 2323 %finish 2324 %else %if a(keyrecord); !%record 2325 d_type = recy 2326 %if a(keyformat) %start 2327 syntax error %if flags&(static+ext) # 0 2328 %if a(keyspec) %start 2329 d_flags = typeid+spec 2330 get IDENT 2331 %finish %else %start 2332 d_flags = typeid 2333 get IDENT 2334 formp == ditem 2335 get(left) 2336 fbase = 0 2337 get FORMATDEF 2338 fieldp_flags = fieldp_flags-more 2339 get(right) 2340 %finish 2341 d_flags = typeid 2342 %return 2343 %finish 2344 get(left) 2345 %if %not a(star) %start 2346 %if %not a(ident) %start 2347 get FORMATDEF 2348 fieldp_flags = fieldp_flags-more 2349 get(right) 2350 d_flags = typeid 2351 declare anon 2352 %finish 2353 name error %if item <= 0 2354 syntax error %if ditem_type # recy 2355 d_type = item; dsize = ditem_val 2356 %finish 2357 get(right) 2358 %else 2359 syntax error %if atom # keyname; !untyped %name 2360 %finish 2361 !End of basic type info: set item size in DECLMODE 2362 %if dsize <= 4 %start 2363 %if dsize <= 2 %then declmode = dsize<= indirect 2378 %if %not a(keyname) %start 2379 syntax error %if flags&parm # 0 2380 flags = flags+parm; !as indic 2381 %exit 2382 %finish 2383 d_type = newatype(d_type,inty) 2384 %finish 2385 syntax error %if d_type >= indirect 2386 d_type = d_type+(indirect-direct) 2387 dsize = 4 2388 %repeat 2389 d_flags = flags!!var 2390 %end; !GET TYPE 2391 ! 2392 %routine GET OWN ARRAY DECLARATION 2393 %integer holdval,dpos 2394 %record(identinfo)%name dp 2395 ! constad = constad+1 %if constad&1 # 0 2396 ! d_val = constad 2397 ! d_val = d_val-ownbase %if d_val >= ownbase 2398 get IDENT 2399 dpos = item; dp == ditem 2400 get LITBOUNDS 2401 dp_type = newatype(d_type,item) 2402 %if a assop %start 2403 allow(terminator) 2404 %cycle 2405 get LITERAL(d_type) 2406 faultnum = rangerr+point+warn %if faultnum = rangerr+point 2407 holdval = t_val 2408 t_val = 1 2409 %if a(left) %start 2410 t_val = elements 2411 get LITINT %if %not a(star) 2412 get(right) 2413 %finish 2414 ! plant const(holdval,t_val) 2415 elements = elements-t_val 2416 %repeat %until %not a(comma) 2417 report(counterr,dpos) %if elements # 0 %and faultnum = 0 2418 %finish 2419 ! plant const(0,elements) %if elements > 0 2420 %end; !get OWN ADECL 2421 2422 %routine GET ARRAY DECLARATION 2423 !ie get IDENTLISTS and BOUNDS 2424 %integer i,dlim1,hold,holdval,type 2425 2426 !%routine put bound pair 2427 ! hold = litref(holdval) %if hold = 0 2428 ! item = litref(t_val) %if item = 0 2429 ! put3(r,hold,item); !(range),lower,upper 2430 !%end 2431 2432 %routine GET BOUNDS 2433 %integer range 2434 get VALUE(anyint) 2435 hold = item; t_val = minint %if hold # 0 2436 holdval = t_val 2437 get(colon) 2438 get VALUE(anyint) 2439 t_val = maxint %if item # 0 2440 range = newrange(inty,holdval,t_val) 2441 GET BOUNDS %if a(comma) 2442 type = newatype(type,range) 2443 %end 2444 2445 %cycle 2446 type = d_type 2447 get IDENTLIST 2448 dlim1 = dlim 2449 get(left) 2450 GET BOUNDS 2451 get(right) 2452 ! %if hold = 0 = item {both literal} %and np = np0 {1-dim} %c 2453 ! %and elements <= 32767 {safe to multiply?} %c 2454 ! %and (elements*dsize*(dlim-dpos))<<1-c_sp-c_delta <= 32000 %start 2455 ! d_par = parref(inty,0,r,0) 2456 ! %finish %else %start 2457 ! put bound pair 2458 ! d_par = 0 2459 ! i = np 2460 ! %while i # np0 %cycle 2461 ! i = i-1 2462 ! d_par = parref(inty,0,exp(i)_act,d_par) 2463 ! %repeat 2464 ! exp(np0)_act = adecl 2465 ! %finish 2466 ! i = np 2467 %while dlim0 # dlim1 %cycle 2468 ! %if i = np0 %start 2469 ! c_delta = c_delta-elements*dsize 2470 ! c_delta = c_delta-1 %if c_delta&1 # 0 2471 ! dict(dlim0)_flags = dict(dlim0)_flags!static 2472 ! %finish %else %start 2473 ! np = i; compile(np0,np0) 2474 ! c_flags = c_flags!dynarray 2475 ! %finish 2476 ! dict(dlim0)_val = c_sp+c_delta 2477 dict(dlim0)_type = type 2478 dlim0 = dlim0+1 2479 %repeat 2480 %repeat %until %not a(comma) 2481 %end; ?I unused 2482 ; !get BOUNDS 2482 2483 %routine GET PARMDEF 2484 %integer headitem,dpos,dlim1 2485 %record(identinfo)%name headditem,dp 2486 %integerfn PARMMATCH(%integer apos) 2487 %integer bpos 2488 %record(identinfo)%name ap,bp 2489 bpos = dlim1 2490 ap == dict(apos) 2491 %while bpos # dlim %cycle 2492 %result = 0 %if ap_flags&more = 0 2493 apos = apos+1 %and ap == dict(apos) %until ap_flags&parm # 0 2494 bp == dict(bpos) 2495 %result = 0 %if ap_type # bp_type; !for now 2496 bpos = bpos+1 2497 %repeat 2498 %result = 1 %if ap_flags&more = 0 2499 %result = 0 2500 %end 2501 ! 2502 headitem = item; headditem == ditem 2503 dlim1 = dlim 2504 %if a(left) %start 2505 %cycle 2506 get TYPE(parm!more) %if atom # ident 2507 %if d_flags&proc = 0 %start 2508 get IDENT 2509 %exit %if %not a(comma) %and atom = right 2510 %if atom # comma %then nonstandard(nocomma) %c 2511 %else atom = next atom 2512 %finish %else %start 2513 get IDENT 2514 speccing = speccing+2 2515 get PARMDEF 2516 speccing = speccing-2 2517 %exit %if %not a(comma) 2518 %finish 2519 %repeat 2520 dict(dlim-1)_flags = dict(dlim-1)_flags-more 2521 get(right) 2522 %finish 2523 %if speccing >= 2 %start 2524 dpos = dictmin 2525 %cycle 2526 dp == dict(dpos) 2527 %if dp_flags&proc # 0 %and dp_type = headditem_type %start 2528 %if parmmatch(dpos) # 0 %start 2529 headditem_type = dpos; dlim = dlim1 2530 %return 2531 %finish 2532 %finish 2533 dpos = dpos+1 2534 %repeat %until dpos >= headitem 2535 fault(caterr); dlim = dlim1 2536 %return 2537 %finish 2538 %if speccing = 0 %and headditem_flags&spec # 0 %start 2539 headditem_flags = headditem_flags-spec 2540 fault(matcherr) %if parmmatch(headitem) = 0 2541 %else 2542 headditem_flags = headditem_flags!more %if dlim # dlim1 2543 %finish 2544 %end; !get PARMDEF 2545 2546 initial(keylabel): nonstandard(klabel) 2547 d_flags = lab+spec; d_type = nulltype 2548 get IDENTLIST 2549 -> term 2550 2551 initial(prefix): 2552 d_flags = subatom; ! !wflag!okflag 2553 ! fault(prefix<<8) %if d_flags&extmask # 0 2554 atom = next atom 2555 initial(krange): initial(keylong): 2556 initial(keyinteger): initial(keyreal): 2557 initial(keystring): initial(keyrecord): 2558 initial(rpred): 2559 matched = 0 2560 get TYPE(d_flags) 2561 %if a(keyspec) %start 2562 %if a(left) %start 2563 get LITINT; get(right) 2564 declmode = declmode&sizemask+absmode 2565 d_val = t_val 2566 get IDENT 2567 speccing = 1 %and get PARMDEF %if d_flags&proc # 0 2568 -> term 2569 %finish 2570 d_flags = d_flags+spec 2571 get IDENTLIST %and -> term %if d_flags&proc = 0 2572 %finish 2573 %if d_flags&proc # 0 %start 2574 get(ident) 2575 %if item >= c_localdpos %and ditem_type = d_type %c 2576 %and ditem_flags&proc # 0 %start 2577 %if ditem_flags&spec = 0 %or d_flags&spec # 0 %start 2578 item = 0; d_flags = d_flags+alt 2579 declare 2580 %finish 2581 %finish %else declare 2582 get LITSTRING %if d_flags&ext # 0 %and a(alias) 2583 %if d_flags&spec # 0 %start 2584 speccing = 1 2585 get PARMDEF 2586 %finish %else %start 2587 open block(item) 2588 get PARMDEF 2589 c_parlim = dlim 2590 compile entry 2591 get(terminator) 2592 get STATEMENTS(end) 2593 ! %if c_access > 0 %start 2594 ! report(noresult,0) %if c_type > nulltype; !fn/map/pred 2595 ! %finish 2596 close block 2597 %finish 2598 %else %if d_flags = typeid {dealt with} 2599 %else %if d_flags&parm # 0; !array 2600 d_flags = d_flags-parm 2601 %if d_flags&static # 0 %start 2602 get OWN ARRAY DECLARATION 2603 %finish %else %start 2604 %if d_flags&static = 0 %and c_flags >= hadon %start 2605 fault(ordererr); c_flags = c_flags&(\(hadon+hadinst)) 2606 %finish 2607 get ARRAY DECLARATION 2608 %finish 2609 %else %if d_flags = static {const} 2610 d_type = dict(d_type&puretype)_type 2611 d_type = d_type+direct %if d_type = recy %or d_type = stringy 2612 %cycle 2613 get IDENT 2614 syntax error %if %not a assop 2615 get LITERAL(d_type) 2616 faultnum = rangerr+point+warn %if faultnum = rangerr+point 2617 dict(dlim-1)_val = t_val 2618 %repeat %until %not a(comma) 2619 %else %if d_flags&static # 0 {own} 2620 ! constad == ownad; constbound = finalbound 2621 declmode = declmode+ownmode 2622 %cycle 2623 ! constad = constad+1 %if constad&1 # 0 %and dsize # 1 2624 ! t_val = constad-ownbase 2625 get IDENT 2626 t_val = 0 2627 %if a assop %start 2628 ! %if d_flags&direct = 0 2629 get LITERAL(d_type) 2630 faultnum = rangerr+point+warn %if faultnum = rangerr+point 2631 %finish 2632 elements = 1 2633 ! plant const(t_val,1) 2634 %repeat %until %not a(comma) 2635 %else; !dynamic variable 2636 ! declmode = declmode+dispmode+level 2637 %if d_flags&static = 0 %and c_flags >= hadon %start 2638 fault(ordererr); c_flags = c_flags&(\(hadon+hadinst)) 2639 %finish 2640 %cycle 2641 !problematic c_delta = c_delta-1 %if c_delta&1 # 0 %and dsize # 1 2642 c_delta = c_delta-dsize 2643 c_delta = c_delta-1 %if c_delta&1 # 0 2644 t_val = c_sp+c_delta 2645 get IDENT 2646 %if a assop %start 2647 nonstandard(initass) 2648 %if d_type >= indirect %start 2649 fault(caterr+point) %if atom # eqeq 2650 get REFERENCE(d_type) 2651 item = item+ad %if item # 0 2652 ! put3(assign,dlim-1+ad,item) 2653 %finish %else %start 2654 fault(caterr+point) %if atom = eqeq 2655 get VALUE(d_type) 2656 ! put2(assign,dlim-1) 2657 %finish 2658 ! compile(np0,np0) 2659 %finish 2660 %repeat %until %not a(comma) 2661 %finish 2662 -> term 2663 2664 %routine GET SWITCH DECLARATION 2665 %integer i,j,dlim1 2666 matched = 1 2667 %cycle 2668 d_flags = lab; d_type = nulltype 2669 declmode = pcmode+wordsize<term 2687 2688 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2689 !!!!!!!!!!!!!!! Control statements !!!!!!!!!!!!!!!!!!!!!!!!!!! 2690 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2691 ! 2692 initial(keycontrol): 2693 get LITINT 2694 control = 0 %if t_val = 0 2695 control = control!!t_val 2696 ->term 2697 2698 initial(include): 2699 get LITSTRING 2700 extra_name = "" 2701 %while t_val > 0 %cycle 2702 extra_name = extra_name.tostring(byteinteger(atomp)) 2703 atomp = atomp+1; t_val = t_val-1 2704 %repeat 2705 get(terminator) 2706 %if faultnum = 0 %start 2707 connect edfile(extra) 2708 nonstop = -999 %and %signal 12 %if extra_flag # 0 2709 mainfp = fp; mainline = line 2710 line = 0; sym = nl 2711 fp = extra_start2; curstart = fp; curlim = extra_lim2 2712 modesym = '&'; nonstop = nonstop+1 2713 %finish 2714 ->next 2715 2716 initial(keylist): 2717 ->term 2718 2719 initial(begin): 2720 c_sp = -8 2721 get(terminator) 2722 open block(0) 2723 get STATEMENTS(0) 2724 close block 2725 -> term %if stopper >= 0 2726 %return 2727 2728 initial(end): 2729 %if %not a(of) %start 2730 fault(nofinish) %if stopper = else %or stopper = finish 2731 fault(norepeat) %if stopper = repeat 2732 %return %if stopper >= 0 2733 fault(nobegin) 2734 ->term 2735 %finish 2736 %if a(keylist) %start 2737 ->term 2738 %finish 2739 %if a(keyfile) %start 2740 %if curlim = extra_lim2 %start 2741 switch input 2742 ->next 2743 %finish 2744 %finish %else get(program) 2745 %end; !GET STATEMENTS 2746 2747 %routine INIT(%integer t,l,h) 2748 d_flags = typeid; d_type = t; d_low = l; d_val = h 2749 dict(dlim) = d; dlim = dlim+1 2750 %end 2751 2752 %on %event 12 %start 2753 -> printout %if fp = main_lim2 2754 -> ended %if main_flag < 0 %or nonstop = -999; !abandon or CROAK 2755 change = main_change 2756 %finish 2757 2758 printstring(" IMP Checker "); newline 2759 hashindex(i) = 0 %for i = 0,1,255; !hash table empty 2760 charbase = addr(char(0)); byteinteger(charbase) = 0; !for anon ident 2761 charlim = charbase+1 2762 charmin = charlim+charbound; !(1 over top) 2763 dict(i)_val = 0 %for i = d0,1,labmax 2764 d_flags = typeid; d_low = minint; d_val = maxint 2765 dmin = dictmax-1; dlim = dictmin 2766 %cycle 2767 d_type = dlim; dict(dlim) = d 2768 dlim = dlim+1 2769 %repeat %until dlim > booltype 2770 d_flags = 0 2771 init(booltype,0,0) 2772 init(booltype,0,1) 2773 d_flags = typeid 2774 init(inty,minint,maxint) 2775 init(inty,-32768,32767) 2776 init(inty,0,65535) 2777 init(inty,0,255) 2778 init(inty,-128,127) 2779 init(inty,0,1) 2780 init(inty,minint,maxint) 2781 init(realy,minint,maxint) 2782 init(realy,minint,maxint) 2783 c = 0; c_localdpos = dlim; c_parlim = dlim 2784 level = outerlevel 2785 spc = finalbound 2786 faults = 0; line = 0; mainline = 0 2787 ! 2788 mainfp = main_start1 2789 extra_name = permfile 2790 connect edfile(extra) 2791 nonstop = -999 %and %signal 12 %if extra_flag # 0 2792 fp = extra_start2; curstart = fp; curlim = extra_lim2 2793 nonstop = -2; nonstop = -1 %if main_flag = 'I' 2794 sym = nl 2795 get STATEMENTS(-1) 2796 ! report(noend,0) %if level < mainlevel 2797 ! report(nobegin,0) %if level > mainlevel 2798 ! compile end %while level >= mainlevel 2799 printout: 2800 ! time2 = cputime 2801 %if faults = 0 %start 2802 write(statements,1) 2803 print string(" statements checked ") 2804 %finish %else %start 2805 write(faults,1) 2806 print string(" fault") 2807 put sym('s') %if faults > 1 2808 print string(" reported ") 2809 %finish 2810 newline 2811 ended: 2812 newline; !*for now to ensure message not erased* 2813 ! %if control&logbit # 0 %start 2814 !! write(zaps,1); print symbol('Z') 2815 ! write(statements,1); print symbol('S') 2816 ! statements = 1 %if statements = 0 2817 ! atoms = atoms+statements 2818 ! print(atoms/statements,1,1); print symbol('A') 2819 ! print(numatoms/statements,1,1); print symbol('N') 2820 ! print(identatoms/statements,1,1); print symbol('I') 2821 ! print(misses/identatoms,1,2); print symbol('H') 2822 ! print((time2-time1)/statements,3,3); print symbol('M') 2823 !! write(finalad,1); print symbol('B') 2824 !! write(ownad-ownbase,1); print symbol('O') 2825 ! newline 2826 ! %finish 2827 2828 %end; ?LISTMATCH unused ?LEFTBRACKET unused ?TEMPVAR unused 0 nused 0 nused ?COMPILE unused ?SETLABEL unused ?IBMHEX unused ?HYPHEN unused ?OVERLOAD unused ?LISTOUT unused ?CHARS unused ?PROLINE unused ?DIAGLINE unused ?CASEMASK unused ?OWNAD unused ?FINALAD unused ?DYNARRAY unused ?NONLOCALREF unused ?WRONGCC unused ?IREADENTRY unused ?INDEXENTRY unused ?AGETENTRY unused ?BOUNDENTRY unused ?SCOMPENTRY unused ?SIGENTRY unused ?DNEWLINE unused ?DREAD unused ?DPRINTSTR unused ?DOUBLE unused ?CS unused ?CC unused ?GE unused ?LT unused ?LE unused ?GT unused ?NE unused ?EQ unused ?ACTMAX unused ?ADECL unused ?LABEL unused ?JUMP unused ?COMPARE unused ?PLUSASS unused ?JAMASSIGN unused ?ASSIGN unused ?SWGOTO unused ?FCALL unused ?FMOD unused ?IMOD unused ?FLOAT unused ?RIGHTBRACKET unused ?COMMENT unused ?WFLAG unused ?RFLAG unused ?OKFLAG unused ?LITMODE unused ?INDEXMODE unused ?PREMODE unused ?POSTMODE unused ?INDMODE unused ?AMODE unused ?DMODE unused ?BYTESIZE unused ?LITSTORE unused ?SLITPOS unused ?DICTSHOWN unused ?ANYNAME unused ?ANYINTVAR unused ?FALSECONST unused ?FREE unused ?A2B unused ?A1B unused ?A0B unused ?D2B unused ?D1B unused ?D0B unused ?MAXAREG unused ?MAXDREG unused ?UNDEF unused ?PREA7 unused ?POSTA7 unused ?A7 unused ?A6 unused ?A1 unused ?D7 unused ?D6 unused ?D2 unused ?D1 unused ?SMALLMIN unused ?EXTRANAME unused 2829 ; !of ECCECI 2829 %endoffile 2102 Statements compiled