! IMP77 compiler first pass
include "Sysinc:com.inc"
!
! On EMAS all shorts should be changed to integers.
! Also, the INCLUDE facility will need to be modified.
!
!
!###################################################
! Copyright: 1 January 1980 #
! Interactive Datasystems (Edinburgh) Ltd. #
! 32 Upper Gilmore Place #
! Edinburgh EH3 9NJ #
! All Rights Reserved #
!###################################################
BEGIN
CONSTSTRING (4) version = "8.4"
!configuration parameters
CONSTINTEGER max int = ((-1)>>1)//10
CONSTINTEGER max dig = (-1)>>1-maxint*10
CONSTINTEGER byte size = 8; !bits per byte
CONSTINTEGER max tag = 800; !max no. of tags
CONSTINTEGER max dict = 6000; !max extent of dictionary
CONSTINTEGER name bits = 11
CONSTINTEGER max names = 1<<namebits-1
OWNINTEGER spare names = max names
CONSTINTEGER max grammar = 1720
CONSTINTEGER lit max = 50; !max no. of constants/stat.
CONSTINTEGER rec size = 520; !size of analysis record
CONSTINTEGER dim limit = 6; !maximum array dimension
!symbols
CONSTINTEGER ff = 12; !form feed
CONSTINTEGER marker = '^'; !marker for faults
CONSTINTEGER squote = '"'; !string quote
CONSTINTEGER cquote = ''''; !character quote
!streams
CONSTINTEGER report = 0, source = 1
CONSTINTEGER object = 1, listing = 2
!types
CONSTINTEGER integer = 1
CONSTINTEGER real = 2
CONSTINTEGER stringv = 3
CONSTINTEGER record = 4
!forms
CONSTINTEGER iform = integer<<4+1
CONSTINTEGER var = 91
CONSTINTEGER const = 93
CONSTINTEGER swit = 105
CONSTINTEGER comment = 22
CONSTINTEGER termin = 20
CONSTINTEGER lab = 3
CONSTINTEGER jump = 54
CONSTINTEGER recfm = 4
CONSTINTEGER proc = 7; !class for proc
!phrase entries
CONSTINTEGER escdec = 252
CONSTINTEGER escproc = 253
CONSTINTEGER escarray = 254
CONSTINTEGER escrec = 255
RECORDFORMAT arfm(SHORTINTEGER class,sub,link,ptype,papp,pformat,x,pos);!imp77:
!emas:%RECORDFORMAT arfm(%INTEGER class,sub,link,ptype,papp,pformat,x,pos)
RECORDFORMAT tagfm(INTEGER app, format, C
SHORTINTEGER flags, index, text, link)
!flags
! *===.===.===.===.===.====.====.====.===.======.======*
! ! u ! c ! c ! p ! s ! a ! o ! pr ! s ! type ! form !
! ! 1 ! 1 ! 1 ! 1 ! 1 ! 1 ! 1 ! 1 ! 1 ! 3 ! 4 !
! *===^===^===^===^===^====^====^====^===^======^======*
! u c c p s a o p s t f
! s l o a u n w r p y o
! e o n r b a n o e p r
! d s s a n m t c e m
! e t m a e
! d s m
! e
!
!
CONSTINTEGER used bit = b'1000000000000000',
closed = b'0100000000000000',
const bit = b'0010000000000000',
parameters = b'0001000000000000',
subname = b'0000100000000000',
aname = b'0000010000000000',
own bit = b'0000001000000000',
prot = b'0000000100000000',
spec = b'0000000010000000'
CONSTINTEGER trans bit = x'4000'
CONSTINTEGER error = x'8000'
CONSTINTEGER manifest = 120, figurative = 130
CONSTINTEGER actions = 180, phrasal = 200
CONSTBYTEINTEGERARRAY amap(0:15) = C
89, 91, 92, 104, 94, const, swit, 100, 101, 102, 103, 106, 107, 108, 109, 89
!? v n l fm const swit rp fp mp pp a an na nan ?
CONSTBYTEINTEGERARRAY atoms(0:15) = 89, 1, 1, 10, 9, 1, 10, 7,
7, 7, 7, 4, 1, 4, 1, 89
RECORD (arfm)ARRAY ar(1:rec size)
OWNINTEGER class = 0; !class of atom wanted
OWNINTEGER x = 0; !usually last tag
OWNINTEGER atom1 = 0; !atom class (major)
OWNINTEGER atom2 = 0; !atom class (minor)
OWNINTEGER subatom = 0; !extra info about atom
OWNINTEGER type = 0,
app = 0,
format = 0; !atom info
INTEGER hash value
OWNINTEGER faulty = 0; !fault indicator
OWNINTEGER fault rate = 0; !fault rate count
OWNINTEGER lines = 0; !current line number
OWNINTEGER text line = 0; !starting line for string const
OWNINTEGER margin = 0; !statement start margin
OWNINTEGER error margin = 0,
error sym = 0,
column = 0
OWNINTEGER stats = 0; !statements compiled
OWNINTEGER mon pos = 0; !flag for diagnose
OWNINTEGER sym = nl; !current input symbol
OWNINTEGER symtype = 0; !type of current symbol
OWNINTEGER quote = 0; !>0 strings, <0 chars
owninteger end mark = 0; !%end flag
OWNINTEGER cont = ' ',
csym = ' '; !listing continuation marker
OWNINTEGER decl = 0; !current declarator flags
OWNINTEGER dim = 0; !arrayname dimension
OWNINTEGER spec given = 0
OWNINTEGER escape class = 0; !when and where to escape
OWNINTEGER protection = 0,
atom flags = 0
OWNINTEGER otype = 0; !current 'own' type
OWNINTEGER reals ln = 1; ! =4 for %REALSLONG
OWNINTEGER last1 = 0; !previous atom class
OWNINTEGER gen type = 0
OWNINTEGER ptype = 0; !current phrase type
OWNINTEGER papp = 0; !current phrase parameters
OWNINTEGER pformat = 0; !current phrase format
OWNINTEGER force = 0; !force next ptype
OWNINTEGER g = 0,
gg = 0,
map gg = 0; !grammar entries
OWNINTEGER fdef = 0; !current format definition
OWNINTEGER this = -1; !current recordformat tag
OWNINTEGER nmin = 0; !analysis record atom pointer
OWNINTEGER nmax = 0; !analysis record phrase pointer
OWNINTEGER rbase = 0; !record format definition base
OWNINTEGER stbase = 0; !constant work area base
OWNINTEGER gmin = max grammar; !upper bound on grammar
OWNINTEGER dmax = 1
OWNINTEGER tmin = max tag; !upper bound on tags
OWNINTEGER ss = 0; !source statement entry
STRING (63) include file
OWNINTEGER include list = 0,
include level= 0
OWNINTEGER include = 0; !=0 unused, #0 being used
OWNINTEGER perm = 1; !1 = compiling perm, 0 = program
OWNINTEGER progmode = 0; !-1 = file, 1 = begin/eop
OWNINTEGER sstype = 0; !-1:exec stat
! 0: declaration
! 1: block in
! 2: block out
OWNINTEGER spec mode = 0; !>=0: definition
! -1: proc spec
! -2: recordformat
OWNINTEGER ocount = -1; !own constants wanted
OWNINTEGER limit = 0; !lookup limit
OWNINTEGER copy = 0; !duplicate name flag
OWNINTEGER order = 0; !out of sequence flag
OWNINTEGER for warn = 0; !non-local flag
OWNINTEGER dubious = 0; !flag for dubious statements
OWNINTEGER dp = 1
OWNINTEGER pos1 = 0,
pos2 = 0; !error position
OWNINTEGER pos = 0; !input line index
OWNINTEGER dimension = 0; !current array dimension
OWNINTEGER local = 0; !search limit for locals
OWNINTEGER fm base = 0; !entry for format decls
OWNINTEGER search base = 0; !entry for record_names
OWNINTEGER format list = 0; !size of current format list
INTEGER recid
OWNBYTEINTEGERARRAY char(0:133) = nl(134); !input line
INTEGERARRAY lit pool(0:lit max)
OWNINTEGER lit = 0; !current literal (integer)
OWNINTEGER lp = 0; !literals pointer
OWNINTEGER block x = 0; !block tag
OWNINTEGER list = 1; !<= to enable
OWNINTEGER control = 0
OWNINTEGER diag = 0; !diagnose flags
SHORTINTEGERARRAY hash(0:max names)
RECORD (tagfm)ARRAY tag(0:max tag)
SHORTINTEGERARRAY dict(1:max dict)
BYTEINTEGERARRAY buff(1:512)
OWNINTEGER bp = 0
!*** start of generated tables ***
include "tables.imp"
!*** end of generated tables ***
ROUTINE flush buffer
INTEGER j
IF faulty = 0 START
select output(object)
FOR j = 1, 1, bp CYCLE
printsymbol(buff(j))
REPEAT
select output(listing)
FINISH
bp = 0
END
ROUTINE print ident(INTEGER p, mode)
INTEGER j, ad
p = tag(p)_text
IF p = 0 START
bp = bp+1 AND buff(bp) = '?' if Mode # 0
RETURN
FINISH
ad = addr(dict(p+1))
IF mode = 0 THEN printstring(string(ad)) ELSE START
FOR j = ad+1, 1, ad+byteinteger(ad) CYCLE
bp = bp+1
buff(bp) = byteinteger(j)
REPEAT
FINISH
END
ROUTINE abandon(INTEGER n)
SWITCH reason(0:9)
INTEGER stream
stream = listing
CYCLE
newline IF sym # nl
printsymbol('*'); write(lines,4); space
->reason(n)
reason(0):printstring("compiler error!"); ->more
reason(1):printstring("switch vector too large"); ->more
reason(2):printstring("too many names"); ->more
reason(3):printstring("program too complex"); ->more
reason(4):printstring("feature not implemented"); ->more
reason(5):printstring("input ended: ")
IF quote # 0 START
IF quote < 0 THEN printsymbol(cquote) C
ELSE printsymbol(squote)
ELSE
printstring("%endof")
IF progmode >= 0 THEN printstring("program") C
ELSE printstring("file")
FINISH
printstring(" missing?"); ->more
reason(6):printstring("too many faults!"); ->more
reason(7):printstring("string constant too long"); ->more
reason(8):printstring("dictionary full"); -> more
reason(9):printstring("Included file ".include file." does not exist")
more: newline
printstring("*** compilation abandoned ***"); newline
EXIT IF stream = report
close output
stream = report
select output(report)
REPEAT
SIGNAL 15,15 IF diag&4096 # 0
STOP
END
ROUTINE op(INTEGER code, param)
buff(bp+1) <- code
buff(bp+2) <- param>>8
buff(bp+3) <- param
bp = bp+3
END
ROUTINE set const(INTEGER m)
buff(bp+1) <- 'N'
buff(bp+5) <- m; m = m>>8
buff(bp+4) <- m; m = m>>8
buff(bp+3) <- m; m = m>>8
buff(bp+2) <- m
bp = bp+5
END
ROUTINE compile block(INTEGER level, block tag, dmin, tmax, id)
INTEGERFNSPEC gapp
ROUTINESPEC delete names(INTEGER quiet)
ROUTINESPEC analyse
ROUTINESPEC compile
INTEGER open; open = closed; !zero if can return from proc
INTEGER dbase; dbase = dmax; !dictionary base
INTEGER tbase; tbase = tmax; !tag base
INTEGER tstart; tstart = tmax
INTEGER label; label = 4; !first internal label
INTEGER access; access = 1; !non-zero if accessible
INTEGER inhibit; inhibit = 0; !non-zero inhibits declaratons
SHORTINTEGERNAME bflags; bflags == tag(block tag)_flags
INTEGER block type; block type = bflags>>4&7
INTEGER block form; block form = bflags&15
INTEGER block fm; block fm = tag(block tag)_format
INTEGER block otype; block otype = otype
INTEGERNAME block app; block app == tag(block tag)_app
INTEGER l, new app
ROUTINE fault(INTEGER n)
! -5 : -1 - warnings
! 1 : 22 - errors
SWITCH fm(-5:22)
INTEGER st
ROUTINE print ss
INTEGER s, p
RETURN IF pos = 0
space
p = 1
CYCLE
printsymbol(marker) IF p = pos1
EXIT IF p = pos
s = char(p); p = p+1
EXIT IF s = nl OR (s='%' AND p = pos)
IF s < ' ' START ; !beware of tabs
IF s = ff THEN s = nl ELSE s = ' '
FINISH
printsymbol(s)
REPEAT
pos = 0 IF list <= 0
END
pos1 = pos2 IF pos2 > pos1
newline IF sym # nl
st = report
st = listing IF n = -3; !don't report unused on the console
cycle
SELECT OUTPUT(st)
if n < 0 then printsymbol('?') and pos1 = 0 else printsymbol('*')
if st # report start
if list <= 0 and pos1 # 0 start
spaces(pos1+margin); PRINTSTRING(" ! ")
finish
finish else start
PRINTSTRING(include file) if include # 0
write(lines, 4); printsymbol(csym); space
finish
->fm(n) if -5 <= n <= 22
PRINTSTRING("fault"); write(n, 2); ->ps
fm(-5):PRINTSTRING("Dubious statement"); dubious = 0; ->psd
fm(-4):PRINTSTRING("Non-local")
pos1 = for warn; for warn = 0; ->ps
fm(-3):print ident(x, 0); PRINTSTRING(" unused"); ->nps
fm(-2):PRINTSTRING("""}"""); ->miss
fm(-1):PRINTSTRING("access"); ->psd
fm(0): PRINTSTRING("form"); ->ps
fm(1): PRINTSTRING("atom"); ->ps
fm(2): PRINTSTRING("not declared"); ->ps
fm(3): PRINTSTRING("too complex"); ->ps
fm(4): PRINTSTRING("duplicate "); Print Ident(x, 0); ->ps
fm(5): PRINTSTRING("type"); ->ps
fm(6): PRINTSTRING("match"); ->psd
fm(7): PRINTSTRING("context"); ->psd
fm(21):PRINTSTRING("context "); print ident(this, 0); ->ps
fm(8): PRINTSTRING("%cycle"); ->miss
fm(9): PRINTSTRING("%start"); ->miss
fm(10):PRINTSTRING("size"); WRITE(lit, 1) if pos1 = 0;->ps
fm(11):PRINTSTRING("bounds")
WRITE(ocount, 1) unless ocount < 0; ->ps
fm(12):PRINTSTRING("index"); ->ps
fm(13):PRINTSTRING("order"); ->psd
fm(14):PRINTSTRING("not a location"); ->ps
fm(15):PRINTSTRING("%begin"); ->miss
fm(16):PRINTSTRING("%end"); ->miss
fm(17):PRINTSTRING("%repeat"); ->miss
fm(18):PRINTSTRING("%finish"); ->miss
fm(19):PRINTSTRING("result"); ->miss
fm(22):PRINTSTRING("format"); ->ps
fm(20):printsymbol('"'); print ident(x, 0); printsymbol('"')
miss: PRINTSTRING(" missing"); ->nps
psd: pos1 = 0
ps: print ss
nps: NEWLINE
exit if st = listing
st = listing
repeat
if n >= 0 start
signal 15,15 if diag&4096 # 0
if n # 13 start ; !order is fairly safe
ocount = -1
gg = 0
copy = 0; quote = 0
search base = 0; escape class = 0
gg = 0
finish
faulty = faulty+1
!check that there haven't been too many faults
fault rate = fault rate+3; abandon(6) IF fault rate > 30
fault rate = 3 IF fault rate <= 0
FINISH
tbase = tstart
IF list <= 0 AND sym # nl START
error margin = column
error sym = sym; sym = nl
FINISH
END
dmin = dmin-1; dict(dmin) = -1; !end marker for starts & cycles
abandon(2) IF dmax = dmin
IF list > 0 AND level > 0 START
write(lines, 5); spaces(level*3-1)
IF block tag = 0 START
printstring("Begin")
FINISH ELSE START
printstring("Procedure "); print ident(block tag, 0)
FINISH
newline
FINISH
!deal with procedure definition (parameters)
IF block tag # 0 START ; !proc
analyse; compile IF ss # 0
IF block otype # 0 START ; !external-ish
IF bflags&spec = 0 START ; !definition
IF progmode <= 0 AND level = 1 THEN progmode = -1 C
ELSE fault(7)
FINISH
FINISH
new app = gapp; !generate app grammar
IF spec given # 0 START ; !definition after spec
fault(6) IF new app # block app; !different from spec
FINISH
block app = new app; !use the latest
IF level < 0 START ; !not procedure definition
delete names(0)
RETURN
FINISH
FINISH ELSE START
open = 0; !can return from a block?
FINISH
CYCLE
analyse
CONTINUE IF ss = 0
compile
fault(-5) IF dubious # 0
flush buffer IF bp >= 128
IF sstype > 0 START ; !block in or out
EXIT IF sstype = 2; !out
compile block(spec mode, block x, dmin, tmax, id)
EXIT IF ss < 0; !endofprogram
FINISH
REPEAT
IF list > 0 AND level > 0 START
write(lines, 5); spaces(level*3-1)
printstring("End")
newline
FINISH
delete names(0)
RETURN
INTEGERFN gapp; !generate app grammar (backwards)
CONSTINTEGER comma = 140; !psep
ROUTINESPEC set cell(INTEGER g, tt)
ROUTINESPEC class(RECORD (tagfm)NAME v)
RECORD (tagfm)NAME v
INTEGER p, link, tp, c, ap, t
RESULT = 0 IF tmax = local; !no app needed
p = gmax1; link = 0; t = tmax
CYCLE
v == tag(t); t = t-1
class(v); !deduce class from tag
IF c < 0 START ; !insert %PARAM
c = -c
set cell(196, tp)
tp = -1
FINISH
set cell(c, tp)
EXIT IF t = local; !end of parameters
set cell(comma, -1); !add the separating comma
REPEAT
abandon(3) IF gmax > gmin
RESULT = link
ROUTINE set cell(INTEGER g, tt)
!add the cell to the grammar, combining common tails
WHILE p # gmax CYCLE
p = p+1
IF glink(p) = link AND gram(p) = g START
IF tt < 0 OR (gram(p+1) = tt AND glink(p+1)=ap) START
link = p; !already there
RETURN
FINISH
FINISH
REPEAT
!add a new cell
gmax = gmax+1
gram(gmax) = g
glink(gmax) = link
link = gmax
IF tt >= 0 START ; ! set type cell
gmax = gmax+1
gram(gmax) = tt
glink(gmax) = ap
FINISH
p = gmax
END
ROUTINE class(RECORD (tagfm)NAME v)
CONSTINTEGER err = 89
CONSTINTEGER rtp = 100
CONSTINTEGER fnp = 101
CONSTINTEGER mapp = 102
CONSTINTEGER predp = 103
CONSTINTEGERARRAY class map(0:15) = C
err,1764, 247, err(4), -rtp, -fnp, -mapp, -predp, err, 214,
err, 229, err
INTEGER tags, type, form
ap = 0
tags = v_flags
type = tags>>4&7; form = tags&15
tp = v_format<<3!type
c = class map(form)
c = 208 AND tp = 0 IF type = 0 AND form = 2; !%NAME
ap = v_app IF tags¶meters # 0
END
END
ROUTINE delete names(INTEGER quiet)
INTEGER flags
RECORD (tagfm)NAME tx
WHILE tmax > tbase CYCLE
x = tmax; tmax = tmax-1
tx == tag(x)
flags = tx_flags
fault(20) IF flags&spec # 0 and flags&own bit = 0
{spec with no definition & not external}
IF flags&used bit = 0 AND level >= 0 AND list <= 0 START
fault(-3) IF quiet = 0; !unused
FINISH
dict(tx_text) = tx_link
REPEAT
END
ROUTINE analyse
CONSTINTEGER order bits = x'3000', order bit = x'1000'
CONSTINTEGER escape = x'1000'
INTEGER strp, mark, flags, prot err, k, s, c
OWNINTEGER key = 0
SHORTINTEGER node
SHORTINTEGERNAME z
RECORD (arfm)NAME arp
!emas: %INTEGER node
!emas: %INTEGERNAME z
SWITCH act(actions:phrasal), paction(0:15)
ROUTINE trace analysis
!diagnostic trace routine (diagnose&1 # 0)
INTEGER a
ROUTINE show(INTEGER a)
IF 0 < a < 130 START
space
printstring(text(a))
FINISH ELSE write(a, 3)
END
OWNINTEGER la1=0, la2=0, lsa=0, lt=0
newline IF mon pos # pos AND sym # nl
mon pos = pos
write(g, 3)
space
printstring(text(class))
printsymbol('"') IF gg&trans bit # 0
a = gg>>8&15
IF a # 0 START
printsymbol('{')
write(a, 0)
printsymbol('}')
FINISH
IF atom1 # la1 OR atom2 # la2 OR lsa # subatom C
OR lt # type START
printstring(" [")
la1 = atom1
show(la1)
la2 = atom2
show(la2)
lsa = subatom
write(lsa, 3)
lt = type
write(lt, 5)
printsymbol(']')
FINISH
newline
END
ROUTINE get sym
readsymbol(sym)
pos = pos+1 IF pos # 133
char(pos) = sym
printsymbol(sym) IF list <= 0
column = column+1
END
ROUTINE read sym
owninteger Last = 0
CONSTBYTEINTEGERARRAY mapped(0:127) = C
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, nl, 0, 3 , 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0 ,'!','"','#', '$', 1 ,'&', 39, '(',')','*','+', ',','-','.','/',
'0','1','2','3', '4','5','6','7', '8','9',':',';', '<','=','>','?',
'@','A','B','C', 'D','E','F','G', 'H','I','J','K', 'L','M','N','O',
'P','Q','R','S', 'T','U','V','W', 'X','Y','Z','[', '¬',']','^','_',
'`','A','B','C', 'D','E','F','G', 'H','I','J','K', 'L','M','N','O',
'P','Q','R','S', 'T','U','V','W', 'X','Y','Z', 2 , '|','}','~', 0
!! 0 = space
!! 1 = %
!! 2 = {
!! 3 = ff
!! other values represent themselves
IF sym = nl START
s1: lines = lines+1
printsymbol(end mark) if end mark # 0
s11: pos = 0; pos1 = 0; pos2 = 0; margin = 0; column = 0
Last = 0
end mark = 0
IF list <= 0 START
IF include # 0 START
printstring(" &"); write(lines, -4)
FINISH ELSE write(lines, 5)
csym = cont; printsymbol(csym)
space
IF error margin # 0 START
lines = lines-1
spaces(error margin)
error margin = 0
IF error sym # 0 START
printsymbol(error sym)
pos = 1; char(1) = error sym
sym = error sym; error sym = 0
->s5
FINISH
FINISH
FINISH
s2: symtype = 1
FINISH
s3:readsymbol(sym)
pos = pos+1 IF pos # 133
char(pos) = sym
printsymbol(sym) IF list <= 0
column = column+1
s5:IF sym # nl START
Last = Sym
RETURN IF quote # 0; !dont alter strings
sym = mapped(sym&127)
IF sym <= 3 START ; !special symbol
->s2 IF sym = 0; !space (or dubious control)
symtype = 2 AND ->s3 IF sym = 1; !%
cont = '+' AND ->s11 IF sym = 3; !ff
!must be {
CYCLE
get sym
->s3 IF sym = '}'
->s4 IF sym = nl
REPEAT
FINISH
key = kdict(sym)
IF key&3 = 0 AND symtype = 2 START ; !keyword
IF sym = 'C' AND nextsymbol = nl START ; !%C...
getsym; cont = '+'; ->s1
FINISH
ELSE
symtype = key&3-2
FINISH
RETURN
FINISH
s4:symtype = quote
->S1 if last = 0 and Quote = 0
Cont = '+'
END
INTEGERFN format selected
format list = tag(format)_app; !number of names
IF format list < 0 START ; !forward ref
atom1 = error+22
RESULT = 0
FINISH
IF sym = '_' START
escape class = esc rec
search base = tag(format)_format
FINISH
RESULT = 1
END
ROUTINE code atom(INTEGER target)
INTEGER dbase, da
INTEGER base, n, mul, pend quote
INTEGER j,k,l, pt
ROUTINE lookup(INTEGER d)
CONSTINTEGER magic = 6700421
INTEGER new name, vid, k1, k2, form
RECORD (tagfm)NAME t
!emas: %LONGINTEGER k0
INTEGER new
!first locate the text of the name
new = addr(dict(dmax+1))
!******** Machine code to inhibit overflow test ********
*LI_1,magic
* M_0,hash value
*ST_1,K2
{K2 = hash value*magic}
!*******************************************************
k2 = k2>>(32-2*name bits)!1
!emas: k0 = magic
!emas: k1 = (k0*hash value)&X'7FFFFFFF'
!emas: k2 = k1>>(32-2*name bits)!1
k1 = k2>>name bits; !giving name bits
CYCLE
newname = hash(k1)
EXIT IF newname = 0; !not in
->in IF string(addr(dict(newname+1))) = string(new)
k1 = (k1+k2)&max names
REPEAT
! not found
spare names = spare names-1
abandon(2) IF spare names <= 0
hash(k1) = dmax; !put it in
dict(dmax) = -1
newname = dmax; dmax = dp; ->not in
in: search base = rbase IF this >= 0 AND d # 0; !record elem defn
IF search base # 0 START ; !record subname
new = -1
x = search base
CYCLE
->not in IF x < format list
EXIT IF tag(x)_text = new name
x = x-1
REPEAT
FINISH ELSE START ; !hash in for normal names
x = dict(newname)
->not in IF x <= limit; !wrong level
FINISH
subatom = x; !name found, extract info
t == tag(x)
atom flags = t_flags
format = t_format; app = t_app
protection = atom flags&prot
type = atom flags>>4&7; atom1 = amap(atom flags&15)
IF diag&8 # 0 START
printstring("lookup:")
write(atom1, 3)
write(type, 1)
write(app, 3)
write(format, 5)
write(atom flags, 3)
newline
FINISH
IF d = 0 START ; !old name wanted
t_flags <- t_flags!used bit
search base = 0
IF atom flags&subname # 0 AND format # 0 START ; !a record
RETURN IF format selected = 0
FINISH
IF atom flags¶meters # 0 START ; !proc or array
IF app = 0 START ; !no parameters needed
atom2 = atom1
atom1 = atom1-4
IF 97 <= atom1 <= 98 START
map gg = atom1; atom1 = var
FINISH
FINISH ELSE START
IF sym = '(' START
search base = 0; !ignore format for now
IF atom1 >= 106 START ; !arrays
app = phrase(app+200)
escape class = esc array
atom1 = (atom1-106)>>1+91; !a,an->v na,nan->n
FINISH ELSE START ; !procedures
escape class = esc proc
atom1 = atom1-4
FINISH
phrase(200) = app
FINISH
FINISH
pos2 = pos; return
FINISH
!deal with constintegers etc
IF atom flags&const bit # 0 AND atom1 = var START
map gg = const; atom2 = const
subatom = -subatom IF type = integer
FINISH
RETURN
FINISH
!new name wanted
->not in IF tbase # tstart; !don't fault proc parm-parm
IF d = lab+spec+used bit START
t_flags = t_flags!used bit
RETURN
FINISH
IF atom flags&spec # 0 START ; !a spec has been given
IF d = lab START ; !define label
t_flags <- t_Flags-Spec
RETURN
FINISH
IF 7 <= decl&15 <= 10 AND decl&spec = 0 START
!procedure definition after spec
IF (decl!!atom flags)&b'1111111' = 0 START ; !correct type?
t_flags = t_flags-spec
spec given = 1
RETURN
FINISH
!note that an external procedure must be speced as a
!non-external procedure.
FINISH
IF decl&15 = recfm START ; !recordformat
t_flags = record<<4+recfm
t_format = fdef
RETURN
FINISH
FINISH
RETURN IF last1 = jump AND atom1 = swit
copy = x IF copy = 0
notin:app = 0; vid = 0
atom1 = error+2
return if d = 0; !old name wanted
type = d>>4&7; form = d&15; atom1 = amap(form)
IF this < 0 START ; !normal scope
new = newname
tmax = tmax+1; x = tmax
FINISH ELSE START ; !recordformat scope
new = -1
recid = recid-1; vid = recid
tmin = tmin-1; x = tmin
format list = tmin
FINISH
IF 11 <= form <= 14 START ; !arrays
dim = 1 IF dim = 0; !set dim for owns
app = dim
FINISH
d = d!used bit IF (otype > 2 AND d&spec = 0) OR perm # 0 OR
Level = Include Level
!external definitions need not be used in the file in which
!they are defined, so inhibit a useless unused warning.
t == tag(x)
IF form = lab START
id = id+1; vid = id
FINISH
t_index = vid
t_text = new name
t_flags <- d
t_app = app
t_format = fdef; format = fdef
subatom = x
IF new >= 0 START ; !insert into hash table
t_link = dict(new); dict(new) = x
IF gmin = max grammar START ; !proc param params
tmin = tmin-1; subatom = tmin
tag(tmin) = t
FINISH
FINISH
abandon(3) IF tmax >= tmin
END
top: pos1 = pos
subatom = 0; pend quote = 0; atom flags = 0
!app and format must be left for assigning to papp & pformat
->name IF symtype = -2; !letter
->number IF symtype < 0; !digit
IF symtype = 0 START
atom1 = termin; atom2 = 0
RETURN
FINISH
IF symtype # 2 START ; !catch keywords here
->text IF quote # 0; !completion of text
->strings IF sym = squote; !start of string
->symbols IF sym = cquote; !start of symbol
->number IF sym = '.' AND '0' <= nextsymbol <= '9'
FINISH
!locate atom in fixed dict
k = key>>2; read sym
CYCLE
j = kdict(k)
EXIT IF j&x'4000' # 0
IF j&127 # sym OR symtype < 0 START
->err UNLESS j < 0
k = k+1
FINISH ELSE START
l = j>>7&127; read sym
IF j > 0 START
IF l # 0 START
->err IF l # sym OR symtype < 0
read sym
FINISH
l = 1
FINISH
k = k+l
FINISH
REPEAT
atom1 = j&127
IF atom1 = 0 START ; !comma
atom1 = 19; subatom = 19; atom2 = 0
IF sym = nl START
RETURN IF ocount >= 0
!special action needs to be taken with <comma nl> as
!const array lists can be enormous
read sym
FINISH
RETURN
FINISH
atom2 = j>>7&127
subatom = kdict(k+1)&x'3fff'
!!!!!cont = ' '
RETURN
!report an error. adjust the error marker (pos1) to point
!to the faulty character in an atom, but care needs to be taken
!to prevent misleading reports in cases like ...?????
err: atom1 = error+1; atom2 = 0
pos1 = pos IF pos-pos1 > 2
RETURN
!take care with strings and symbol constants.
!make sure the constant is valid here before sucking it in
!(and potentially loosing many lines)
symbols:atom1 = var; atom2 = const; type = integer
map gg = const; protection = prot
subatom = lp; abandon(3) IF lp >= lit max
quote = ¬pend quote
RETURN
!an integer constant is acceptable so get it in and
!get the next atom
chars:n = 0; cont = cquote
CYCLE
read sym
IF sym = cquote START
EXIT IF nextsymbol # cquote
read sym
FINISH
IF n&(¬((-1)>>byte size)) # 0 START ; ! overflow
pos1 = pos; atom1 = error+10; RETURN
FINISH
->err IF quote = 0
n = n<<byte size+sym
quote = quote+1
REPEAT
quote = 0; cont = ' '
readsym IF sym # nl
lit pool(lp) = n; lp = lp+1
->top
!sniff the grammar before getting the string
strings:atom1 = var; atom2 = const; type = stringv
subatom = (strp-stbase)!x'4000'
map gg = const; protection = prot
quote = subatom
text line = lines; !in case of errors
RETURN
!a string constant is ok here, so pull it in and get
!the next atom
text: ->chars IF quote < 0; !character consts
l = strp; n = strp
j = addr(glink(gmin-1)); !absolute limit
k = l+256; !string length limit
k = j IF j < k; !choose lower
CYCLE
cont = squote; quote = 1
CYCLE
read sym
IF sym = squote START ; !terminator?
EXIT IF nextsymbol # squote; !yes ->
read sym; ! skip quote
FINISH
l = l+1; byteinteger(l) = sym
lines = text line AND abandon(7) IF l >= k; !too many chars
REPEAT
byteinteger(n) = l-n; !plug in length
strp = l+1; !ready for next string
quote = 0; cont = ' '; read sym
code atom(target)
RETURN UNLESS atom1 = 48 AND sym = squote; !fold "???"."+++"
REPEAT
ROUTINE get(INTEGER limit)
INTEGER s, shift
shift = 0
IF base # 10 START
IF base = 16 START
shift = 4
FINISH ELSE START
IF base = 8 START
shift = 3
FINISH ELSE START
IF base = 2 START
shift = 1
FINISH
FINISH
FINISH
FINISH
n = 0
CYCLE
IF symtype = -1 START ; !digit
s = sym-'0'
FINISH ELSE START
IF symtype < 0 START ; !letter
s = sym-'A'+10
FINISH ELSE START
RETURN
FINISH
FINISH
RETURN IF s >= limit
pt = pt+1; byteinteger(pt) = sym
IF base = 10 START ; !check overflow
IF n >= max int AND (s > max dig OR n > max int) START
!too big for an integer,
!so call it a real
base = 0; type = real; n = 0
FINISH
FINISH
IF shift = 0 START
n = n*base+s
FINISH ELSE START
n = n<<shift+s
FINISH
read sym
REPEAT
END
number:base = 10
bxk: atom1 = var; atom2 = const; type = integer; subatom = lp
map gg = const; protection = prot
abandon(3) IF lp >= lit max
pt = strp; mul = 0
CYCLE
get(base)
EXIT UNLESS sym = '_' AND base # 0 AND pend quote = 0; !change of base
pt = pt+1; byteinteger(pt) = '_'
read sym
base = n
REPEAT
IF pend quote # 0 START
->err IF sym # cquote
readsym
FINISH
IF sym = '.' START ; !a real constant
pt = pt+1; byteinteger(pt) = '.'
read sym
type = real; n = base; base = 0; get(n)
FINISH
IF sym = '@' START ; !an exponent
pt = pt+1; byteinteger(pt) = '@'; k = pt
readsym
type = integer; base = 10
IF sym = '-' START
read sym; get(10); n = -n
FINISH ELSE START
get(10)
FINISH
pt = k+1; byteinteger(pt) = lp; litpool(lp) = n; lp = lp+1
atom1 = error+10 IF base = 0
type = real; !exponents force the type
FINISH
IF type = real START
byteinteger(strp) = pt-strp
subatom = (strp-stbase)!x'2000'; strp = pt+1
FINISH ELSE START
litpool(lp) = n
lp = lp+1
FINISH
RETURN
name: atom1 = 0 AND RETURN IF 27 <= target <= 41
hash value = 0
!*****************************
!*machine dependent for speed*
!*****************************
dp = dmax+1
da = addr(dict(dp)); dbase = da
CYCLE
hash value = hash value+(hash value+sym); !is this good enough?
da = da+1; byteinteger(da) = sym
read sym
EXIT IF symtype >= 0
REPEAT
IF sym = cquote START
pend quote = 100
->symbols IF hash value = 'M'
read sym
IF hash value = 'X' THEN base = 16 AND ->bxk
IF hash value = 'K' C
OR hash value = 'O' THEN base = 8 AND ->bxk
IF hash value = 'B' THEN base = 2 AND ->bxk
->err
FINISH
n = da-dbase
byteinteger(dbase) = n
dp = dp+(n+2)>>1
abandon(8) IF dp >= dmin
atom2 = 90; !ident
IF last1 = 0 AND sym = ':' START ; !label
limit = local; lookup(lab); RETURN
FINISH
IF last1 = jump START ; !->label
limit = local; lookup(lab+spec+used bit); RETURN
FINISH
IF decl # 0 AND target = 90 START ; !identifier
search base = fm base
limit = local; lookup(decl)
search base = 0
FINISH ELSE START
limit = 0; lookup(0)
FINISH
END
INTEGERFN parsed machine code
! *opcode_??????????
routine octal(integer n)
integer m
m = n>>3
octal(m) if m # 0
bp = bp+1; buff(bp) = n&7+'0'
end
atom1 = error AND RESULT =0 UNLESS symtype = -2; !starts with letter
flush buffer IF bp >= 128
bp=bp+1 AND buff(bp)='w'
CYCLE
bp=bp+1 AND buff(bp)=sym
read sym
EXIT IF symtype >= 0; !pull in letters and digits
REPEAT
bp=bp+1 AND buff(bp)='_'
IF symtype # 0 START ; !not terminator
atom1 = error AND result =0 UNLESS sym = '_'
read sym
WHILE symtype # 0 CYCLE
IF symtype < 0 START ; !complex
code atom(0); result =0 IF atom1&error # 0
IF atom2 = const AND type = integer START
IF subatom < 0 THEN octal(tag(-subatom)_format) C
ELSE octal(litpool(subatom))
FINISH ELSE START
IF 91 <= atom1 <= 109 START
if atom1 = 104 {label} and
Tag(Subatom)_Flags&Closed = 0 start
This = Subatom; Atom1 = Error+21
result = 0
finish
op(' ', tag(subatom)_index)
FINISH ELSE START
atom1 = error; result =0
FINISH
FINISH
FINISH ELSE START
bp=bp+1 AND buff(bp)=sym; read sym
FINISH
REPEAT
FINISH
bp=bp+1 AND buff(bp)=';'
RESULT =1
END
cont = ' ' IF gg = 0
last1 = 0; mapgg = 0
s = 0; ss = 0; sstype = -1; fdef = 0
fm base = 0
app = 0
!deal with alignment following an error in one statement
!of several on a line
margin = column; !start of statement
pos = 0
stbase = addr(glink(gmax+1)); strp = stbase; lp = 0
tbase = tstart; !??????????????
local = tbase
IF gg = 0 or ocount >= 0 START ; !data or not continuation(z)
again:WHILE sym type = 0 CYCLE ; !skip redundant terminators
c = cont
cont = ' '; cont = '+' IF ocount >= 0
read sym
cont = c
REPEAT
->skip IF sym = '!'; !comment
this = -1
code atom(0)
IF atom1 = comment START
skip: quote = 1
c = cont
read sym AND cont = c WHILE sym # nl; !skip to end of line
quote = 0; symtype = 0
->again
FINISH
FINISH
decl = 0; mark = 0
gentype = 0; force = 0
dim = 0; prot err = 0
node = 0; nmax = 0; nmin = rec size+1
order = 1; gmin = max grammar+1
sstype = 0 AND ->more IF gg # 0; !continuation
ptype = 0; spec given = 0
stats = stats+1; op('O', lines) IF perm = 0
->fail1 IF atom1&error # 0; !first atom faulty
IF escape class # 0 START ; !enter the hard way after
g = imp phrase; sstype = -1; ->a3
FINISH
g = initial(atom1); !pick up entry point
IF g = 0 START ; !invalid first atom
g = initial(0); sstype = 0; ->a3; !declarator?
FINISH
IF g < 0 START ; !phrase imp
g = g&255
nmax = 1
ar(1)_class = 0; ar(1)_link = 0; ar(1)_sub = imp phrase
FINISH
gg = gram(g); class = gg&255; sstype = gg>>12&3-1
->a1
act(194): ptype = type; papp = app; pformat = format; ->more
act(196):k =g+1; ->a610
act(188):k = ar(nmax)_sub+1
a610: papp = glink(k)
k = gram(k)
->more IF k = 0; !%NAME
ptype = k&7; pformat = k>>3
act(183):k = type; gentype = k IF gentype = 0 OR k = real
IF pformat < 0 START ; !general type
app = papp; format = pformat
k = real IF ptype = real AND type = integer
k = force AND force = 0 IF force # 0
FINISH
->fail2 UNLESS papp = app AND (ptype = k OR ptype = 0)
->more IF pformat=format OR pformat = 0 OR format = 0
->fail2
act(197):arp == ar(nmin)
k = arp_sub
->fail3 UNLESS block form = k&15
arp_sub = k>>4
type = block type
ptype = block type; pformat = block fm; papp = app
pformat = -1 IF ptype # record
->more
act(195):->Fail2 if Type # 0 and Type # Integer and
Type # Real
arp == ar(nmin)
k = arp_sub
arp_sub = k>>2
k = k&3
!1 = check integer
!2 = check real
!3 = check real + int
->more IF k = 0; !0 = no action
IF k = 1 START
force = integer
->more IF type = integer OR type = 0
->fail2
FINISH
->fail2 UNLESS ptype = real or ptype = 0 {or added?}
force = integer IF k = 3
->more
act(198):!%OTHER
k = gg>>8&15
IF k = 0 START ; !restore atom
atom1 = last1
->more
FINISH
IF k = 1 START ; !test string
->fail2 UNLESS type = stringv
->more
FINISH
if k = 2 start {fault record comparisons}
->fail2 if type = record
->more
finish
if k = 3 start ; !check OWN variable coming
code atom(0)
->A7 if atom flags&own bit = 0
->more
finish
for warn = pos1 IF x <= local; !%FORTEST
->more
paction(1):IF type = record THEN g = phrase(242) ELSE pformat = -1
->a3
paction(2):ptype = real; pformat = -1; ->a3
paction(3):ptype = stringv; pformat = -1; ->a3
paction(4):ptype = integer; pformat = -1; ->a3
paction(5):->a3 if ptype = integer
g = phrase(212) AND pformat=-1 IF ptype = real
g = phrase(213) IF ptype = stringv
->a3
paction(6):ptype = gram(ar(nmax)_sub+1)&7; pformat = -1; ->a3
paction(7):ptype=real IF ptype = integer; pformat = -1; ->a3
a1: last1 = class; atom1 = 0; s = subatom
a2: IF gg&trans bit = 0 START ; !insert into analysis record
z == node
CYCLE ; !insert cell in order
k = z
EXIT IF gg&order bits = 0 OR k = 0
gg = gg-order bit; z == ar(k)_link
REPEAT
gg = map gg IF map gg # 0 AND gg&255 = var
nmin = nmin-1; ->fail0 IF nmin = nmax
z = nmin
arp == ar(nmin)
arp_sub = s; arp_class = (gg&255)!mark
arp_link = k
FINISH
mark = 0; map gg = 0
more: g = glink(g); !chain down the grammar
paction(0):
a3: gg = gram(g); class = gg&255
trace analysis IF diag&1 # 0
->a5 IF class = 0; !end of phrase
IF class < actions START ; !not a phrase or an action
class = atomic(class) IF class >= figurative
->a2 IF class >= manifest
code atom(class) IF atom1 = 0
IF escape class # 0 START ; !escape to new grammar
class = escape class; escape class = 0
g = g+escape
!note that following an escape the next item is
!forced to be transparent!
esc: gg = 0
arp == ar(nmax+1)
arp_papp = papp; arp_x = x; ->a4
FINISH
->a1 IF class = atom1 OR class = atom2
a7: ->fail1 IF gg >= 0; !no alternative
g = g+1
->a3
FINISH
IF class >= phrasal START ; !a phrase
a4: nmax = nmax+1; ->fail0 IF nmax = nmin
arp == ar(nmax)
arp_ptype = ptype
arp_pos = pos1
arp_pformat = pformat
arp_link = gentype
arp_class = node
arp_sub = g
node = 0
g = phrase(class)
ptype = force AND force = 0 IF force # 0
gentype = 0
->paction(gg>>8&15)
FINISH
->act(class); !only actions left
a5: !reverse links
s = 0
WHILE node # 0 CYCLE
z == ar(node)_link
k = z; z = s; s = node; node = k
REPEAT
ss = s
a6: IF nmax # 0 START
k = gentype; !type of phrase
arp == ar(nmax); nmax = nmax-1
node = arp_class
gentype = arp_link
ptype = arp_ptype
pformat = arp_pformat
g = arp_sub
IF g&escape # 0 START
g = g-escape
papp = arp_papp
mark = 255
subatom = s
->a3
FINISH
gentype = k IF gentype = 0 OR k = real
type = gen type
k = gg; !exit-point code
CYCLE
gg = gram(g)
->a2 IF k = 0
->fail1 IF gg >= 0; !no alternative phrase
k = k-order bit
g = g+1; !sideways step
REPEAT
FINISH
Fault(4) IF copy # 0
fault(13) IF order = 0
fault(-4) IF for warn # 0
pos1 = 0
fault rate = fault rate-1
RETURN
act(193):gg = 0 AND ->a5 UNLESS sym = '=' or sym = '<'; !cdummy
act(181):atom1 = amap(decl&15); !dummy
->more
act(182):class = escdec; g = glink(g)!escape
decl = 0; otype = 0; ->esc; !decl
act(199): !compile
s = 0
WHILE node # 0 CYCLE
z == ar(node)_link
k = z; z = s; s = node; node = k
repeat
ss = s
code atom(28) IF quote # 0; !expend
compile; ->more IF atom1&error = 0
->fail1
act(184):->fail4 UNLESS type = integer
IF subatom < 0 THEN lit = tag(-subatom)_format C
ELSE lit = lit pool(subatom)
->fail4 IF lit # 0
->more
act(185): !apply parameters
s = 0
WHILE node # 0 CYCLE
z == ar(node)_link
k = z; z = s; s = node; node = k
REPEAT
ss = s
atom1 = ar(s)_class; atom2 = 0
atom1 = var IF atom1 = 97 OR atom1 = 98
arp == ar(nmax)
x = arp_x
pos1 = arp_pos
pos2 = 0
app = 0
format = tag(x)_format
flags = tag(x)_flags
type = flags>>4&7
protection = flags&prot
protection = 0 IF flags&aname # 0
IF flags&subname # 0 AND format # 0 START
->fail1 if format selected = 0
FINISH
->a6
act(187):protection = prot; ->more; !%SETPROT
act(186):->More if protection&prot = 0
prot err = nmin
->A7
act(191):k = protection; !%GUARD
code atom(0)
protection = k IF atom flags&aname = 0
->more
act(192):->fail1 IF parsed machine code=0
->more
act(189):k = gapp; !%GAPP
delete names(1)
tmax = tbase; tbase = gram (gmin); !restore tmax
local= tbase
gmin = gmin+1
x = ar(ar(nmax)_class)_sub
tag(x)_app = k; !update app
->more
act(190):gmin = gmin-1; !%LOCAL
abandon(2) IF gmin <= gmax
gram (gmin) = tbase; tbase = tmax
local = tbase
->more
! errors
fail4:k = error+10; ->failed; !*size
fail3:k = error+7; ->failed; !*context
fail2:k = error+5; pos2 = 0; ->failed; !*type
fail0:k = error+3; ->failed; !*too complex
fail1:k = atom1; pos2 = 0
failed:
IF diag&32 # 0 START
printstring("Atom1 ="); write(atom1, 3)
printstring(" Atom2 ="); write(atom2, 3)
printstring(" subatom ="); write(subatom, 3); newline
printstring("Type ="); write(type, 1)
printstring(" Ptype ="); write(ptype, 1); newline
printstring("App ="); write(app, 1)
printstring(" Papp ="); write(papp, 1); newline
printstring("Format ="); write(format, 1)
printstring(" Pformat ="); write(pformat, 1); newline
SIGNAL 13,15
FINISH
quote = 0 AND readsym WHILE sym # nl AND sym # ';'
IF k&error # 0 START
fault(k&255)
FINISH ELSE START
IF prot err = nmin THEN fault(14) ELSE fault(0)
FINISH
gg = 0; ss = 0; symtype = 0
END ; !of analyse
ROUTINE compile
CONSTINTEGER then = 4, else = 8, loop = 16
SWITCH c(0:actions), litop(1:12)
CONSTBYTEINTEGERARRAY operator(1:14) = C
'[', ']', 'X', '/', '&', '!', '%', '+',
'-', '*', 'Q', 'x', '.', 'v'
CONSTBYTEINTEGERARRAY cc(0 : 7) = '#','=',')','<','(','>', 'k','t'
CONSTBYTEINTEGERARRAY anyform(0:15) = 1,0,1,1(4),1,0,1,1,0,1,1,1,1
CONSTSHORTINTEGERARRAY decmap(0:15) = C
1, 2,
x'100B', x'100D', x'140C', x'140E',
3, 4,
x'1007', x'1008', x'1009', x'100A',
6, 0, 0, 0
OWNBYTEINTEGERARRAY cnest(0:15)
INTEGER lmode, clab, dupid
INTEGER resln
OWNINTEGER last def = 0
OWNINTEGER lb, ub
INTEGER cp, ord
INTEGER next, link, j, k, n, done
INTEGER class
INTEGER lit2, defs, decs, cident
INTEGER pending; OWNINTEGERARRAY pstack(1:40)
OWNSTRING (8) name = ""
OWNINTEGER count = 0
ROUTINE def lab(INTEGER l)
op(':', l)
access = 1
END
ROUTINE get next
RECORD (arfm)NAME p
gn: IF next = 0 START ; !end of phrase
class = 0 AND RETURN IF link = 0; !end of statement
p == ar(link)
next = p_link
link = p_sub
FINISH
CYCLE
p == ar(next)
x = p_sub
class = p_class
EXIT IF class < actions; !an atom
IF x = 0 START ; !null phrase
next = p_link; ->gn
FINISH
IF p_link # 0 START ; !follow a phrase
p_sub = link; link = next
FINISH
next = x
REPEAT
next = p_link
IF diag&2 # 0 START
spaces(8-length(name)) UNLESS name = ""
name = text(class)
write(x, 2)
space
printstring(name)
space
count = count-1
IF count <= 0 START
count = 5
name = ""
newline
FINISH
FINISH
END
ROUTINE set subs(INTEGER n)
!update the app field in n array descriptors
INTEGER p
p = tmax
WHILE n > 0 CYCLE
SIGNAL 15,15 IF p < tbase
tag(p)_app = dimension
p = p-1; n = n-1
REPEAT
END
ROUTINE set bp
!define a constant bound pair from the last stacked constants
pending = pending-2
lb = pstack(pending+1); ub = pstack(pending+2)
IF ub-lb+1 < 0 START
pos1 = 0; next = link; fault(11)
ub = lb
FINISH
set const(lb); set const(ub)
bp=bp+1 AND buff(bp)='b' UNLESS class = 146
END
ROUTINE compile end(INTEGER type)
! type = 0:eof, 1:eop, 2:end
IF access # 0 START
open = 0
fault(19) IF block form > proc; !can reach end
FINISH
WHILE dict(dmin) >= 0 CYCLE ; !finishes & repeats
fault(17+dict(dmin)&1)
dmin = dmin+1
REPEAT
{delete names(0)}
bp=bp+1 AND buff(bp)=';'
bp=bp+1 AND buff(bp)=';' IF type = 1; !endofprogram
bflags = bflags!open; !show if it returns
def lab(0) IF block tag # 0 AND level # 1; !for jump around
IF type # 2 START ; !eop, eof
fault(16) IF level # type; !end missing
FINISH ELSE START
IF level = 0 START
fault(15); !spurious end
FINISH
FINISH
end mark = 11; !******Mouses specific******
END
ROUTINE def(INTEGER p)
!dump a descriptor
INTEGER t, f, type
RECORD (tagfm)NAME v
flush buffer if bp # 0
defs = defs+1
v == tag(p)
t = 0
UNLESS v_index < 0 START ; !no index for subnames
id = id+1 AND v_index = id IF v_index = 0
last def = v_index
t = last def
FINISH
op('$', t)
print ident(p, 1); !output the name
t = v_flags
type = t
type = type&(¬(7<<4)) IF type&(7<<4) >= 6<<4;!routine & pred
op(',', type&b'1111111'); !type & form
f = v_format
f = tag(f)_index IF t&x'70' = record<<4
f = v_index IF f < 0
op(',', f); !format
f = otype+t>>4&b'1111000'
f = f!8 IF class = 125; !add spec from %DUP
dim = v_app; !dimension
dim = 0 unless 0 < dim <= dim limit
op(',', f+dim<<8); !otype & spec & prot
defs = 0 IF t¶meters = 0
f = t&15
IF v_flags&spec # 0 START
v_flags = v_flags&(¬spec) UNLESS 3 <= f <= 10
ocount = -1; !external specs have no constants
FINISH
dimension = 0
if otype = 2 and (f=2 or f=12 or f=14) start
v_flags = v_flags-1; !convert to simple
finish
END
ROUTINE def s lab(INTEGER n)
!define a switch label, x defines the switch tag
INTEGER p, l, b, w, bit
p = tag(x)_format; !pointer to table
l = dict(p); !lower bound
IF l <= n <= dict(p+1) START
b = n-l
w = b>>4+p
bit = 1<<(b&15)
IF dict(w+2)&bit # 0 START ; !already set
fault(4) IF pending # 0
RETURN
FINISH
dict(w+2) <- dict(w+2)!bit IF pending # 0
set const(n)
op('_', tag(x)_index)
FINISH ELSE START
fault(12)
FINISH
access = 1
END
ROUTINE call
RECORD (tagfm)NAME T
t == tag(x)
op('@', t_index)
access = 0 IF t_flags&closed # 0; !never comes back
bp=bp+1 AND buff(bp)='E' IF t_app = 0; !no parameters
END
ROUTINE pop def
set const(pstack(pending)); pending = pending-1
END
ROUTINE pop lit
IF pending = 0 THEN lit = 0 ELSE START
lit = pstack(pending); pending = pending-1
FINISH
END
IF sstype < 0 START ; !executable statement
IF level = 0 START ; !outermost level
fault(13); !*order
FINISH ELSE START
IF access = 0 START
access = 1; fault(-1); !only a warning
FINISH
FINISH
FINISH
IF diag&2 # 0 START
newline IF sym # nl
printstring("ss =")
write(ss, 1)
newline
count = 5
name = ""
FINISH
next = ss
pending = 0; lmode = 0
link = 0; decs = 0
defs = 0; resln = 0; done = 0
ord = level
ord = 1 IF this >= 0; !recordformat declarations
c(0):
top: IF next # link START
get next; ->c(class)
FINISH
!all done, tidy up declarations and jumps
newline IF diag&2 # 0 AND count # 5
IF lmode&(loop!then!else) # 0 START ; !pending labels and jumps
op('B', label-1) IF lmode&loop # 0; !repeat
def lab(label) IF lmode&then # 0; !entry from then
def lab(label-1) IF lmode&else # 0; !entry from else
FINISH
RETURN IF decs = 0
atom1 = error AND RETURN IF atom1 # 0; !%INTEGERROUTINE
order = ord
decl = decl&(¬15)+decmap(decl&15); !construct declarator flags
atom1 = atoms(decl&15); !generate class
IF otype # 0 START ; !own, const etc.
atom1 = atom1+1 IF atom1 # proc
IF otype = 2 START ; !const
n = decl&15
if n&1 # 0 start
decl = decl!prot
decl = decl!const bit IF decl&b'1111111' = iform
finish
else
decl = decl!own bit
FINISH
FINISH
sstype = 1 IF sstype = 0 AND atom1 = proc
atom1 = atom1+1 IF decl&spec # 0; !onto spec variant
ocount = 0 AND cont = '+' IF atom1 = 5; !own array
IF anyform(decl&15) = 0 START ; !check meaningful
IF decl>>4&7 = record START
this = fdef IF tag(fdef)_flags&spec # 0
atom1 = error+21 IF fdef = this; !*context for format
FINISH
atom1 = error+10 IF fdef = 0; !*size
FINISH
RETURN
atop: access = 0; ->top
! declarators
c(88): !rtype
c(28): decl = x&(¬7); !stype
fdef = x&7; !precision
fdef = reals ln IF x&b'1110001' = real<<4+1; !convert to long
decs = 1; ->top
c(34): !own
c(35): otype = x; ord = 1; ->top; !external
c(152):decl = decl+x<<1; ->top; !xname
c(31): !proc
c(32): spec mode = level+1; !fn/map
decl = decl!prot IF x = 9; !function
c(29): ord = 1; !array
dim = 0
c(30): decl = decl+x; !name
decs = 1
->top
c(27): lit = 0; ! arrayd
IF pending # 0 START
pop lit
UNLESS 0<lit<=dim limit START
atom1 = error + 11; RETURN
FINISH
FINISH
dim = lit
decl = decl + x; decs = 1
-> top
c(37): x = x!subname; !record
c(36): lit = 0; !string
IF pending # 0 START
pop lit
UNLESS 0 < lit <= 255 START ; !max length wrong
atom1 = error+10; RETURN
FINISH
FINISH
fdef = lit; !format or length
c(33): decl = x; !switch
decs = 1
->top
c(39): decl = decl!spec; !spec
ocount = -1; !no initialisation
spec mode = -1
->top
c(38): decl = 64+4; !recordformat (spec)
order = 1
atom1 = x
decl = decl!spec if atom1 = 12; !formatspec
fdef = tmax+1; !format tag
return
c(175):id = id+1; tag(x)_index = id; return ; !FSID
c(41): decs = 1; decl = x!spec!closed; ->top; !label
c(133):recid = 0; rbase = tmin-1; !fname
this = x
fm base = fdef; format list = tmin
def(this); ->top
c(148):fdef = 0 AND ->top IF next = 0; !reclb
get next; !skip name
fdef = x
->top
c(127):bp=bp+1 AND buff(bp)='}'; ->top; !%POUT
c(126):bp=bp+1 AND buff(bp)='{'; ->top; !%PIN
c(174):set bp; !rangerb
c(171): !fmlb
c(172): !fmrb
c(173):bp=bp+1 AND buff(bp)='~'; bp=bp+1 AND buff(bp)=class-171+'A'; ->top; !fmor
c(168):rbase = -rbase; !orrb
sstype = 0; spec mode = 0
c(147):search base = 0; !recrb
tag(this)_app = tmin
tag(this)_format = rbase
->top
c(45):bp=bp+1 and buff(bp)='U' IF x = 36; ->top; !sign
c(46):bp=bp+1; buff(bp)='¬'; ->top; !uop
c(47): !mod
c(48): !dot
c(42): !op1
c(43): !op2
c(44):bp=bp+1; buff(bp)=operator(x); ->top; !op3
!conditions & jumps
ROUTINE push(INTEGER x)
IF cnest(cp)&2 # x START
cnest(cp) = cnest(cp)!1; x = x+4
FINISH
clab = clab+1 IF cnest(cp)&1 # 0
cnest(cp+1) = x; cp = cp+1
END
ROUTINE pop label(INTEGER mode)
lmode = dict(dmin)
IF lmode < 0 OR lmode&1 # mode START
fault(mode+8)
FINISH ELSE START
dmin = dmin+1; label = label-3
FINISH
END
c(56): !and
c(57):push(x); ->top; !or
c(58):cnest(cp) = cnest(cp)!!2; ->top; !not
c(138):x = 128+32+16+4; !csep: treat like %WHILE
c(59): !while
c(60):IF class = 138 THEN op('f', label-1) C
ELSE def lab(label-1); !until
c(166): !runtil
c(62):lmode = (lmode&(else!loop)) !(x>>3); !cword
clab = label; cp = 1; cnest(1) = x&7
->top
c(72):pop label(0); !repeat
def lab(label+1) IF lmode&32 # 0; ->atop
c(69):pop label(1); ->top; !finish
c(163): !xelse
c(70):pop label(1); !finish else ...
fault(7) IF lmode&3 = 3; !dangling else
c(68):lmode = (lmode&else)!3; !...else...
IF access # 0 START
op('F', label-1); lmode = else!3
FINISH
def lab(label)
->top IF next # 0
c(120): !%MSTART
c(67): !start
c(71): !cycle
stcy: def lab(label-1) AND lmode = loop IF lmode = 0;!cycle
dmin = dmin-1; abandon(3) IF dmin <= dmax
dict(dmin) = lmode
label = label+3
RETURN
c(64):fault(13) IF dict(dmin) >= 0 OR inhibit # 0; !on event
inhibit = 1
n = 0
n = x'FFFF' IF pending = 0; !* = all events
WHILE pending > 0 CYCLE
pop lit; fault(10) IF lit&(¬15) # 0;!too big
j = 1<<lit
dubious = 1 IF n&j # 0
n = n!j; !construct bit mask
REPEAT
op('o', n); op(',', label)
lmode = then!1; ->stcy
c(104):op('J', tag(x)_index); !l
inhibit = 1; ->atop
c(149):stats = stats-1; !lab
access = 1; inhibit = 1
op('L', tag(x)_index); ->top
c(63):j = dmin; l = label-3; !exit, continue
CYCLE
fault(7) AND ->top IF dict(j) < 0
EXIT IF dict(j)&1 = 0
j = j+1; l = l-3
REPEAT
l = l+1 IF x = 32; !continue
op('F', l)
dict(j) = dict(j)!x; !show given
->atop
c(50):bp=bp+1 AND buff(bp)='C'; ->cop; !acomp
c(49): bp = bp+1
IF next # 0 START ; !comparator
buff(bp)='"'; push(0); !double sided
FINISH ELSE START
buff(bp)='?'
FINISH
cop: x = x!!1 IF cnest(cp)&2 # 0; !invert the condition
j = cp; l = clab
WHILE cnest(j)&4 = 0 CYCLE
j = j-1; l = l-cnest(j)&1
REPEAT
op(cc(x), l)
def lab(clab+1) IF cnest(cp)&1 # 0
cp = cp-1
clab = clab-cnest(cp)&1
->top
c(78): !fresult
c(79): !mresult
c(80): open = 0; !return, true, false
c(82): access = 0; !stop
c(89): !addop
c(81): bp=bp+1 AND buff(bp)=x; ->top; !monitor
c(65): pop lit; op('e', lit); ->atop; !signal
c(51): bp=bp+1 AND buff(bp)='S'; ->top; !eq
c(53): bp=bp+1 AND buff(bp)='j'; ->top; !jam transfer
c(52): bp=bp+1 AND buff(bp)='Z'; ->top; !eqeq
c(74):IF level = 0 START ; !begin
IF progmode <= 0 THEN progmode = 1 ELSE fault(7)
{Permit BEGIN after external defs}
FINISH
spec mode = level+1
block x = 0
bp=bp+1 AND buff(bp)='H'; RETURN
c(77):perm = 0; lines = 0; stats = 0; !endofperm
close input
select input(source)
list = list-1
tbase = tmax; tstart = tmax
RETURN
c(76):IF include # 0 AND x = 0 START ; !end of ...
lines = include; sstype = 0; !include
close input
list = include list
include level = 0
include = 0; select input(source); RETURN
FINISH
ss = -1; !prog/file
c(75):compile end(x); RETURN ; !%END
c(85):IF x=0 THEN control=lit ELSE START ; !control
diag = lit&x'3FFF' IF lit>>14&3 = 1
FINISH
op('z'-x, lit)
->top
c(83):list = list+x-2; ->top; !%LIST/%ENDOFLIST
c(84):reals ln = x; ->top; !%REALS long/normal
c(86):IF include # 0 START ; !include "file"
fault(7); RETURN
FINISH
get next; !sconst
include file = string(x-x'4000'+stbase)
begin
on 9 start ; Abandon(9); finish
open input(3, include file)
end
include = lines; lines = 0
include list = list; include level = level
select input(3)
->top
c(154):dimension = dimension+1; !dbsep
fault(11) IF dimension = dim limit+1
->top
c(145):set bp; ->top; !crb
c(146):set bp; !rcrb
c(142): !bplrb
dimension = 1 IF dimension = 0
op('d', dimension); op(',', defs)
IF class # 146 START
set subs(defs)
fault(13) IF dict(dmin) >= 0 OR inhibit # 0 OR level=0
FINISH
dimension = 0; defs = 0
->top
c(128):id = dupid; ->top; !EDUP
c(130):block x = x
op('F', 0) IF decl&spec = 0 AND level # 0; !jump round proc
c(125):dupid = id; !%DUP
return if Level < 0 {spec about}
c(90): def(x); ->top; !ident
c(131): !cident
IF tag(x)_flags&(b'1111111'+const bit) = iform+const bit START
tag(x)_format = lit
FINISH ELSE START
set const(lit) IF pending # 0
def(x)
op('A', 1)
FINISH
cident = x
->top
c(124):dubious = 1 IF tag(cident)_flags&prot # 0; !%DUBIOUS
->top
c(97): !f
c(98): !m
c(99): !p
c(96): call; ->top; !r
c(165): !nlab
c(100): !rp
c(101): !fp
c(102): !mp
c(103): !pp
c(91): !v
c(92): !n
c(106): !a
c(107): !an
c(108): !na
c(109): !nan
k = tag(x)_index
IF k < 0 THEN op('n', -k) ELSE op('@', k)
->top
c(121):set const(0); ->top; !special for zero
c(167):bp=bp+1; buff(bp)='G'; ->pstr; !aconst (alias)
c(const): !const
IF x < 0 START ; !constinteger
set const(tag(-x)_format); ->top
FINISH
IF x&x'4000' # 0 START ; !strings
bp=bp+1 AND buff(bp)=''''
pstr: x = x-x'4000'+stbase
k = byteinteger(x)
bp=bp+1 AND buff(bp)=k
k = k+x
CYCLE
->top IF x = k
x = x+1; bp=bp+1 AND buff(bp)=byteinteger(x)
REPEAT
FINISH
IF x&x'2000' # 0 START ; !real
x = x-x'2000'+stbase
k = byteinteger(x)
op('D', k); bp=bp+1 AND buff(bp)=','
k = k+x
CYCLE
->top IF x = k
x = x+1; j = byteinteger(x)
IF j = '@' START
op('@', litpool(byteinteger(x+1))); ->top
FINISH
bp=bp+1 AND buff(bp)=j
REPEAT
FINISH
set const(lit pool(x))
->top
c(137):bp=bp+1 AND buff(bp)='i'; ->top; !asep
c(141):bp=bp+1 AND buff(bp)='a'; ->top; !arb
!own arrays
c(132):ocount = ub-lb+1
def(x); !oident
dimension = 1; set subs(1)
IF next = 0 START ; !no initialisation
op('A', ocount) IF ocount > 0
ocount = -1
FINISH ELSE START ; !initialisation given
get next
FINISH
->top
c(162):lit = ocount; ->ins; !indef
c(143):pop lit; !orb
ins: fault(10) AND lit = 0 IF lit < 0
get next
->inst
c(139): !osep (x=19)
c(153):lit = 1
inst: pop def IF pending # 0; !ownt (x=0)
op('A', lit)
ocount = ocount-lit
IF ocount >= 0 START
->top IF x # 0; !more coming
ocount = -1 AND RETURN IF ocount = 0; !all done
FINISH
fault(11); RETURN
c(swit):op('W', tag(x)_index); inhibit = 1; ->atop
c(134):def(x); !swid
n = ub-lb+1
n = (n+15)>>4; !slots needed (includes zero)
j = dmax; dmax = dmax+n+2
abandon(1) IF dmax >= dmin
tag(x)_format = j
dict(j) = lb; dict(j+1) = ub
CYCLE
n = n-1
->top IF n < 0
j = j+1; dict(j+1) = 0
REPEAT
c(151):stats = stats-1; !slab
fault(7) AND RETURN IF x < tbase
IF pending # 0 START ; !explicit label
def s lab(pstack(1))
FINISH ELSE START
fault(4) AND RETURN IF tag(x)_app # 0
tag(x)_app = 1
n = tag(x)_format
FOR j = dict(n), 1, dict(n+1) CYCLE
def s lab(j)
flush buffer IF bp >= 128
REPEAT
FINISH
inhibit = 1
RETURN
c(140):bp=bp+1 AND buff(bp)='p'; ->top; !psep
c(144):buff(bp+1)='p'; buff(bp+2)='E'; bp=bp+2; ->top; !prb
!constant expressions
c(155): !pconst
IF x < 0 THEN lit = tag(-x)_format c
ELSE lit = lit pool(x)
pending = pending+1; pstack(pending) = lit; ->top
c(156):lit = pstack(pending); lit = -lit IF lit < 0
pstack(pending) = lit; ->top; !cmod
c(157):lit = -pstack(pending); pstack(pending) = lit; ->top; !csign
c(158):lit = ¬pstack(pending); pstack(pending) = lit; ->top; !cuop
c(159): !cop1
c(160): !cop2
c(161):pending = pending-1; !cop3
lit2 = pstack(pending+1); lit = pstack(pending)
->litop(x>>2)
litop(10):lit = lit*lit2; ->setl
litop(12):
litop(3):n = 1; !lit = lit¬¬lit2
fault(10) IF lit2 < 0
WHILE lit2 > 0 CYCLE
lit2 = lit2-1
n = n*lit
REPEAT
lit = n; ->setl
litop(1):lit = lit<<lit2; ->setl
litop(2):lit = lit>>lit2; ->setl
litop(5):lit = lit&lit2; ->setl
litop(11):
litop(4):IF lit2 = 0 THEN fault(10) ELSE lit = lit//lit2
->setl
litop(8):lit = lit+lit2; ->setl
litop(9):lit = lit-lit2; ->setl
litop(6):lit = lit!lit2; ->setl
litop(7):lit = lit!!lit2
setl: pstack(pending) = lit; ->top
c(170):Fault(4) if IMPCOM_Option # ""
IMPCOM_Option = String(x-x'4000'+Stbase); !Option string
->Top
!string resolution
c (135):resln = 2; ->top; !dotl
c(136):resln = resln+1; ->top; !dotr
c(55): op('r', resln); resln = 0; ->top; !resop
c(164):op('r', resln+4); resln = 0; !cresop
c(122):x = 6; ->cop; !%PRED
c(87): set const(pstack(1)); !mass
bp=bp+1 AND buff(bp)='P'; ->top
END
END ; !of compile block
ON 9 START
abandon(5)
FINISH
list = 15 IF Impcom_Flags&x'1000' # 0
selectinput(2); selectoutput(listing)
tag(max tag) = 0; !%BEGIN defn
tag(0) = 0; tag(0)_flags = 7; !%BEGIN tag!
Hash(x) = 0 FOR x = 0, 1, max names
printstring(" Edinburgh IMP77 Compiler - Version ")
printstring(version); newlines(2)
op('l', 0)
compile block(0, 0, max dict, 0, 0)
bp=bp+1 AND buff(bp)=nl {for bouncing off}
flush buffer
Impcom_Statements = stats
Impcom_Statements = -faulty IF faulty # 0
ENDOFPROGRAM