begin
routine spec readsym(integer name i)
routine spec readps
routine spec readline
integer fn spec compare(integer psp)
routine spec ss
routine spec fault(integer a, b, c, d)
routine spec out(integer i)
integer fn spec chnext
integer fn spec newcell
integer fn spec returncell(integer i)
routine spec printname(integer i)
routine spec printlabel(integer i)
routine spec showtags
integer i, j, ap, app, tp, asl, btn, ctn, chp, faults, nl, level, ca, comp, scf, pars
integer array ps(-1000 : -620)
! REDUCED PHRASE STRUCTURE
integer array chl, tagl(0 : 255)
integer array tag, link(1 : 1000)
! TAGS LISTS
integer array a, pn, np(1 : 200)
! ANALYSIS RECORD
integer array t(1 : 300)
! SOURCE TEXT
integer array bat, cot(0 : 1023)
! BRANCH, CONST TABLES
integer array ch(1 : 512)
! NAME CHAR TABLE
integer array jump, star, brt, name, rtp, br, start, rad(0 : 15)
!LEVEL INFO
integer array true, false(1 : 6)
! CONDITIONAL BRANCH INSTR
integer array prec, ucn(1 : 12)
! OPERATOR PRECS, TYPES
integer array opr(0 : 12)
! MACHINE OPERATIONS
integer array pt, pi(1 : 15)
! FOR RT SPECS, HEADINGS
!****
!%EXTERNALROUTINESPEC DEFINE(%STRING(63) S)
! DEFINE('STREAM01,SKIMPPS+SKIMPI')
open input(1, "skimpps+skimpi"); select input(1)
! SELECT INPUT(1)
! DEFINE('STREAM02,SKIMPO')
open output(2, "skimpo"); select output(2)
! SELECT OUTPUT(2)
!****
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine readsym(integer name i)
readsymbol(i)
printsymbol(i)
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine readps
! READ IN AND REDUCE PHRASE STRUCTURE
integer pnp, alt, p, i, j, k
integer array pn, psp(256 : 300)
! PHRASE NAME CHARS & POINTERS
routine spec insertlit
integer fn spec getpn
pnp = 256
! PN POINTER
p = -1000
! PS POINTER
L1:
readsym(i)
if i = 'B' then start
! BUILT-IN PHRASE
L2:
readsym(i)
! SKIP TO <
if i ¬= '<' then -> L2
j = getpn
! READ PHRASE NAME ETC
L3:
readsym(i)
! SKIP TO =
if i ¬= '=' then -> L3
read(k)
! READ PHRASE NUMBER
write(k, 1)
newline
psp(j) = k
! FILL IN PHRASE NUMBER
-> L1
finish
! GO DEAL WITH NEXT PHRASE
if i = 'P' then start
! PHRASE
L4:
readsym(i)
! SKIP TO <
if i ¬= '<' then -> L4
j = getpn
! READ PHRASE NAME
ps(p) = pn(j)
! STORE NAME
psp(j) = p
! FILL IN POSITION
p = p + 1
L7:
alt = p
! REMEMBER START POSITION
L6:
p = p + 1
! NEXT PS POSITION
L5:
readsym(i)
! START OF NEXT ITEM
if i = '''' then start
! LITERAL TEXT
insertlit
! READ LITERAL & INSERT
-> L5
finish
! GO FOR NEXT ITEM
if i = '<' then start
! ITEM IS A PHRASE NAME
ps(p) = getpn
! READ PHRASE NAME & FILL IN
-> L6
finish
! GO FOR NEXT ITEM
if i = ',' then start
! END OF THIS ALTERNATIVE
ps(alt) = p
! FILL IN POINTER TO END
-> L7
finish
! GO FOR START OF NEXT ALT
if i = ';' then start
! END OF PHRASE DEFINITION
ps(alt) = p
! FILL IN POINTER TO END
ps(p) = 0
! FILL IN END MARKER
p = p + 1
! NEXT PS POSITION
-> L1
finish
! GO FOR NEXT PHRASE
-> L5
finish
! SKIP
if i = 'E' then start
! END OF PHRASE STRUCTURE
printsymbol(10); ! Newpage
! REPLACE ALL POINTERS TO PS
i = -1000
! & PRINT OUT REDUCED FORM
j = 0
L8:
if j = 0 then start
! 8 PER LINE
newline
write(i, 4)
! INDEX TO PS
spaces(3)
finish
k = ps(i)
if k >= 256 and k <= 300 then ps(i) = psp(k)
! PHRASES
if ps(i) <= 256 then write(ps(i), 7) else start
spaces(4)
out(k)
finish
i = i + 1
j = (j + 1) & 7
if i ¬= p then -> L8
printsymbol(10); ! Newpage
return
finish
-> L1
! SKIP
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
routine insertlit
! INSERT LITERAL TEXT INTO 'PS'
integer sh, i
sh = 0
! % SHIFT VALUE TO 0
L1:
readsym(i)
if i = '''' then start
if nextsymbol ¬= '''' then return
! END OF LITERAL
readsym(i)
! QUOTE INSIDE LITERAL - IGNORE
finish
if i = '%' then sh = 128 else start
! SHIFT VALUE TO 128 FOR %
if i < 'A' or i > 'Z' then sh = 0
! END OF KEYWORD - SHIFT VAL
ps(p) = i + sh
! STORE SHIFTED (POSSIBLY) CHAR
p = p + 1
! MOVE TO NEXT POSITION IN PS
finish
-> L1
end
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
integer fn getpn
! READ IN PHRASE NAME AND GET INDEX IN 'PSP'
integer np, i
np = M' '
! TO ACCUMULATE PHRASE NAME CHARS
L1:
readsym(i)
if i ¬= '>' then start
! NOT END OF NAME YET
np = np << 8 ! i
! PACK NEXT CHAR OF PHRASE NAME
-> L1
finish
if pnp ¬= 256 then start
! NOT FIRST PHRASE NAME
i = 256
! SCAN NAMES TO FIND IF ALREADY IN
L2:
if np = pn(i) then result = i
i = i + 1
if i ¬= pnp then -> L2
finish
pn(pnp) = np
! INSERT NEW NAME IN DICTIONARY
psp(pnp) = M'????'
! UNDEFINED PHRASE MARKER
pnp = pnp + 1
! MOVE TO NEXT DICTIONARY POSITION
result = pnp - 1
end
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine readline
! LEXICAL PHASE - READ & CLEAN UP NEXT LINE OF TEXT
routine spec store(integer i)
integer sh, i
newlines(2)
sh = 0
! % & LITERAL SHIFT VALUE TO 0
tp = 1
! POINTER TO TEXT ARRAY T
L1:
readsym(i)
if i = '''' then start
sh = 0
! SHIFT VALUE FOR LITERAL
L2:
store(i)
! STORE CHAR IN TEXT A
readsym(i)
if i ¬= '''' then -> L2
! NOT END OF LITERAL YET
readsym(i)
if i = '''' then -> L2
! QUOTE IN LITERAL, IGNORE ONE
store('''' + 128)
! STORE SHIFTED VAL
finish
if i = '%' then start
! SHIFT VALUE TO 128 FOR KEYWD
sh = 128
-> L1
finish
if i < 'A' or i > 'Z' then sh = 0
! SHIFT VALUE TO 0 FOR END
if i = ' ' then -> L1
! IGNORE SPACES
store(i)
if i ¬= nl then -> L1
! NEWLINE CHAR
if tp > 2 then start
! IGNORE BLANK LINES
if t(tp - 2) = 'C' + 128 then tp = tp - 2 else return
!MOVEPOINTERBACKIFC
finish else tp = 1
-> L1
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
routine store(integer i)
! STORE (POSSIBLY) SHIFTED CHAR IN TEXT ARRAY & CHECK LINE NOT TOO LONG
if tp > 300 then start
fault(M'STAT', M'MNT ', M'TOO ', M'LONG')
tp = 1
finish
t(tp) = i + sh
! STORE CHAR IN TEXT ARRAY
tp = tp + 1
! MOVE TO NEXT POSITION
end
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer fn compare(integer psp)
! ANALYSE PHRASE
integer fn spec name
! BUILT-IN PHRASE <NAME>
integer fn spec cnst
! BUILT-IN PHRASE <CNST>
integer app, tpp, ae, n
tpp = tp
! PRESERVE INITIAL TEXT POINTER
app = ap
! PRESERVE INITIAL ANAL REC PTR
a(ap) = 1
! ALTERNATIVEE 1 FIRST
pn(ap) = ps(psp)
psp = psp + 1
L11:
ae = ps(psp)
! POINTER TO END OF ALTERNATIVE
psp = psp + 1
! FIRST ITEM OF ALTERNATIVE DEF
L12:
if psp = ae then start
! END OF ALT REACHED - SUCCESS
np(app) = ap + 1
! POINTER TO NEXT PHRASE
result = 1
finish
n = ps(psp)
! NEXT ITEM OF ALT DEFN
psp = psp + 1
! FOR FOLLOWING ITEM
if n < 0 then start
! SUB-PHRASEE
ap = ap + 1
! NEXT ANALYSIS RECORD POSITION
if ap > 200 then start
fault(M'ANAL', M' REC', M' FUL', M'L ')
stop
finish
if compare(n) = 1 then -> L12
! SUCCESSFUL COMPARISON
-> L13
finish
! UNSUCCESSFUL - GO FOR NEXT ALT
if n = 1 then start
! BUILT-IN PHRASE <NAME>
if name = 1 then -> L12
! SUCCESS
-> L13
finish
! FAILURE
if n = 2 then start
! BUILT-IN PHRASE CNST
if cnst = 1 then -> L12
! SUCCESS
-> L13
finish
! FAILURE
if n = t(tp) then start
! LITERAL - MATCHES SOURCE CHAR
tp = tp + 1
! MOVE TO NEXT SOURCE CHAR
-> L12
finish
! GO FOR NEXT ITEM
L13:
if ps(ae) = 0 then result = 0
! END OF PHRASE
psp = ae
! START OF DEFN OF NEXT ALT
tp = tpp
! BACKTRACK SOURCE TEXT
ap = app
! AND ANALYSIS RECORD POINTER
a(ap) = a(ap) + 1
! COUNT ALTERNATIVE NUMBER ON
-> L11
! GO TO ANALYSE NEW ALTERNATIVE
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
integer fn name
! RECOGNISE AND INSERT NAME IN HASHING AREA OF TAG/LINK ARRAYS
integer i, j, k, l, m, n
i = t(tp)
! FIRST SOURCE CHAR
if i < 'A' or i > 'Z' or (i = 'M' and t(tp + 1) = '''') then result = 0
!FAILURE-NOTACONSTANT
j = chp
! NEXT POSITION IN CHAR ARRAY
k = i << 16
! LEAVE HOLE FOR LENGTH & PACK
l = 1
! NO OF CHARS
m = 8
! NEXT SHIFT VALUE FOR PACKING
n = i
! SUM VALUE OF CHARS FOR HASHING
L1:
tp = tp + 1
i = t(tp)
! NEXT CHAR FROM TEXT ARRAY
if ('0' <= i and i <= '9') or ('A' <= i and i <= 'Z') then start
!ADIGITORALETTER
k = k ! i << m
! PACK NEXT LETTER
l = l + 1
! CHARACTER COUNT
m = m - 8
! NEXT SHIFT
n = n + i
! SUM OF LETTERS
if m < 0 then start
! PACKED WORD OF CHARS FULL
ch(chnext) = k
! STORE WORD IN CHAR ARRAY
k = 0
! PACKING WORD TO ZERO
m = 24
! NEW SHIFT VALUE
finish
-> L1
finish
! GO FOR NEXT CHAR
if k ¬= 0 then ch(chnext) = k
! STORE ANY REMAINING CHARS
ch(j) = ch(j) ! l << 24
! FILL IN LENGTH IN HOLE LEFT
i = (n << 4 !! n >> 4) & 255
! HASH VALUE
k = i
! SCAN DICTIONARY FOR NAME
L2:
if chl(k) ¬= 0 then start
! A NAME IN THIS POSITION
l = chl(k)
! CHAR ARRAY POSITION
m = j
! CHAR ARRAY POSITION OF NEW NAME
L4:
if ch(l) = ch(m) then start
! PACKED WORDS MATCH
m = m + 1
! NEXT WORD OF NEW NAME
if m = chp then start
! NAMES MATCH
chp = j
! MOVE CHP BACK SINCE NAME IN
-> L3
finish
l = l + 1
! NEXT WORD OF OLD NAME
-> L4
finish
! GO FOR NEXT WORD
k = (k + 1) & 255
! NO MATCH SO TRY NEXT POSITION
if k = i then start
! STARTING POSITION REACHED AGAIN
fault(M'DICT', M'IONA', M'RY F', M'ULL ')
stop
finish
-> L2
finish
chl(k) = j
! STORE CHAR ARRAY POSITION
L3:
ap = ap + 1
! NEXT ANALYSIS RECORD POSITION
if ap > 200 then start
fault(M'ANAL', M' REC', M' FUL', M'L ')
stop
finish
a(ap) = k
! STORE IDENTIFICATION NO OF NAME
pn(ap) = M'NAME'
! PHRASE <NAME> MATCHED
np(ap) = ap + 1
! NEXT PHRASE
result = 1
! SUCCESS
end
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
integer fn cnst
! RECOGNISE INTEGER AND LITERAL TEXT CONSTANTS
integer i, j, k
i = t(tp)
! FIRST CHAR
if i = 'M' and t(tp + 1) = '''' then start
! M-TYPE CONSTANT
tp = tp + 1
! IGNORE THE M
i = ''''
finish
if i = '''' then start
! START OF A LITERAL
j = 0
! TO ACCUMULATE LITERAL VALUE
k = 0
! CHARACTER COUNT
L1:
tp = tp + 1
i = t(tp)
! NEXT CHAR
if i ¬= '''' + 128 then start
! NOT END OF LITERAL
j = j << 8 ! i
! PACK CHAR
k = k + 1
! COUNT CHAR
-> L1
finish
tp = tp + 1
! POINTER AFTER QUOTE
if k > 4 then fault(M'STRI', M'NG T', M'OO L', M'ONG ')
-> L2
finish
if i < '0' or i > '9' then result = 0
! NOT A CONSTANT
j = 0
k = 0
L3:
if j < 214748364 or (j = 214748364 and i <= '7') then j = 10 * j + i - '0' else k = 1
! CHECK AND ACCUMULATE VALUE
tp = tp + 1
i = t(tp)
! NEXT CHAR
if '0' <= i and i <= '9' then -> L3
! A DIGIT - PART OF CONSTANT
if k ¬= 0 then fault(M'CONS', M'T TO', M'O BI', M'G ')
L2:
ap = ap + 1
! NEXT ANALYSIS REC POSITION
if ap > 200 then start
fault(M'ANAL', M' REC', M' FUL', M'L ')
stop
finish
a(ap) = j
! FILL IN VALUE OF CONSTANT
pn(ap) = M'CNST'
! PHRASE <CNST> MATCHED
np(ap) = ap + 1
! NEXT PHRASE
result = 1
! SUCCESS
end
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine ss
! COMPILE SOURCE STATEMENT
routine spec ui
routine spec sccond(integer name label)
routine spec sexpr
integer fn spec findlabel
routine spec check
routine spec unset
routine spec pushstart(integer flag, label)
integer fn spec btnext
integer fn spec ctnext
integer fn spec wsnext
routine spec storetag(integer nam, form, type, dim, lev, ad)
routine spec dump(integer op, reg, base, disp)
routine spec rt
routine spec arrad
routine spec enter(integer type, alloc)
routine spec return
integer i, j, k, l, m, n, p, q, r, ws, label
i = a(ap)
! ANALYSIS RECORD ENTRY
ap = ap + 1
! FOR FOLLOWING ENTRY
ws = 2
! SET WORKSPACE POINTER
if i = 1 then -> L10
! UNCONDITIONAL INSTRUCTION
if i = 2 then -> L20
! CONDITIONAL STATEMENT
if i = 3 then -> L30
! LABEL
if i = 4 then -> L40
! %FINISH
if i = 5 then -> L50
! DECLARATIONS
if i = 6 then -> L60
! ROUTINE/FN SPEC
if i = 7 then -> L70
! %END
if i = 8 then -> L80
! %BEGIN
if i = 9 then -> L90
! %ENDOFPROGRAM
return
! <SEP>
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
L10:
ui
! COMPILE UNCONDITIONAL INSTR
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %IF - - - %THEN - - - %ELSE
L20:
sccond(i)
! COMPILE CONDITION
if a(ap) = 2 then start
! AP ON <UI> - JUMP INSTR
ap = ap + 2
! AP ON <ELSE>
j = -1
! MARKER FOR 'JUMP'
finish else start
! NOT A JUMP
if a(ap) = 3 then start
! %START
if a(ap + 1) = 1 then fault(M'%STA', M'RT %', M'ELSE', M' ')
pushstart(0, i)
return
finish
ui
! COMPILE REMAINING UI
j = 0
! 'NOT JUMP' MARKER
finish
if a(ap) = 1 then start
! <ELSE>-CLAUSE PRESENT
if j = 0 then start
! <UI> WAS NOT A JUMP
j = btnext
! JUMP ROUND <ELSE>-CLAUSE
dump('B', 0, M'BT', j)
finish
if i >= 0 then bat(i) = ca
! FILL IN LAB ON <ELSE>-CLAUSE
ap = ap + 1
! AP ON <UI>
if a(ap) = 3 then start
! %START
pushstart(1, j)
return
finish
ui
! COMPILE REMAINING <UI>S
i = j
! JUMP AROUND LABEL
finish
if i >= 0 then bat(i) = ca
! TO BRANCH ROUND THE UI
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! CONST: - - -
L30:
i = findlabel
! LOCATE/INSERT LABEL IN JUMP
if i >= 0 then start
! VALID LABEL
if bat(i) >= 0 then start
write(label, 1)
spaces(2)
fault(M'LABE', M'L SE', M'T TW', M'ICE ')
finish
bat(i) = ca
! FILL IN LABEL ADDRESS
finish
ss
! COMPILE STATEMENT AFTER LAB
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %FINISH - - -
L40:
i = start(level)
! LINK TO FIRST CELL
if i = 0 then start
! NO CELLS IN LIST
fault(M'SPUR', M'IOUS', M' %FI', M'NISH')
return
finish
j = tag(i) & 65535
! JUMP AROUND LABEL
k = tag(i) >> 16
! BEFORE/AFTER %ELSE MARK
start(level) = returncell(i)
! POP UP CELL
if a(ap) = 1 then start
! %ELSE PRESENT
if k = 1 then fault(M'TWO ', M'%ELS', M'ES !', 0)
k = btnext
! JUMP AROUND <UI>
dump('B', 0, M'BT', k)
if j ¬= 65535 then bat(j) = ca
! FILL IN LABEL ON <UI>
ap = ap + 1
! AP ON <UI>
if a(ap) = 3 then start
! %START
pushstart(1, k)
return
finish
ui
! COMPILE REMAINING <UI>S
j = k
! JUMP AROUND LABEL
finish
if j ¬= 65535 then bat(j) = ca
! FILL IN JUMP AROUND LAB
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! DECLARATIONS
L50:
if a(ap) = 1 then start
! <ARR> = %ARRAY
app = ap
! SAVE AP
ap = np(ap + 2)
! AP ON <+-¬>
sexpr
! COMPILE EXPR
dump(M'STR', M'ACC', br(level), wsnext)
! STORE VALUE IN WRK
sexpr
! COMPILE EXPR
dump(M'LDA', M'ACC', M'ACC', 1)
! INCREMENT VALUE
dump(M'STR', M'ACC', br(level), wsnext)
ws = ws - 2
! RESTORE WORKSPACE
i = 1
! NO OF DIMS
j = 2
! TAG FOR 'ARRAY'
ap = app
! RESTORE AP
finish else start
! SCALAR DECLARATIIONS
i = 0
! DIMS=0 FOR SCALARS
j = 0
! TAG FOR SCALAR
finish
L52:
storetag(a(ap + 1), j, 1, 0, level, rad(level))
! PUSHDOWN TAG
if i = 1 then start
! 1-DIM ARRAYS
dump(M'SUB', M'STP', br(level), ws)
dump(M'STR', M'STP', br(level), rad(level))
dump(M'ADD', M'STP', br(level), ws + 1)
finish
rad(level) = rad(level) + 1
ap = ap + 2
! AP ON <NAMS>
if a(ap) = 1 then -> L52
! MORE NAMES
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! RT SPEC - - -
L60:
i = a(ap) - 1
! ROUTINE/FN
j = a(ap + 1)
! SPEC
k = a(ap + 2)
! NAME OF ROUTINE
ap = ap + 3
! AP ON <FPP>
l = 0
! PARAMETER COUNT
m = 10
! FIRST REL ADDR
L63:
if a(ap) = 1 then start
! PARAMETERS
ap = ap + 1
! AP ON <ARRN>
if a(ap) = 1 then n = 3 else n = 3 - a(ap)
! SET TAG FOR PARAM
p = n << 28 ! 1 << 24 ! (level + 1) << 16
! SET UP PATTERN
L62:
l = l + 1
! PARAMETER COUNT
if l > 15 then start
fault(M'TOO ', M'MANY', M' PAR', M'AMS ')
-> L61
finish
! IGNORE PARAMS
pt(l) = p ! m
! STORE TAG
pi(l) = a(ap + 1)
! STORE IDENT
m = m + 1
! NEXT REL ADDR
ap = ap + 2
! AP ON <NAMS>
if a(ap) = 1 then -> L62
! MORE NAMES
ap = ap + 1
! AP ON <FPS>
-> L63
finish
L61:
n = tagl(k)
! LINK TO TAG
if n = 0 or tag(n) >> 16 & 15 < level then start
! NAME NOT SET
storetag(k, 4, i, l, level, btnext)
! PUSHDOWN TAG
if l > 0 then start
! PARAMETERS
p = 1
! PARAMETER COUNT
q = tagl(k)
! 'INSERT AFTER' PTR
L64:
r = newcell
! PUSHDOWN TAG
tag(r) = pt(p)
link(r) = link(q)
link(q) = r
q = r
! NEW VALUE FOR PTR
p = p + 1
! PARAMETER COUNT
if p <= l then -> L64
! MORE PARAMETERS
finish
if level = 0 then bat(btn - 1) = k + 65536
! FLAG FOR EXT RT
finish else start
! NAME ALREADY SET
if j = 2 and tag(n) >> 28 = 4 then start
! STATEMENT NOT SPEC
if tag(n) >> 24 & 15 ¬= i then start
printname(k)
fault(M'RT N', M'OT A', M'S SP', M'EC ')
finish
if bat(tag(n) & 65535) >= 0 then start
printname(k)
fault(M'RT A', M'PPEA', M'RS T', M'WICE')
finish
p = tag(n) >> 20 & 15
! NO OF PARAMS
if l ¬= p then start
fault(M'PARS', M' NOT', M' AS ', M'SPEC')
if l > p then l = p
! IGNORE PARAMS
finish
if l > 0 then start
! PARAMS PRESENT
p = 1
! PARAM COUNT
q = link(n)
! LINK TO TAG
L67:
if pt(p) ¬= tag(q) then start
printname(pi(p))
fault(M'PAR ', M'NOT ', M'AS S', M'PEC ')
finish
p = p + 1
! PARAM COUNT
q = link(q)
! NEXT TAG CELL
if p <= l then -> L67
! MORE PARAMS
finish
finish else start
printname(k)
fault(M'NAME', M' SET', M' TWI', M'CE ')
finish
finish
if j = 2 then start
! STATEMENT NOT SPEC
brt(level) = btnext
! BRANCH ROUND RT
dump('B', 0, M'BT', brt(level))
bat(tag(tagl(k)) & 65535) = ca
! FILL IN ADDR
if level = 15 then fault(M'TOO ', M'MANY', M' LEV', M'ELS ') else level = level + 1
enter(i, m)
if l > 0 then start
! PARAMS PRESENT
p = 1
! PARAM COUNT
L69:
i = pt(p)
! PUSHDOWN TAGS
storetag(pi(p), i >> 28, 1, 0, level, i & 65535)
p = p + 1
if p <= l then -> L69
! MORE PARAMS
finish
finish else start
! STATEMENT A SPEC
if l > 0 then start
! PARAMS PRESENT
p = 1
L68:
i = pi(p)
! PARAM IDENT
if tagl(i) = 0 then start
! NO TAG SET UP
if chp > chl(i) then chp = chl(i)
! MOVE CHP BACK
chl(i) = 0
! CLEAR NAME LINK
finish
p = p + 1
if p <= l then -> L68
! MORE PARAMS
finish
finish
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %END
L70:
showtags
! PRINT OUT TAGS
check
! CHECK LABS & STARTS
cot(star(level)) = rad(level)
! STORE STATIC ALLOC
unset
! UNSET NAMES DECLARED
if rtp(level) ¬= 0 then dump(M'STOP', 0, 0, 0)
! %STOP FOR FNS
return
! DUMP %RETURN CODE
level = level - 1
! DECREMENT TEXT LEV
if level < 1 then start
! NOT OUTER LEV
fault(M'EXCE', M'SS %', M'END ', 0)
-> L71
finish
! TREAT AS %ENDOFPROG
bat(brt(level)) = ca
! FILL ADDR FOR BRANCH
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %BEGIN
L80:
if level ¬= 0 then start
fault(M'%BEG', M'IN E', M'XTRA', 0)
! NO INTERNAL BLOCKS
return
finish
if ca ¬= 0 or rad(0) ¬= 10 then start
fault(M'%BEG', M'IN N', M'OT F', M'IRST')
return
finish
level = 1
! TEXTUAL LEVEL COUNT TO 1
enter(-1, 10)
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %ENDOFPROGRAM
L90:
showtags
! PRINT OUT NAME TAGS
check
! CHECK LABELS & START
cot(star(level)) = rad(level)
! FILL IN STATIC ALLOCATION
unset
! UNSET NAMES DECLARED
if level ¬= 1 then fault(M'TOO ', M'FEW ', M'%END', M'S ')
L71:
dump(M'STOP', 0, 0, 0)
! %STOP
printlabel(M'BT')
ca = 0
L93:
if ca ¬= btn then start
dump('B', 0, M'PR', bat(ca))
! BRANCH RELATIVE TO START
-> L93
finish
printlabel(M'CT')
ca = 0
L91:
if ca ¬= ctn then start
dump(0, 0, 0, cot(ca))
-> L91
finish
printlabel(M'ST')
write(faults, 1)
! NUMBER OF PROGRAM FAULTS
fault(M' FAU', M'LTS ', M'IN P', M'ROG.')
stop
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine ui
! COMPILE UNCONDITIONAL INSTRUCTION
integer i, j, k, l
i = a(ap)
! NEXT ANALYSIS RECORD ENTRY
ap = ap + 1
if i = 1 then -> L10
! ROUTINE CALL OR ASSIGNMENT
if i = 2 then -> L20
! JUMP INSTRUCTION
if i = 3 then -> L30
! %START
if i = 4 then -> L40
! %RETURN
if i = 5 then -> L50
! %RESULT=
dump(M'STOP', 0, 0, 0)
! %STOP
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! NAME APP ASS
L10:
i = tagl(a(ap))
! POINTER TO NAME TAGS
if i = 0 then start
printname(a(ap))
fault(M'NAME', M' NOT', M' SET', 0)
finish else i = tag(i)
! NAME TAGS OR ZERO
j = ap
! PRESERVE ANAL REC PTR
ap = np(ap + 1)
! AP ON <ASS>
if a(ap) = 2 then start
! ROUTINE CALL
if i >> 24 = 64 then start
! 'FORM/TYPE' IS ROUTINE
ap = j
! RESTORE AP TO <NAME>
rt
! CALL ROUTINE
finish else start
if i ¬= 0 then start
printname(a(j))
fault(M'NOT ', M'ROUT', M'INE ', M'NAME')
finish
finish
ap = ap + 1
! AP AFTER <UI>
return
finish
k = i >> 28
! 'FORM' OF NAME
if k = 4 then start
printname(a(j))
fault(M'NAME', M' NOT', M' A D', M'ESTN')
! ROUTINE/FN FORM
i = 0
! CLEAR TAGS TO AVOID
finish
ap = ap + 1
! AP ON <+-¬>
sexpr
if i = 0 then return
! LHS NAME NOT SET
if k >= 2 then start
! LHS AN ARRAY TYPE
dump(M'STR', M'ACC', br(level), wsnext)
! PRESERVE ACCUMMULATOR
k = ap
! PRESERVE AP
ap = j
! RESTORE ANAL REC PTR
arrad
! CALCULATE ARRAY ADDR
ws = ws - 1
! RESTORE WORKSPACE PTR
dump(M'LOAD', M'WK', br(level), ws)
! RESTORE ACCUMMULATOR
dump(M'STR', M'WK', M'ACC', 0)
! DUMP ASSIGNMENT
ap = k
! RESTORE AP TO <UI>+1
return
finish
if k = 1 then start
dump(M'LOAD', M'WK', br(i >> 16 & 15), i & 65535)
! INDIRECT ASSIGMENT
dump(M'STR', M'ACC', M'WK', 0)
finish else dump(M'STR', M'ACC', br(i >> 16 & 15), i & 65535)
if a(j + 1) = 1 then start
printname(a(j))
fault(M'SCAL', M'AR H', M'AS P', M'ARAM')
finish
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! -> CONST
L20:
dump('B', 0, M'BT', findlabel)
! SCAN/INSERT JUMP LIST
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %START
L30:
fault(M'%STA', M'RT ', 0, 0)
! %START ALONE ILLEGAL
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %RETURN
L40:
if rtp(level) ¬= 0 then fault(M'%RET', M'URN ', M'CONT', M'EXT ')
return
! DUMP %RETURN CODE
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %RESULT=
L50:
i = rtp(level)
! ROUTINE/FN TYPE
if i <= 0 then fault(M'%RES', M'ULT ', M'CONT', M'EXT ')
! %BEGIN/%RT
sexpr
! COMPILE RESULT EXPR
return
! LEAVE RESULT IN ACC
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine sexpr
! COMPILE ARITHMETIC EXPRESSION
routine spec torp
routine spec store(integer i, j)
routine spec eval(integer p)
integer rpp, app, pstp
integer array rp, pt, pst(1 : 32)
! REV POL, TYPES, PS-EVAL
rpp = 1
! RP POINTER
pstp = 0
! PSEUDO-EVAL STACK PTR
torp
! EXPR TO REV POLISH
if scf = 1 then start
! PART OF A SIMPLE COND
scf = 0
! RESET FLAG
comp = a(ap)
! COMPARATOR NUMBER
if a(ap + 3) = 0 and a(ap + 4) = 2 then ap = ap + 5 else start
ap = ap + 1
! 2ND EXPR NON-ZERO
torp
! 2ND EXPRESSION TO REV POL
store(10, 1)
! STORE 1ST-2ND
finish
finish
app = ap
! SAVE FINAL ANAL REC PTR
eval(rpp - 1)
! DUMP CODE FOR EXPR EVAL
ap = app
! RESTORE ANAL REC PTR
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
routine torp
! TRANSFORM EXPRESSION TO REVERSE POLISH
integer array op(1 : 4)
integer opp, i, j, k
if a(ap) = 2 or a(ap) = 3 then start
! UNARY - OR ¬
op(1) = a(ap) + 9
! STACK UNARY OPERATOR
opp = 1
finish else opp = 0
ap = ap + 1
! AP ON <OPD>
L3:
if a(ap) = 3 then start
! SUB-EXPRESSION
ap = ap + 1
! AP ON <+-¬>
torp
! CONVERT SUB-EXPR TO RP
-> L1
finish
if a(ap) = 2 then start
! CONSTANT
store(a(ap + 1), -4)
! STORE VALUE OF CONST
ap = ap + 2
! AP ON <EXPR>
-> L1
finish
i = a(ap + 1)
! NAME IDENT NUMBER
j = tagl(i)
! LINK TO TAG OF NAME
if j = 0 then start
! NAME NOT SET
printname(i)
fault(M'NAME', M' NOT', M' SET', 0)
store(0, -3)
! STORE DUMMY TAG
-> L2
finish
k = tag(j)
! TAG OF NAME
if k >> 28 <= 1 then start
! SCALAR VARIABLE
if a(ap + 2) = 1 then start
! PARAMETERS PRESENT
printname(i)
fault(M'SCAL', M'AR H', M'AS P', M'ARAM')
finish
store(k, -3)
! STORE TAG & TYPE -3
-> L2
finish
if k >> 28 <= 3 then start
! ARRAY VARIABLE
store(ap + 1, -2)
! STORE ANAL REC POSITION
-> L2
finish
if k >> 24 & 15 = 0 then start
! %ROUTINE TYPE
printname(i)
fault(M'ROUT', M'INE ', M'IN E', M'XPR ')
store(0, -3)
! STORE DUMMY TAG
-> L2
finish
store(ap + 1, -1)
! STORE ANAL REC POSITION
L2:
ap = np(ap + 2)
! AP TO AFTER <APP>
L1:
if a(ap) = 1 then start
! ANOTHER OPERAND YET
i = a(ap + 1)
! NEXT OPERATOR
ap = ap + 2
! AP TO <OPD>
L4:
if opp = 0 or prec(i) > prec(op(opp)) then start
! HIGHER PREC
opp = opp + 1
! SO STACK NEW OPERATOR
op(opp) = i
-> L3
finish
! GO FOR NEXT OPERAND
store(op(opp), 1)
! UNSTACK TOP OPERATOR
opp = opp - 1
-> L4
finish
! COMPARE WITH PREVIOUS OP
L5:
if opp > 0 then start
! OPERATORS LEFT IN STACK
store(op(opp), 1)
! SO UNSTACK THEM
opp = opp - 1
-> L5
finish
! ANY MORE OPERATORS LEFT ?
ap = ap + 1
! AP AFTER <EXPR>
end
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
routine store(integer i, j)
! STORE IN RP & PT ARRAYS & PSEUDO-EVALUATE
if rpp > 32 then start
! REV POL ARRAY FULL
fault(M'EXPR', M' TOO', M' LON', M'G ')
rpp = 1
! IN ORDER TO CONTINUE
finish
if j > 0 then start
! OPERATOR
if i <= 10 then start
! BINARY OP
pstp = pstp - 1
! UNSTACK TOP ITEM
j = pst(pstp)
! POINTER TO 1ST OPERAND
finish
finish else pstp = pstp + 1
! OPERAND
rp(rpp) = i
! STORE OP/OPD
pt(rpp) = j
! STORE POINTER OR TYPE
pst(pstp) = rpp
! STACK NEXT POINTER
rpp = rpp + 1
! NEXT POSITION
end
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
routine eval(integer p)
! DUMP CODE FOR EVALUATION OF EXPRESSION
routine spec opn(integer op, l)
integer i, j, k
i = pt(p)
! PTR/TYPE OF LAST
if i < 0 then start
! OPERAND
opn(0, p)
! LOAD OPERAND
return
finish
j = rp(p)
! OPERATOR
k = p - 1
! START OF 2ND OPD
if ucn(j) = 1 then start
! UNARY OPERATOR
if pt(k) >= -2 then eval(k) else opn(0, k)
! EVAL IF NODE
dump(opr(j), M'ACC', 0, 0)
! DUMP UNARY OPN
return
finish
if pt(i) >= -2 then start
! FIRST OPD A NODE
if pt(k) >= -2 then start
! SECOND OPD A NODE
eval(k)
! EVALUATE 2ND OPD
dump(M'STR', M'ACC', br(level), wsnext)
! & STORE IT
eval(i)
! EVALUATE 1ST OPD
ws = ws - 1
! RESTORE WORKSPACE
dump(opr(j), M'ACC', br(level), ws)
! DUMP OPERATION
finish else start
! 2ND OPD NOT NODE
eval(i)
! EVALUATE 1ST OPD
opn(j, k)
! OPERATION WITH 2ND
finish
finish else start
! 1ST OPD NOT NODE
if pt(k) >= -2 then start
! 2ND OPERAND A NODE
eval(k)
! EVALUATE 2ND OPD
if ucn(j) = 2 then start
! OPERATOR IS COMM
opn(j, i)
! OPERATION WITH 1ST
return
finish
dump(M'STR', M'ACC', br(level), wsnext)
! STORE VALUE OF 2ND
opn(0, i)
! LOAD 1ST OPERAND
ws = ws - 1
! RESTORE WORKSPACE
dump(opr(j), M'ACC', br(level), ws)
! DUMP OPN WITH 2ND
finish else start
! 2ND OPD NOT NODE
opn(0, i)
! LOAD 1ST OPERAND
opn(j, k)
! OPERATION WITH 2ND
finish
finish
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
routine opn(integer op, l)
! DUMP SIMPLE OPERATION, OP=OPERATOR, L=RP POSITION OF OPERAND
integer i, j
i = pt(l)
! KIND OF OPERAND
ap = rp(l)
! ANAL REC POINTER
if i = -1 then start
! ROUTINE/FN TYPE
rt
! DUMP CALL ON FN
return
finish
if i = -2 then start
! ARRAY ACCESS
arrad
! CALC ARRAY ADDR
dump(M'LOAD', M'ACC', M'ACC', 0)
! LOAD VALUE
return
finish
if i = -3 then start
! SCALAR TYPE
if ap >> 28 = 1 then start
! %NAME TYPE
dump(M'LOAD', M'WK', br(ap >> 16 & 15), ap & 65535)
! LOAD INDIRECT
dump(opr(op), M'ACC', M'WK', 0)
finish else dump(opr(op), M'ACC', br(ap >> 16 & 15), ap & 65535)
return
finish
if op ¬= 0 or ap > 65535 then start
! NOT 'LDA'-ABLE
j = ctnext
! NEXT HOLE IN CT
cot(j) = ap
! STORE VALUE
dump(opr(op), M'ACC', M'CT', j)
finish else dump(M'LDA', M'ACC', 0, ap)
end
end
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine sccond(integer name label)
! COMPILE CONDITION <SC><COND>, LABEL SET FOR POSITION AFTER UI
routine spec sc
routine spec cond
routine spec store(integer ft)
integer i, j, k, l, app
integer array cap, lvl, tf, jmp, lbl(1 : 16)
! ANAL REC PTRS,
!NESTINGLEVEL,TRUE/FALSE,JUMPARRAYS
i = 1
! INDEX TO ARRAYS
l = 0
! NESTING LEVEL
sc
! PROCESS <SC>
cond
! PROCESS <COND>
app = ap
! PRESERVE ANAL PTR
l = -1
store(1)
! PSEUDO-FALSE
l = -2
store(2)
! PSEUDO-TRUE
k = i - 1
! LAST POS FILLED IN
i = 1
L2:
j = i
! FIND JUMPS
l = lvl(i)
L1:
j = j + 1
if lvl(j) >= l then -> L1
! SKIP HIGHER LEVELS
l = lvl(j)
if tf(j) = tf(i) then -> L1
jmp(i) = j
! JUMP TO COMPARISON
i = i + 1
if i < k then -> L2
! MORE JUMPS TO FILL
if a(ap) = 2 then start
! UI A JUMP INST
ap = ap + 1
! TO <CONST>
j = k - 1
! LAST POS FILLED
tf(j) = 2
! SET AS 'TRUE'
jmp(j) = j
! SET JUMP AS UI JMP
lbl(j) = findlabel
! FILL IN BRANCH
finish
i = 1
! FILL IN PSEUDO-LAB
L3:
if lbl(jmp(i)) < 0 then lbl(jmp(i)) = btnext
! NEXT BAT POSITION
i = i + 1
if i < k then -> L3
! MORE TO FILL IN
i = 1
L4:
ap = cap(i)
! ANAL REC PTR 1ST
scf = 1
! SET FLAG FOR SEXPR
sexpr
! TO EVAL 1ST-2ND
if tf(i) = 1 then l = false(comp) else l = true(comp)
dump(l, M'ACC', M'BT', lbl(jmp(i)))
! BRANCH TO REQ POS
if i < k - 1 then start
if lbl(i) >= 0 then bat(lbl(i)) = ca
i = i + 1
! FILL IN LABEL ADDR
-> L4
finish
! MORE COMPARISONS
if lbl(i) >= 0 and tf(i) = 1 then bat(lbl(i)) = ca
! NOT FOR UI JUMP
label = lbl(k)
! FINAL LABEL
ap = app
! FINAL ANAL REC PTR
return
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
routine store(integer ft)
! STORE LEVEL & TRUE/FALSE FLAG
if i > 16 then start
! ARRAYS FULL
fault(M'COND', M'N TO', M'O LO', M'NG ')
i = 1
! TO CONTINUE
finish
lvl(i) = l
! SAVE NESTING LEVEL
tf(i) = ft
! SAVE TRUE/FALSE FLAG
lbl(i) = -1
! SET 'LAB NOT FILLED'
i = i + 1
! NEXT ARRAY POSITION
end
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
routine sc
ap = ap + 1
if a(ap - 1) = 2 then start
l = l + 1
! NESTING LEVEL UP 1
sc
! PROCESS SUB-<SC>
cond
! PROCESS SUB-<COND>
l = l - 1
! NESTING LEVEL DOWN
finish else start
cap(i) = ap
! ANAL REC POINTERP
ap = np(np(ap + 1))
! SKIP 1ST EXPR
ap = np(np(ap + 2))
! SKIP COMP & 2ND EXPR
finish
end
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
routine cond
! PROCESS <COND> FOR SIMPLE COMPARISONS
integer i
i = a(ap)
! <COND>
ap = ap + 1
! AP ON <SC>
if i ¬= 3 then start
! NOT NULL ALT OF <COND>
L1:
store(i)
! SAVE %AND OR %OR TYPE
sc
! PROCESS <SC>
ap = ap + 1
if a(ap - 1) = 1 then -> L1
! MORE %ANDS OR %ORS
finish
end
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine check
! CHECK LABELS ALL SET & STARTS MATCH FINISHES
integer i, j
i = jump(level)
! POINTER TO JUMP LIST
L1:
if i ¬= 0 then start
! NO LABELS OR JUMPS
if bat(tag(i) & 65535) < 0 then start
! LABEL SET INCORRECTLY
write(tag(i) >> 16, 1)
! PRINT OUT LABEL NO
fault(M' LAB', M'EL N', M'OT S', M'ET ')
finish
i = returncell(i)
! RETURN JUMP LIST CELL
-> L1
finish
i = start(level)
! LINK TO START LIST
L2:
if i ¬= 0 then start
! A CELL STILL IN LIST
fault(M'%FIN', M'ISH ', M'MISS', M'ING ')
i = returncell(i)
! POP UP CELL
-> L2
finish
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine unset
! UNSET NAMES AND CHECK FOR MISSING ROUTINES
integer i, j, k
i = name(level)
! NAME LIST POINTER
L1:
if i ¬= 0 then start
! UNSET NAMES DECLARED
j = tag(i)
! NAME IDENT NO
k = tag(tagl(j))
! TAG WORD AT TOP
tagl(j) = returncell(tagl(j))
! POP UP CELL
if k >> 28 = 4 then start
! ROUTINE/FN TYPE
if bat(k & 65535) < 0 then start
printname(j)
fault(M'ROUT', M'INE ', M'MISS', M'ING ')
finish
k = k >> 20 & 15
! NO OF PARAMS
L2:
if k ¬= 0 then start
! PARAMS PRESENT
tagl(j) = returncell(tagl(j))
! POP UP CELLS
k = k - 1
! PARAM COUNT
-> L2
finish
finish
if tagl(j) = 0 then start
! NO PREVIOUS DECLN
if chp > chl(j) then chp = chl(j)
! MOVE CHP BACK
chl(j) = 0
! CLEAR NAME LINK
finish
i = returncell(i)
! RETURN NAMELIST CELL
-> L1
finish
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine pushstart(integer flag, label)
! PUSHDOWN START/FINISH BLOCK INFORMATION
integer i
i = newcell
if label < 0 then label = 65535
tag(i) = flag << 16 ! label
! PACK FLAG & LABEL
link(i) = start(level)
! PUSH CELL DOWN
start(level) = i
! ONTO START LIST
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine enter(integer type, alloc)
! DUMP CODE FOR NEW LEVEL & INITIALISE LEVEL ARRAYS
integer i
if level = 1 then dump(M'LDA', M'STP', M'ST', 0) else dump(M'STR', br(level), M'STP', 0)
! ENTRY SEQUENCE
dump(M'LDA', br(level), M'STP', 0)
dump(M'STR', M'WK', M'STP', 1)
i = ctnext
! STATIC ALLOC HOLE
dump(M'ADD', M'STP', M'CT', i)
star(level) = i
! REMEMBER POS OF HOLE
jump(level) = 0
! NO JUMPS AT NEW LEVEL
name(level) = 0
! NO NAMES AT NEW LEVEL
rtp(level) = type
! BLOCK/ROUTINE/FN TYPE
start(level) = 0
! NO START/FINISH BLOCK
rad(level) = alloc
! NEXT RELATIVE ADDRESS
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine return
! DUMP CODE FOR %RETURN
dump(M'LDA', M'STP', br(level), 0)
! RESTORE DISPLAY
dump(M'LOAD', br(level), M'STP', 0)
dump(M'LOAD', M'WK', M'STP', 1)
dump('B', 0, M'WK', 0)
! BRANCH TO RETRN ADDR
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine rt
! DUMP CODE FOR A ROUTINE OR FUNCTION CALL
integer i, j, k, l, m, n, p, pp
if pars > 10 then dump(M'LDA', M'STP', M'STP', pars)
pp = pars
pars = 10
i = tagl(a(ap))
! LINK TO TAG
ap = ap + 1
! AP ON <APP>
j = tag(i)
! TAG OF NAME
k = j >> 20 & 15 + 1
! PARAMS+1
L1:
k = k - 1
! COUNT PARAMS
ap = ap + 1
! AP ON <APP>+1
if a(ap - 1) = 2 then start
! PARAMS ABSENT
dump(M'BAL', M'WK', M'BT', j & 65535)
! DUMP BRANCH
if k > 0 then fault(M'TOO ', M'FEW ', M'PARA', M'MS ')
pars = pp
if pars > 10 then start
i = ctnext
cot(i) = pars
dump(M'SUB', M'STP', M'CT', i)
finish
return
finish
if k <= 0 then start
! TOO MANY PARAMS
if k = 0 then fault(M'TOO ', M'MANY', M' PAR', M'AMS ')
-> L2
finish
i = link(i)
! LINK TO NEXT CELL
l = tag(i)
! TAG OF PARAMETER
if l >> 28 = 0 then start
! SCALAR VALUE
sexpr
! COMPILE EXPR
-> L3
finish
if a(ap) = 4 and a(ap + 1) = 1 then -> L4
! <+-¬> IS NULL
L5:
fault(M'NOT ', M'A NA', M'ME P', M'ARAM')
L2:
ap = np(np(ap + 1))
! SKIP INVALID EXPR
-> L1
L4:
m = tagl(a(ap + 2))
! LINK TO TAG
if m = 0 then start
printname(a(ap + 2))
fault(M'NAME', M' NOT', M' SET', M' ')
-> L2
finish
n = tag(m)
! TAG OF ACTUAL PARAM
if l >> 28 = 1 then start
! PARAM SCALAR
if n >> 28 = 4 then start
! ACTUAL IS RT
printname(a(ap + 2))
-> L5
finish
if n >> 28 >= 2 then start
! ACTUAL IS ARRAY
ap = ap + 2
! AP ON <NAME>
arrad
! GET ELEMENT ADDR
ap = ap + 1
! AP <EXPR>+1
if a(ap - 1) = 1 then -> L5
! FURTHER OPERANDS
-> L3
finish
if a(ap + 3) = 1 then start
! <APP> NOT NULL
printname(a(ap + 2))
fault(M'SCAL', M'AR H', M'AS P', M'ARAM')
-> L2
finish
if a(ap + 4) = 1 then -> L5
! FURTHER OPERAND
if n >> 28 = 1 then p = M'LOAD' else p = M'LDA'
! LOAD FOR NAME
dump(p, M'ACC', br(n >> 16 & 15), n & 65535)
finish else start
! PARAM IS ARRAY
if a(ap + 3) ¬= 2 or a(ap + 4) ¬= 2 then -> L5
! <APP> NOT NULL
if n >> 28 & 2 = 0 then start
printname(a(ap + 2))
fault(M'NOT ', M'AN A', M'RRAY', M' NME')
-> L2
finish
dump(M'LOAD', M'ACC', br(n >> 16 & 15), n & 65535)
finish
ap = ap + 5
! AP ON <EXPS>
L3:
dump(M'STR', M'ACC', M'STP', l & 65535)
pars = pars + 1
-> L1
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine arrad
! DUMP CODE TO CALCULATE ARRAY ELEMENT ADDRESS
integer i, j, k, l
l = a(ap)
i = tagl(l)
! LINK TO TAG
j = tag(i)
ap = ap + 2
! AP ON <APP>+1
if a(ap - 1) = 1 then start
! INDEXES PRESENT
sexpr
! COMPILE EXPR
if a(ap) = 1 then start
! 2ND INDEX PRESENT
printname(l)
fault(M'TOO ', M'MANY', M' IND', M'EXES')
ap = np(ap)
! SKIP EXCESS INDEXES
finish else ap = ap + 1
! AP AFTER EXPR
dump(M'ADD', M'ACC', br(j >> 16 & 15), j & 65535)
finish else start
printname(l)
fault(M'NO A', M'RRAY', M' IND', M'EXES')
finish
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer fn btnext
! ALLOCATE NEXT POSITION IN BRANCH TABLE
if btn > 1023 then start
! FULL
fault(M'TOO ', M'MANY', M'LABE', M'LS ')
btn = 0
! TRY TO CONTINUE
finish
bat(btn) = -1
! MARKER
btn = btn + 1
! NEXT POSITION
result = btn - 1
! THIS POSITION
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer fn ctnext
! ALLOCATE NEXT POSITION IN CONSTANT TABLE
if ctn > 1023 then start
! FULL
fault(M'TOO ', M'MANY', M' CON', M'STS ')
ctn = 0
! TRY TO CONTINUE
finish
cot(ctn) = -1
ctn = ctn + 1
! NEXT POSITION
result = ctn - 1
! THIS POSITION
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer fn wsnext
! ALLOCATE NEXT WORK SPACE POSITION
ws = ws + 1
if ws = 11 then fault(M'COMP', M'ILER', M' WKS', M'PACE')
result = ws - 1
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer fn findlabel
! CHECK & LOCATE OR INSERT LABEL IN JUMP LIST FOR THIS LEVEL
integer i, j
label = a(ap)
! VALUE OF CONST
ap = ap + 1
! AFTER <CONST>
if label >> 16 ¬= 0 then start
! INVALID LABEL NUMBER
write(label, 1)
spaces(2)
fault(M'INVA', M'LID ', M'LABE', M'L ')
result = -1
! 'FAULTY' RESULT
finish
i = jump(level)
! JUMP LIST POINTER
L1:
if i ¬= 0 then start
! SOMETHING IN LIST
if label = tag(i) >> 16 then result = tag(i) & 65535
! LABEL ALREADY
i = link(i)
! NEXT CELL IN LIST
-> L1
finish
i = newcell
! LABEL NOT IN LIST
j = btnext
! GET NEXT BRANCH TABLE
tag(i) = label << 16 ! j
! FILL IN LIST ENTRY
link(i) = jump(level)
! PUSHDOWN
jump(level) = i
! NEW JUMP LIST POINTER
result = j
! NEW BRANCH TABLE POS
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine storetag(integer nam, form, type, dim, lev, ad)
! STORE TAGS - SET NAME & CHECK NOT SET ALREADY
integer m, n
m = tagl(nam)
! PTR TO EXISTING TAG
if m ¬= 0 and lev = tag(m) >> 16 & 15 and form ¬= 4 then start
printname(nam)
fault(M'NAME', M' SET', M' TWI', M'CE ')
return
finish
n = newcell
! NEW CELL FOR TAGS
tag(n) = form << 28 ! type << 24 ! dim << 20 ! lev << 16 ! ad
! FILL IN TAGS
link(n) = tagl(nam)
! PUSHDOWN ON TAGS LIST
tagl(nam) = n
n = newcell
tag(n) = nam
! PUSHDOWN ON NAME LIST
link(n) = name(level)
name(level) = n
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine dump(integer op, reg, base, disp)
! PRINT OUT CURRENT ADDRESS, OPERATION MNEMONIC & OPERANDS
routine spec pmn(integer i)
write(ca, 5)
! CURRENT ADDRESS
printsymbol('.')
spaces(10)
pmn(op)
! OPERATOR MNEMONIC
pmn(reg)
! REGISTER MNEMONIC
if base = M'PR' and disp >= 65536 then printname(disp - 65536) else start
pmn(base)
! BASE MNEMONIC
write(disp, 1)
! DISPLACEMENT
finish
newline
ca = ca + 1
! INCREMENT CURRENT ADDR
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
routine pmn(integer i)
! PRINT MNEMONIC - CHARS INTO ONE WORD
integer j, k, l
j = 2
! AT LEAST TWO SPACES
k = 24
! FIRST SHIFT VALUE
L1:
l = i >> k & 255
! UNPACK NEXT CHARACTER
if l = 0 then j = j + 1 else printsymbol(l)
k = k - 8
! NEXT SHIFT VALUE
if k >= 0 then -> L1
! MORE CHARS POSSIBLY YET
if i = M'BT' or i = M'CT' or i = M'PR' or i = M'ST' then printsymbol('+') else start
printsymbol(',')
spaces(j)
! TO ALLIGN FIELDS
finish
end
end
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine fault(integer a, b, c, d)
! MONITOR FAULT - A 'PRINT STRING' ROUTINE
out(a)
out(b)
out(c)
out(d)
newline
faults = faults + 1
! INCREMENT FAULT COUNT
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine out(integer i)
! PRINT OUT PACKED CHARS
printsymbol(i >> 24)
printsymbol(i >> 16 & 255)
printsymbol(i >> 8 & 255)
printsymbol(i & 255)
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer fn chnext
! ALLOCATE NEXT POSITION IN 'CH' ARRAY
if chp > 512 then start
! CHARACTER ARRAY FULL
fault(M'NAME', M'S TO', M'O LO', M'NG ')
stop
finish
chp = chp + 1
result = chp - 1
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer fn newcell
! ALLOCATE NEW CELL FOR LIST PROCESSING
integer i
if asl = 0 then start
! END OF AVAILABLE SPACE LIST
fault(M'ASL ', M'EMPT', M'Y ', M' ')
stop
finish
i = asl
! POINTER TO TOP CELL OF ASL
asl = link(asl)
! ASL POINTER TO NEXT CELL DOW
tag(i) = 0
! CLEAR NEW CELL OUT
link(i) = 0
result = i
! INDEX TO NEW CELL
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer fn returncell(integer i)
! DEALLOCATE CELL AND RETURN IT TO ASL
integer j
j = link(i)
! PRESENT LINK VALUE OF CELL
link(i) = asl
! LINK TO TOP OF ASL
asl = i
! ASL POINTER TO RETURNED CELL
result = j
! RETURN VALUE OF LINK
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine printname(integer i)
! PRINT NAME FROM HASH POSITION
integer j, k, l, m
j = chl(i)
! POINTER TO CH ARRAY
k = ch(j)
! LENGTH & FIRST 3 CHARS
l = k >> 24
! NUMBER OF CHARS IN NAME
m = 16
! FIRST SHIFT VALUE
L1:
printsymbol(k >> m & 255)
l = l - 1
if l = 0 then start
spaces(2)
return
finish
m = m - 8
! NEXT SHIFT VALUE
if m < 0 then start
j = j + 1
k = ch(j)
! NEXT WORD OF CHARS
m = 24
finish
-> L1
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine printlabel(integer i)
! PRINT PACKED LABEL NAME
printsymbol('.')
out(i)
printsymbol(':')
newline
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine showtags
! DISPLAY TAGS OF NAMES IN SCOPE
integer i, j, k, l, m
i = 0
! EXAMINE TAGS FROM 0 UP
L1:
if chl(i) = 0 then -> L2
! NO NAME WITH IDENTIFICATION
newline
write(i, 10)
! IDENT NO
spaces(4)
printname(i)
newline
j = tagl(i)
! POINTER TO NAME TAGS
if j = 0 then -> L2
! IN CASE NO TAG SET UP
spaces(11)
L7:
spaces(4)
k = tag(j)
! FIRST TAGS WORD
l = 28
! FIRST SHIFT VALUE
L6:
m = k >> l & 15
! NEXT HEX DIGIT
if m < 10 then printsymbol(m + '0') else printsymbol(m + 'A' - 10)
l = l - 4
! NEXT SHIFT
if l >= 0 then -> L6
! MORE DIGITS IN THIS WORD
j = link(j)
! POINTER TO NEXT CELL
if j ¬= 0 then -> L7
! MORE CELLS
L2:
i = i + 1
if i <= 255 then -> L1
! MORE NAMES TO CONSIDER
newlines(2)
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
readps
i = 0
L10:
chl(i) = 0
tagl(i) = 0
! CLEAR HASHING ARRAY
i = i + 1
if i <= 255 then -> L10
i = 1
L11:
tag(i) = 0
link(i) = i + 1
! SET UP SPACE LIST
i = i + 1
if i < 1000 then -> L11
link(1000) = 0
asl = 1
! BASE REGISTER MNEMONICS
br(0) = M'BR0'
br(1) = M'BR1'
br(2) = M'BR2'
br(3) = M'BR3'
br(4) = M'BR4'
br(5) = M'BR5'
br(6) = M'BR6'
br(7) = M'BR7'
br(8) = M'BR8'
br(9) = M'BR9'
br(10) = M'BR10'
br(11) = M'BR11'
br(12) = M'BR12'
br(13) = M'BR13'
br(14) = M'BR14'
br(15) = M'BR15'
! CONDITIONAL BRANCH MNEMONICS
true(1) = M'BZ'
false(1) = M'BNZ'
true(2) = M'BNZ'
false(2) = M'BZ'
true(3) = M'BNG'
false(3) = M'BG'
true(4) = M'BL'
false(4) = M'BNL'
true(5) = M'BNL'
false(5) = M'BL'
true(6) = M'BG'
false(6) = M'BNG'
! INSTRUCTION MNEMONICS, PRECEDENCES & TYPES
! 4 : HIGHEST PRECEDENCE, 1 : LOWEST PRECEDENCE
! 1 : UNARY, 2 : BINARY COMMUTATIVE, 3 : BINARY NON-COMMUTATIVE TYPES
opr(0) = M'LOAD'
opr(1) = M'SHL'
prec(1) = 3
ucn(1) = 3
! <<
opr(2) = M'SHR'
prec(2) = 3
ucn(2) = 3
! >>
opr(3) = M'AND'
prec(3) = 2
ucn(3) = 2
! &
opr(4) = M'XOR'
prec(4) = 1
ucn(4) = 2
! !!
opr(5) = M'OR'
prec(5) = 1
ucn(5) = 2
! !
opr(6) = M'EXP'
prec(6) = 3
ucn(6) = 3
! **
opr(7) = M'DIV'
prec(7) = 2
ucn(7) = 3
! /
opr(8) = M'MLT'
prec(8) = 2
ucn(8) = 2
! *
opr(9) = M'ADD'
prec(9) = 1
ucn(9) = 2
! +
opr(10) = M'SUB'
prec(10) = 1
ucn(10) = 3
! -
opr(11) = M'NEG'
prec(11) = 1
ucn(11) = 1
! -
opr(12) = M'NOT'
prec(12) = 4
ucn(12) = 1
! ¬
btn = 0
! BRANCH TABLE POINTER
ctn = 0
! CONSTANT TABLE POINTER
chp = 1
! NAME CHARACTER TABLE POINTER
faults = 0
! FAULT COUNT
nl = 10
! VALUE OF NEWLINE CHAR
level = 0
! TEXTUAL LEVEL
scf = 0
! CONDITION FLAG
jump(0) = 0
! JUMP LIST POINTER
star(0) = 0
! STORAGE ALLOCATION POSITION
name(0) = 0
! NAME LIST POINTER
rtp(0) = -1
! ROUTINE TYPE
start(0) = 0
! START/FINISH LIST
rad(0) = 10
! NEXT REL ADDR TO ALLOCATE
pars = 10
! NEXT PARAMETER REL ADDR
ca = 0
! CURRENT CODE DUMPING ADDRESS
printlabel(M'PR')
! LABEL AT START OF CODE
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
L1:
readline
tp = 1
! TEXT POINTER
L2:
if t(tp) = '!' then -> L3
! COMMENT - SKIP TO END
ap = 1
! ANALYSIS REC POINTER
if compare(-1000) = 1 then start
! SUCCESSFUL ANALYSIS
i = 1
! PRINT OUT ANALYSIS REC
j = 1
L5:
write(j, 5)
! INDEX TO ANALYSIS REC
j = j + 1
if j <= i + 11 and j <= ap then -> L5
newline
j = i
L6:
spaces(2)
! PHRASE NAMES
out(pn(j))
j = j + 1
if j <= i + 11 and j <= ap then -> L6
newline
j = i
L7:
write(a(j), 5)
! ALTERNATIVE NUMBERS
j = j + 1
if j <= i + 11 and j <= ap then -> L7
newline
j = i
L8:
write(np(j), 5)
! NEXT PHRASE POSITION
j = j + 1
if j <= i + 11 and j <= ap then -> L8
newlines(2)
i = i + 12
if j <= ap then -> L5
ap = 1
! ANALYSIS REC POINTER
ss
! PROCESS SOURCE STAT
if t(tp - 1) = ';' then -> L2
! FURTHER STAT ON LINE
-> L1
finish
! GO TO READ NEXT LINE
fault(M'SYNT', M'AX ', 0, 0)
! UNSUCCESSFUL ANALYSIS
L4:
if t(tp) = nl then -> L1
! READ NEXT LINE
if t(tp) = ';' then start
! END OF STATEMENT
tp = tp + 1
! TP TO START OF NEXT
-> L2
finish
! GO TO EXAMINE NEXT
L3:
tp = tp + 1
! SKIP TO NEXT CHARACTER
-> L4
end of program