!IMP syntax checker - based on M68000 IMP compiler ! (qv for fuller annotation) ! Hamish Dewar Computer Science Edinburgh University 1983 ! %constinteger MAXNAME=127 %recordformat EDFILE(%integer start1,lim1, {part 1} start2,lim2, {part2} lim, {VMLIM} lbeg,fp,change,flag, line {line number of current pos}, diff {diff between LINE and ROW}, shift {right shift of window on file}, %byteinteger top {top row of sub_window}, win {floating top}, bot {bottom row +1 of sub_window}, min {minimum window size}, row {last row position}, col {last col position}, %string(maxname) name) ! %external%routine%spec EDI(%record(edfile)%name main,sec, %string(255) message) %external%routine%spec CONNECT EDFILE(%record(edfile)%name f) %external%routine%spec DISCONNECT EDFILE(%record(edfile)%name f) ! !$IF VAX {%conststring(13) permfile="ECCE:PERM.IMP" !$IF AMDAHL %conststring(18) permfile="ERCLIB:VECCE.IPERM" !$FINISH !! control %constinteger logbit= 16_00040000 {print log}, warnbit= 16_00020000 {print warnings}, nonsbit= 16_00010000 {print nonstandard reports}, DICTLIST= 16_00001000 {list dict entries}, EXPLIST= 16_00000800 {list EXP entries} %owninteger control=warnbit+nonsbit !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! %externalroutine ECCECI(%record(edfile)%name main) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! %ownstring(maxname) extraname %ownrecord(edfile) extra=0,null=0 %integer curstart,curlim %integer nonstop %owninteger change=0 !! Fault numbers %constinteger FORMERR=0, ATOMERR=1, NAMERR=2, CATERR=3, SIZERR=4, ASSERR=5, TYPERR=6, DUPERR=7, NOSTART=8, NOCYCLE=9, ORDERERR=10, MATCHERR=11, RANGERR=12, NONLITERAL=13, BOUNDSERR=14, ACCESSERR=15, NOTINLOOP=16, NOTINROUT=17, NOTINFUN=18, NOTINPRED=19, PLEXERR=20, NOIF=21, NONSTAND=22, NOTIN=23, INDEXERR=24, MOPERR=27, NOTERM=28, NONSTARTER=29, NONVAR=30, NONREF=31, TOOMANY=32, TOOFEW=33, UNWANTED=34, NOPARM=35, UNENDING=37, SELFREF=38 %constinteger NOEND=40, NOBEGIN=41, IDMISSING=42, NOFINISH=43, NOREPEAT=44, COUNTERR=45, NORESULT=46 %constinteger ERRMAX=46 %constinteger POINT=64,WARN=128 %owninteger FAULTNUM=0 %owninteger FAULTS=0; !fault count ! %constinteger MAXINT=16_7FFFFFFF, MININT=\MAXINT, MAX10=maxint//10, MAXDIG=maxint-max10*10 %constinteger FALSE=0, TRUE=1 %integer I ! !! Program statistics %owninteger STATEMENTS=0; !statement count !%owninteger ATOMS=0; !atom count !%owninteger IDENTATOMS=0; !identifier count !%owninteger NUMATOMS=0; !numeric atom count !%owninteger MISSES=0; !ident mismatches !%owninteger ZAPS=0 ! !!!!!!!!!!!!!!!! Operand Representation !!!!!!!!!!!!!!!!!!! %constinteger SMALLMIN=-1000, SMALLMAX=1000, LITMIN=smallmax+1, LITMAX=smallmax+1000, D0=litmax+1, D1=d0+1, D2=d0+2, D6=d0+6, D7=d0+7, A0=d0+8, A1=a0+1, A6=a0+6, A7=a0+7, INDA0=a0+8, POSTA0=inda0+8, POSTA7=posta0+7, PREA0=posta0+8, PREA7=prea0+7, DICTMIN=prea0+8, DICTMAX=prea0+1200, LABMIN=dictmax+1, LAB1=labmin+1, LABMAX=labmin+20, EXPMIN=labmax+1, EXPMAX=labmax+300, UNDEF=expmax+1, AD=16_4000 %constinteger MAXDREG=d0+4, MAXAREG=a0+3 %constinteger D0B=1, D1B=2, D2B=4, A0B=16_100, A1B=16_200, A2B=16_400 %constinteger ALLREGS=2_0000111100011111; !a3:a0 & d4:d0 %owninteger FREE=allregs %constinteger NULLTYPE=dictmin, RECY=nulltype+1, ARRY=recy+1, STRINGY=arry+1, REALY=stringy+1, INTY=realy+1, CHARTYPE=inty+1, BOOLTYPE=chartype+1, FALSECONST=booltype+1, TRUECONST=booltype+2, INTTYPE=trueconst+1, SHORTTYPE=inttype+1, HALFTYPE=shorttype+1, BYTETYPE=halftype+1, MITETYPE=bytetype+1, BITTYPE=MITETYPE+1, LONGINTTYPE=bittype+1, REALTYPE=longinttype+1, LONGREALTYPE=realtype+1 %constinteger PURETYPE=8191, DIRECT=8192, INDIRECT=16384 %constinteger ANYINT=inty+direct, ANYINTVAR=inty+indirect, ANYSTRING=stringy+direct, ANYSTRINGVAR=stringy+indirect %constinteger ANYNAME=nulltype+indirect ! %owninteger dictshown=dictmin !!!!!!!!!!!!!!!!!!!!!!! Big Literals !!!!!!!!!!!!!!!!!!!!!!! %owninteger LITPOS=litmin, SLITPOS=litmax %integerarray LITSTORE(litmin:litmax) ! !!!!!!!!!!!!!!!!!!!!!!!!!! MODE VALUES !!!!!!!!!!!!!!!!!!!!!!!!! !Size codes: %constinteger bytesize=1, wordsize=2, longsize=3 %constinteger sizemask=16_C0, sizeshift=6 !Address modes: %constinteger dmode=0, amode=2_001000, indmode=2_010000, postmode=2_011000, premode=2_100000, dispmode=2_101000, indexmode=2_110000, absmode=2_111000, pcmode=2_111010, litmode=2_111100 %constinteger ownmode=dispmode+6; !d(A6) ! !!!!!!!!!!!!!!!!!!!!!!!! Identifiers !!!!!!!!!!!!!!!!!!!!!!!! ! %recordformat OBJINFO %C (%integer flags,type, (%integer extra, %byteinteger spare,mode %or %integer low), %integer val) %recordformat IDENTINFO %C ((%integer flags,type, (%integer extra, %byteinteger spare,mode %or %integer low), %integer val %or %record(objinfo) details), %integer text,link) ! ! Significance of FLAGS: %constinteger VAR=16_0001, LAB=16_0002, PROC=16_0004, STATIC=16_0008, SPEC=16_0010, EXT=16_0020, PARM=16_0040, MORE=16_0080, TYPEID=16_0100, OKFLAG=16_0200, ALT=16_0800, RFLAG=16_1000,WFLAG=16_2000 ! ! Significance of VAL: ! for literal : the actual value ! for variable : machine address (displacement) ! for undefined label : reference chain ! for undefined procedure : " ! for base type : (index to) range ! for record type : size of record in bytes ! ! Identifier dictionary: %record(identinfo)%array DICT(d0:labmax) ! indexing DICT: %owninteger DLIM=trueconst+1; !dict limit (up) %owninteger DLIM0 %owninteger PERMLIM=dictmin %owninteger DMIN=dictmax-1; !dict upper limit (down) ! Text of identifiers (indexed by _TEXT): %constinteger CHARBOUND=6000 %byteintegerarray CHAR(0:charbound) %integer CHARBASE,CHARLIM,CHARMIN; !pointers %integer NEWLEN ! Hash index to DICT: %integerarray HASHINDEX(0:255) %integername HEAD; !head of ident search list ! !!!!!!!!!!!!!!!!!!!!! Complex operands !!!!!!!!!!!!!!!!!!!!!!! !%recordformat EXPINFO(%integer act,x,y) !%record(expinfo)%array EXP(expmin:expmax) %owninteger EXPLO=expmax+1, OLDEXPLO=expmax+1 %constinteger NP0=expmin %owninteger NP,CONDNP,INSTNP !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!! Keywords and operators !!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !*!!!!!!! Keyword codes -- used by KEYGEN to produce tables !! %constinteger END=1 {end}, REPEAT=2 {repeat}, FINISH=3 {finish}, ELSE=4 {else}, BEGIN=5 {begin}, EXIT=6 {exit_1,continue_0}, RETURN=7 {return}, TF=8 {true_1,false_0}, RESULT=9 {result}, STOP=10 {stop}, GOTO=11 {goto}, SIGNAL=12 {signal}, MONITOR=13 {monitor}, ON=15 {on}, IU=16 {if_0,unless_1}, WHILE=17 {while}, UNTIL=18 {until_1}, FOR=19 {for}, THEN=20 {then}, START=21 {start}, CYCLE=22 {cycle}, KEYLABEL=23 {label}, PREFIX=24 {const_9,constant_9,own_8,external_40,system_40,dynamic_40}, KRANGE=25 {short_1,half_2,byte_3,mite_4,bit_5}, KEYLONG=26 {long}, KEYINTEGER=27 {integer}, KEYREAL=28 {real}, KEYSTRING=29 {string}, KEYRECORD=30 {record}, KEYFORMAT=31 {format}, FNMAP=32 {fn_0,function_0,map_1}, RPRED=33 {routine_0,predicate_1}, KEYSPEC=34 {spec}, KEYARRAY=35 {array}, KEYNAME=36 {name}, KEYSWITCH=37 {switch}, OF=38 {of}, KEYFILE=39 {file}, PROGRAM=40 {program}, KEYLIST=41 {list}, KEYCONTROL=42 {control}, COMMENT=43 {comment}, KEYEVENT=44 {event}, INCLUDE=45 {include}, ALIAS=46 {alias}, KEYNOT=47 {not}, KEYAND=64 {and}, KEYOR=65 {or} %CONSTintegerARRAY SYMINIT(97:122) = %C 2, 15, 27, 57, 64, 87,118,122,126, 1, 1,141,154,168,175,184, 1,199,230,270,278, 1,288, 1, 1, 1 %CONSTBYTEINTEGERARRAY SYMBOL(1:292) = %C 128,114,114, 97,121,163,108,105, 97,115,174,110,100,192,101,103, 105,110,133,121,116,101,153,105,116,153,111,110,116,105,110,117, 101,134,121, 99,108,101,150,109,109,101,110,116,171,115,116, 97, 110,116,152,152,114,111,108,170,121,110, 97,109,105, 99,152,110, 100,129,108,115,101,132,120,105,116,134,118,101,110,116,172,116, 101,114,110, 97,108,152,105,110,105,115,104,131, 97,108,115,101, 136,111,114,109, 97,116,159,110,160,117,110, 99,116,105,111,110, 160,147,108,101,167,111,116,111,139, 97,108,102,153,102,144,110, 116,101,103,101,114,155, 99,108,117,100,101,173, 97, 98,101,108, 151,111,110,103,154,105,115,116,169,111,110,105,116,111,114,141, 105,116,101,153, 97,112,160, 97,109,101,164,111,116,175,110,143, 119,110,152,102,166,114,193,114,101,100,105, 99, 97,116,101,161, 111,103,114, 97,109,168,101,112,101, 97,116,130,111,117,116,105, 110,101,161,116,117,114,110,135,115,117,108,116,137, 97,108,156, 99,111,114,100,158,116,111,112,138,105,103,110, 97,108,140,121, 115,116,101,109,152,104,111,114,116,153,112,101, 99,162,119,105, 116, 99,104,165, 97,114,116,149,114,105,110,103,157,114,117,101, 136,104,101,110,148,110,108,101,115,115,144,116,105,108,146,104, 105,108,101,145 %CONSTBYTEINTEGERARRAY ALTDISP(1:292) = %C 0, 5, 0, 0, 0, 0, 5, 0, 0, 0, 0, 0, 0, 0, 5, 0, 0, 0, 0, 4, 0, 0, 3, 0, 0, 5, 8, 12, 17, 23, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 40, 3, 0, 0, 4, 0, 0, 0, 4, 8, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 40, 6, 27, 0, 0, 0, 0, 5, 0, 0, 0, 0, 6, 0, 14, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 2, 0, 0, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 7, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 1, 4, 0, 0, 0, 0, 0, 0, 2, 0, 3, 0, 8, 2, 0, 0, 0, 0, 8, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 6, 12, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5, 0, 0, 0, 0, 5, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 4, 30, 0, 0, 6, 0, 0, 0, 0, 0, 6, 0, 0, 0, 0, 40, 5, 0, 0, 0, 1, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 1, 0, 0, 0, 0, 0, 5, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0 !*!!!!!! end of generated tables !!!!!!!!!!!!!!!!!!!!!!!!!!! ! %constinteger TERMINATOR=52, CONST=53, IDENT=54, AREF=55, RECREF=56, MODSIGN=57, COLON=58, COMMA=59, RIGHT=60, RIGHTBRACKET=61, DUD=63 !Operators (in banks of 8 acc to rank) %constinteger BOOLAND=64, BOOLOR=65, BOOLNOT=66, FLOAT=67, IMOD=68, FMOD=69 %constinteger EQUALS=70, NOTEQ=71, LESSEQ=72, LESS=73, GREATEQ=74, GREATER=75, EQEQ=76, NOTEQEQ=77, RESOLVE=79 %constinteger PLUS=80, MINUS=81, LOGOR=82, LOGXOR=83, CONCAT=84 %constinteger MULT=88, FDIV=89, IDIV=90, LOGAND=91 %constinteger FPOWER=96, IPOWER=97, LSHIFT=100, RSHIFT=101, LOGNOT=102 %constinteger FCALL=106, MCALL=107 %constinteger ATOMMAX=107 ! Instruction actions: %constinteger swgoto=35, rcall=mcall+2, assign=41, jamassign=42, plusass=43, compare=44, jump=45, label=46, adecl=47 %constinteger actmax=49 ! !Branch cases ( = machine condition-code) %constinteger EQ=2_0111, NE=2_0110, GT=2_1110, LE=2_1111, LT=2_1101, GE=2_1100, CC=2_0100, CS=2_0101 %constinteger DOUBLE=16 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Perm procedure identifiers which are recognised explicitly and ! either implemented in-line or mapped to system entry-point %constinteger DSHORT=dictmin+6, DLENGTH=dshort+1, DCHARNO=dlength+1, DADDR=dcharno+1, DTOSTR=daddr+1, DREM=dtostr+1, DNEXTSYM=drem+1, DREADSYM=dnextsym+1, DPRINTSTR=dreadsym+3, DREAD=dictmin+27, DNEWLINE=dictmin+41 !System entry-points used explicitly %constinteger SIGENTRY=16_1114, SCOMPENTRY=16_1128, BOUNDENTRY=16_1134, AGETENTRY=16_1138, INDEXENTRY=16_113C, IREADENTRY=16_1118 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! %owninteger STARTS=0, CYCLES=0 %owninteger LOOPLAB=0 %owninteger CURLAB=lab1 ! %recordformat BLOCKINF(%integer sp, delta, fortemps, flags, type, localdpos, parlim, localtext, localpc, localspc, pidpos, access, forward, events, eventpc, faults, return, shorts) !Flag bits (VAR=1 from D_FLAGS) %constinteger WRONGCC=2, NONLOCALREF=4, DYNARRAY=8 %constinteger HADON=16_10, HADINST=16_20 %constinteger OUTERLEVEL=0, MAXLEVEL=16 %owninteger LEVEL=outerlevel; !current block level %record(blockinf) C; !info for current block %record(blockinf)%array HOLD(0:maxlevel-1); !info for global blocks ! Final core image %constinteger PUREBOUND=0, OWNBASE=purebound+1, FINALBOUND=ownbase+8191 %byteintegerarray FINAL(0:finalbound); !for switch info only %owninteger FINALAD=2, OWNAD=ownbase !%owninteger FIRSTENTRY=finalbound, FIRSTDPOS=dictmax !%ownintegername CONSTAD; !== ownad or finalad !%owninteger CONSTBOUND=purebound; !for const/code ! =finalbound; !for own %owninteger PC=0, SPC=finalbound; !for switch info !Recognition:- %constinteger CASEMASK=95, CASEBIT=32; !for case conversion !Memo variables for current statement:- %owninteger ITEM=0; !current operand %record(objinfo) T; !full typeinfo for ITEM %record(identinfo)%name DITEM %owninteger ELEMENTS; !range details %owninteger HASH %owninteger SPECCING=0, MCODING=0 %owninteger DECLMODE, DSIZE %ownrecord(identinfo) D; !declaration details !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Source file input and listing %owninteger ATOM=0; !current lexical atom %owninteger MATCHED=1; !indic that atom has been matched %owninteger SYM=nl; !current input symbol %owninteger LINE=0; !current line number %owninteger MAINLINE=0 %owninteger DIAGLINE=-9999 %owninteger PROLINE=0 %owninteger MODESYM='&'; !space or '+' or '&' or '"' !%owninteger OUTCOL=0; !output line position ! Pointers to source file: %owninteger LINESTART=0 %owninteger FP=0; !(file pointer) current position %owninteger CHARS=0 %owninteger ATOMP=0; !start of current atom %owninteger FAULTP=0; !fault position %owninteger MAINFP %owninteger STRINGP,EXPP %owninteger listout=0 ! !! Listing, diagnostic and report routines ! %ownstring(255) rep="" ! %routine NEWLINE print string(rep); print symbol(nl) rep = "" %end ! %routine PUT SYM(%integer k) rep = rep.tostring(k) %if length(rep) < 132 %end ! %routine PRINT STRING(%string(255) s) rep = rep.s %if length(rep) < 132 %end ! %routine SPACES(%integer n) %while n > 0 %cycle rep = rep." "; n = n-1 %repeat %end ! %routine WRITE(%integer val,p) %routine PD(%integer v) p = p-1 pd(v//10) %and v = v-v//10*10 %if v <= -10 spaces(p) %and p = 0 %if p > 0 put sym('0'-v) %end %if val < 0 %start put sym('-'); pd(val) %finish %else pd(-val) %end !%routine put ident(%integer t) ! rep = rep.string(charbase+t) !!%integer l ! t = t+charbase ! l = byteinteger(t); l = 11 %if l > 11 ! %while l > 0 %cycle ! l = l-1; t = t+1 ! put sym(byteinteger(t)) ! %repeat !%end ! !%routine mark at(%integer col) ! put sym(' ') %while outcol < col; put sym('|') !%end ! !%routine show dict(%integer from) !%integer f,i !%record(identinfo) d !%constbyteintegerarray flagsym(0:7) = ! 'V','L','P','O','S','E', 'A', 'M' !%constbyteintegerarray dsym(0:3) = ! ' ','D','I','!' !%conststring(6)%array typetext(0:7) = ! "NULL ", "RECORD", "ARRAY ", "STRING", ! "REALY ", "INTY ", "CHAR ", "BOOL " ! %return %if from >= dlim ! newline %and outcol = 0 %if outcol # 0 ! print string(" __identifier___flags___type___extra___value___") ! newline; outcol = 0 ! %cycle ! spaces(5); outcol = 5 ! pdec(from); mark at(10) ! d = dict(from) ! put sym(' ') ! put ident(d_text) ! mark at(23) ! %for i = 7,-1,0 %cycle ! %if d_flags>>i&1 = 0 %then put sym(' ') %c ! %else put sym(flagsym(i)) ! %repeat ! put sym('|') ! i = d_type-nulltype ! %if 0 <= i <= 7 %then printstring(typetext(i)) %c ! %else putsym(dsym(d_type>>13)) %and pdec(d_type&puretype) ! mark at(39) ! put sym(' '); pdec(d_extra); mark at(47) ! put sym(' '); pdec(d_val); mark at(56) ! newline; outcol = 0 ! from = from+1 ! %repeat %until from = dlim ! print string(" +----------------------------------------------+") ! newline; outcol = 0 !%end ! !%routine show exp(%integer from,to) !![out of date] !%conststring(7)%array acttext(0:63) = ! "?0", "?1", "ADD", "SUB", ! "?4", "LOGAND", "LOGOR", "LOGXOR", ! "NEGATE", "LOGNOT", "LSHIFT", "RSHIFT", ! "IABS", "FABS", "?14", "?15", ! "MULT", "IDIV", "IPOWER", "FPLUS", ! "FMINUS", "FMULT", "FDIV", "FPOWER", ! "FNEGATE", "FLOAT", "CONCAT", "BOOLNOT", ! "BOOLAND", "BOOLOR", "MEMBER", "MODULO", ! "RECREF", "AREF", "INDRECT", "SWJUMP", ! "FCALL", "MCALL", "?38", "RCALL", ! "?40", "ASSIGN", "JAMASS", "PLUSASS", ! "COMPARE", "JUMP", "LABEL", "ADECL", ! "?48", "?49", "?50", "?51", ! "?52", "?53", "?54", "?55", ! "?56", "?57", "?58", "?59", ! "?60", "?61", "?62", "?63" !%routine put operand(%integer i) ! %if dictmin <= i <= dictmax %then put ident(dict(i)_text) %else pdec(i) !%end ! %return %if from >= np ! newline %and outcol = 0 %if outcol # 0 ! print string(" __action_____first_______second____") ! newline; outcol = 0 ! %cycle ! spaces(5); outcol = 5 ! pdec(from); mark at(10) ! put sym(' '); printstring(acttext(exp(from)_act&63)) ! mark at(20); put sym(' ') ! put operand(exp(from)_x) ! mark at(32); put sym(' ') ! put operand(exp(from)_y) ! mark at(44) ! newline; outcol = 0 ! from = from+1 ! %if from = to %start ! from = explo ! %exit %if from >= oldexplo ! printstring(" |---------------------------------|") ! newline; outcol = 0 ! %finish ! %repeat %until from >= oldexplo ! oldexplo = explo ! print string(" +---------------------------------+") ! newline; outcol = 0 !%end ! !! Fault reporting ! %routine REPORT(%integer n,joker) %integer mark,start,errline,k,editfp %routine PRINT IDENT(%integer x) put sym('"') print string(string(dict(x)_text+charbase)) put sym('"') %end %routine PRINT TEXT(%integer x,stream) %constinteger esc=27 %integer k,p %switch s(0:errmax) put sym(mark) write(line,4) put sym(modesym); put sym(' ') ->s(n&63) s(formerr): printstring("Faulty form"); -> print s(atomerr): printstring("Unknown atom"); -> print s(namerr): printstring("Unknown name"); -> print s(caterr): printstring("Unsuitable"); -> print s(sizerr): printstring("Size"); -> print s(typerr): printstring("Wrong type"); -> print s(boundserr): printstring("Inside out"); -> print s(unending): printstring("Endless loop"); -> print s(indexerr): printstring("Index"); -> print s(accesserr): printstring("Not accessible");-> print s(notinloop): printstring("Not in loop"); -> print s(notinrout): printstring("Not in routine");-> print s(notinfun): printstring("Not in fn/map"); -> print s(notinpred): printstring("Not in pred"); -> print s(plexerr): printstring("Too complex!"); -> print s(duperr): printstring("Duplicate"); -> print s(ordererr): printstring("Out of order"); -> print s(matcherr): printstring("Mismatch"); -> print s(rangerr): printstring("Out of range"); -> print s(nonliteral):printstring("Not literal"); -> print s(nonstand): printstring("Nonstandard"); -> print s(notin): printstring("Not in yet"); -> print s(moperr): printstring("Faulty operand");-> print s(nocycle): printstring("Missing %CYCLE"); -> print s(nostart): printstring("Missing %START"); -> print s(noif): printstring("Missing %IF"); -> print s(noterm): printstring("';' missing"); -> print s(nonstarter):printstring("Non-starter"); -> print s(nonvar): printstring("Not variable"); -> print s(nonref): printstring("Not reference"); -> print s(noparm): printstring("No parameters"); -> print s(toofew): printstring("Too few"); -> print s(unwanted): printstring("Unwanted"); -> print s(toomany): printstring("Too many"); -> print s(selfref): printstring("Self-reference"); -> print s(nobegin): printstring("Extra %END"); -> print print: spaces(21-length(rep)) p = start %if p < faultp-50 %then p = faultp-47 %and printstring("...") %c %else put sym(' ') %cycle k = byteinteger(p); p = p+1 %if p = faultp %start !$IF VAX { put sym(esc) %and put sym('F') %if stream = 0 !$FINISH put sym('~') !$IF VAX { put sym(esc) %and put sym('G') %if stream = 0 !$FINISH %finish %exit %if k = nl %if ' ' <= k <= '~' %then put sym(k) %c %else put sym('[') %and write(k,-1) %and put sym(']') %repeat %return s(noend): printstring("%END"); ->mend s(noresult): printstring("Result"); ->mend s(nofinish): printstring("%FINISH"); ->mend0 s(norepeat): printstring("%REPEAT") mend0: printstring(" etc") %if curlab > lab1+2 -> mend s(idmissing): %cycle ! newline %and spaces(8) %and outcol = 8 %if outcol > 50 put sym(' ') print ident(x) print string("(?)") %if dict(x)_flags&spec = 0; !switch x = dict(x)_val %repeat %until x = 0 mend: printstring(" missing") %if c_type # 0 %start print string(" at END of ") print ident(c_pidpos) %finish %else n = 0 %return s(counterr): %if elements < 0 %start write(-elements,0); printstring(" extra") %finish %else %start write(elements,0); printstring(" missing") %finish printstring(" value(s) for ") print ident(x) %return s(asserr): print ident(x) print string(" void") %end !Warning or error mark = '?' %if n&warn = 0 %start mark = '*' c_faults = c_faults+1; faults = faults+1 %finish faultnum = 0; c_access = -1 !Ignore uncorrected earlier error %return %if main_start1 <= fp < change !Track back if before current line start = linestart; errline = line %if n&point = 0 %then faultp = 0 %else %start faultp = joker %if joker > 0 %while faultp <= start %cycle start = start-1 errline = errline-1 %if byteinteger(start) = nl %repeat start = start-1 %while start # curstart %and byteinteger(start-1) # nl %finish editfp = start; editfp = faultp-1 %if faultp > start editfp = mainfp %if curlim = extra_lim2 start = start+1 %while byteinteger(start) = ' ' print text(joker,0) newline %and %return %if n&warn # 0 %or nonstop # 0 main_fp = editfp; main_line = line %if change # 0 %then main_change = 16_7FFFFFFE edi(main,null,rep) rep = "" nonstop = 1 %if main_flag = 'I' %stop %if main_flag < 0 %signal 12 %if main_change < 16_7FFFFFFE {change made} %end; !report %routine CROAK(%string(255) s) print string("** ".s.". Checking abandoned at line ") write(line,0); newline nonstop = -999 %signal 12 %end %routine FAULT(%integer n) !Note fault number and position of (earliest) fault ! for subsequent reporting (warnings and weak errors) faultnum = n %and faultp = atomp %if faultnum = 0 %end %routine EXPFAULT(%integer n) faultnum = n!point %and faultp = expp %if faultnum = 0 %or expp < faultp %end %constinteger pred=1, uparr=1<<1, nocomma=1<<2, overload=1<<3, ranges=1<<4, nolength=1<<5, initass=1<<6, kgoto=1<<7, hyphen=1<<8, naming=1<<9, klabel=1<<10, ibmhex=1<<11, oldcycle=1<<12, loop2=1<<13 %routine NONSTANDARD(%integer case) %owninteger hadit=0 %if control&nonsbit # 0 %and case&hadit = 0 %start hadit = hadit+case fault(nonstand+point+warn) %finish %end %routine ERROR(%integer case) report(case,atomp) %signal 14 %end %routine NAME ERROR !check if the culprit has occurred before !and, if not, add it to the pool of unknowns stored at the !far end of the dictionary. %while item < 0 %c %and string(dict(-item)_text+charbase) # string(charlim) %cycle item = dict(-item)_link %repeat %if item >= 0 %start; !first time report(namerr+point,atomp) %if charmin-newlen-80 >= charlim %start dmin = dmin-1 charmin = charmin-newlen-1 string(charmin) = string(charlim) dict(dmin)_text = charmin-charbase head == dict(head)_link %while head > 0; !find last link dict(dmin)_link = head; head = -dmin %finish %finish %signal 14 %end %routine SYNTAX ERROR %integer e e = formerr+point; e = atomerr+point %if atom = dud report(e,atomp) %signal 14 %end !!!!!!!!!!!!!!!!!!!! CELL CONSTRUCTORS !!!!!!!!!!!!!!!!!!! ! !%integerfn litref(%integer v) !%integer i ! %result = v %if smallmin <= v <= smallmax ! litstore(litpos) = v ! i = litmin-1 ! i = i+1 %until litstore(i) = v ! %if i = litpos %start ! litpos = litpos+1 ! croak("Too many literals") %if litpos >= slitpos ! %finish ! %result = i !%end !%integerfn litval(%integer v) ! %result = v %if v <= smallmax ! %result = litstore(v) !%end %integerfn floated(%integer item) %result = 0 %if item = 0 %result = explo;!expref(float,item,0) %end !%predicate is short (%integer v) ! %result=1 %if -32768 <= v <= 32767 ! %result=0 !%end !%predicate is mite (%integer v) ! %result=1 %if -128 <= v <= 127 ! %result=0 !%end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!! CODE GENERATION !!!!!!!!!!!!!!!!!!!!!!!! ! %routine forget %end %routine forget all %integer i,j litpos = litmin; explo = expmax+1; oldexplo = explo %end ! %routine set label(%integer b) %end; !set label %routine set user label(%integer dpos) %end %routine compile(%integer from,to) ! show exp(from,to) %if control&explist # 0 np = np0 %end %routine compile entry %end %routine compile end %end; !compile end !!!!!!!!!!!!!!! end of Code Generation !!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! %routine PUT3(%integer act,x,y) ! exp(np)_act = act; exp(np)_x = x; exp(np)_y = y ! np = np+1 %end ! %routine PUT2(%integer act,x) %end ! %integerfn TEMPVAR %result = dlim %end %routine OPEN BLOCK(%integer pidpos) forget; !a bit extreme croak("Too many levels") %if level = maxlevel hold(level) = c; level = level+1 c = 0 starts = 0; cycles = 0 curlab = lab1; looplab = 0 forget all c_flags = 0; c_type = d_type c_pidpos = pidpos c_localdpos = dlim; c_parlim = dlim; c_localtext = charlim c_localpc = pc; c_localspc = spc c_access = 1 %end; !OPEN BLOCK %routine CLOSE BLOCK %integer i %integer miss,dpos %integername p %record(identinfo)%name dp !Check identifier usage miss = 0; p == miss dpos = c_localdpos %while dpos # dlim %cycle dp == dict(dpos) ! %if (dp_xtype = ptrxtype %and dp_type = dpos) %if dp_flags&(proc+lab) # 0 %and dp_flags&(ext+spec) = spec %start p = dpos; p == dp_val; p = 0 %finish ! %if hashindex(dp_spare) = dpos %start ! dp_link = dict(dp_link)_link %while dp_link >= c_localdpos ! hashindex(dp_spare) = dp_link ! %finish ! dpos = dp_xtype %if dp_type = 0 %and dp_xtype > dpos; !skip fields dpos = dpos+1 %repeat report(idmissing,miss) %if miss # 0 compile end pc = c_localpc; spc = c_localspc dlim = c_parlim; charlim = c_localtext %for i = 0,1,255 %cycle hashindex(i) = dict(hashindex(i))_link %while hashindex(i) >= c_localdpos %repeat level = level-1; c = hold(level) starts = 0; cycles = 0 %end; !CLOSE BLOCK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!! Source input !!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! %routine SWITCH INPUT ! croak("Input ended") %if fp = main_lim2 %signal 12 %if fp = main_lim2 %if nonstop < 0 %start; !perming nonstop = nonstop+3; permlim = dlim c_localdpos = dlim; c_parlim = dlim statements = 0 %finish %if fp # main_lim1 %start nonstop = nonstop-1 fp = mainfp; line = mainline curstart = main_start1; curlim = main_lim1 %finish %else fp = main_start2 %if main_start2 <= fp <= main_lim2 %start curstart = main_start2; curlim = main_lim2 %finish modesym = ' '; sym = nl %end %routine READ LINE ! Read (or otherwise make available) the next source line ! Skip remnant of previous line if SYM # NL *NB* ! Set LINESTART to point to start of new line report(faultnum,faultp) %if faultnum # 0 %while sym # nl %cycle; !Skip remnant sym = byteinteger(fp); fp = fp+1 %repeat %while fp = curlim %cycle switch input %repeat line = line+1; linestart = fp sym = 0 %end; !READ LINE ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!! Lexical processing !!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! %owninteger percent=0, subatom=0 ! !Aliases: %constinteger ARROW=resolve %constinteger EXCLAM=logor, EXCLAM2=logxor, DOT=concat %constinteger STAR=mult, SLASH=fdiv, SLASH2=idiv, AMPERSAND=logand %constinteger BACKSLASH=fpower, BACKSLASH2=ipower, UPARROW=fpower, UPARROW2=ipower, TILDE=lognot %constinteger LEFT=aref, UNDERLINE=recref, LEFTBRACKET=106 %constinteger SIMPLE=104, MAJOR=plus, SCOND=equals, COND=keyand ! ! Type compatibility vectors: %constinteger RECOK=1<<0, ARROK=1<<1, STRINGOK=1<<2, REALOK=1<<3, INTOK=1<<4, CHAROK=1<<5, BOOLOK=1<<6, ENUMOK=1<<7, SETOK=1<<8 %constinteger ZNOP=1<<9, REFONLY=1<<10, VARONLY=1<<11 %constinteger ARITHOK=intok+realok, ORDOK=intok+charok+boolok+enumok, ANY=realok+ordok+stringok+arrok+recok ! %constintegerarray opbits(64:atommax) = {BOOLAND} boolok, {BOOLOR} boolok, 0, 0, 0, 0, {EQUALS} any, {NOTEQ} any, {LESSEQ} setok+stringok+ordok+realok, {LESS} stringok+ordok+realok, {GREATEQ} setok+stringok+ordok+realok, {GREATER} stringok+ordok+realok, any, any, 0, {RESOLVE} stringok, {PLUS} znop+setok+arithok, {MINUS} znop+setok+arithok, {LOGOR} znop+intok, {LOGXOR} znop+intok, {CONCAT} stringok, 0, 0, 0, {MULT} arithok, {FDIV} arithok, {IDIV} intok, {LOGAND} intok, 0, 0, 0, 0, {FPOWER} arithok, {IPOWER} intok, 0, 0, {LSHIFT} znop+intok, {RSHIFT} znop+intok, {LOGNOT} intok, 0, {AREF} arrok, {RECREF} recok, {} 0, 0 ! %integerfn NEXT ATOM !Encode next atom from source file ![Time-critical] %switch s(0:255) %constinteger tab=9 %integer i,j,p,radix,digits %real rval %constbyteintegerarray map(0:127) = 0 ('0'), '0','1','2','3','4','5','6','7','8','9', 0, 0, 0, 0, 0, 0, 0, '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', 0, 0, 0, 0, 0, 0, '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', 0, 0, 0, 0, 0 %routine assemble real j = 0 %cycle %cycle sym = byteinteger(fp); fp = fp+1 %repeat %until sym # ' ' i = sym-'0' %return %unless 0 <= i < radix rval = rval*radix+i; j = j+1 %repeat %end ! atoms = atoms+1 matched = 0 again: s(tab): read line %if sym = nl %cycle sym = byteinteger(fp); fp = fp+1 %repeat %until sym # ' ' atomp = fp; !(actually one after) -> s(sym) linebreak: s(nl): %result = terminator %if atom # comma -> again s('{'): %cycle sym = byteinteger(fp); fp = fp+1 -> linebreak %if sym = nl %repeat %until sym = '}' -> again s('+'): %result = plus s('-'): fp = fp+1 %and %result = arrow %if byteinteger(fp) = '>' -> again %if byteinteger(fp) = nl %result = minus s('*'): %result = star s('/'): fp = fp+1 %and %result = slash2 %if byteinteger(fp) = '/' %result = slash s('\'): fp = fp+1 %and %result = backslash2 %if byteinteger(fp) = '\' %result = backslash s('^'): nonstandard(uparr) fp = fp+1 %and %result = uparrow2 %if byteinteger(fp) = '^' %result = uparrow s('!'): fp = fp+1 %and %result = exclam2 %if byteinteger(fp) = '!' %result = exclam s('&'): %result = ampersand s('.'): %result = dot s('='): fp = fp+1 %and %result = eqeq %if byteinteger(fp) = '=' %result = equals s('#'): fp = fp+1 %and %result = noteqeq %if byteinteger(fp) = '#' %result = noteq s('<'): fp = fp+1 %and %result = lesseq %if byteinteger(fp) = '=' fp = fp+1 %and %result = noteq %if byteinteger(fp) = '>' fp = fp+1 %and %result = lshift %if byteinteger(fp) = '<' %result = less s('>'): fp = fp+1 %and %result = greateq %if byteinteger(fp) = '=' fp = fp+1 %and %result = rshift %if byteinteger(fp) = '>' %result = greater s('_'): %result = underline s(':'): %result = colon s(','): %result = comma s(';'): %result = terminator s('('): %result = left s(')'): %result = right s('|'): %result = modsign s('E'): s('e'): fp = fp+1 %and -> stringconst %if byteinteger(fp) = '"' s('M'): s('m'): s('C'): s('c'): fp = fp+1 %and -> charconst %if byteinteger(fp) = '''' s('A'):s('B'):s('D'):s('F'):s('G'):s('H'): s('I'):s('J'):s('K'):s('L'):s('N'):s('O'):s('P'): s('Q'):s('R'):s('S'):s('T'):s('U'):s('V'):s('W'):s('X'): s('Y'):s('Z'):s('a'):s('b'):s('d'):s('f'): s('g'):s('h'):s('i'):s('j'):s('k'):s('l'):s('n'): s('o'):s('p'):s('q'):s('r'):s('s'):s('t'):s('u'):s('v'): s('w'):s('x'):s('y'):s('z'): -> keyword %if percent # 0 ! identatoms = identatoms+1 newlen = charlim+1; hash = sym!casebit; !lower-case (if letter) byteinteger(newlen) = hash %cycle sym = byteinteger(fp); fp = fp+1 %repeat %until sym # ' ' !$IF AMDAHL %if sym = '''' %start radix = 16 %and -> ibm %if hash = 'x' radix = 8 %and -> ibm %if hash = 'k' radix = 2 %and -> ibm %if hash = 'b' %finish !$FINISH sym = map(sym) %if sym # 0 %start %cycle newlen = newlen+1; byteinteger(newlen) = sym hash = hash<<1!!sym %cycle sym = byteinteger(fp); fp = fp+1 %repeat %until sym # ' ' sym = map(sym) %repeat %until sym = 0 %finish fp = fp-1 newlen = newlen-charlim; byteinteger(charlim) = newlen head == hashindex(hash&255) item = head %if item > 0 %start %cycle %result = ident %if item <= 0 ditem == dict(item) %exit %if string(ditem_text+charbase) = string(charlim) ! misses = misses+1 item = ditem_link %repeat %until item <= 0 %finish %result = ident s('%'): sym = byteinteger(fp) -> again %unless 'a' <= sym!casebit <= 'z' fp = fp+1 keyword: percent = 0 p = syminit(sym!casebit) %cycle ! %cycle ! sym = byteinteger(fp)!casebit ! %exit %if symbol(p) # sym %while symbol(p) = byteinteger(fp)!casebit %cycle p = p+1; fp = fp+1 %repeat %exit %if symbol(p) >= 128 atom = altdisp(p) %if atom = 0 %start %result = dud %unless sym!casebit = 'c' %and byteinteger(fp) = nl read line ->again %finish p = p+atom %repeat percent = 1 %if 'a' <= byteinteger(fp)!casebit <= 'z' subatom = altdisp(p) atom = symbol(p)-128 %result = dud %if atom = 0 %result = atom !$IF AMDAHL ibm: nonstandard(ibmhex) item = -1; t_val = 0 -> ibm1 !$FINISH s('0'):s('1'):s('2'):s('3'):s('4'):s('5'):s('6'):s('7'):s('8'):s('9'): item = 0; t_type = inty radix = 10; t_val = sym-'0' ibm1: %cycle %cycle %cycle sym = byteinteger(fp); fp = fp+1 %repeat %until sym # ' ' i = sym-'0' %if radix = 10 %start %exit %if i < 0 %or i >= 10 %if t_val > max10 %or (t_val=max10 %and i > maxdig) %start t_type = realy; rval = t_val assemble real %exit %finish t_val = t_val*10+i %finish %else %start i = sym!casebit-'a'+10 %if i >= 10 %exit %if i < 0 %or i >= radix j = radix %cycle i = i+t_val %if j&1 # 0 t_val = t_val<<1; j = j>>1 %repeat %until j = 0 t_val = i %finish %repeat %exit %unless sym = '_' radix = t_val %result = dud %if radix = 0 t_val = 0 %repeat %if sym = '.' %start t_type = realy %and rval = t_val %if t_type = inty assemble real %result = dud %if j = 0 rval = rval/radix\j %finish ! %if t_type = realy %start; !vax->ieee ! t_val = integer(addr(rval)) ! t_val = t_val<<16+t_val>>16-16_01000000 ! %finish ! numatoms = numatoms+1 !$IF AMDAHL %if item < 0 %start %result = dud %if sym # '''' item = 0 %finish %else %start fp = fp-1; sym = 0 %finish !$IF VAX OR APM { fp = fp-1; sym = 0 !$FINISH %result = const s(''''): charconst: item = 0; t_type = inty t_val = 0 %cycle sym = byteinteger(fp); fp = fp+1 %result = dud %if sym = nl; !?allow %if sym = '''' %start %exit %unless byteinteger(fp) = '''' fp = fp+1 %finish t_val = t_val<<8+sym %repeat %result = const %if t_val # 0 %result = dud s('"'): stringconst: item = 0; t_type = stringy stringp = atomp; !for include t_val = 0 i = line; j = linestart %cycle sym = byteinteger(fp); fp = fp+1 %if sym = '"' %start %exit %if byteinteger(fp) # '"' fp = fp+1 %finish t_val = t_val+1 %if t_val > 255 %start sym = 0 fp = atomp; linestart = j %result = dud %finish read line %if sym = nl %repeat %result = const s(*): %result = dud %end; !NEXT ATOM %routine LOOKUP FIELD IDENT(%integer list) item = list; %return %if item = 0 %cycle ditem == dict(item) %if ditem_flags&typeid = 0 %start %return %if string(ditem_text+charbase) = string(charlim) %exit %if ditem_flags&more = 0 %finish item = item+1; !misses = misses+1 %repeat item = 0 %end %integerfn A (%integer k) !Basic atom-testing predicate atom = next atom %if matched # 0 %result=0 %if k # atom matched = 1 %result=1 %end %routine GET(%integer k) atom = next atom %if matched # 0 matched = 1 %return %if atom = k syntax error %if atom = dud faultp = atomp; report(formerr+point,-k) %signal 14 %end %routine ALLOW(%integer k) %if a(k)#0 %start %finish %end %routine DECLARE %if speccing = 0 %start; !not within spec params %if item >= c_localdpos %start; !there already %if d_flags&spec = 0 %and d_flags+spec = ditem_flags %c %and ditem_type = d_type %start ditem_flags = ditem_flags-spec %return %finish fault(duperr+point) %finish d_link = head; head = dlim; !insert in list ! d_spare = hash&255 %if item > 0 %then d_text = ditem_text %c %else %start d_text = charlim-charbase; charlim = charlim+newlen+1 croak("Identifier space exhausted") %if charlim+80 >= charmin %finish %finish %else d_text = 0 item = dlim; ditem == dict(item) ditem = d dlim = dlim+1; croak("Too many identifiers") %if dlim >= dmin %end; !DECLARE %routine DECLARE ANON d_text = 0; d_link = 0 dict(dlim) = d dlim = dlim+1; croak("Too many identifiers") %if dlim >= dmin %end %owninteger jammy %integerfn A ASSOP atom = next atom %if matched # 0 %if atom # equals %and atom # eqeq %start %result=0 %unless atom = less %and byteinteger(fp) = '-' jammy = 2; fp = fp+1 %finish %else jammy = 0 matched = 1 %result=1 %end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!! Expressions !!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! %owninteger literal=0 %routinespec get EXPRESSION(%integer rank,control) %integerfn COMPAT(%integer control) %if t_type = inty %start %if control&intok = 0 %and control&realok # 0 %start item = floated(item) t_type = realy %finish %result = control&(intok+realok) %finish %result = control&(boolok>>(booltype-t_type)) %if t_type <= booltype %result = control&enumok %if t_type < direct %result = control&arrok %end ! %integerfn LISTMATCH(%integer alist,blist) %record(identinfo)%name ap,bp %result = 1 %if alist = blist %result = 0 %if alist < dictmin %or blist < dictmin %cycle ap == dict(alist); bp == dict(blist) %result = 0 %if ap_type # bp_type; !for now alist = alist+1; blist = blist+1 %repeat %until ap_flags&bp_flags&more = 0 %result = 0 %if ap_flags&more # 0 %or bp_flags&more # 0; !for now %result = 1 %end ! %routine GET REFERENCE(%integer reftype) %integer type,temp get EXPRESSION(simple,refonly+any) type = ditem_type&puretype; reftype = reftype&puretype %return %if reftype = type %if type < reftype %start temp = type; type = reftype; reftype = temp %finish %return %if reftype = nulltype; !untyped %name type = dict(type)_type %return %if type <= inty %and type = reftype %return %if type >= direct %and type = dict(reftype)_type; !aname expfault(typerr+point) %end ! %routine GET VALUE(%integer valtype) %record(identinfo)%name dp,p get EXPRESSION(major,any) valtype = valtype&puretype dp == dict(valtype) %if t_type # dp_type %start; !base types differ %return %if item = 0 = t_val; !zero %if dp_type = realy %and t_type = inty %start !float t_type = realy %return %finish %finish %else %if t_type >= inty %start; !scalar %if item = 0 %start %return %if dp_low <= t_val <= dp_val jammy = jammy!1 %if jammy >= 0 %finish %else %start %if t_low >= dp_low %start %return %if t_val <= dp_val jammy = jammy!1 %if jammy >= 0 %return %if t_low <= dp_val %finish %else %start jammy = jammy!1 %if jammy >= 0 %return %if t_val >= dp_low %finish %finish expfault(rangerr+point) %if jammy < 2 %return %finish %else %if t_type = stringy %start %if t_val > dp_val %start; !VALUE = LENGTH* jammy = jammy!1 %if jammy >= 0 expfault(rangerr+point) %if item = 0 %and jammy < 2 %finish %return %finish %else %if t_type = recy %start %return %if t_extra = dp_extra jammy = jammy!1 %and %return %if jammy >= 2 !partial assignment? %finish %else %if t_type = realy %start %return %finish expfault(typerr+point) %end; !GET VALUE ! %routine GET LITERAL(%integer littype) literal = literal+1 get VALUE(littype) literal = literal-1 %end ! %routine GET LITINT literal = literal+1 get EXPRESSION(major,intok) literal = literal-1 %end ! %routine GET LITSTRING %integer holditem !Must be quoted string (for %alias and %include) holditem = item; !preserve get(const) error(typerr+point) %if t_type # stringy item = holditem; !restore %end ! %routine GET PARMLIST %record(identinfo)%name hp,dp %integer i,j,headitem,headact,dpos,case,procnp,first headitem = item; hp == ditem headact = rcall !stack procedure ident ! procnp = np; put3(headact,headitem,0) i = 0; first = 1 dpos = headitem; dp == hp %cycle !Set up expression state from formal param details error(toomany+point) %if dp_flags&more = 0 dpos = dpos+1 %and dp == dict(dpos) %until dp_flags&parm # 0 %if dp_flags&proc # 0 %start get(ident) name error %if item <= 0 fault(typerr+point) %if ditem_flags&proc = 0; !for now fault(caterr+point) %if item > headitem %finish %else %if dp_type < indirect %start; !value ! %if pp_type&numericmask # 0 %then case = i&7 %and i = i+1 %c ! %else case = i>>3+8 %and i = i+8 case = i&7; i = i+1 get VALUE(dp_type) %finish %else %start; !name or proc case = i>>3+8; i = i+8 get REFERENCE(dp_type) %finish ! case = case<<8+headact ! item = litref(t_val) %if item = 0 ! j = np-1 ! %if first = 0 %start ! j = np ! !NB Don't re-order parameters for implicits ! %if item >= expmin %and headitem > dnewline %start ! %while j > procnp %and exp(j-1)_y < expmin %cycle ! exp(j)_act = exp(j-1)_act; exp(j)_y = exp(j-1)_y ! j = j-1 ! %repeat ! %finish ! exp(np)_x = 0; np = np+1 ! %finish ! exp(j)_act = case; exp(j)_y = item ! first = 0 %repeat %until %not a(comma)#0 ! %if hp_type # nulltype %start ! i = explo ! %while i <= expmax %cycle ! %if exp(i)_x = headitem %start; ![enough?] ! item = i; j = procnp ! %cycle ! %exit %if exp(i)_y # exp(j)_y ! i = i+1; j = j+1 ! ->okf %if j >= np ! %repeat ! %finish ! i = i+1 ! %repeat ! %cycle ! explo = explo-1; np = np-1 ! exp(explo) = exp(np) ! %repeat %until np = procnp item = explo !okf:np = procnp ! %finish %end; !get PARMLIST %routine GET RESOLUTION %if %not a(left)#0 %start get REFERENCE(anystringvar) get(dot) get(left) %finish get VALUE(anystring) get(right) %if a(dot)#0 %start get REFERENCE(anystringvar) %finish %end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! %routine GET EXPRESSION(%integer rank,control) !Main expression recognition routine !To bring together the treatment of all binary operators ! and ensure fast recognition of simple expressions, ! expressions of different levels are handled by ! precedence techniques rather than syntactically !CONTROL defines acceptability %integer type,f,opok,c1,op,atomp1,item1 %record(objinfo) t1 %record(identinfo)%name dp %integerfn litval %switch lit(64:atommax) -> lit(op) lit(plus): %result = t1_val+t_val lit(minus): %result = t1_val-t_val lit(mult): %result = t1_val*t_val lit(idiv): %result = t1_val//t_val %if t_val # 0 fault(rangerr) %result = 0 lit(logand): lit(booland): %result = t1_val&t_val lit(logor): lit(boolor): %result = t1_val!t_val lit(logxor): %result = t1_val!!t_val lit(lshift): %result = t1_val<>t_val lit(boolnot): %result = t_val!!true lit(lognot): %result = \t_val !lit(negate): %result = -t_val lit(equals): %result = true %if t1_val = t_val %result = false lit(noteq): %result = true %if t1_val # t_val %result = false lit(lesseq): %result = true %if t1_val <= t_val %result = false lit(less): %result = true %if t1_val < t_val %result = false lit(greateq): %result = true %if t1_val >= t_val %result = false lit(greater): %result = true %if t1_val > t_val %result = false lit(concat): %result = t1_val+t_val lit(*): !report(notwhat,-op) %result = 1 %end !Get leading operand atom = next atom %if matched # 0 atomp1 = atomp; !note position for reports %if atom = ident %start matched = 1 name error %if item <= 0 fault(selfref+point) %if item >= dlim0 type = ditem_type %if control&(refonly+varonly) # 0 %start error(nonvar+point) %if control&varonly # 0 %and f&var = 0 error(nonref+point) %if type < direct %finish f = ditem_flags %if inty <= type <= booltype %and f&proc = 0 %start; !literal item = 0; t = ditem_details %finishelsestart fault(nonliteral+point) %if literal > 0 %if f&proc # 0 %start ditem == dict(type) %and type = ditem_type %if f&parm # 0 error(caterr+point) %if type = nulltype; !routine %if a(left)#0 %start dp == ditem get PARMLIST; get(right) ditem == dp %finishelsestart error(toofew+point) %if ditem_flags&more # 0 item = explo;!expref(f&var+fcall,item,0) %finish %finish %cycle dp == dict(type&puretype); t = dp_details atom = next atom %if matched # 0 %exit %if atom # underline %and atom # left matched = 1 item1 = item %if atom = left %start %cycle syntax error %if t_type < direct; !element type type = t_type get VALUE(t_val); !index item = explo;!expref(aref,item1,item,t_val) ditem == dp %exit %if %not a(comma)#0 dp == dict(type&puretype); t = dp_details item1 = item %repeat get(right) %finishelsestart; !rec subfield syntax error %if t_type # recy get(ident) lookup field ident(t_extra) error(namerr+point) %if item <= 0 type = ditem_type item = explo;!expref(recref,item,item1) %finish %repeat -> final %if control&(varonly+refonly) # 0 %finish %finishelsestart error(nonvar+point) %if control&varonly # 0 error(nonref+point) %if control&refonly # 0 %if a(const)#0 %start %finish %else %if atom = minus %start; !leave unmatched item = 0; t = 0; t_type = inty %finish %else %if a(left)#0 %start %if rank < major %start; !condition get EXPRESSION(cond,any) %finish %else %start jammy = jammy-4 c1 = control; c1 = c1!intok %if c1&realok # 0 get EXPRESSION(major,c1) jammy = jammy+4 %finish get(right) %finish %else %if a(keynot)#0 %start syntax error %if rank >= major get EXPRESSION(scond,any) %if item = 0 %then t_val = t_val!!true %c %else item = explo;!expref(boolnot,item,0) %finish %else %if atom = backslash %start item = 0; t = 0; t_type = inty atom = tilde %finish %else %if a(modsign)#0 %start fault(typerr+point) %if control&arithok = 0 get EXPRESSION(major,arithok) get(modsign) %if item = 0 %start %if t_val < 0 %start %if t_val # minint %then t_val = -t_val %else expfault(rangerr) %finish %finish %else %if t_type = inty %start item = explo;!expref(imod,item,0) %finish %else %if t_type = realy %start item = explo;!expref(fmod,item,0) %finishelsestart error(typerr) %finish %finishelsestart syntax error %finish %finish atom = next atom %if matched # 0 %while atom >= rank %cycle op = atom; matched = 1 opok = opbits(op); c1 = compat(opok); ![may change ITEM,T_TYPE] fault(typerr+point) %if c1 = 0 item1 = item; t1 = t %if op >= major %start; !non-conditional %if op = dot %then get EXPRESSION(dot,stringok) {right-associate} %c %else get EXPRESSION(op&(\7)+8,c1) %if t_type = realy %and t1_type = inty %start item1 = floated(item1); t1_type = realy %finish ! op = op+? %if t_type = realy %and opok&intok # 0 %finishelsestart %if op = resolve %start get RESOLUTION %finish %else %if op >= eqeq %start get EXPRESSION(simple,any+refonly) %finish %else %if op >= equals %start get EXPRESSION(major,c1) %if equals <= atom < eqeq %start op = atom; matched = 1 get EXPRESSION(major,c1) %finish %if t_type = realy %and t1_type = inty %start item1 = floated(item1); t1_type = realy %finish %finishelsestart get EXPRESSION(scond,any) %if atom >= cond %start syntax error %if atom # op %finish %finish t_type = booltype t_low = 0 %and t_val = 1 %if item # 0 %finish %if item1 = 0 %start; !first operand literal %if item = 0 %start; !both literal t_val = litval %continue %if item = 0 ! item1 = litref(t1_val) ! %finish %else %if inverse(op) # 0 %start; !invertable ! op = inverse(op) ! temp = t; t = t1; t1 = temp; !standardise order ! item1 = item; item = 0 %finishelsestart ! item1 = litref(t1_val) %finish %finish %if item = 0 %start; !second operand literal %if op = minus %and t_type = inty %start; !standardise t_val = -t_val %if t_val # minint; op = plus %finish item = item1 %and %continue %if t_val = 0 %and opok&znop # 0 %finish item = explo;!expref(op,item1,item,t_val) t_low = minint; t_val = maxint; !?real %repeat final: expp = atomp1; !restore to start expfault(typerr) %if compat(control) = 0 %end; !get EXPRESSION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!! Conditions and loops !!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! %routine GET CONDITION %integer polarity polarity = subatom condnp = np get EXPRESSION(cond,any) ! put3(jump+polarity,item,0) %end; !get CONDITION %routine GET STATEMENTS(%integer stopper) %integer holdnp,holdlooplab %switch initial(0:atommax) %routine GET INSTRUCTION %integer item1,hold,act %record(identinfo)%name ditem1 %routine putact ! put3(act,t_val,hold) %end ! %if c_flags < hadinst %start; !first in block c_flags = c_flags+hadinst fault(ordererr) %if level <= outerlevel %finish instnp = np %cycle %if a(ident)#0 %start name error %if item <= 0 %if ditem_flags&var # 0 %start matched = 0 get EXPRESSION(simple,any) item1 = item; ditem1 == ditem %if a(equals)#0 %start get VALUE(ditem1_type) ! put2(assign,item1) %finish %else %if a(eqeq)#0 %start syntax error %if ditem1_type < indirect get REFERENCE(ditem1_type) item = item+ad %if item # 0 ! put2(assign,item1+ad) %finish %else %if atom = less %and byteinteger(fp) = '-' %start fp = fp+1; matched = 1 jammy = 2 get VALUE(ditem1_type) ! put2(jamassign,item1) %finishelsestart syntax error %if %not a(arrow)#0 get RESOLUTION ! put2(resolve,item1) %finish %finishelsestart error(caterr+point) %if ditem_flags&proc = 0 ditem == dict(ditem_type) %if ditem_flags&parm # 0 error(caterr+point) %if ditem_type # nulltype %if a(left)#0 %start get PARMLIST; get(right) %finishelsestart; !parameterless routine error(toofew+point) %if ditem_flags&more # 0 ! put3(rcall,item,0) %finish %finish %finish %else %start act = atom; hold = subatom; t_val = 0 c_access = 0 %if a(monitor)#0 %start c_access = 1 ! fault(monitor<<8) %finish %else %if a(exit)#0 %start; !%exit, %continue %if looplab = 0 %then fault(notinloop+point) %c %else t_val = looplab %and putact %exit %finish %else %if a(return)#0 %start %if c_type # nulltype %then fault(notinrout+point) %c %else putact %exit %finish %else %if a(result)#0 %start error(notinfun+point) %if c_type <= nulltype syntax error %if %not a assop#0 %if c_type < direct %start; !function fault(caterr+point) %if atom = eqeq get VALUE(c_type) ! put2(result,0) %finishelsestart; !map fault(caterr+point) %if atom # eqeq get REFERENCE(c_type+(indirect-direct)) ! put2(result,0) %finish %exit %finish %else %if a(tf)#0 %start; !%result=1, %result=0 %if c_type # booltype %then fault(notinpred+point) %c %else putact %exit %finish %else %if a(arrow)#0 %or a(goto)#0 %start nonstandard(kgoto) %if atom = goto get(ident) %if byteinteger(fp) # '(' %start %if item < c_localdpos %or ditem_flags&lab = 0 %c %or ditem_type # nulltype %start d_flags = spec+lab; d_type = nulltype declare %finish ! put3(jump,item,0) %finish %else %start name error %if item < c_localdpos syntax error %if ditem_flags&lab = 0 %or ditem_type = nulltype get(left) get VALUE(ditem_type); !index get(right) %finish %exit %finish %else %if a(stop)#0 %start putact %exit %finish %else %if a(signal)#0 %start c_access = 1 allow(keyevent) get LITINT expfault(rangerr+point) %unless 0 <= t_val <= 15 hold = t_val; t_val = 0 get LITINT %if a(comma)#0 hold = t_val<<4+hold item = 0; t_val = 0 get VALUE(anyint) %if a(comma)#0 ! put2(act,hold) %exit %finishelsestart syntax error %finish %finish %repeat %until %not a(keyand)#0 %end; !GET INSTRUCTION %routine GET FOR CLAUSE %integer loopvar,k,s,start,sval,i,inc,ival,e,n,temp %integer eval %record(identinfo)%name dp holdnp = np; temp = 0 dict(curlab)_val = 1; !dummy condnp = np get(ident) name error %if item <= 0 fault(typerr+point) %if dict(ditem_type&puretype)_type # inty fault(caterr+point+warn) %if ditem_type # direct+inttype loopvar = item; dp == ditem get(equals) get VALUE(ditem_type) start = item; sval = t_val get(comma) get VALUE(anyint) inc = item; ival = t_val expfault(rangerr+point) %and ival = 1 %if inc = 0 = ival get(comma) get VALUE(ditem_type) !Deal with INC and replace START by START-INC ! k = undef ! k = exp(start)_y %if start >= expmin %and exp(start)_act = plus %if inc = 0 %start; !literal increment i = 1; !litref(ival) %if start = 0 %start; !START and INC both literal sval = sval-ival; s = 1; !litref(sval) ! %finish %else %if k <= litmax %start; !START is x+lit ! k = ival-litval(k) ! s = exp(start)_x; s = explo;!expref(plus,s,litref(k)) %if k # 0 %finishelsestart s = explo;!expref(plus,start,litref(-ival)) %finish %finish %else %start; !allocate temp var ! i = tempvar; put3(assign,i,inc); temp = temp-4 ! %if start = inc %start; !identical ! s = 0; sval = 0 ! %finish %else %if k = inc %start; !START is x+INC ! s = exp(start)_x ! %finishelsestart ! s = start; s = litref(sval) %if s = 0 s = explo;!expref(minus,s,i) ! %finish %finish ! %if item = 0 %start; !literal end-value ! e = litref(t_val); eval = t_val ! %finish %else %start ! e = tempvar; put3(assign,e,item); temp = temp-4 ! %finish ! put3(assign,loopvar,s) ! put3(label,curlab,0) %if start!inc!item = 0 %start; !all literal k = t_val-sval; n = k//ival fault(boundserr) %if n < 0 fault(unending) %if n*ival # k ! %if 0 <= t_val <= 32767 %start ! temp = loopvar ! %finish %finish ! %if temp <= 0 %start ! c_fortemps = c_fortemps-temp; !ie increment ! put3(compare,loopvar,e) ! put3(eq,0,curlab+1) ! %finish ! put3(plusass,loopvar,i) ! compile(holdnp,np) %end; !get FORCLAUSE %routine GET SWITCH INDEX %integer item1 %record(identinfo)%name dp item1 = item; dp == ditem get(left) item = 1 %if a(star)#0 %start fault(duperr+point) %if dp_spare # 0 dp_spare = 1 %finishelsestart get LITERAL(dp_type) !beware faulty declaration or index %if dp_type > inttype %and faultnum = 0 %start t_val = t_val-dict(dp_type)_low+dp_val expfault(duperr+point) %if final(t_val) # 0 ! define jumps(final(t_val)); !in case of lit jumps final(t_val) = 1 %finish %finish get(right) c_access = 1 %end ![unsure of efficiency implications of trapping overflow lower down] %on %event 1,14 %start !$IF VAX { report(rangerr,0) %if event_event = 1 !$IF AMDAHL report(rangerr,0) %if eventinf>>8 = 1 !$FINISH -> skip %finish !!!!!!!!!!!!!!!!!!! Start of new statement !!!!!!!!!!!!!!!!!!! next: statements = statements+1 next1: report(faultnum,faultp) %if faultnum # 0 d = 0; declmode = 0; dsize = 0 dlim0 = dlim; elements = 0 speccing = 0; mcoding = 0 literal = 0; jammy = 0 dict(curlab)_val = 0; dict(curlab+1)_val = 0 np = np0; instnp = np0; condnp = np0 ! constad == finalad; constbound = purebound %if explo < expmin+50 %or litpos > litmax-50 %start !zaps = zaps+1; zaps = zaps+999 %if litpos > litmax-50 forget all %finish t_val = 0 ! initial(terminator): atom = next atom; matched = 1 -> initial(atom) initial(star): initial(exclam): initial(exclam2): read line -> next1 term: get(terminator) -> next skip: c_access = -1 %if atom # terminator %start %cycle subatom = atom; atom = next atom %repeat %until atom = terminator starts = starts+1 %if subatom = start cycles = cycles+1 %if subatom = cycle %finish -> next initial(dud): syntax error; !ie atom error initial(*): error(nonstarter+point) initial(ident): %if byteinteger(fp) = ':' %start; !simple label fp = fp+1 d_flags = lab; d_type = nulltype declare set user label(item) ->next %finish name error %if item <= 0 %if ditem_flags&lab # 0 %start get SWITCH INDEX get(colon) ->next %finish initial(return): initial(result): initial(tf): initial(stop): initial(signal): initial(monitor): initial(exit): initial(goto): initial(arrow): matched = 0 get INSTRUCTION -> next %if a(terminator)#0 c_access = 1 %if a(iu)#0 %start holdnp = np get CONDITION ! compile(holdnp,np) %finish %else %if a(while)#0 %start holdnp = np ! put3(label,curlab,0) get CONDITION ! compile(holdnp,np) ! put3(jump,curlab,0) ! put3(label,curlab+1,0) %finish %else %if a(for)#0 %start get FOR CLAUSE ! put3(jump,curlab,0) ! put3(label,curlab+1,0) %finishelsestart syntax error %if %not a(until)#0 get CONDITION %finish -> term initial(iu): !%if, %unless %cycle holdnp = np get CONDITION ! compile(holdnp,np) %if a(then)#0 %start -> fudge %if a(start)#0 get INSTRUCTION %finish %else %start get(start) fudge: %cycle get(terminator) curlab = curlab+2 get STATEMENTS(else) curlab = curlab-2 %exit %if atom # else; !%finish -> get CONDITION %if a(iu)#0 %repeat %return %if atom # finish %finish %exit %if %not a(else)#0 -> fudge %if a(start)#0 get INSTRUCTION %and %exit %if %not a(iu)#0 %repeat -> term initial(cycle): %if a(terminator)#0 %start holdlooplab = looplab; looplab = curlab curlab = curlab+2 get STATEMENTS(repeat) curlab = curlab-2; looplab = holdlooplab %return %if atom # repeat get CONDITION %if a(until)#0 -> term %finish nonstandard(oldcycle) get FOR CLAUSE -> for1 initial(while): holdnp = np ! put3(label,curlab,0) get CONDITION ! compile(holdnp,np) get(cycle) get(terminator) holdlooplab = looplab; looplab = curlab curlab = curlab+2 get STATEMENTS(repeat) curlab = curlab-2; looplab = holdlooplab %return %if atom # repeat nonstandard(loop2) %and get CONDITION %if a(until)#0 ! put3(jump,curlab,0) ! put3(label,curlab+1,0) ->term initial(for): get FOR CLAUSE get(cycle) for1: get(terminator) holdlooplab = looplab; looplab = curlab curlab = curlab+2 get STATEMENTS(repeat) curlab = curlab-2; looplab = holdlooplab %return %if atom # repeat ! put3(repeat,0,0) -> term initial(on): fault(ordererr+point) %if c_flags >= hadon %or level <= outerlevel c_flags = c_flags!hadon matched = 1 allow(keyevent) %cycle get LITINT expfault(rangerr+point) %unless 0 <= t_val <= 15 c_events = c_events!1< term ! initial(else): -> skip %if starts # 0 %return %if stopper = else error(noif) %if stopper = finish initial(finish): starts = starts-1 %and -> skip %if starts # 0 %return %if stopper = finish %or stopper = else error(nostart) initial(repeat): cycles = cycles-1 %and -> skip %if cycles # 0 %return %if stopper = repeat error(nocycle) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!! Declarations !!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! %integerfn NEWATYPE(%integer eltype,xtype) %integer dpos %record(identinfo)%name dp %ownrecord(identinfo) d=0 dpos = dictmin %cycle dp == dict(dpos) %result = dpos+direct %if dp_flags&typeid # 0 %c %and dp_type = eltype %and dp_val = xtype dpos = dpos+1 %repeat %until dpos = dlim d_flags = typeid; d_type = eltype; d_val = xtype dict(dpos) = d dlim = dlim+1; croak("Too many identifers") %if dlim >= dmin %result = dpos+direct %end ! %integerfn NEWSTYPE(%integer max) %integer dpos %record(identinfo)%name dp %ownrecord(identinfo) d=0 dpos = dictmin %cycle dp == dict(dpos) %result = dpos %if dp_type = stringy %and dp_val = max dpos = dpos+1 %repeat %until dpos = dlim d_flags = typeid; d_type = stringy d_val = max dict(dpos) = d dlim = dlim+1; croak("Too many identifers") %if dlim >= dmin %result = dpos %end ! %integerfn NEWRANGE(%integer type,lower,upper) %integer dpos %record(identinfo)%name dp %ownrecord(identinfo) d=0 fault(boundserr) %and upper = lower %if lower > upper elements = maxint elements = upper-lower %if upper!!lower >= 0 %c %or minint+upper-lower < 0 elements = elements+1 %if elements # maxint dpos = dictmin %cycle dp == dict(dpos) %result = dpos %if dp_flags = typeid %and dp_type = type %c %and dp_low = lower %and dp_val = upper dpos = dpos+1 %repeat %until dpos = dlim d_flags = typeid; d_type = type d_low = lower; d_val = upper dict(dpos) = d dlim = dlim+1; croak("Too many identifers") %if dlim >= dmin %result = dpos %end %routine GET LITBOUNDS %integer lower get(left) get LITINT; lower = t_val get(colon) get LITINT; get(right) t_low = lower item = newrange(inty,t_low,t_val); !always integer at present %end %routine GET IDENT dlim0 = dlim get(ident) declare get LITSTRING %if d_flags&ext # 0 %and a(alias)#0 %end %routine GET IDENTLIST dlim0 = dlim %cycle get(ident) declare get LITSTRING %if d_flags&ext # 0 %and a(alias)#0 %repeat %until %not a(comma)#0 %end %routine GET TYPE(%integer flags) %owninteger fbase %ownrecord(identinfo)%name formp,fieldp ! %routine GET FORMATDEF; !(%integername base) %integer disp,max,base %routine GET FIELD IDENT get(ident) %if item > 0 %then d_text = ditem_text %c %else %start d_text = charlim-charbase; charlim = charlim+newlen+1 croak("Identifier space exhausted") %if charlim+80 >= charmin %finish ditem == dict(dlim); fieldp == ditem ditem = d %if formp_extra = 0 %then formp_extra = dlim %c %else %start ! lookup field ident(formp_extra) ! fault(duperr+point) %and item = dlim %if item # dlim %finish dlim = dlim+1; croak("Too many identifiers") %if dlim >= dmin %end %routine get UNIT %cycle %if a(left)#0 %start get FORMATDEF; get(right) %return %if %not a(comma)#0 %finishelsestart get TYPE(static+more) %if d_flags&parm = 0 %start; !not array %cycle disp = disp+1 %if disp&1 # 0 %and dsize # 1 d_val = disp disp = disp+dsize get FIELD IDENT %return %if %not a(comma)#0 atom = next atom %repeat %until atom # ident %finishelsestart; !array d_flags = d_flags-parm disp = disp+1 %if disp&1 # 0; d_val = disp get FIELD IDENT get LITBOUNDS fieldp_type = newatype(d_type,item) disp = disp+dsize*elements %return %if %not a(comma)#0 %finish %finish %repeat %end max = 0; base = 0 %cycle disp = base get UNIT max = disp %if max < disp %repeat %until %not a(keyor)#0 base = max %end; !get FORMATDEF dsize = 0; d_mode = 0; d_val = 0 d_type = nulltype %if a(rpred)#0 %start; !%routine,(%integerfn) flags = flags&(\static) %if flags&ext # 0 syntax error %if flags&static # 0 nonstandard(pred) %and d_type = booltype %if subatom # 0 d_flags = flags+proc; declmode = declmode+pcmode %return %finish %if a(krange)#0 %start; !%byte,%short,%half,%mite d_type = inttype+subatom; dsize = 1 dsize = 2 %if d_type = shorttype %or d_type = halftype nonstandard(ranges) %if d_type >= mitetype allow(keyinteger) %finish %else %if a(keyinteger)#0 %start; !%integer d_type = inttype; dsize = 4 atom = next atom %if atom = left %start get LITBOUNDS d_type = item dsize = 2 %if elements <= 65536 %and t_low >= -32768 dsize = 1 %if elements <= 256 %and t_low >= -128 %finish %finish %else %if a(keylong)#0 %start; !%long d_type = longinttype; dsize = 8 d_type = longrealtype %and get(keyreal) %if %not a(keyinteger)#0 %finish %else %if a(keyreal)#0 %start; !%real d_type = realtype; dsize = 4 %finish %else %if a(keystring)#0 %start; !%string d_type = stringy t_val = 255; dsize = 256 %if a(left)#0 %start t_val = 0 %if %not a(star)#0 %start get LITINT expfault(rangerr+point) %and t_val = 255 %unless 0 < t_val <= 255 %finish get(right) %finish %else nonstandard(nolength) %if t_val # 0 %start d_type = newstype(t_val) dsize = (t_val+2)&(\1); !+1 & evened up %finish %finish %else %if a(keyrecord)#0 %start; !%record d_type = recy %if a(keyformat)#0 %start syntax error %if flags&(static+ext) # 0 %if a(keyspec)#0 %start d_flags = typeid+spec get IDENT %finish %else %start d_flags = typeid get IDENT formp == ditem get(left) fbase = 0 get FORMATDEF fieldp_flags = fieldp_flags-more get(right) %finish d_flags = typeid %return %finish get(left) %if %not a(star)#0 %start %if %not a(ident)#0 %start get FORMATDEF fieldp_flags = fieldp_flags-more get(right) d_flags = typeid declare anon %finish name error %if item <= 0 syntax error %if ditem_type # recy d_type = item; dsize = ditem_val %finish get(right) %finishelsestart syntax error %if atom # keyname; !untyped %name %finish !End of basic type info: set item size in DECLMODE %if dsize <= 4 %start %if dsize <= 2 %then declmode = dsize<= indirect %if %not a(keyname)#0 %start syntax error %if flags&parm # 0 flags = flags+parm; !as indic %exit %finish d_type = newatype(d_type,inty) %finish syntax error %if d_type >= indirect d_type = d_type+(indirect-direct) dsize = 4 %repeat d_flags = flags!!var %end; !GET TYPE ! %routine GET OWN ARRAY DECLARATION %integer holdval,dpos %record(identinfo)%name dp ! constad = constad+1 %if constad&1 # 0 ! d_val = constad ! d_val = d_val-ownbase %if d_val >= ownbase get IDENT dpos = item; dp == ditem get LITBOUNDS dp_type = newatype(d_type,item) %if a assop#0 %start allow(terminator) %cycle get LITERAL(d_type) faultnum = rangerr+point+warn %if faultnum = rangerr+point holdval = t_val t_val = 1 %if a(left)#0 %start t_val = elements get LITINT %if %not a(star)#0 get(right) %finish ! plant const(holdval,t_val) elements = elements-t_val %repeat %until %not a(comma)#0 report(counterr,dpos) %if elements # 0 %and faultnum = 0 %finish ! plant const(0,elements) %if elements > 0 %end; !get OWN ADECL %routine GET ARRAY DECLARATION !ie get IDENTLISTS and BOUNDS %integer i,dlim1,hold,holdval,type !%routine put bound pair ! hold = litref(holdval) %if hold = 0 ! item = litref(t_val) %if item = 0 ! put3(r,hold,item); !(range),lower,upper !%end %routine GET BOUNDS %integer range get VALUE(anyint) hold = item; t_val = minint %if hold # 0 holdval = t_val get(colon) get VALUE(anyint) t_val = maxint %if item # 0 range = newrange(inty,holdval,t_val) GET BOUNDS %if a(comma)#0 type = newatype(type,range) %end %cycle type = d_type get IDENTLIST dlim1 = dlim get(left) GET BOUNDS get(right) ! %if hold = 0 = item {both literal} %and np = np0 {1-dim} %c ! %and elements <= 32767 {safe to multiply?} %c ! %and (elements*dsize*(dlim-dpos))<<1-c_sp-c_delta <= 32000 %start ! d_par = parref(inty,0,r,0) ! %finish %else %start ! put bound pair ! d_par = 0 ! i = np ! %while i # np0 %cycle ! i = i-1 ! d_par = parref(inty,0,exp(i)_act,d_par) ! %repeat ! exp(np0)_act = adecl ! %finish ! i = np %while dlim0 # dlim1 %cycle ! %if i = np0 %start ! c_delta = c_delta-elements*dsize ! c_delta = c_delta-1 %if c_delta&1 # 0 ! dict(dlim0)_flags = dict(dlim0)_flags!static ! %finish %else %start ! np = i; compile(np0,np0) ! c_flags = c_flags!dynarray ! %finish ! dict(dlim0)_val = c_sp+c_delta dict(dlim0)_type = type dlim0 = dlim0+1 %repeat %repeat %until %not a(comma)#0 %end; !get BOUNDS %routine GET PARMDEF %integer headitem,dpos,dlim1 %record(identinfo)%name headditem,dp %integerfn PARMMATCH(%integer apos) %integer bpos %record(identinfo)%name ap,bp bpos = dlim1 ap == dict(apos) %while bpos # dlim %cycle %result = 0 %if ap_flags&more = 0 apos = apos+1 %and ap == dict(apos) %until ap_flags&parm # 0 bp == dict(bpos) %result = 0 %if ap_type # bp_type; !for now bpos = bpos+1 %repeat %result = 1 %if ap_flags&more = 0 %result = 0 %end ! headitem = item; headditem == ditem dlim1 = dlim %if a(left)#0 %start %cycle get TYPE(parm!more) %if atom # ident %if d_flags&proc = 0 %start get IDENT %exit %if %not a(comma)#0 %and atom = right %if atom # comma %then nonstandard(nocomma) %c %else atom = next atom %finish %else %start get IDENT speccing = speccing+2 get PARMDEF speccing = speccing-2 %exit %if %not a(comma)#0 %finish %repeat dict(dlim-1)_flags = dict(dlim-1)_flags-more get(right) %finish %if speccing >= 2 %start dpos = dictmin %cycle dp == dict(dpos) %if dp_flags&proc # 0 %and dp_type = headditem_type %start %if parmmatch(dpos) # 0 %start headditem_type = dpos; dlim = dlim1 %return %finish %finish dpos = dpos+1 %repeat %until dpos >= headitem fault(caterr); dlim = dlim1 %return %finish %if speccing = 0 %and headditem_flags&spec # 0 %start headditem_flags = headditem_flags-spec fault(matcherr) %if parmmatch(headitem) = 0 %finishelsestart headditem_flags = headditem_flags!more %if dlim # dlim1 %finish %end; !get PARMDEF initial(keylabel): nonstandard(klabel) d_flags = lab+spec; d_type = nulltype get IDENTLIST -> term initial(prefix): d_flags = subatom; ! !wflag!okflag ! fault(prefix<<8) %if d_flags&extmask # 0 atom = next atom initial(krange): initial(keylong): initial(keyinteger): initial(keyreal): initial(keystring): initial(keyrecord): initial(rpred): matched = 0 get TYPE(d_flags) %if a(keyspec)#0 %start %if a(left)#0 %start get LITINT; get(right) declmode = declmode&sizemask+absmode d_val = t_val get IDENT speccing = 1 %and get PARMDEF %if d_flags&proc # 0 -> term %finish d_flags = d_flags+spec get IDENTLIST %and -> term %if d_flags&proc = 0 %finish %if d_flags&proc # 0 %start get(ident) %if item >= c_localdpos %and ditem_type = d_type %c %and ditem_flags&proc # 0 %start %if ditem_flags&spec = 0 %or d_flags&spec # 0 %start item = 0; d_flags = d_flags+alt declare %finish %finish %else declare get LITSTRING %if d_flags&ext # 0 %and a(alias)#0 %if d_flags&spec # 0 %start speccing = 1 get PARMDEF %finish %else %start open block(item) get PARMDEF c_parlim = dlim compile entry get(terminator) get STATEMENTS(end) ! %if c_access > 0 %start ! report(noresult,0) %if c_type > nulltype; !fn/map/pred ! %finish close block %finish %finish %else %if d_flags = typeid {dealt with} %start %finish %else %if d_flags&parm # 0 %start; !array d_flags = d_flags-parm %if d_flags&static # 0 %start get OWN ARRAY DECLARATION %finish %else %start %if d_flags&static = 0 %and c_flags >= hadon %start fault(ordererr); c_flags = c_flags&(\(hadon+hadinst)) %finish get ARRAY DECLARATION %finish %finish %else %if d_flags = static {const} %start d_type = dict(d_type&puretype)_type d_type = d_type+direct %if d_type = recy %or d_type = stringy %cycle get IDENT syntax error %if %not a assop#0 get LITERAL(d_type) faultnum = rangerr+point+warn %if faultnum = rangerr+point dict(dlim-1)_val = t_val %repeat %until %not a(comma)#0 %finish %else %if d_flags&static # 0 {own} %start ! constad == ownad; constbound = finalbound declmode = declmode+ownmode %cycle ! constad = constad+1 %if constad&1 # 0 %and dsize # 1 ! t_val = constad-ownbase get IDENT t_val = 0 %if a assop#0 %start ! %if d_flags&direct = 0 get LITERAL(d_type) faultnum = rangerr+point+warn %if faultnum = rangerr+point %finish elements = 1 ! plant const(t_val,1) %repeat %until %not a(comma)#0 %finishelsestart; !dynamic variable ! declmode = declmode+dispmode+level %if d_flags&static = 0 %and c_flags >= hadon %start fault(ordererr); c_flags = c_flags&(\(hadon+hadinst)) %finish %cycle !problematic c_delta = c_delta-1 %if c_delta&1 # 0 %and dsize # 1 c_delta = c_delta-dsize c_delta = c_delta-1 %if c_delta&1 # 0 t_val = c_sp+c_delta get IDENT %if a assop#0 %start nonstandard(initass) %if d_type >= indirect %start fault(caterr+point) %if atom # eqeq get REFERENCE(d_type) item = item+ad %if item # 0 ! put3(assign,dlim-1+ad,item) %finish %else %start fault(caterr+point) %if atom = eqeq get VALUE(d_type) ! put2(assign,dlim-1) %finish ! compile(np0,np0) %finish %repeat %until %not a(comma)#0 %finish -> term %routine GET SWITCH DECLARATION %integer i,j,dlim1 matched = 1 %cycle d_flags = lab; d_type = nulltype declmode = pcmode+wordsize<term !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!! Control statements !!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! initial(keycontrol): get LITINT control = 0 %if t_val = 0 control = control!!t_val ->term initial(include): get LITSTRING extra_name = "" %while t_val > 0 %cycle extra_name = extra_name.tostring(byteinteger(atomp)) atomp = atomp+1; t_val = t_val-1 %repeat get(terminator) %if faultnum = 0 %start connect edfile(extra) nonstop = -999 %and %signal 12 %if extra_flag # 0 mainfp = fp; mainline = line line = 0; sym = nl fp = extra_start2; curstart = fp; curlim = extra_lim2 modesym = '&'; nonstop = nonstop+1 %finish ->next initial(keylist): ->term initial(begin): c_sp = -8 get(terminator) open block(0) get STATEMENTS(0) close block -> term %if stopper >= 0 %return initial(end): %if %not a(of)#0 %start fault(nofinish) %if stopper = else %or stopper = finish fault(norepeat) %if stopper = repeat %return %if stopper >= 0 fault(nobegin) ->term %finish %if a(keylist)#0 %start ->term %finish %if a(keyfile)#0 %start %if curlim = extra_lim2 %start switch input ->next %finish %finish %else get(program) %end; !GET STATEMENTS %routine INIT(%integer t,l,h) d_flags = typeid; d_type = t; d_low = l; d_val = h dict(dlim) = d; dlim = dlim+1 %end %on %event 12 %start -> printout %if fp = main_lim2 -> ended %if main_flag < 0 %or nonstop = -999; !abandon or CROAK change = main_change %finish printstring(" IMP Checker "); newline hashindex(i) = 0 %for i = 0,1,255; !hash table empty charbase = addr(char(0)); byteinteger(charbase) = 0; !for anon ident charlim = charbase+1 charmin = charlim+charbound; !(1 over top) dict(i)_val = 0 %for i = d0,1,labmax d_flags = typeid; d_low = minint; d_val = maxint dmin = dictmax-1; dlim = dictmin %cycle d_type = dlim; dict(dlim) = d dlim = dlim+1 %repeat %until dlim > booltype d_flags = 0 init(booltype,0,0) init(booltype,0,1) d_flags = typeid init(inty,minint,maxint) init(inty,-32768,32767) init(inty,0,65535) init(inty,0,255) init(inty,-128,127) init(inty,0,1) init(inty,minint,maxint) init(realy,minint,maxint) init(realy,minint,maxint) c = 0; c_localdpos = dlim; c_parlim = dlim level = outerlevel spc = finalbound faults = 0; line = 0; mainline = 0 ! mainfp = main_start1 extra_name = permfile connect edfile(extra) nonstop = -999 %and %signal 12 %if extra_flag # 0 fp = extra_start2; curstart = fp; curlim = extra_lim2 nonstop = -2; nonstop = -1 %if main_flag = 'I' sym = nl get STATEMENTS(-1) ! report(noend,0) %if level < mainlevel ! report(nobegin,0) %if level > mainlevel ! compile end %while level >= mainlevel printout: ! time2 = cputime %if faults = 0 %start write(statements,1) print string(" statements checked ") %finish %else %start write(faults,1) print string(" fault") put sym('s') %if faults > 1 print string(" reported ") %finish newline ended: newline; !*for now to ensure message not erased* ! %if control&logbit # 0 %start !! write(zaps,1); print symbol('Z') ! write(statements,1); print symbol('S') ! statements = 1 %if statements = 0 ! atoms = atoms+statements ! print(atoms/statements,1,1); print symbol('A') ! print(numatoms/statements,1,1); print symbol('N') ! print(identatoms/statements,1,1); print symbol('I') ! print(misses/identatoms,1,2); print symbol('H') ! print((time2-time1)/statements,3,3); print symbol('M') !! write(finalad,1); print symbol('B') !! write(ownad-ownbase,1); print symbol('O') ! newline ! %finish %end; !of ECCECI %endoffile