!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"
!$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)
! %true %if -32768 <= v <= 32767
! %false
!%end
!%predicate is mite (%integer v)
! %true %if -128 <= v <= 127
! %false
!%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
predicate A (integer k)
!Basic atom-testing predicate
atom = next atom if matched # 0
false if k # atom
matched = 1
true
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) 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
predicate A ASSOP
atom = next atom if matched # 0
if atom # equals and atom # eqeq start
false unless atom = less and byteintegeR(fp) = '-'
jammy = 2; fp = fp+1
finish else jammy = 0
matched = 1
true
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
else if t_type >= inty; !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
else if t_type = stringy
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
else if t_type = recy
return if t_extra = dp_extra
jammy = jammy!1 and return if jammy >= 2
!partial assignment?
else if t_type = realy
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
else if dp_type < indirect; !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)
! %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) start
get REFERENCE(anystringvar)
get(dot)
get(left)
finish
get VALUE(anystring)
get(right)
if a(dot) 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(rshift): 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
else
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) start
dp == ditem
get PARMLIST; get(right)
ditem == dp
else
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)
dp == dict(type&puretype); t = dp_details
item1 = item
repeat
get(right)
else ; !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
else
error(nonvar+point) if control&varonly # 0
error(nonref+point) if control&refonly # 0
if a(const) start
else if atom = minus; !leave unmatched
item = 0; t = 0; t_type = inty
else if a(left)
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)
else if a(keynot)
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)
else if atom = backslash
item = 0; t = 0; t_type = inty
atom = tilde
else if a(modsign)
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
else if t_type = inty
item = explo;!expref(imod,item,0)
else if t_type = realy
item = explo;!expref(fmod,item,0)
else
error(typerr)
finish
else
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
else
if op = resolve start
get RESOLUTION
else if op >= eqeq
get EXPRESSION(simple,any+refonly)
else if op >= equals
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
else
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)
! %else %if inverse(op) # 0; !invertable
! op = inverse(op)
! temp = t; t = t1; t1 = temp; !standardise order
! item1 = item; item = 0
else
! 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) 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) start
get VALUE(ditem1_type)
! put2(assign,item1)
else if a(eqeq)
syntax error if ditem1_type < indirect
get REFERENCE(ditem1_type)
item = item+ad if item # 0
! put2(assign,item1+ad)
else if atom = less and byteintegeR(fp) = '-'
fp = fp+1; matched = 1
jammy = 2
get VALUE(ditem1_type)
! put2(jamassign,item1)
else
syntax error if not a(arrow)
get RESOLUTION
! put2(resolve,item1)
finish
else
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) start
get PARMLIST; get(right)
else ; !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) start
c_access = 1
! fault(monitor<<8)
else if a(exit); !%exit, %continue
if looplab = 0 then fault(notinloop+point) c
else t_val = looplab and putact
exit
else if a(return)
if c_type # nulltype then fault(notinrout+point) c
else putact
exit
else if a(result)
error(notinfun+point) if c_type <= nulltype
syntax error if not a assop
if c_type < direct start ; !function
fault(caterr+point) if atom = eqeq
get VALUE(c_type)
! put2(result,0)
else ; !map
fault(caterr+point) if atom # eqeq
get REFERENCE(c_type+(indirect-direct))
! put2(result,0)
finish
exit
else if a(tf); !%true, %false
if c_type # booltype then fault(notinpred+point) c
else putact
exit
else if a(arrow) or a(goto)
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
else if a(stop)
putact
exit
else if a(signal)
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)
hold = t_val<<4+hold
item = 0; t_val = 0
get VALUE(anyint) if a(comma)
! put2(act,hold)
exit
else
syntax error
finish
finish
repeat until not a(keyand)
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)
! %else %if k <= litmax; !START is x+lit
! k = ival-litval(k)
! s = exp(start)_x; s = explo;!expref(plus,s,litref(k)) %if k # 0
else
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
! %else %if k = inc; !START is x+INC
! s = exp(start)_x
! %else
! 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) start
fault(duperr+point) if dp_spare # 0
dp_spare = 1
else
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)
c_access = 1
if a(iu) start
holdnp = np
get CONDITION
! compile(holdnp,np)
else if a(while)
holdnp = np
! put3(label,curlab,0)
get CONDITION
! compile(holdnp,np)
! put3(jump,curlab,0)
! put3(label,curlab+1,0)
else if a(for)
get FOR CLAUSE
! put3(jump,curlab,0)
! put3(label,curlab+1,0)
else
syntax error if not a(until)
get CONDITION
finish
-> term
initial(iu): !if , unless
cycle
holdnp = np
get CONDITION
! compile(holdnp,np)
if a(then) start
-> fudge if a(start)
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)
repeat
return if atom # finish
finish
exit if not a(else)
-> fudge if a(start)
get INSTRUCTION and exit if not a(iu)
repeat
-> term
initial(cycle):
if a(terminator) 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)
-> 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)
! 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<<t_val
repeat until not a(comma)
get(start)
! put3(on,0,0)
curlab = curlab+2
get STATEMENTS(finish)
curlab = curlab-2
return if atom # finish
-> 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)
end
routine GET IDENTLIST
dlim0 = dlim
cycle
get(ident)
declare
get LITSTRING if d_flags&ext # 0 and a(alias)
repeat until not a(comma)
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) start
get FORMATDEF; get(right)
return if not a(comma)
else
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)
atom = next atom
repeat until atom # ident
else ; !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)
finish
finish
repeat
end
max = 0; base = 0
cycle
disp = base
get UNIT
max = disp if max < disp
repeat until not a(keyor)
base = max
end ; !get FORMATDEF
dsize = 0; d_mode = 0; d_val = 0
d_type = nulltype
if a(rpred) 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) 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)
else if a(keyinteger); !%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
else if a(keylong); !%long
d_type = longinttype; dsize = 8
d_type = longrealtype and get(keyreal) if not a(keyinteger)
else if a(keyreal); !%real
d_type = realtype; dsize = 4
else if a(keystring); !%string
d_type = stringy
t_val = 255; dsize = 256
if a(left) start
t_val = 0
if not a(star) 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
else if a(keyrecord); !%record
d_type = recy
if a(keyformat) start
syntax error if flags&(static+ext) # 0
if a(keyspec) 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) start
if not a(ident) 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)
else
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<<sizeshift c
else declmode = longsize<<sizeshift
finish
!Appendages
if a(fnmap) start ; !%fn, %map
flags = flags&(\static) if flags&ext # 0
syntax error if flags&static # 0
flags = flags+var and d_type = d_type+direct if subatom # 0; !map
d_flags = flags+proc; declmode = declmode+pcmode
return
finish
d_type = d_type+direct
while a(keyarray) or a(keyname) cycle
if atom = keyarray start ; !%array
nonstandard(naming) if d_type >= indirect
if not a(keyname) 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 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) start
t_val = elements
get LITINT if not a(star)
get(right)
finish
! plant const(holdval,t_val)
elements = elements-t_val
repeat until not a(comma)
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)
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)
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) start
cycle
get TYPE(parm!more) if atom # ident
if d_flags&proc = 0 start
get IDENT
exit if not a(comma) 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)
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
else
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) start
if a(left) 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)
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
else if d_flags = typeid {dealt with}
else if d_flags&parm # 0; !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
else if d_flags = static {const}
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
get LITERAL(d_type)
faultnum = rangerr+point+warn if faultnum = rangerr+point
dict(dlim-1)_val = t_val
repeat until not a(comma)
else if d_flags&static # 0 {own}
! 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 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)
else ; !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 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)
finish
-> term
routine GET SWITCH DECLARATION
integer i,j,dlim1
matched = 1
cycle
d_flags = lab; d_type = nulltype
declmode = pcmode+wordsize<<sizeshift
get IDENTLIST
dlim1 = dlim
get LITBOUNDS
cycle ; !For each ident in group
exit if spc-elements <= 0; !ignore if too many
for i = 1,1,elements cycle
spc = spc-1; final(spc) = 0
repeat
dict(dlim0)_val = spc
dict(dlim0)_type = item
dlim0 = dlim0+1
repeat until dlim0 = dlim1
repeat until not a(comma)
end
initial(keyswitch):
get SWITCH DECLARATION
->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) 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) start
->term
finish
if a(keyfile) 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