externalstring(255)fnspec date
externalstring(255)fnspec time
systemroutinespec exit alias "exit" (integer rc)
externalintegerfnspec cputime
externalroutinespec getblock alias "GETBLOCK_JSB" (integer len, bytename base)
externalintegerfunctionspec getlong alias "GETLONG_JSB"
externalintegerfunctionspec getword alias "GETWORD_JSB"
externalroutinespec get(integername n)
externalroutinespec put(integer n)
externalroutinespec putword(integer n)
externalroutinespec putlong(integer n)
externalroutinespec putblock(integer len, bytename b)
! Computer Science IMP77 Compiler - Version 8 Third pass
! 23rd March 1981
! Mods by MT October/November 1981
!
! Uses common include file defining constants,
! spec'ing common externals etc.
!
!!%include "control.imp"
{%systemroutinespec exit %alias "exit" (%integer s)
!%external %routine %spec PUT (%integer n)
!%external %routine %spec PUT WORD (%integer n)
!%external %routine %spec PUT LONG (%integer n)
!%external %routine %spec PUT BLOCK (%integer n, %bytename b)
external routine spec SELECT INPUT TANK (integer n)
external routine spec SELECT OUTPUT TANK (integer n)
!%external %routine %spec GET (%integer %name ch)
!%external %routine %spec GET BLOCK (%integer len, %byte %name b)
external routine spec PRINT RECORD (integer len, byte name buff)
external integer function spec LOOK
!%external %integer %function %spec GETWORD
!%external %integer %function %spec GETLONG
external integer function spec TAG alias "GETLONG"; ! For pass 2
external string(63) function spec ITOS (integer n, p)
! streams
const integer report = 0
const integer object file = 1
const integer listing = 2
const integer diag stream = listing
! miscellaneous
const integer max ident = 31; ! Length for external linkage
const integer fatal = 16_1000002C; ! Error exit code to VMS
! external data (defined in driver)
external string(6) spec version; ! Compiler version string
external integer spec command
external integer spec control
! command bit meanings (set by command line)
const integer diag bit = 8_00004
const integer line bit = 8_00010
const integer log bit = 8_00020
const integer time bit = 8_01000
const integer entry bit = 8_02000
const integer init bit = 8_04000
const integer pic bit = 8_10000
! control bit meanings (%control n, or set by driver (/check= etc))
! bit set => check on
const integer ass check = 1; ! unassigned checking
const integer str check = 2; ! string capacity checking
const integer for check = 4; ! %for checking
const integer arr check = 8; ! array bound checking
const integer ovf check = 16; ! integer overflow checking
const integer rec round = 128; ! rounding in records (turns it on)
const integer profiling = 256; ! call TRACE (line no) at bounds
! object file commands Pass2 => Pass3
const integer obj extern = 1; ! insert external entry
const integer obj code = 2; ! code block
const integer obj gla = 3; ! gla block
const integer obj pdef = 4; ! external proc definition
const integer obj pspec = 5; ! external proc specification
const integer obj ddef = 6; ! external data definition
const integer obj dspec = 7; ! external data specification
const integer obj reloc = 8; ! relocate gla
const integer obj set = 9; ! set gla to tag address
const integer obj header = 10; ! start of procedure
const integer obj call = 11; ! procedure call
const integer obj jump = 12; ! jump
const integer obj prim spec = 13; ! prim definition
const integer obj end = 14; ! end of object file
const integer obj line = 15; ! line number
const integer obj term = 16; ! end of block
const integer obj diag p = 17; ! diags for proc header
const integer obj diag v = 18; ! diags for variable
const integer obj weak = 19
const integer obj b lab = 20; ! bxxb in m/code
const integer obj w lab = 21; ! bxxw in m/code
const integer obj glam = 22; ! initialise n items in GLA
const integer obj modd = 23; ! modify displacement
const integer obj prim ref = 24; ! call to prim
const integer obj ext ref = 25; ! call to external procedure
const integer last obj code = 25
! directive file commands Pass2 => Pass3
const integer dir used = 1; ! external used
const integer dir ldef = 2; ! label definition
const integer dir pref = 3; ! procedure reference
const integer dir cref = 4; ! conditional label reference
const integer dir uref = 5; ! unconditional label reference
const integer dir end = 6; ! end of procedure
const integer dir sizes = 7; ! end of directives+sizes
const integer dir x end = 8; ! end of external entry
const integer dir header = 9; ! start of procedure
const integer dir entry = 10; ! define entry label
const integer last dir code = 10
!!%end %of %file
! Size constants
const integer max tag = 4000; ! total tags in use
const integer max ref = 6000; ! references to tags
const integer max procs = 600; ! procedures in module
const integer max externals = 400; ! external defs/refs
const integer max rec = 512; ! object record size
external routine PASS3 (string(63) module, integer object, directives)
integer check ass = control&ass check; ! unassigned checking on
integer diags = command&diag bit; ! dump diag psect
integer ldump = command&line bit; ! dump lines (trace) psect
integer pic = command&pic bit; ! PIC for gla
integer init = command&init bit; ! initialisation needed
integer timing = command&time bit; ! full timing report
integer clog = command&log bit; ! summary to console
const integer proc enter prim = 13; ! = "$_M"
const integer non zero = 1; ! boolean
! Op-codes
const integer brb = 16_11; ! +127/-128
const integer brw = 16_31; ! +32767/-32768
const integer jmp = 16_17; ! anywhere...
const integer bneq = 16_12, bnequ = 16_12
const integer beql = 16_13, beqlu = 16_13
const integer bgtr = 16_14
const integer bleq = 16_15
const integer bgeq = 16_18
const integer blss = 16_19
const integer bgtru = 16_1A
const integer blequ = 16_1B
const integer bgequ = 16_1E
const integer blssu = 16_1F
const integer jsb = 16_16
const integer calls = 16_FB
const integer movl = 16_D0
const integer moval = 16_DE
const integer movab = 16_9E
const integer subl2 = 16_C2
const integer movc5 = 16_2C
! Branch table - invert (branch (b)) = branch(b!!7)
const byte array branch (0 : 15) =
brb, beql, blss, bleq, bgtr, bgeq, bneq, 0, {signed}
{ u/c = < <= > >= # never }
brb, beqlu, blssu, blequ, bgtru, bgequ, bnequ, 0 {unsigned}
const integer margin = 800; ! stretch margin for jumps
const integer safe low = 16_ffff8001+margin
const integer safe high= 16_00008000-margin
const integer middling = 16_1000; ! word disp ref
! Object record constants
const integer obj hdr = 0
const integer hdr mhd = 0; ! module header
const integer hdr lng = 1; ! language sub-header
const integer obj gsd = 1
const integer gsd psc = 0; ! P-sect def
const integer gsd sym = 1; ! Symbol (def/ref)
const integer gsd epm = 2; ! Ext def + mask
const integer obj tir = 2
const integer tir stag = 0; ! Stack global symbol
const integer tir stasb = 1; ! Stack signed byte
const integer tir stasw = 2
const integer tir stal = 3
const integer tir stpbb = 4
const integer tir stpbw = 5
const integer tir stpbl = 6
const integer tir staub = 7; ! Stack unsigned byte
const integer tir stob = 20; ! Store signed byte
const integer tir stow = 21; ! Store signed word
const integer tir stol = 22; ! Store longword
const integer tir stold = 25; ! Store longword
const integer tir stopidr = 27; ! Store PIC data reference
const integer tir stopicr = 28; ! Store PIC reference
const integer tir sto rl = 31; ! Store repeated long
const integer tir stoub = 33; ! Store unsigned byte
const integer tir stogb = 37; ! Store general byte
const integer tir sto rb = 39; ! Store repeated byte
const integer tir sto rw = 40; ! Store repeated word
const integer tir add = 51
const integer tir setrb = 80
const integer tir augrb = 81
const integer obj eom = 3
const integer obj dbg = 4
!P-sect info
const integer quad = 3; ! 8(=2**3)-byte alignment
const integer ps pic = 1<<0
const integer ps rel = 1<<3
const integer ps shr = 1<<5
const integer ps exe = 1<<6
const integer ps rd = 1<<7
const integer ps wrt = 1<<8
own integer name ca
own integer name ga
own integer base = 0
own short ref head = 0
own short name ref chain; ref chain == ref head
own short def list = 0; !ordered list of labels
own integer this line = 0
own integer entry tag = -1
const integer code flags = ps pic ! ps rel ! ps rd ! ps exe ! ps shr
own integer glap flags = ps rd ! ps wrt ! ps rel ! ps pic
! glap flags = glap flags ! ps pic %if pic # 0
const integer diag flags = ps pic ! ps rel ! ps rd ! ps shr
const integer line flags = ps pic ! ps rel ! ps rd ! ps shr
const string(10) code name = "$_CODEAREA"
own string(10) glap name = "$_GLAPAREA"
! glap name = "$_GLAPPIC"
const string(10) diag name = "$_DIAGAREA"
const string(10) line name = "$_CODELINE"
const string(10) init proc = "IMP$_INIT"
integer refs, last tag
integer code size, glap size, diag size, line size
integer procs, events, event base, evp, specs
own string(max ident) text
record format psect fm (integer bp, pa, dump, bs, lr, lrp,
integer index, lbs, bb, be, max,
(byte type or
byte array b (1 : maxrec)))
own record(psect fm) codep, glapp, workp, diagp, linep
own record(psect fm) name buff; ! Points at one of above
record format ref fm (integer ca, tag, short flag, link)
record format def fm (integer ca, short uses, link)
record(def fm) array def (0 : max tag)
record(ref fm) array ref (1 : max ref)
record format proc fm (integer frame,
short type, mask, diag, diag ep, line ep)
record(proc fm) array proc tab (1 : max procs)
byte array ext used (1 : max externals)
string(max ident) array ext text (1 : max externals)
routine ERROR (string(31) text, integer extra)
select output (report)
newline
print string ("***Pass3 fails """); print string (text)
print string (""" ("); write (extra, 0); print symbol (')')
newline
monitor
exit (16_1000002c) {1000002c is SS$_ABORT with the inhibit message bit set - could just use EXIT_FAILURE}
end
routine GET STRING (string(*) name t)
integer len, file len
get (len)
file len = len
error ("external size?", len) unless 0 < len <= max ident
len = len - 1 if len = max ident {make room for '_' in Gla name}
length(t) = len
getblock (file len, charno(t,1))
end
routine spec STPB (record(psect fm) name p, integer d)
routine spec ADD (integer b)
routine FLUSH BUFF
integer name bp
bp == buff_bp
if bp > max rec start
! over the limits!
error ("buffer error - seek help!!", bp-maxrec)
finish
if buff_dump # 0 start
error ("buffer error", 1) if buff_bs > 0; ! Still in IMMED mode
if bp > 1 start
print record (bp, buff_b(1))
finish
finish
buff_bs = 0; buff_be = 0; buff_lbs = 0; buff_lr = 0
bp = 1; ! leave type field
if buff_type = obj tir and buff_dump # 0 start
! fill in reloc command
stpb (buff, buff_pa); add (tir setrb)
buff_lr = buff_bp; buff_lrp = 1
finish
end
routine NEED (integer b)
! ensure there are at least b bytes free in current buffer
flush buff if buff_bp + b > max rec
end
routine SET WORK (integer type)
buff == workp; flush buff
workp = 0; workp_dump = 1
workp_type = type; workp_bp = 1
end
routine ADD (integer b)
return if buff_dump = 0
buff_bp = buff_bp + 1; buff_b(buff_bp) = b&255
end
routine ADDW (integer n)
return if buff_dump = 0
shortinteger(addr(buff_b(buff_bp+1))) = n
buff_bp = buff_bp + 2
end
routine ADDL (integer n)
return if buff_dump = 0
integer(addr(buff_b(buff_bp+1))) = n
buff_bp = buff_bp + 4
end
routine ADD STRING (integer from, string(63) s)
integer b, l
return if buff_dump = 0
l = length(s)
if from = 0 start
string(addr(buff_b(buff_bp+1))) = s
buff_bp = buff_bp + 1
else
b = buff_b(buff_bp)
string(addr(buff_b(buff_bp))) = s
buff_b(buff_bp) = b
finish
buff_bp = buff_bp + l
end
routine ADD TEXT (integer data)
string(max ident) t = text
return if buff_dump = 0
t = t . "_" if data # 0
add string (0, t)
end
integer function RANGE (integer disp, extra)
result = 1 if -128 <= disp <= 127
result = 2 if 16_FFFF8000 <= disp-extra <= 16_7FFF
result = 4
end
routine STAG (string(max ident+3) S)
need (1+1+length(S))
add (tir stag); add string (0, S)
end
routine TIR COMMAND (integername value, integer param,
byte array name clist)
integer size
size = range (value, 0)
need (2+size)
add (clist(size))
add (param) if param >= 0
if size = 1 start
add (value)
else if size = 2
addw (value)
else
addl (value)
finish
value = size
end
routine STPB (record(psect fm) name p, integer offset)
own byte array stpbc (1 : 4) =
tir stpbb, tir stpbw, 0, tir stpbl
tir command (offset, p_index, stpbc)
end
routine STAK (integer value)
own byte array stac (1 : 4) =
tir stasb, tir stasw, 0, tir stal
tir command (value, -1, stac)
end
routine SELECT (integer disp)
return if buff_dump = 0
need (7); ! Sequence must be in one record!
error ("psect overflow", disp) if disp > buff_max
if buff_lr = buff_bp start
! Have not planted anything since last 'select'
buff_bp = buff_lrp; ! Forget last select
buff_pa = -20; ! Ensure this one planted!
finish
if buff_pa # disp start
buff_lrp = buff_bp
stpb (buff, disp)
add (tir setrb)
buff_lr = buff_bp
buff_pa = disp
finish
end
routine START IMMED (integer max)
return if buff_dump = 0
error ("buffer in use", 0) if buff_bs # 0
error ("immediate size error", max) if max > 128
need (max+1)
if buff_be = buff_bp and
max + (buff_bp - buff_lbs) <= 128 start
! Can concatenate buffers
buff_bs = buff_lbs
else
add (0); ! Length byte
buff_bs = buff_bp
finish
buff_bb = buff_bp; ! Where this block started
end
routine END IMMED
integer size
return if buff_dump = 0
error ("buffer not in use", 0) if buff_bs = 0
size = buff_bp - buff_bs
if size # 0 start
error ("buffer overflow", size) if size > 128
buff_b(buff_bs) = -size
buff_lbs = buff_bs
buff_be = buff_bp
else
buff_bp = buff_bp - 1
finish
buff_pa = buff_pa + buff_bp - buff_bb; ! Update psect disp.
error ("Psect immediate overflow", 0) if buff_pa > buff_max
buff_bs = 0; ! Not buffering now
end
routine SPEC (integer flags, data, value, mask)
integer def, len, psect
psect = |data|
data = 0 if data < 0; ! no '_' for ext data def
def = flags&2
len = (1+1)+(data+length(text))
len = len + 7 if def # 0
set work (obj gsd)
if def = 0 start
add (gsd sym)
else
add (gsd epm)
finish
add (0); ! data type - unknown
addw (flags); ! symbol flags
if def # 0 start; ! definition
add (psect)
addl (value)
addw (mask)
finish
add text (data)
end
routine INPUT DIRECTIVES
switch d (1 : last dir code)
short first = 0, list = 0
short name ref list == first, end
record(proc fm) name proc
record(ref fm) name r
record(def fm) name t
integer name q
integer proc head, n, frame, ldiag
integer ecode, unass code, size
integer rp, tag, block tag, dcode
own integer dap = 0, lap = 2
procs = procs + 1
proc == proc tab(procs)
proc_diag ep = 0
proc_line ep = 0
cycle
get (dcode)
-> d(dcode) if 1 <= dcode <= last dir code
error ("spurious directive", dcode)
d(dir used):
ext used(getword) = non zero
continue
d(dir ldef):
tag = getword
error ("too many labels", tag) unless 0 < tag <= max tag
t == def(tag)
t_ca = getlong; ! ca
end == t_link if list = 0
t_link = list; list = tag
continue
d(dir pref):
d(dir cref):
d(dir uref):
tag = getword
error ("too many labels", n) unless 0 < tag <= max tag
error ("too many references", refs) if refs = max ref
refs = refs + 1; r == ref(refs)
r_tag = tag
r_ca = getlong; ! ca
r_flag = dcode - 3
ref list = refs
ref list == r_link
continue
d(dir entry): ! define ep
entry tag = getword
continue
d(dir header):
input directives
repeat
d(dir end):
proc_type = getlong
proc_mask = getword&16_CFFC
frame = -getlong
proc_frame = frame; ! frame size
ldiag = getword
proc_diag = ldiag
error ("corrupt diags", diags) if ldiag = 0 and diags # 0
proc_diag ep = dap; dap = dap + ldiag
proc_line ep = lap; lap = lap + getword
block tag = getword
! compute length of entry code sequence
ecode = 2; ! for entry mask
if block tag = entry tag and init # 0 start
ecode = ecode + 7; ! calls #0,l^init proc
finish
if proc_type # 0 start
ecode = ecode + 7; ! moval l^ep_,gla
finish
ecode = ecode + 3; ! movl fp, base
if frame # 0 start
! locals - needs frame + unass code
unass code = 8; ! movc5 #0,(fp),(gla),s^#f,(sp)
if frame <= 63 start
!short lit - byte's worth
ecode = ecode + 3; ! subl2 i^#f, sp
unass code = 6; ! movc5 #0,(fp),(gla),i^#f,(sp)
else if frame <= 16_7fff
!word's worth (sheer poetry)
ecode = ecode + 5; ! moval w^-f(sp), sp
else
ecode = ecode + 7; ! subl2 s^#f, sp
finish
if check ass # 0 start
ecode = ecode + unass code
proc_mask = proc_mask ! 16_003C; ! r0-r5 corrupted by MOVC5!!!
finish
finish
t == def(block tag)
t_ca = t_ca - ecode
base = base + ecode
d(dir xend): ! end of external proc
tag = list
while tag # 0 cycle
t == def(tag)
t_ca = t_ca + base
tag = t_link
repeat
if list # 0 start; ! add labels to def list
end = def list
def list = list
finish
ref list = 0; ! mark the end
rp = first
while rp # 0 cycle
r == ref(rp)
r_ca = r_ca + base
rp = r_link
repeat
size = getlong; ! total size
base = base + size
if first # 0 start
ref chain = first
ref chain == ref list
ref chain = 0
finish
return
d(dir sizes): ! end of directives, totals follow
glap size = getlong
last tag = getword
specs = getword
diag size = getword
events = getword
proc tab(1)_diag ep = dap
line size = lap
end
routine STRETCH JUMPS
integer extra, here, there, disp, mod, tag
integer name pt
short name last, next
record(ref fm) name r
record(def fm) name t
cycle
extra = 0
last == ref head
while last # 0 cycle
r == ref(last)
next == r_link
r_ca = r_ca + extra
here = r_ca + 2
there = def(r_tag)_ca
disp = there - here
mod = 0
if r_flag&middling = 0 and
not -128 <= disp <= 127 start
r_flag = r_flag!middling
!******** %if safelow <= disp <= safe high %start
!******** ! will not stretch again
!******** last = next
!******** next == last
!******** %finish
mod = 1; ! 1-byte -> 2-byte disp
mod = 3 if r_flag&1 # 0; ! conditional -> skip+brw
else unless 16_FFFF8001 <= disp <= 16_8000
! cannot get bigger
last = next
next == last
mod = 2; ! word disp -> longword disp
mod = 3 if r_flag&3 # 0; ! brw -> jmp
finish
if mod # 0 start
tag = def list
while tag # 0 cycle
t == def(tag)
pt == t_ca
exit if pt < here
pt = pt + mod
tag = t_link
repeat
extra = extra + mod
finish
last == next
repeat
base = base + extra
repeat until extra = 0
event base = (base+7)&(¬7)
evp = event base
code size = event base + events*16 + 4
end
routine DUMP CODE (integer base, btag, limit)
switch c (1 : last obj code)
own byte array base mod (5 : 15)
! Code type enables pre-selection of the appropriate
! output buffer for each command code byte from Pass 2.
const byte array code type (1 : last obj code) =
0, 0, 1, 0, 0,
1, 1, 1, 1, 0,
0, 0, 0, 0, 3,
0, 2, 2, 0, 0,
0, 1, 0, 0, 0
own record(psect fm) name array buff for (0 : 3)
own integer called = 0
integer disp, cond
integer ldiag, value
integer ocode, type
integer gb, gx, cx, xno, pno
integer old ca, old la, old da
integer count, size, n, save
integer reg, specifier, mode
integer evlow, evep, evword
integer tag, lim, nbase
record(proc fm) name proc
routine DUMP LINE
buff == linep
start immed (6)
addl (ca); addw (this line)
end immed
end
routine LOAD BLOCK
integer n
get (n); start immed (n)
get block (n, buff_b(buff_bp+1))
buff_bp = buff_bp + n
end immed
end
routine SET PRIM TEXT (integer pno)
text = "$_"
text = text . "_" and pno = pno - 26 while pno > 26
text = text . tostring ('A'-1+pno)
end
routine PLUG GLAP (record(psect fm) name with,
integer with disp, where, inst)
integer old ga = ga
unless 0 < where < glap size start
error ("faulty glap relocation", where)
finish
buff == glapp; select (where)
need (7); ! Must have following in one record..
stpb (with, with disp)
add (inst)
select (old ga)
end
routine BSEL (integername old, record(psect fm) name p,
integer new)
buff == p
old = p_pa
select (new)
end
routine INITIALISE BUFFERS
buff for(0) == codep
buff for(1) == glapp
buff for(2) == diagp
buff for(3) == linep
called = non zero
end
routine HANDLE BLOCK ENTRY
integer mask, unsaved, reg
integer frame
base = 13 if base = 12; ! bottom 2 levels
dump line if ldump # 0
buff == codep
! Calculate true offset from FP of args to this proc
! for benefit of inner procs referencing them. This
! is affected by the number of regs saved on the stack
! on proc call. Pass 2 assumes all regs saved, we now
! calculate how many aren't, and subtract this*4 from
! displacement used by pass 2.
mask = proc_mask; unsaved = 0
for reg = 2, 1, 11 cycle
unsaved = unsaved + 1 if mask & (1<<reg) = 0
repeat
base mod(base) = unsaved*4; ! to subtract off
frame = proc_frame; ! frame size
start immed (50); ! For entry sequence
addw (mask); ! entry mask
if proc_type # 0 start
! %external entry
get string (text); ! name
if entry tag = btag and init # 0 start
add (calls); add (0); ! calls #0,init proc
end immed
stag (init proc); ! spec reference
add (tir stopicr); ! store it
ca = ca + 5
start immed (1)
finish
add (moval); end immed; ! moval
need (1+1+length(text)+1+1);
stag (text."_");
add (tir stopicr); ! ep_,
ca = ca + 5
start immed (50); add (16_5B); ! gla
finish
add (movl); ! movl
add (16_5D); add (16_50+base); ! fp, base
if frame # 0 start
if frame <= 63 start
add (subl2); ! subl2
add (frame); ! S^#frame
else if frame <= 16_7fff
add (movab); ! movab
add (16_CE); addw (-frame); ! W^-frame(sp)
else
add (subl2); ! subl2
add (16_8F); addl (frame); ! I^#frame
finish
add (16_5E); ! , SP
if check ass # 0 start
add (movc5); add (0); add (16_6D); add (16_6B)
if frame <= 63 start
add (frame)
else
add (16_8F); addw (frame&16_7FFF)
finish
add (16_6E)
!movc5_#0,(fp),(gla), #N, (sp)
finish
finish
end immed
end
initialise buffers if called = 0
procs = procs + 1
proc == proc tab(procs)
bsel (old da, diagp, proc_diag ep)
bsel (old la, linep, proc_line ep)
bsel (old ca, codep, def(btag)_ca)
handle block entry if base # 0
cycle
get (ocode)
buff == buff for(code type(ocode))
-> c(ocode) if 0 < ocode <= 25
c(*): error ("spurious object", ocode)
c(obj diag p):
n = getword
get string (text)
ldiag = proc_diag
error ("corrupt diags", 0) if ldiag = 0
start immed (50)
addw (ldiag); addw (n); addl (limit); add text (0)
end immed
continue
c(obj diag v):
start immed (50)
addw (getword); addl (getlong)
get string (text); add text (0)
end immed
continue
c(obj code):
load block
continue
c(obj modd):
get (ocode); error ("faulty mod", ocode) if ocode # 2
get (n); ! # bytes following
start immed (n)
get (specifier); n = n - 1
reg = specifier & 15
add (specifier)
if n = 1 start
get (disp)
else if n = 2
disp = getword
else if n = 4
disp = getlong
else
error ("faulty disp in mod", n)
finish
disp = disp - base mod(reg)
add (disp)
add (disp>>8) if n > 1
addw (disp>>16) if n = 4
end immed
continue
c(obj gla):
gb = getlong
error ("gla pos error", gb-ga) if gb # ga
load block
continue
c(obj glam):
gb = getlong
error ("glam pos error", gb-ga) if gb # ga
value = getlong; ! value
count = getlong; ! repeat count
size = getlong; ! bytes in object
if count*size > 15 start
! Worth doing as 'store repeated' type
stak (value)
stak (count)
need (1)
if size = 1 start
add (tir sto rb)
else if size = 2
add (tir sto rw)
else if size = 4
add (tir sto rl)
else
error ("Faulty glam size", size)
finish
ga = ga + count*size
else
start immed (count*size)
for n = 1, 1, count cycle
if size = 1 start
add (value)
else if size = 2
addw (value)
else if size = 4
addl (value)
else
error ("Faulty glam size", size)
finish
repeat
end immed
finish
continue
c(obj pdef): ! proc def
tag = getlong
get string (text)
spec (2_1010, 0,
def(tag)_ca, proc_mask); ! ep
spec (2_1010, 1, 0, 0); ! gla (ep_)
continue
c(obj pspec): ! proc spec
xno = getword
get string (text)
if ext used(xno) # 0 start; ! strong code
spec (2_1000, 0, 0, 0)
ext text(xno) = text
finish
continue
c(obj ddef): ! data def
gx = getlong
get string (text)
spec (2_1010, -1, gx, 0); ! Note -1 => special
continue
c(obj weak): ! weak ref
c(obj dspec): ! data ref
xno = getword
get string (text)
ext text(xno) = text
mode = 2_1000; mode = 2_1001 if ocode = obj weak
spec (mode, 0, 0, 0)
continue
c(obj ext ref):
xno = getword; ! External number
disp = getlong; ! Offset
get (reg); ! Base reg (+ indirect bit)?
stag (ext text(xno)); ! External address
if disp # 0 start
stak (disp); need (1); add (tir add)
finish
need (1); add (tir stopicr); ca = ca + 5
if reg&16 # 0 start
!indirect ref - won't work if absolute!!
need (16)
add (tir augrb); addl (-5); ! Go back to specifier byte
add (tir staub); add (16_FF); ! stack byte 16_FF = @L^X(PC)
add (tir stoub); ! store byte
add (tir augrb); addl (4); ! return to correct ca
finish
continue
c(obj reloc): ! relocate gla
! error ("Not PIC", 0) %if pic # 0
gb = getlong; gx = getlong
plug glap (glapp, gx, gb, tir stopidr)
continue
c(obj set): !set gla
cx = def(getlong)_ca; ! Switch label address
gb = getlong; ! Gla address to plug
plug glap (codep, cx+4, gb, tir stold)
continue
c(obj header):
get (nbase); ! base
tag = getword; ! tag
lim = getword
this line = getword
dump code (nbase, tag, def(lim)_ca)
continue
c(obj call):
tag = getlong
disp = def(tag)_ca-ca-2
start immed (5)
n = range (disp, 1)
if n = 1 start;
add (16_AF); add (disp)
else if n = 2
add (16_CF); addw (disp-1)
else
add (16_EF); addl (disp-3)
finish
end immed
continue
c(obj jump): ! jump <cond> <tag>
get (cond); tag = getword
cond = cond&15
disp = def(tag)_ca-ca-2
size = range (disp, 1)
start immed (8)
if cond = 0 start; !unconditional
if size = 1 start
add (brb); add (disp)
else if size = 2
add (brw); addw (disp-1)
else
add (jmp); add (16_EF); addl (disp-4)
finish
else; !conditional
if size = 1 start
add (branch(cond)); add (disp)
else if size = 2
add (branch(cond!!7)); add (3)
add (brw); addw (disp-3)
else
add (branch(cond!!7)); add (6)
add (jmp); add (16_EF); addl (disp-6)
finish
finish
end immed
continue
c(obj b lab): ! m/code byte label reference
c(obj w lab): ! " " " word " " " " " "
disp = def(getword)_ca-ca-1
start immed (2)
if ocode = obj w lab start; !word
addw (disp-1)
else; !byte
error ("branch overflow", disp) unless -128 <= disp <= 127
add (disp)
finish
end immed
continue
c(obj prim spec):
get (pno); set prim text (pno)
spec (2_1000, 0, 0, 0)
continue
c(obj prim ref):
get (pno); set prim text (pno)
if pno # proc enter prim start
start immed (1); add (jsb); end immed
finish
stag (text)
need (1); add (tir stopicr); ca = ca + 5
continue
c(obj line): ! line number
this line = getword
dump line if ldump # 0
repeat
c(obj term):!block end
if diagp_pa # 0 start
buff == diagp
start immed (1); add (0); end immed
finish
evword = getword; !events
if evword # 0 start; !events trapped
evlow = getword; !evlow
evep = getword; !evep
buff == codep; save = ca
select (evp)
start immed (16)
addl (evword); !ev list
addl (def(evlow)_ca); !from
addl (save); !to (ca)
addl (def(evep)_ca); !entry point
end immed
evp = evp + 16
finish
c(obj end):
bsel (n, diagp, old da)
bsel (n, linep, old la)
bsel (n, codep, old ca)
end
routine DUMP ALL CODE
select input tank (object)
procs = 0
dump code (0, 0, 0)
end
routine DEFINE PSECT (record(psect fm) name ps,
integer align, flags, size,
string(31) name)
own integer psect no = 0
set work (obj gsd)
add (gsd psc); ! P-sect def field
add (align); ! Align (as power of 2)
addw (flags); ! P-sect flags (rd,wrt,exe etc)
addl (size); ! Allocation in bytes
add string (0, name); ! Ident
ps = 0
ps_dump = 1; ps_type = obj tir; ps_bp = 1
ps_max = size
ps_index = psect no
psect no = psect no + 1
flush buff
buff == ps; ps_pa = -999; ! ensure SELECT happens...
select (0)
end
routine DUMP MODULE HEADER
string(31) temp
select output (object file)
set work (obj hdr); !header
add (hdr mhd); !module header record
add (0); !structure level
addw (max rec); !max record length
add string (0, module); !module name
add string (0, "V01.00"); !module version
temp = date . " " . time
length(temp) = length(temp) - 3; !remove milliseconds
add string (1, temp); !creation date
add string (1, "IMP is wonderful!"); !last patch!!
set work (obj hdr)
add (hdr lng); !language sub-header
add string (1, "VAX-11 Imp77 ".version)
end
routine DEFINE PSECTS
define psect (codep, quad, code flags, code size, code name)
define psect (glapp, quad, glap flags, glap size, glap name)
if diags # 0 start
define psect (diagp, quad, diag flags, diag size+2, diag name)
! add 2 to ensure 0 word at end...
else
diagp_dump = 0
finish
if ldump # 0 start
define psect (linep, quad, line flags, line size, line name)
!fill in length word
buff == linep; select (0)
start immed (2); addw (line size); end immed
else
linep_dump = 0
finish
end
routine INITIALISE
integer j
ext used(j) = 0 for j = 1, 1, max externals
select input tank (directives)
refs = 0; procs = 0; def(0) = 0
ca == codep_pa; ga == glapp_pa
end
routine SPEC INIT PROC
return if entry tag < 0 or init = 0
set work (obj gsd)
add (gsd sym); ! symbol entry
add (0); ! unknown data type
addw (2_1000); ! flags
add string (0, init proc); ! name
flush buff
end
routine PLUG PSECTS
buff == glapp; select (12); ! plug things into gla
! code psect base
need (50)
stpb (codep, 4); add (tir stold)
ga = ga + 4
! diags psect base
if diags # 0 start
stpb (diagp, 4)
else
stak (4)
finish
add (tir stold)
ga = ga + 4
! lines psect base
if ldump # 0 start
stpb (linep, 4)
else
stak (4)
finish
add (tir stold)
ga = ga + 4
start immed (10)
addw (0); ! null string
addl (proc tab(1)_diag ep)
addl (event base)
end immed
buff == codep; select (evp)
stak (0); add (tir stol)
if diags # 0 start
buff == diagp; select (diag size)
start immed (2); addw (0); end immed
finish
end
routine DUMP EOM
set work (obj eom)
add (0); ! Successful compilation
if entry tag >= 0 start
add (0)
addl (def(entry tag)_ca)
finish
flush buff
end
routine FLUSH BUFFERS
buff == codep; flush buff
buff == glapp; flush buff
buff == diagp; flush buff
buff == linep; flush buff
buff == workp; flush buff
end
routine REPORT INFO
integer stream
for stream = report, listing-report, listing cycle
continue if clog = 0 and stream = report
select output (stream)
print string ("Code"); write (codep_max-4, 1)
print string (" bytes Glap"); write (glapp_max, 1)
print string (" bytes Diags"); write (diagp_max+linep_max, 1)
print string (" bytes Total size")
write (codep_max-4+glapp_max+diagp_max+linep_max, 1)
print string (" bytes"); newline
repeat
end
routine TIME (routine R, string(15) name)
external integer function spec PAGEFAULTS
integer t, p
own integer called = 0
p = page faults; t = cputime
R
t = cputime - t; p = pagefaults - p
return if timing = 0
select output (report)
print string ("Pass 3 breakdown:") and newline if called = 0
called = 1
spaces (3)
print string (name); print symbol (':')
spaces (15-length(name)); space
if t >= 20 start
write (t, -5); print string ("ms, ")
else
print string ("negligible, ")
finish
write (p, -3); print string (" page fault")
print symbol ('s') if p # 1
newline
select output (object file)
end
! MAIN CODE
initialise
time (input directives, "Directive input")
time (stretch jumps, "Jump stretching")
dump module header
define psects
spec init proc
time (dump all code, "Code dumping")
plug psects
flush buffers
dump eom
report info
end
BEGIN
END
end of file