externalroutinespec exit alias "exit" (integer rc)
externalroutine{spec} getblock {%alias "GETBLOCK_JSB"} (integer len, bytename base)
end
externalintegerfunction{spec} getlong {%alias "GETLONG_JSB"}
result=0
end
externalintegerfunction{spec} getword {%alias "GETWORD_JSB"}
result=0
end
externalroutine{spec} get(integername n)
end
externalroutine{spec} put(integer n)
end
externalroutine{spec} putword(integer n)
end
externalroutine{spec} putlong(integer n)
end
externalroutine{spec} putblock(integer len, bytename b)
end
! Computer Science VAX-11 Imp77 Compiler Second Pass
! 23rd March 1981
!
! Mods by MT June/July 1981:
!
! - removed %const<>%name fault
! - fixed problem with definition of externals after %externally
! spec'ing them
! - fixed trouble with ++ and -- : introduction of VMAP
! - improved handling of 1-dimensional arrays (when checks off)
! - better code in general cases (eg. a(j+const); a(const) -> store ref)
! - generation of indexing (base[index]) in appropriate cases
! - fixed bug with moving records > 255 bytes from rec(*) name
! - generates error for untyped record moves
! - fixed general bug with moving/clearing records > 32K
! - improved record element access in several cases (save loading base)
! - ADDRESS, code in ASSEMBLE at C('n'): modified.
! - mod to LOAD to prefer 2-op operations where possible (but this
! should perhaps be removed when - if ever - remembering reg contents
! is implented, since useful information is deleted).
! - fixed (subtle) problem where turning off iovf checks after proc entry
! prevented suitable code to prevent traps on shifts, byte addition
! from being planted: control&16 # 0 => entry mask&iovf bit # 0
! - fixed bug where large quantities of data in gla made array header
! displacement wrong (var_header was %short, changed to %integer)
!
! August 81:
!
! - fixed %external..%array for cases where aref address not loaded
! into register - was losing XNO.....
!
! September 81:
! - extended %prims - skipsymbol/ch etc added
!
! October 81:
! - bug fix for "real = ¬integer" etc
! - prims extended: PRINTSTRING parameter not now copied to
! work string (but may already be there!)
! - proper assignment checks on string resolution
! - added $_X:: CHARNO (as perm call)
! - %for loop mods
! - constant-bound loops
! - checks for validity at compile-time, no perm-call
! - doesn't call %any perm for no-check case!!
! - string length checking (AT LAST!!!!)
! - checks on size of constants in operations: eg "byte = 257" fails
! at compile time
! - put in compiler-specific perm routines GET, GET WORD, PUT etc
! as JSB-type, for compiler speed..
!
! November 81:
! - outlawed other than plain %integer %for control variables!!
! - implemented READSYMBOL/CH for %strings
! - improved code for things like ++ (and effectively similar cases)
! - bug fixes for real constants, %for loops
!
! December 81:
! - fixed external refs to ensure PIC code generated (avoid P3
! having to plug reference) ie @external never generated...
! - fixed (obscure) bug in taking the address of a label
! - generates error for ++, -- on string(*), record(*)
!
! Known bugs:
!
! * %external %routine %spec x (%routine y)
! - corrupts next declaration
! (this is actually a pass 1 problem and should go away sometime)
! ? Meaning of %for j = x, 0, y %cycle ?
! ? Meaning of ADDR(arrayname), ADDR(array) ?
!
control 0
! Include common constants, specs 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)
end
external routine {%spec} SELECT OUTPUT TANK (integer n)
end
!%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
external routine PASS2 (integer icode, object, directives)
!
! Aborts: (* means solution %might be to turn up a size constant)
!
! 0 unimplemented feature
! 1 Operand: bad base register for operand
! 2 Operand: operation still pending on operand
! 3 Release: register not claimed
! 4 Hazard: bad operand form
! 5 Hazard: register activity inconsistent
! * 6 Descriptor: no free descriptors
! * 7 Descriptor: no free descriptor pointers
! * 8 Descriptor: stack overflow
! 9 Drop: descriptor not on using list
! 10 Set both: stack underflow
! 11 Pop lhs: stack underflow
! 12 Pop drop: stack underflow
! 13 Operand: invalid operand form
! * 14 Define var: var table overflow
! 15 Amap: cannot take address of object
! * 16 New label: no labels left
! 17 Operate: stack empty on unary operation
! 18 Operate: stack < 2 deep on binary
! 19 Cop: unexpected operation
! 20 For: non-integer control variable
! 21 Assemble: bad code item
! 22 Assemble: array in record bounds inside-out
! 23 Line bound: stack not empty
! 24 Line bound: using list not empty
! 25 Line bound: regs still active
! * 26 Assemble: var table overflow
! 27 Operand: cannot perform indexing
! 28 Operand: AP/FP/PC as register operand
! * 29 Work string: too many temp areas required
! 30 Load: 2nd reg for >> or REM is locked
! 31 Hazard: index reg usage inconsistent (hazarding index reg)
! 32 Load: cannot perform real op
! 33 Load: cannot perform integer op
! 34 Set cc: bad comparator specified
! 35 Scale index: invalid length for indexed addressing
! 36 Assemble: bad symbol after '~' (ie. not {A, B, C})
! 37 Load: bad register
! 38 Hazard: index register use inconsistent
! 39 Line bound: index reg still active
! 40 Claim: bad register for index
! 41 Release: " " " " " " " "
! 42 Release: released index reg is locked
! 43 Release: released index reg but no indexing active
! 44 Release: released index reg not claimed as index
! 45 Record sel: invalid form for base record
! 46 Address: bad form for indexed operand
! 47 Call: operation pending on READSYMBOL parameter
! 48 Set modulus: constant not %longreal %or %integer
!
!================================================================
!
! %diagnose significance
!
! diag bit: monitors:
! 1 = stack procedures
! 2 = load
! 4 = hazard/claim/release
! 8 = assign/array ref
! 16 = call/push
! 32 = address
! 64 = amap/vmap
! 128 = put code/operand
! 256 = operate
!
! 2048 = I-code main symbols
! 4096 = stack dump on MONITOR
! 8192 = %monitor on MONITOR
!
own integer original control
original control = control
own integer diag = 0
const integer mainrt = 1, mainfn = 2
! Size constants +++++++++++++++++++++ associated aborts
const integer max vars = 2000; ! 14, 26 : var table size
const integer max labels = 120; ! 16 : # active internal labs
const integer max depth = 16; ! 8 : depth of descr stack
const integer max stack = 25; ! 6, 7 : # in-use descriptors
const integer max work = 12; ! 29 : # active work strings
!register definition
const integer r0 = 1; !used in prim
const integer r1 = 2; !used in prim
const integer r2 = 3; !used in prim
const integer r3 = 4; !used in prim
const integer r4 = 5; !used in prim
const integer r5 = 6; !used in prim
const integer r6 = 7; !base register (level 1)
const integer r7 = 8; !base register (level 2)
const integer r8 = 9; !base register (level 3)
const integer r9 = 10; !base register (level 4)
const integer r10 = 11
const integer gla = 12; !r11 = gla base
const integer ap = 13; !argument pointer (r12)
const integer fp = 14; !frame pointer (lnb)
const integer sp = 15; !stack pointer (r14)
const integer pc = 16; !program counter (r15)
const integer any = 17; !any general register
const integer fpr0 = 18
const integer fpr2 = 19
const integer fpr4 = 20
const integer pending = 22; !spec pending
const short array actual reg (0 : 20) =
-1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
13, 14, 15, 0, 0, 2, 4
const short array reg mask (0 : 20) =
0, 0, 0, 4, 8, 16_10, 16_20, 16_40, 16_80,
16_100, 16_200, 16_400, 16_800, 0, 0, 0, 0, 0, 0,
16_c, 16_30
const integer iovf bit = 16_4000; ! Set in entry mask to enable IOVF trap
const byte array base reg (-1 : 6) =
ap, ap, r6, r7, r8, r9, ap, ap
!types and precisions
const integer integers = 16_10
const integer byte = 2; !unsigned byte
const integer short = 1; !signed halfword
const integer long = 5; !longinteger
const integer reals = 16_23, reall = 16_24, real bit = 16_20
const integer strings = 16_40, in work = 4
const integer records = 16_80
const integer null string = 24; !disp of null string in gla
!data forms
const integer jump = 0; !cond code for jump
const integer switch = 6
const integer recfm = 4
const integer proc bit = 16
const integer array bit = 32
const integer arrayname bit = 64
const integer indirect bit = 128
const integer constant = 0
const integer v in r = 1; !variable in register
const integer v in s = 2; !variable in store
const integer av in s = 3; !address of variable in store
const integer a in s = 4; !address in store (indirect)
const integer rec mod = 3; ! x in rec = x in s + rec mod
const integer v in rec = 5; !variable in record (+extra)
const integer av in rec = 6; !address of variable in record (+extra)
const integer a in rec = 7; !address in record (indirect+extra)
!form flags
const integer indexed = 1, { base[index] }
x defer = 2, {(with indexed) @base[index] - arrayname}
auto i = 4,
auto d = 8
const byte array fmap (0 : 15) =
0, vins, ains+indirect bit,
{null scalar name}
15, recfm, 0, switch,
{3 4 5 6}
procbit, vinr+procbit, vins+procbit, procbit,
{routine function map pred}
vins+arraybit, vins+arrayname bit,
{array arrayname}
ains+array bit+indirect bit,
{namearray}
ains+arrayname bit+indirect bit,
{namearrayname}
0
{null}
!operators
const integer not = 7
const integer neg = 8
const integer add = 9
const integer sub = 10
const integer bsub = 11
const integer bic = 12
const integer or = 13
const integer xor = 14
const integer lsh = 15
const integer rsh = 16
const integer div = 17
const integer bslh = 18
const integer brsh = 19
const integer bdiv = 20
const integer exp = 21
const integer rexp = 22
const integer rdiv = 23
const integer bexp = 24
const integer brexp= 25
const integer brdiv= 26
const integer mul = 27
const integer remy = 28
const integer brem = 29
!primitive routines
const integer prim rts = 26; ! number of last routine
const integer set dv = 1; ! A create dope vect on stack
const integer adec = 2; ! B declare array space
const integer test ass = 3; ! C %signal if unassigned
! %const %integer = 4; ! D set up %for block (old)
! %const %integer = 5; ! E V6 resolution
const integer check resolution = 6; ! F %signal if res fails
! %const %integer for test = 7; ! G test %for validity
const integer stop = 8; ! H %signal 0, 0, 0
! %const %integer smove = 9; ! I unused!!!!!
const integer for test = 10; ! J ** new %for test
const integer scomp = 11; ! K compare strings lexically
const integer monit = 12; ! L call diag routine
const integer proc enter = 13; ! M call proc param
const integer exp int = 14; ! N integer exponentiation
const integer exp real = 15; ! O real exponentiation
const integer signal = 16; ! P %signal
const integer arefn = 17; ! Q multi-dim array ref
const integer a ref = 18; ! R single dim array ref (check)
const integer sw jump = 19; ! S switch jump
const integer rch = 20; ! T read ch
const integer rsym = 21; ! U read symbol
const integer pch = 22; ! V print ch
const integer psym = 23; ! W print symbol
const integer char num = 24; ! X charno (checks range)
const integer test string ovf = 25; ! Y string length check
const integer resolution = 26; ! Z perform resolution
const byte array prim mask (1 : primrts) =
16_3C, 16_20, 16_00, 16_00, 16_3C,
16_00, 16_00, 16_00, 16_00, 16_00,
16_3C, 16_00, 16_00, 16_00, 16_3C,
16_00, 16_3C, 16_08, 16_00, 16_0C,
16_0C, 16_0C, 16_0C, 16_00, 16_00,
16_00
!opcode flag bits
const integer one bit = 16_0100, {one operand}
two bit = 16_0200, {two operand}
add bit = 16_0400, {add operation}
sub bit = 16_0800, {subtract operation}
addr bit = 16_1000, {address operation}
move bit = 16_2000, {move operation}
commute = 16_4000, {commutative op}
reversible = 16_8000 {order of operands unimportant}
const integer no short = 16_10000; ! use char instr in STRING3
const integer len check = 16_20000; ! check length on string op
const integer no ass chk = 16_40000 {omit string assigned check}
!opcodes
const integer movl = 1*8+move bit+one bit+two bit
const integer mnegl = 0*8
const integer mcoml = 3*8
const integer addl = 14*8+add bit+one bit+two bit+commute
const integer subl = 15*8+sub bit+one bit+two bit
const integer bicl = 18*8+two bit
const integer bisl = 19*8+two bit+commute
const integer xorl = 20*8+two bit+commute
const integer bitl = 21*8+commute+reversible
const integer mull = 16*8+two bit+commute
const integer divl = 17*8+two bit
const integer moval = 2*8+addr bit, movab = moval+2
const integer clrl = 6*8
const integer tstl = 29*8
const integer cmpl = 30*8, cmpd = cmpl+4, cmpw = cmpl+1
const integer calls = 0*8+7
const integer jsb = 1*8+7
const integer ret = 2*8+7
const integer sobgtr = 12*8+7
const integer ashq = 17*8+6
const integer ashl = 17*8+5
const integer ediv = 17*8+7
const integer incl = 12*8
const integer movzbl = 9*8, movzwl = 9*8+7
const integer movq = 1*8+5, movw = movl+1, movb = movl+2
const integer movd = 1*8+4, movf = 1*8+3
const integer pushal = 5*8 + addr bit
const integer pushl = 4*8
const integer movc3 = 3*8+6, cmpc3 = 30*8+6
const integer movc5 = 3*8+7
const integer mnegd = mnegl+4
const integer addd = addl+4, addb2 = addl+2
const integer subd = subl+4
const integer muld = mull+4
const integer divd = divl+4
const integer cvtlw = 7*8+1
const integer cvtld = 7*8+4
const integer movpsl = 4*8+7
const integer extzv = 10*8+7, extv = 11*8+7
! sundry actual op-codes
const integer bicpsw vbit = 16_20B9; ! Clear V-bit in PSW
const integer bispsw vbit = 16_20B8; ! Set V-bit in PSW
const integer bgeq = 16_18; ! Branch if >= (0), for |X|
const integer three op = 8*8
record format varfm (c
integer disp, length, extra, zeroad, header,
short format, xno,
byte type, form, base, flags)
record format stackfm (c
(integer disp, mantissa or longreal lrval),
integer extra, length, header,
short format, xno,
byte type, form, base, oper, flags, index, iscale,
record(stackfm) name link )
!data formats
record format dfm (record(stackfm) name d, record(dfm) name link)
record format labelfm (short id, tag)
own integer specs = 0; !size of spec area (code)
own integer ca = 0; !current code address
own integer ga = 0; !current gla address
own integer cp = 0; !code buffer pointer
own integer gp = 0; !gla buffer pointer
own integer diag lines = 0; !size of line info
own integer diag size = 0; !size of diag tables
own integer sym = 0; !current code symbol
own integer code = 0; !current coded code symbol
own integer errors = 0; !total errors
own integer line error = 0; !flag for errors on this line
own integer current line = 0
own integer stp = 0
own integer data size = 0
own integer ivbit state = 0; ! for overflow masking
own integer entry mask = 0; !proc entry mask
own integer frame = 0; !current stack frame limit
own integer last local; !local limit for unass check
own integer level = -1
own integer unsigned = 0
own integer invert = 0; !condition inversion flag
own integer uncond jump = 0
own integer last movc3 = -1; !address of MOVC3
own integer gmode = 0; !parameter-format flag
own integer gtype = 0; ! do.
own integer last ref = 0
own integer evno = 0; !event trap counter
own integer ownval, mantissa; !***Own and order critical***
own integer discard
own integer index regs = 0
own integer active regs = 0
integer parms = max vars+1; !start of parameter area
integer local = 0; !local base register
integer otype, potype = 0
integer decl; !last descriptor index
integer owntype, ownform
integer spec
integer vlb, vub; !vector bounds
integer j, n
const record(*) name null == 0
record(stackfm) name lhs, rhs
record(stackfm) name desc asl
record(dfm) name dasl
record(dfm) using
record(varfm) name decvar
record(varfm) name formal, actual
own byte array code buffer (1 : 128)
own byte array gla buffer (1 : 128)
own record(varfm) begin
external string(max ident) spec entryname
own string(255) text; !for string constants
own string(max ident) external name, alias, var name
own record(stackfm) array regv (r0 : fpr4)
own integer array activity (0 : fpr4) = 0(*)
own integer array used (0 : fpr4) = 0(*)
own byte array indx (r0 : r10) = 0(*)
record(stackfm) head, dope, zeroth
record(stackfm) zero v
record(stackfm) gla work; !used for clearing records
record(stackfm) spv; ! => -(SP) operand
record(stackfm) name array stacked (1 : max depth)
record(dfm) array dlist (0 : max stack)
record(stackfm) array stak (0 : max stack)
record(labelfm) array labels (1 : max labels)
record(varfm) array var (0 : max vars)
const short array op map (add : brem) =
addl+three op, subl+three op, 0, bicl+three op,
bisl+three op, xorl+three op, 0, 0,
divl+three op, 0(9), mull+three op, 0(2)
!0 = ok, 1 = same, 2 = never
const byte array trans (add : brem) =
0, 0,
0, 2, 1, 1,
2, 2, 2, 2,
2, 2, 2, 2,
2, 2, 2, 2,
1, 2, 2
const byte array comm (add : brem) =
1, 0,
0, 0, 1, 1,
0, 0, 0, 0,
0, 0, 0, 0,
0, 0, 0, 0,
1, 0, 0
const integer no null = 2
! values of RH for which LH oper RH = LH: 2 => no value
const integer array rnull op (add : brem) =
0, 0,
0, 0, 0, 0,
0, 0, 1, 0,
2, 2, 1, 1,
1, 2, 2, 2,
1, 2, 2
! values of LH for which LH oper RH = RH: 2 => no value
const integer array lnull op (add : brem) =
0, 2,
0, 2, 0, 0,
2, 2, 2, 2,
2, 2, 2, 2,
2, 2, 2, 2,
1, 2, 2
! %const %byte %array op real (not : brem) =
! 0, 1, 1, 1,
! 0, 0, 0, 0,
! 0, 0, 0, 0,
! 0, 0, 0, 1,
! 1, 0, 0, 0,
! 1, 0, 0
const string(4) array op name (not : brem) =
"U¬", "U-", "+", "-",
"B-", "BIC", "!", "!!",
"<<", ">>", "//", "B<<",
"B>>", "B/", "^^", "^",
"/", "B^^", "B^", "B/",
"*", "REM", "BREM"
!opcode table
const byte array op code (0 : 31*8-1) =
16_ce, 16_ae, 16_8e, 16_52, 16_72, 0, 0, 16_fb,
! 0 mnegl mnegw mnegb mnegf mnegd - - calls
16_d0, 16_b0, 16_90, 16_50, 16_70, 16_7d, 0, 16_16,
! 1 movl movw movb movf movd movq - jsb
16_de, 16_3e, 16_9e, 16_de, 16_7e, 16_7e, 0, 16_04,
! 2 moval movaw movab movaf movad movaq - ret
16_d2, 16_b2, 16_92, 0, 0, 0, 16_28, 16_2c,
! 3 mcoml mcomw mcomb - - - movc3 movc5
16_dd, 0, 0, 0, 0, 0, 0, 16_dc,
! 4 pushl - - - - - - movpsl
16_df, 16_3f, 16_9f, 16_df, 16_7f, 16_7f, 0, 0,
! 5 pushal pushaw pushab pushaf pushad pushaq - -
16_d4, 16_b4, 16_94, 16_d4, 16_7c, 16_7c, 0, 0,
! 6 clrl clrw clrb clrf clrd clrq - -
16_d0, 16_f7, 16_90, 16_4e, 16_6e, 0, 0, 0,
! 7 movl cvtlw movb cvtlf cvtld - - -
16_32, 16_b0, 16_90, 16_4d, 16_6d, 0, 0, 0,
! 8 cvtwl movw movb cvtwf cvtwd - - -
16_9a, 16_9b, 16_90, 16_4c, 16_6c, 0, 0, 16_3c,
! 9 movzbl movzbw movb cvtbf cvtbd - - movzwl
16_4a, 16_49, 16_48, 16_50, 16_56, 0, 16_4b, 16_ef,
!10 cvtfl cvtfw cvtfb movf cvtfd - cvtrfl extzv
16_6a, 16_69, 16_68, 16_76, 16_70, 0, 16_6b, 16_ee,
!11 cvtdl cvtdw cvtdb cvtdf movd - cvtrdl extv
16_d6, 16_b6, 16_96, 0, 0, 0, 0, 16_f5,
!12 incl incw incb - - - - sobgtr
16_d7, 16_b7, 16_97, 0, 0, 0, 0, 0,
!13 decl decw decb - - - - -
16_c0, 16_a0, 16_80, 16_40, 16_60, 0, 0, 0,
!14 addl2 addw2 addb2 addf2 addd2 - - -
16_c2, 16_a2, 16_82, 16_42, 16_62, 0, 0, 0,
!15 subl2, subw2, subb2, subf2, subd2 - - -
16_c4, 16_a4, 16_84, 16_44, 16_64, 0, 0, 0,
!16 mull2 mulw2 mulb2 mulf2 muld2 - - -
16_c6, 16_a6, 16_86, 16_46, 16_66, 16_78, 16_79, 16_7b,
!17 divl2 divw2 divb2 divf2 divd2 ashl ashq ediv
16_ca, 16_aa, 16_8a, 0, 0, 0, 0, 0,
!18 bicl2 bicw2 bicb2 - - - - -
16_c8, 16_a8, 16_88, 0, 0, 0, 0, 0,
!19 bisl2 bisw2 bisb2 - - - - -
16_cc, 16_ac, 16_8c, 0, 0, 0, 0, 0,
!20 xorl2 xorw2 xorb2 - - - - -
16_d3, 16_b3, 16_93, 0, 0, 0, 0, 0,
!21 bitl bitw bitb - - - - -
16_c1, 16_a1, 16_81, 16_41, 16_61, 0, 0, 0,
!22 addl3 addw3 addb3 addf3 addd3 - - -
16_c3, 16_a3, 16_83, 16_43, 16_63, 0, 0, 0,
!23 subl3 subw3 subb3 subf3 subd3 - - -
16_c5, 16_a5, 16_85, 16_45, 16_65, 0, 0, 0,
!24 mull3 mulw3 mulb3 mulf3 muld3 - - -
16_c7, 16_a7, 16_87, 16_47, 16_67, 0, 0, 0,
!25 divl3 divw3 divb3 divf3 divd3 - - -
16_cb, 16_ab, 16_8b, 0, 0, 0, 0, 0,
!26 bicl3 bicw3 bicb3 - - - - -
16_c9, 16_a9, 16_89, 0, 0, 0, 16_b9, 16_b8,
!27 bisl3 bisw3 bisb3 - - - bicpsw bispsw
16_cd, 16_ad, 16_8d, 0, 0, 0, 0, 0,
!28 xorl3 xorw3 xorb3 - - - - -
16_d5, 16_b5, 16_95, 16_53, 16_73, 0, 0, 0,
!29 tstl tstw tstb tstf tstd - - -
16_d1, 16_b1, 16_91, 16_51, 16_71, 16_71, 16_29, 16_2d
!30 cmpl cmpw cmpb cmpf cmpd cmpd cmpc3 cmpc5
!bit significance:
const integer check1 = 2_0000 0001,
check2 = 2_0000 0010,
check3 = 2_0000 0100,
move check = 2_0000 1000
const byte array operand bits (0 : 255) =
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
! 0 halt nop rei bpt ret rsb
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
! 6 ldpctx svpctx cvtps cvtsp index crc
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
! 12 prober probew insque remque bsbb brb
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
! 18 bneq beql bgtr bleq jsb jmp
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
! 24 bgeq blss bgtru blequ bvc bvs
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
! 30 bgequ blssu addp4 addp6 subp4 subp6
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
! 36 cvtpt mulp cvttp divp movc3 cmpc3
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
! 42 scanc spanc movc5 cmpc5 movtc movtuc
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
! 48 bsbw brw cvtwl cvtwb movp comp3
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
! 54 cvtpl cmpp4 editpc matchc locc skpc
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0011,2_0000 0011,
! 60 movzwl acbw movaw pushaw addf2 addf3
2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,
! 66 subf2 subf3 mulf2 mulf3 divf2 divf3
2_0000 0001,2_0000 0001,2_0000 0001,2_0000 0001,2_0000 0000,2_0000 0000,
! 72 cvtfb cvtfw cvtfl cvtrfl cvtbf
2_0000 0001,2_0000 0000,2_0000 1001,2_0000 0011,2_0000 0001,2_0000 0001,
! 78 cvtlf acbf movf cmpf mnegf tstf
2_0000 0000,2_0000 0000,2_0000 0001,2_0000 0000,2_0000 0000,2_0000 0000,
! 84 emodf polyf cvtfd adawi
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
! 90
2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,
! 96 addd2 addd3 subd2 subd3 muld2 muld3
2_0000 0011,2_0000 0011,2_0000 0001,2_0000 0001,2_0000 0001,2_0000 0001,
!102 divd2 divd3 cvtdb cvtdw cvtdl cvtrdl
2_0000 0000,2_0000 0000,2_0000 0001,2_0000 0000,2_0000 1001,2_0000 0001,
!108 cvtbd cvtwd cvtld acbd movd cmpd
2_0000 0001,2_0000 0001,2_0000 0000,2_0000 0000,2_0000 0001,2_0000 0000,
!114 mnegd tstd emodd polyd cvtdf
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!120 ashl ashq emul ediv clrq movq
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!126 movaq pushaq addb2 addb3 subb2 subb3
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!132 mulb2 mulb3 devb2 divb3 bisb2 misb3
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!138 bicb2 bicb3 xorb2 xorb3 mnegb caseb
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!144 movb cmpb mcomb bitb clrb tstb
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!150 incb decb cvtbl cvtbw movzbl movzbw
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!156 rotl acbb movab pushab addw2 addw3
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!162 subw2 subw3 mulw2 mulw3 divw2 divw3
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!168 bisw2 bisw3 bicw2 bicw3 xorw2 xorw3
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!174 mnegw casew movw cmpw mcomw bitw
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!180 clrw tstw incw decw bispsw bicpsw
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!186 popr pushr chmk chme chms chmu
2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,
!192 addl2 addl3 subl2 subl3 mull2 mull3
2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,
!198 divl2 divl3 bisl2 bisl3 bicl2 bicl3
2_0000 0011,2_0000 0011,2_0000 0001,2_0000 0000,2_0000 1001,2_0000 0011,
!204 xorl2 xorl3 mnegl casel movl cmpl
2_0000 0001,2_0000 0011,2_0000 0000,2_0000 0001,2_0000 0001,2_0000 0001,
!210 mcoml bitl clrl tstl incl decl
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0001,
!216 adwc sbwc mtpr mfpr movpsl pushl
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!222 moval pushal bbs bbc bbss bbcs
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!228 bbsc bbcc bbssi bbcci blbs blbc
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!234 ffs ffc cmpv cmpzv extv extzv
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!240 insv acbl aoblss aobleq sobgeq sobgtr
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
!246 cvtlb cvtlw ashp cvtlp callg calls
2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000
!252 xfc
!diagnostic tables
const string(3)array reg name (0 : 20) =
"???", " R0", " R1", " R2", " R3", " R4", " R5", " R6", " R7",
" R8", " R9", "R10", "GLA", " AP", " FP", " SP", " PC", "Any",
" F0", " F2", " F4"
const string(6) array op mnem (0 : 255) =
"HALT", "NOP", "REI", "BPT", "RET", "RSB",
"LDPCTX", "SVPCTX", "CVTPS", "CVTSP", "INDEX", "CRC",
"PROBER", "PROBEW", "INSQUE", "REMQUE", "BSBB", "BRB",
"BNEQ", "BEQL", "BGTR", "BLEQ", "JSB", "JMP",
"BGEQ", "BLSS", "BGTRU", "BLEQU", "BVC", "BVS",
"BGEQU", "BLSSU", "ADDP4", "ADDP6", "SUBP4", "SUBP6",
"CVTPT", "MULP", "CVTTP", "DIVP", "MOVC3", "CMPC3",
"SCANC", "SPANC", "MOVC5", "CMPC5", "MOVTC", "MOVTUC",
"BSBW", "BRW", "CVTWL", "CVTWB", "MOVP", "COMP3",
"CVTPL", "CMPP4", "EDITPC", "MATCHC", "LOCC", "SKPC",
"MOVZWL", "ACBW", "MOVAW", "PUSHAW", "ADDF2", "ADDF3",
"SUBF2", "SUBF3", "MULF2", "MULF3", "DIVF2", "DIVF3",
"CVTFB", "CVTFW", "CVTFL", "CVTRFL", "CVTBF", "?????",
"CVTLF", "ACBF", "MOVF", "CMPF", "MNEGF", "TSTF",
"EMODF", "POLYF", "CVTFD", "?????", "ADAWI", "?????",
"?????", "?????", "?????", "?????", "?????", "?????",
"ADDD2", "ADDD3", "SUBD2", "SUBD3", "MULD2", "MULD3",
"DIVD2", "DIVD3", "CVTDB", "CVTDW", "CVTDL", "CVTRDL",
"CVTBD", "CVTWD", "CVTLD", "ACBD", "MOVD", "CMPD",
"MNEGD", "TSTD", "EMODD", "POLYD", "CVTDF", "?????",
"ASHL", "ASHQ", "EMUL", "EDIV", "CLRQ", "MOVQ",
"MOVAQ", "PUSHAQ", "ADDB2", "ADDB3", "SUBB2", "SUBB3",
"MULB2", "MULB3", "DEVB2", "DIVB3", "BISB2", "BISB3",
"BICB2", "BICB3", "XORB2", "XORB3", "MNEG", "CASEB",
"MOVB", "CMPB", "MCOMB", "BITB", "CLRB", "TSTB",
"INCB", "DECB", "CVTBL", "CVTBW", "MOVZBL", "MOVZBW",
"ROTL", "ACBB", "MOVAB", "PUSHAB", "ADDW2", "ADDW3",
"SUBW2", "SUBW3", "MULW2", "MULW3", "DIVW2", "DIVW3",
"BISW2", "BISW3", "BICW2", "BICW3", "XORW2", "XORW3",
"MNEGW", "CASEW", "MOVW", "CMPW", "MCOMW", "BITW",
"CLRW", "TSTW", "INCW", "DECW", "BISPSW", "BICPSW",
"POPR", "PUSHR", "CHMK", "CHME", "CHMS", "CHMU",
"ADDL2", "ADDL3", "SUBL2", "SUBL3", "MULL2", "MULL3",
"DIVL2", "DIVL3", "BISL2", "BISL3", "BICL2", "BICL3",
"XORL2", "XORL3", "MNEGL", "CASEL", "MOVL", "CMPL",
"MCOML", "BITL", "CLRL", "TSTL", "INCL", "DECL",
"ADWC", "SBWC", "MTPR", "MFPR", "MOVPSL", "PUSHL",
"MOVAL", "PUSHAL", "BBS", "BBC", "BBSS", "BBCS",
"BBSC", "BBCC", "BBSSI", "BBCCI", "BLBS", "BLBC",
"FFS", "FFC", "CMPV", "CMPZV", "EXTV", "EXTZV",
"INSV", "ACBL", "AOBLSS", "AOBLEQ", "SOBGEQ", "SOBGTR",
"CVTLB", "CVTLW", "ASHP", "CVTLP", "CALLG", "CALLS",
"XFC", "????"(*)
routine spec FLUSH CODE
routine spec HAZARD (integer reg)
routine spec CLAIM (integer reg)
routine spec RELEASE (integer reg)
routine spec PRIM (integer n)
integer function spec SCALE TYPE (integer length)
record(stackfm) map spec LITERAL (integer n)
record(stackfm) map spec TEMP (integer size)
!******** initialisation *********
regv(r0)_base = r0; regv(r0)_type = integers; regv(r0)_form=vinr
regv(r1)_base = r1; regv(r1)_type = integers; regv(r1)_form=vinr
regv(r2)_base = r2; regv(r2)_type = integers; regv(r2)_form=vinr
regv(r3)_base = r3; regv(r3)_type = integers; regv(r3)_form=vinr
regv(r4)_base = r4; regv(r4)_type = integers; regv(r4)_form=vinr
regv(r5)_base = r5; regv(r5)_type = integers; regv(r5)_form=vinr
regv(r6)_base = r6; regv(r6)_type = integers; regv(r6)_form=vinr
regv(r7)_base = r7; regv(r7)_type = integers; regv(r7)_form=vinr
regv(r8)_base = r8; regv(r8)_type = integers; regv(r8)_form=vinr
regv(r9)_base = r9; regv(r9)_type = integers; regv(r9)_form=vinr
regv(r10)_base= r10; regv(r10)_type= integers; regv(r10)_form=vinr
regv(gla)_base= gla; regv(gla)_type= integers; regv(gla)_form=vinr
regv(fp)_base = fp; regv(fp)_type = integers; regv(fp)_form=vinr
regv(ap)_base = ap; regv(ap)_type = integers; regv(ap)_form=vinr
regv(sp)_base = sp; regv(sp)_type = integers; regv(sp)_form=vinr
regv(pc)_base = pc; regv(pc)_type = integers; regv(pc)_form=vinr
regv(fpr0)_base=fpr0; regv(fpr0)_type = reall; regv(fpr0)_form = vinr
regv(fpr2)_base=fpr2; regv(fpr2)_type = reall; regv(fpr2)_form = vinr
regv(fpr4)_base=fpr4; regv(fpr4)_type = reall; regv(fpr4)_form = vinr
zerov = 0
zerov_type = integers; zerov_form = constant
gla work = 0
gla work_type = integers; gla work_form = v in s
gla work_base = gla
spv = 0
spv_type = integers; spv_form = v in s
spv_base = sp; spv_flags = auto d
zeroth = 0
zeroth_type = integers; zeroth_form = v in s
dope = 0
dope_base = gla; dope_type = integers; dope_form = v in s
head = 0
head_type = integers; head_form = v in s
select input tank (icode); select output tank (object)
select output (diag stream)
var(0) = 0
activity(pc) = -1
activity(sp) = -1
activity(fp) = -1
activity(ap) = -1
activity(gla) = -1
activity(0) = -1
for j = 0, 1, max stack-1 cycle
stak(j)_link == stak(j+1)
dlist(j)_link == dlist(j+1)
repeat
stak(max stack)_link == null
dlist(max stack)_link == null
desc asl == stak(0)
dasl == dlist(0)
using_link == null
decvar == begin
!********************************************
! Utilities
predicate ZERO (record(stackfm) name v)
! check descriptor for zero
false unless v_form = constant and v_type&(integers!reals) # 0
false unless v_disp = 0 and v_oper = 0
false if v_type = reall and v_mantissa # 0
true
end
predicate CONST (record(stackfm) name v)
! check descriptor for a constant value (integer)
true if v_form = constant and v_oper = 0 and v_type&integers # 0
false
end
predicate SAME (record(stackfm) name a, b)
switch f (constant : a in rec)
false unless a_oper = 0 = b_oper c
and a_flags&indexed = 0 = b_flags&indexed c
and a_type = b_type c
and a_form = b_form c
and a_xno = b_xno c
and a_flags = b_flags
if a_type&records # 0 start
false unless a_format = b_format
finish
-> f (a_form&7)
f(constant):
true if a_type&integers # 0 and a_disp = b_disp
true if a_type&real bit # 0 and a_lrval = b_lrval
false
f(v in rec):
f(a in rec):
f(av in rec):
false unless a_extra = b_extra
f(v in s):
f(a in s):
f(av in s):
false unless a_disp = b_disp
f(v in r):
false unless a_base = b_base
true
end
predicate FLOATING (record(stackfm) name v)
true if v_type&real bit # 0
false if v_oper <= neg
true if v_oper = rdiv or v_oper = rexp
false if v_link_type&real bit = 0
true
end
predicate IN FREE REG (record(stackfm) name v)
! true if v is in a useable register
false unless v_form = v in r
false unless activity(v_base) = 1
true
end
!diagnostics
string(15) function TYPE STR (integer type, max)
string(15) res = ""
integer i
const byte array tbits (0 : 9) =
0, records, strings, strings!in work, reall, reals,
integers+short, integers+long, integers+byte, integers
const string(15) array tstr (0 : 9) =
"no-type", "record ", "string ", "w/string", "l-real ",
"real ","shortinteger", "long integer", "byte integer",
"integer "
type = type & 16_FF
for i = 0, 1, 9 cycle
res = tstr(i) and exit if type = tbits(i)
repeat
res = "type=" . itos(type,-3) if res = ""
length(res) = max if length(res) > max
result = res
end
routine PREC (record(stackfm) name v)
integer op, val
const string(9) array fmstr (0 : 7) =
"constant ", "V-in-R ", "V-in-S ", "AV-in-S ",
"A-in-S ", "V-in-Rec ", "AV-in-Rec", "A-in-Rec "
routine NON ZERO (integer n, string(15) m)
if n # 0 start
print string (m)
write (n, 0)
finish
end
if v == null start
print string ("(NULL!!!!!)")
newline
return
finish
if v_form = 15 start
print string ("Label")
spaces (17)
else
print string (fmstr(v_form&7))
space; print string (type str (v_type, 8))
space; val = v_form & (¬15)
if val&arrayname bit # 0 then print string ("AN") c
else if val&proc bit # 0 then print string ("PR") c
else spaces (2)
finish
space; write (v_mantissa, 5)
print symbol ('@') if v_flags&(indexed!xdefer) = indexed!xdefer
write (v_disp, 5)
if v_form # constant start
print symbol ('-') if v_flags&autod # 0 and v_disp = 0
printsymbol ('(')
print string (reg name(v_base))
printsymbol (')')
print symbol ('+') if v_flags&autoi # 0 and v_disp = 0
if v_flags&indexed # 0 start
print symbol ('[')
print string (reg name(v_index))
print symbol (']')
write (v_iscale, 0); space
finish
if v_form >= v in rec start
print string (": ")
write (v_extra, 0)
finish
finish
non zero (v_header, " hdr=")
non zero (v_xno, " xno=")
print string (" L="); write (v_length,0)
op = v_oper
if op # 0 start
print string (" oper=")
if not <= op <= brem start
print symbol ('"')
print string (op name(op))
print symbol ('"')
if op > neg start
newline; spaces (13)
prec (v_link)
return
finish
else
write (op, 0)
finish
finish
newline
end
routine STACK DUMP
integer sp = stp
print string ("Stack:")
if sp <= 0 start
print string (" empty")
newline
else
newline
while sp > 0 cycle
write (sp, 2); spaces (10)
prec (stacked(sp)); sp = sp - 1
repeat
finish
end
routine MON REG (string(20) s, integer r)
print string (s); print symbol (':')
spaces (11 - length(s))
print string (reg name(r))
newline
end
routine MONITOR (record(stackfm) name v, string(15) s)
print string (s)
printsymbol (':')
spaces (12-length(s))
prec (v)
stack dump if diag&4096 # 0
monitor if diag&8192 # 0
end
routine SHOW REGS
integer reg
print string ("Register activity: "); newline
print string (" R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 F0 F2 F4")
newline
for reg = r0, 1, r10 cycle
if activity(reg) < 0 start
print string (" L")
else
write (activity(reg), 3)
finish
repeat
for reg = fpr0, 1, fpr4 cycle
if activity(reg) < 0 then print string (" L") c
else write (activity(reg), 3)
repeat
newline
print string ("[]")
write (indx(r0), -2)
write (indx(reg), 3) for reg = r1, 1, r10
newline
end
routine ABORT (integer n)
!report catastrophic failure and stop
flush code
select output (0)
newline
print string ("***Pass 2 fails ")
write (n, 0)
print string (" at line ")
write (current line, 0)
newlines (2)
show regs; newline
stack dump; newline
print string ("Using:")
if using_link == null start
print string (" empty")
newline
else
newline
while using_link ## null cycle
spaces (13)
prec (using_link_d)
using_link == using_link_link
repeat
finish
newline
monitor
exit (16_1000002C) {1000002c is SS$_ABORT with the inhibit message bit set - could just use EXIT_FAILURE}
stop; ! we don't come back - let pass 1/2 know..
end
routine ERROR (integer sym, string(127) s)
own integer erred = 0
integer st = report
return if line error # 0
line error = 1
cycle
select output (st)
if erred = 0 start
print string ("Pass 2:")
newline
finish
if sym = '!' start
print string ("**** Fatal error at line ")
write (current line, 0)
print symbol (':')
else
print symbol (sym)
write (current line, 4)
finish
spaces (2); print string (s)
newline
exit if st # report
st = diag stream
repeat
exit (fatal) if sym = '!'
erred = 1
errors = errors + 1 if sym # '?'
end
integer function NEW TAG
own integer tag = 0
tag = tag + 1
result = tag
end
!code planting routines
routine SET LINE
own integer last line = 0
return if command & 8 = 0
return if last line = current line or current line = 0
last line = current line
diag lines = diag lines + 6
put (obj line); put word (current line)
end
routine FLUSH CODE
return if cp = 0
set line
put (obj code)
put (cp)
put block (cp, codebuffer(1))
cp = 0
end
routine PUT NUMBER BYTE (integer n)
cp = cp + 1
code buffer(cp) = n&255
flush code if cp > 120
ca = ca + 1
end
routine PUT CODE (integer op)
op = op&255
put number byte (op)
if diag&128 # 0 start
print string ("Op code = ")
print string (op mnem(op))
newline
finish
end
routine WORD (integer n)
shortinteger(addr(codebuffer(cp+1))) = n
cp = cp + 2
flush code if cp > 120
ca = ca + 2
end
routine LONGWORD (integer n)
integer(addr(codebuffer(cp+1))) = n
cp = cp + 4
flush code if cp > 120
ca = ca + 4
end
routine FLUSH GLA
return if gp = 0
put (obj gla)
put long (ga-gp)
put (gp)
put block (gp, gla buffer(1))
gp = 0
end
routine INIT GLA (integer count, size, val)
flush gla
put (obj glam)
put long (ga)
put long (val)
put long (count)
put long (size)
ga = ga + size*count
end
routine GBYTE (integer v)
gp = gp + 1; ga = ga + 1
gla buffer(gp) = v&255
flush gla if gp > 120
end
routine GWORD (integer v)
shortinteger(addr(glabuffer(gp+1))) = v
gp = gp + 2; ga = ga + 2
flush gla if gp > 120
end
routine GLONGWORD (integer v)
integer(addr(glabuffer(gp+1))) = v
gp = gp + 4; ga = ga + 4
flush gla if gp > 120
end
routine GFIX (integer mask)
gbyte (0) while ga&mask # 0
end
integer function SCALE TYPE (integer len)
result = byte if len = 1; ! byte
result = short if len = 2; ! word
result = 0 if len = 4; ! longword
result = long if len = 8; ! quadword (not double)
result = -1
end
integer function CTYPE (integer i)
! Given an integer value, returns the type
! code required to contain this value.
! Note that this applies to IMP-type ranges
! ie. byte 0:255, NOT -128:127
! result -1 means that the value may be contained
! in a short literal operand (type irrelevant)
result = -1 if 0 <= i <= 63
result = byte if 0 <= i <= 255
result = short if ¬16_7FFF <= i <= 16_7FFF
result = 0 {int}
end
integer function MSIZE (integer val)
! Returns the number of bytes required to
! hold an integer constant of value 'val'
! Note: value interpreted as machine signed
! value.
! (0 => short lit OK)
result = 0 if 0 <= val <= 63; ! Short lit
result = 1 if -128 <= val <= 127
result = 2 if ¬16_7FFF <= val <= 16_7FFF
result = 4
end
predicate FITS (integer val, type)
! True if the value val can be held
! in an object of type 'type' (IMP-types)
integer vtype
type = type&7
vtype = ctype (val)
true if vtype < 0; ! Short lit : OK
true if type = 0; ! integer - OK
true if type = short and vtype # 0
true if type = byte = vtype
false
end
integer function SHORT LITERAL (record(stack fm) name v)
! returns byte operand if v can be held as short lit,
! otherwise -1
if v_form = constant and v_type&(integers!realbit) # 0 start
if v_type&integers # 0 start
result = v_disp if 0 <= v_disp <= 63
else if v_mantissa = 0 and
v_disp&16_FFFFFC0F = 16_00004000
result = v_disp>>4&2_111 111
finish
finish
result = -1
end
routine OPERAND (record(stackfm) name v)
integer base, disp, abase, mod
integer index, size, val, err
switch f (constant : a in rec)
monitor (v, "Operand") if diag&128 # 0
mod = 0
disp = v_disp
abase = v_base
abort (28) if v_form = v in r and
(abase = pc or abase = fp or abase = ap)
if abase = local start
abase = fp
abase = ap and disp = disp - 60 if disp > 0; !parameter
finish
abort (1) if abase = 0 and v_form # constant and v_form # v in s
abort (2) if v_oper # 0
base = actual reg(abase)
entry mask = entry mask ! regmask(abase) if v_form = v in r
if v_flags&indexed # 0 start
index = v_index
abort (27) if index = 0 or index = pc or
index = v_base or v_form # v in s
if v_flags&xdefer # 0 start; ! @base[index]
abort (27) if base < 0
base = base ! 16
finish
put number byte (16_40+index-1)
release (index!128)
finish
-> f (v_form)
f(constant):
val = short literal (v)
if val >= 0 start; ! short literal
put number byte (val)
else if v_type&real bit # 0
put number byte (16_8f)
longword (disp)
longword (v_mantissa) if v_type = reall
else; !use immediate
put number byte (16_8F); !(pc)+
unless fits (disp, v_type) start
err = '*'
err = '?' if control&ovf check = 0; ! Warn only
error (err, "value " . itos(disp,0) . " overflows " . c
type str(v_type&(integers+7), 15))
finish
if v_type = integers start
longword (disp)
else if v_type = short+integers
word (disp)
else if v_type = byte+integers
put number byte (disp)
finish
finish
return
f(v in r):
put number byte (16_50+base); ! register
return
f(a in s):
base = base ! 16; ! to overflow into mode field
f(v in s):
if base < 0 start; ! %const<*>%name, object(const adr)
put number byte (16_9f); !@#
longword (disp)
return
finish
release (v_base)
if v_xno # 0 start
flush code
put (obj ext ref)
put word (v_xno); put long (disp); ca = ca + 5
put (base)
return
finish
! check if param of higher level
if r6 <= abase <= r9 and disp > 60 and abase < local start
flush code
put (obj modd)
mod = 1
finish
size = msize (disp)
if size <= 1 start; !byte displacement
if disp = 0 and base&16 = 0 start; !register deferred
if v_flags&auto d # 0 start
put number byte (16_70+base)
else if v_flags&auto i # 0
put number byte (16_80+base)
else
put number byte (16_60+base)
finish
else
put number byte (16_A0+base)
put number byte (disp)
finish
else if size = 2
put number byte (16_c0+base)
word (disp)
else
put number byte (16_e0+base)
longword (disp)
finish
flush code if mod # 0
return
f(*):abort (13)
end
routine REMOVE (record(stackfm) name v)
release (v_base) if v_form # v in r
release (v_index!128) if v_flags&indexed # 0
end
predicate NEGATIVE (record(stackfm) name v)
false if v_form # constant
if v_type&real bit # 0 start
false unless v_disp&16_8000 # 0
v_lrval = -v_lrval
else
false if v_disp = 16_80000000
false unless v_disp < 0
v_disp = -v_disp
finish
true
end
routine TEST ASSIGNED (record(stackfm) name v)
integer op, old d
return if v_form = constant or v_form = v in r or
v_base = gla or v_xno # 0
v_form = v in r if v_form = 255; !special from plant2
return if control&ass check = 0
if v_type = reall then op = cmpd&255 else op = cmpl&255
op = cmpw&255 if v_type = strings
return if v_base = local and
((v_disp > 0 and v_form # a in s) or v_disp < last local)
old d = diag; diag = 0; ! Don't monitor anything here
put code (opcode(op))
operand (v); claim (v_base) unless v_form = v in r
claim (v_index!128) if v_flags&indexed # 0
put number byte (16_60+gla-1); !(gla)
diag = old d
prim (test ass)
end
routine CHECK INDIRECT (record(stackfm) name v)
integer save
return if control&ass check = 0
if v_form = v in s and
v_flags&(indexed!xdefer) = indexed!xdefer start
save = v_flags; v_flags = 0
test assigned (v)
v_flags = save
else if v_form = a in s
save = v_type; v_type = integers; v_form = v in s
test assigned (v)
v_type = save; v_form = a in s
finish
end
routine PLANT1 (integer op, record(stackfm) name v)
op = opcode(op&255)
if control&ass check # 0 start
check indirect (v)
test assigned (v) if operand bits(op)&check1 # 0
finish
put code (op); operand (v)
end
routine spec PLANT3 (integer op, record(stack fm) name v1, v2, v3)
routine PLANT2 (integer op, record(stackfm) name v1, v2)
integer bits, negflag
record(stackfm) work
record(stack fm) name temp
if op&addr bit # 0 and v1_base # pc and v1_form = v in s and
v1_flags&indexed = 0 start
! MOVAx_k(Rn),Y
if v1_disp = 0 start
! MOVAx_(Rn),Y -> MOVL_Rn,Y : twice as fast!!
work = v1; v1 == work
v1_form = v in r; op = op&(¬7) - 1*8
release (v1_base); ! OPERAND doesn't in this case...
else if -63 <= v1_disp <= 63 and
(v1_disp < 0 or v1_base # local)
! MOVAx_S(Rn),Y -> ADDL3_Rn,#S,Y where s is short lit, and
! not a parameter!!!!
work = 0; work_disp = v1_disp; work_type = integers
plant3 (addl+three op, regv(v1_base), work, v2)
release (v1_base)
return
finish
finish
negflag = 0
negflag = 1 if v1_type&integers#0 and v1_form = constant and
-64 <= v1_disp < 0
if op&one bit # 0 start; !has 1-op variant
if v2 == spv start; !-(sp)
if op&addr bit # 0 or
(op = movl and negflag = 0) start; ! pusha, pushl
op = op+8*3
plant1 (op, v1); return
finish
finish
if v1_form = constant start
if op&move bit # 0 start
if zero (v1) and v2_form # v in r start
! mov #0 -> clr, except when dest a register!!!
plant1 (op+8*5, v2)
return
else if negflag # 0 and v1_type # byte+integers
if v1_disp = -64 start
v1_disp = ¬v1_disp; ! movx #-64 -> mcomx #63
op = op + 8*2
else
v1_disp = -v1_disp
op = op - 8*1; ! movx #-n -> mnegl #n
finish
finish
finish
if op&(add bit!sub bit) # 0 start
op = op!!(8!add bit!sub bit!commute) if negative (v1)
if v1_type&integers # 0 and v1_disp = 1 and
v2_form # v in r start
! add -> inc, except when dest reg...
plant1 (op-8*2, v2)
return
finish
finish
finish
finish
if op&reversible # 0 and short literal (v1) >= 0 start
! If possible, make a short literal the 2nd operand,
! for pipelining speed gain.
temp == v1; v1 == v2; v2 == temp
finish
op = opcode(op&255)
bits = operand bits(op)
check indirect (v1) if control&ass check # 0
if bits&move check = 0 or v2_form # v in r start
if control&ass check # 0 start
test assigned (v1) if bits&check1 # 0
check indirect (v2)
test assigned (v2) if bits&check2 # 0
finish
put code (op)
operand (v1)
operand (v2)
else
put code (op)
operand (v1)
operand (v2)
if (v1_type = integers or v1_type&real bit # 0) andc
(v1_form = a in s or
(v1_form = v in s and
(v1_base # local or
v1_disp >= last local))) start
v2_form = 255; !**special**
test assigned (v2)
finish
finish
end
routine PLANT3 (integer op, record(stackfm) name v1, v2, v3)
integer bits
record(stackfm) name temp
record(stackfm) work
if op&commute # 0 start
if v2_form = constant or same (v1, v3) start
temp == v1; v1 == v2; v2 == temp
finish
finish
if op&two bit # 0 start
if op&(add bit!sub bit) # 0 start
op = op!!(8!add bit!sub bit!commute) if negative (v1)
if v3_type = integers and v1_form = constant and
not 0 <= v1_disp <= 63 and
v2_form = v in r and v2_type&realbit = 0 and
not same (v2, v3) start
! addl3_#n,Rm,X -> moval_n(Rm),X
v1_disp = -v1_disp if op&sub bit # 0
work = v2
work_form = v in s
work_disp = v1_disp
claim (v2_base); ! will get released
plant2 (moval, work, v3)
return
finish
finish
if same (v2, v3) start; !can use two op form
remove (v2)
plant2 ((op-8*8)&(¬commute), v1, v3)
return
finish
finish
if op&commute # 0 and short literal (v1) >= 0 start
! Better to have short literal 2nd, for
! pipelining effects
temp == v1; v1 == v2; v2 == temp
finish
op = opcode(op&255)
bits = operand bits(op)
if control&ass check # 0 start
check indirect (v1); test assigned (v1) if bits&check1 # 0
check indirect (v2); test assigned (v2) if bits&check2 # 0
check indirect (v3); test assigned (v3) if bits&check3 # 0
finish
put code (op)
operand (v1)
operand (v2)
operand (v3)
end
routine PLANT4 (integer op, record(stackfm) name v1, v2, v3, v4)
if control&ass check # 0 start
check indirect (v1); check indirect (v2)
check indirect (v3); check indirect (v4)
finish
put code (opcode(op&255))
operand (v1); operand (v2)
operand (v3); operand (v4)
end
routine PLANT5 (integer op, record(stackfm) name v1, v2, v3, v4, v5)
if control&ass check # 0 start
check indirect (v1); check indirect (v2); check indirect (v3)
check indirect (v4); check indirect (v5)
finish
put code (opcode(op&255))
operand (v1); operand (v2); operand (v3)
operand (v4); operand (v5)
entry mask = entry mask ! 16_3c
end
routine HAZARD STRINGS
integer reg
hazard (reg) for reg = r0, 1, r5
end
routine IOVF OFF
! prevent overflow trap
if entry mask&iovf bit # 0 and ivbit state # 0 start
word (bicpsw vbit)
ivbit state = 0
finish
end
routine IOVF ON
! re-enable overflow trap if it should be on
if entry mask&iovf bit # 0 and ivbit state = 0 start
word (bispsw vbit)
ivbit state = 1
finish
end
routine STRING3 (integer op, record(stackfm) name v1, v2, v3)
integer code, stype, no check v2, old control = control
no check v2 = op&no ass chk
op = op & (¬no ass chk)
code = 0
if v1_form = constant start
v1_type = short+integers
if op = 0 or op = movc3 start; !look for short form
stype = scale type (v1_disp)
code = movl+stype if stype >= 0
finish
finish
op = op & (¬no short)
if code = 0 start; ! character op required
release (v1_base); release (v2_base); release (v3_base)
hazard strings
claim (v1_base); claim (v2_base); claim (v3_base)
finish
if control&ass check # 0 start
if no check v2 = 0 start
check indirect (v2)
test assigned (v2)
finish
check indirect (v3)
test assigned (v3) if op = cmpc3
control = control & (¬ass check)
finish
if op = 0 start; !concat
op = movc3
v2_disp = v2_disp + 1; !skip the length
finish
if code # 0 start
if v3_base = r3 and v3_disp = 0 and
v3_form = v in s and v3_flags = 0 = v3_xno start
v3_flags = auto i
op = 0
finish
plant2 (code, v2, v3)
last movc3 = ca and v3_flags = 0 if op = 0
else
entry mask = entry mask ! 16_3C; ! R0:R5 used
plant3 (op, v1, v2, v3)
last movc3 = ca if op = movc3
finish
control = old control
end
! %routine STRING5 (%integer op,
! %record(stackfm) %name v1, v2, v3, v4, v5)
! release (v1_base)
! release (v2_base)
! release (v3_base)
! release (v4_base)
! release (v5_base)
! hazard strings
! claim (v1_base)
! claim (v2_base)
! claim (v3_base)
! claim (v4_base)
! claim (v5_base)
! entry mask = entry mask ! 16_3c
! plant5 (op, v1, v2, v3, v4, v5)
! %end
routine PRIM EP (integer n)
integer ep
own byte array prim eps (1 : prim rts) = 0(*)
ep = prim eps(n)
if ep = 0 start; !first use
prim eps(n) = 1
put (obj prim spec); put (n)
finish
entry mask = entry mask ! prim mask(n)
end
routine PRIM (integer n)
integer r
prim ep (n)
if test ass # n # test string ovf start
hazard (r) for r = r0, 1, r5
finish
flush code; set line
put (obj prim ref); put (n); ca = ca + 6
end
routine DUMP TEXT (string(*) name text)
integer p, sym
length(text) = max ident if length(text) > max ident
for p = 0, 1, length(text) cycle
sym = charno(text, p)
sym = sym-32 if 'a' <= sym <= 'z'
put (sym)
repeat
end
routine LPUT (integer ep, addr)
put (ep)
put long (addr)
dump text (external name)
end
routine DEFINE TAG (integer ref)
select output tank (directives)
put (dir ldef)
put word (ref); put long (ca)
select output tank (object)
end
routine DEFINE ENTRY (integer ref)
select output tank (directives)
put (dir entry); put word (ref)
select output tank (object)
end
routine DEFINE REFERENCE (integer ref, type)
select output tank (directives)
put (type)
last ref = ref
put word (ref); put long (ca)
select output tank (object)
end
!register handling routines
routine CLAIM (integer reg)
!cherish the value in the register
string(2) s = ""
integer j
if reg&128 # 0 start; ! Claimed as index
reg = reg & 127
index regs = index regs + 1
abort (40) unless activity(reg) >= 0 and r0 <= reg <= r10
indx(reg) = indx(reg) + 1
s = "[]"
finish
return if reg = 0 or activity(reg) < 0; !none or locked
mon reg ("Claim".s, reg) if diag&4 # 0
active regs = active regs+1; !one more active
activity(reg) = activity(reg)+1; !note claimed
used(reg) = ca; !and note when used last
if reg >= fpr0 start; !claim general equivs
reg = (reg-fpr0)<<1+r0
j = diag; diag = 0
claim (reg); claim (reg+1)
diag = j
finish
end
routine RELEASE (integer reg)
! hazard the value in a register
integer old d
string(2) s = ""
if reg&128 # 0 start
reg = reg&127
abort (41) unless r0 <= reg <= r10
abort (42) if activity(reg) < 0
index regs = index regs - 1
abort (43) if index regs < 0
indx(reg) = indx(reg) - 1
abort (44) if indx(reg) < 0
s = "[]"
finish
return if reg = 0 or activity(reg) < 0; !none or locked
mon reg ("Release".s, reg) if diag&4 # 0
active regs = active regs - 1; !one less active
activity(reg) = activity(reg) - 1; !one less user
abort (3) if activity(reg) < 0; !too many
if reg >= fpr0 start
reg = (reg-fpr0)<<1+r0
old d = diag; diag = 0
release (reg); release (reg+1)
diag = old d
finish
end
routine CLEAR (record(stackfm) name v)
monitor (v, "Clear") if diag&4 # 0
release (v_base) if v_form = v in r
end
routine SCALE INDEX (integername op, record(stackfm) name v)
! Ensure that array elements are scaled correctly when
! the address of one is required (the descriptor will normally
! look like an integer at this stage!)
integer type
return if op&addr bit = 0 or v_flags&indexed = 0
monitor (v, "Scale index") if diag&128 # 0
type = scale type (v_iscale)
abort(35) if type < 0
op = (op&(¬7)) ! type
end
routine HAZARD (integer reg)
! protect the value in register 'reg' by storing in a temp
integer n, op, r, form
record(dfm) name p
record(stackfm) temp
record(stackfm) name s
routine MOD (record(stackfm) name v)
switch s (constant : a in rec)
n = n - 1
active regs = active regs - 1
monitor (v, "Hazard") if diag&4 # 0
-> s(v_form&7)
s(constant):
s(v in rec):
s(avin rec):
s(a in rec):
abort (4)
s(v in s):
s(avin s):
s(a in s):
v_form = v_form+3; v_extra = temp_disp; v_base = local
return
s(v in r):
v_form = v in s; v_disp = temp_disp; v_base = local
end
routine SET TEMP (integer size)
frame = frame-(size)&(¬(size-1))
temp = 0
temp_base = local; temp_disp = frame
temp_type = integers; temp_form = v in s
op = movl; op = movd if size = 8
end
mon reg ("Hazard", reg) if diag&4 # 0
n = activity(reg)
if n <= 0 start
return if reg < fpr0
reg = (reg-fpr0)<<1+r0
hazard (reg); hazard (reg+1)
return
finish
if indx(reg) # 0 start; ! Reg in use as index
p == using_link
while p ## null cycle
s == p_d
if s_flags&indexed # 0 and s_index = reg start
set temp (4)
op = moval; scale index (op, s)
form = s_form+3; s_form = v in s
plant2 (op, s, temp)
s_flags = 0; s_form = form; s_disp = 0
s_base = local; s_extra = temp_disp
finish
p == p_link
repeat
abort (31) if indx(reg) # 0
abort (5) if activity(reg) # 0
return
finish
activity(reg) = 0
if reg >= fpr0 start
r = (reg-fpr0)<<1+r0
activity(r) = 0; activity(r+1) = 0
active regs = active regs-n-n
set temp (8)
else
if reg <= r5 start; !check fpr equivs
r = (reg-r0)>>1+fpr0
if activity(r) > 0 start
hazard (r); return
finish
finish
set temp (4)
finish
plant2 (op, regv(reg), temp)
p == using_link
while p ## null cycle
mod (p_d) if p_d_base = reg
p == p_link
repeat
abort (5) if n # 0
end
integer function REGISTER (integer pair)
!returns a suitable register
integer r
integer worstn, worstr, worstu
worstn = 100; worstu = ca
for r = r10, -1, r1 cycle
if activity(r) = 0 = activity(r+pair) start; !not being used
used(r) = ca; result = r
else if 0 < activity(r) < worstn
worstn = activity(r); worstr = r
worstu = used(r)
else if activity(r) = worstn and used(r) < worstu
worstr = r; worstu = used(r)
finish
repeat
hazard (worstr)
used(worstr) = ca
result = worstr
end
integer function FPR
own integer next = fpr4+1
result = fpr0 if activity(r0) = 0 = activity(r1)
result = fpr2 if activity(r2) = 0 = activity(r3)
result = fpr4 if activity(r4) = 0 = activity(r5)
next = fpr4+1 if next = fpr0
next = next-1
hazard (next)
result = next
end
!descriptor processing
record(stackfm) map DESCRIPTOR
record(dfm) name d
record(stackfm) name v
v == desc asl; abort (6) if v == null
d == d asl; abort (7) if d == null
desc asl == v_link; v = 0; v_link == null
d asl == d_link
d_link == using_link
using_link == d
d_d == v
abort (8) if stp >= max depth
stp = stp + 1
stacked(stp) == v
result == v
end
routine DROP (record(stackfm) name d)
record(dfm) name p, q
monitor (d, "Drop") if diag&1 # 0
p == using
cycle
q == p_link
abort (9) if q == null
exit if q_d == d
p == q
repeat
p_link == q_link
q_link == d asl
d asl == q
d_link == desc asl
desc asl == d
end
routine VSTACK (record(varfm) name v)
record(stackfm) name x
x == descriptor
x_type = v_type
x_form = v_form&(15!arrayname bit!proc bit)
x_base = v_base
x_disp = v_disp
x_format = v_format
x_extra = v_extra
x_length = v_length
x_header = v_header
x_mantissa = v_zeroad; ! Zero-address for C-B arrays
x_mantissa = v_flags if v_flags # 0; ! or prim index
x_xno = v_xno
monitor (x, "Vstack") if diag&1 # 0
end
routine DSTACK (record(stackfm) name v)
record(stackfm) name t
t == descriptor
t = v
monitor (t, "Dstack") if diag&1 # 0
end
routine GET REAL
long real p, val
record(stackfm) name v
integer n, s
on 1 start; ! real overflow!
error ('*', "real value too large")
val = 0; -> out
finish
n = getword; get (discard)
val = 0
cycle
get (s)
-> power if s = '@'
exit if s = '.'
val = val*10+(s-'0')
n = n-1
-> out if n = 0
repeat
p = 1
cycle
n = n - 1; -> out if n = 0
get (s)
-> power if s = '@'
p = p/10
val = val + (s-'0')*p
repeat
power:
n = getword; ! Was GETLONG!!!!
val = val*10¬n
out:
v == descriptor
v_type = reall; v_form = constant
v_lrval = val
end
routine CSTACK (integer value)
record(stackfm) name v
v == descriptor
v_disp = value
v_type = integers
v_form = constant
monitor (v, "Cstack") if diag&1 # 0
end
routine LSTACK (integer disp)
record(stackfm) name v
v == descriptor
v_disp = disp
v_base = local
v_type = integers
v_form = v in s
monitor (v, "Lstack") if diag&1 # 0
lhs == v
end
record(stackfm) map TEMP (integer size)
record(stackfm) name d
d == descriptor
frame = (frame-size)&(¬3)
d_base = local; d_disp = frame
d_type = integers; d_form = v in s
result == d
end
record(stackfm) map LITERAL (integer n)
record(stackfm) name d
d == descriptor
d_base = 0; d_disp = n
d_type = integers; d_form = constant
result == d
end
routine SET LHS
lhs == stacked(stp)
monitor (lhs, "Set lhs") if diag&1 # 0
end
routine SET BOTH
abort (10) if stp <= 1
lhs == stacked(stp-1)
rhs == stacked(stp )
if diag&1 # 0 start
monitor (lhs, "Both lhs")
monitor (rhs, " rhs")
finish
end
routine POP LHS
abort (11) if stp <= 0
stp = stp - 1
lhs == stacked(stp+1)
monitor (lhs, "Pop lhs") if diag&1 # 0
end
routine POP DROP
integer d
record(stack fm) name t
abort (12) if stp <= 0
stp = stp - 1
t == stacked(stp+1)
monitor (t, "Pop drop") if diag&1 # 0
d = diag; diag = 0; drop (t); diag = d
end
routine MACHINE CODE
integer sym, n, j
integer opcode, operands, flags
string(6) optext
const integer array code (0 : 511) =
16_871238F1,16_F360015B, 16_87123AB3,16_F260015B,
16_88B2CAB7,16_B9200002, 16_88BACAB7,16_B8200002,
16_8B8B50CC,16_6B40001C, 16_8B8B510C,16_4B40001B,
16_8E65DA43,16_3880024A, 16_970ACEE5,16_0E400019,
16_9C6916D8,16_06000000, 16_9E3B1543,16_3980028A,
16_9F1C4AAC,16_DC200003, 16_9F1C5AE3,16_2FC0A24A,
16_9F1C708C,16_9A400019, 16_9F1C7097,16_9B400011,
16_9F1C732C,16_3C40001A, 16_A54890F2,16_0C600051,
16_A54890F7,16_0D600051, 16_A57AA862,16_9F200001,
16_A57AA86C,16_DF200003, 16_A57AA871,16_7F200004,
16_A57AA877,16_3F200002, 16_A877CEE5,16_0F400019,
16_AB1224F1,16_F440002B, 16_AB1226D2,16_F540002B,
16_AB8916D8,16_07000000, 16_00000000,16_00000000,
16_00000000,16_00000000, 16_00000000,16_00000000,
16_00000000,16_00000000, 16_00000000,16_00000000,
16_00000000,16_00000000, 16_00000000,16_00000000,
16_00000000,16_00000000, 16_00000000,16_00000000,
16_00000000,16_00000000, 16_00000000,16_00000000,
16_00000000,16_00000000, 16_00000000,16_00000000,
16_00011083,16_E160014B, 16_00011093,16_E060014B,
16_00011254,16_03000000, 16_00011282,16_11200005,
16_00011297,16_31200006, 16_00011303,16_1C200005,
16_00011313,16_1D200005, 16_00011683,16_0BA03299,
16_00012103,16_EB80064B, 16_00012113,16_EA80064B,
16_000131F0,16_17200001, 16_000132A2,16_16200001,
16_00014230,16_01000000, 16_000150E9,16_02000000,
16_000150F4,16_04000000, 16_000152A2,16_05000000,
16_00016903,16_FC000000, 16_00219482,16_9D800C49,
16_00219484,16_6F800D24, 16_00219486,16_4F800CDB,
16_0021948C,16_F1800CDB, 16_00219497,16_3D800C92,
16_00219B23,16_D840001B, 16_0021D54C,16_786000D9,
16_0021D550,16_F8C0A251, 16_0021D551,16_79600121,
16_002210A3,16_E560014B, 16_002210B3,16_E360014B,
16_002212A3,16_E460014B, 16_002212B3,16_E260014B,
16_00221E6C,16_13200005, 16_002224F1,16_18200005,
16_002226D2,16_14200005, 16_00222EC2,16_93400009,
16_00222ECC,16_D340001B, 16_00222ED7,16_B3400012,
16_00223883,16_E940002B, 16_00223893,16_E840002B,
16_002238F1,16_15200005, 16_00223AB3,16_19200005,
16_002240F1,16_12200005, 16_00225482,16_10200005,
16_00225497,16_30200006, 16_0022A9E5,16_BD200002,
16_0022A9EB,16_BC200002, 16_0022A9F3,16_BE200002,
16_0022A9F5,16_BF200002, 16_0022BA82,16_94200001,
16_0022BA8C,16_D4200003, 16_0022BA91,16_7C200004,
16_0022BA97,16_B4200002, 16_0022BE42,16_91400009,
16_0022BE44,16_71400024, 16_0022BE46,16_5140001B,
16_0022BE4C,16_D140001B, 16_0022BE56,16_EC80064B,
16_0022BE57,16_B1400012, 16_00231CA2,16_97200001,
16_00231CAC,16_D7200003, 16_00231CB7,16_B7200002,
16_00232F10,16_27C0A28A, 16_00239976,16_7B8006E3,
16_0023BEEC,16_7A8008DB, 16_0023EAD6,16_EE80064B,
16_00250DD4,16_00000000, 16_0025C0A2,16_96200001,
16_0025C0AC,16_D6200003, 16_0025C0B7,16_B6200002,
16_0025C2B6,16_F080025B, 16_002744A3,16_3A600051,
16_0027A252,16_DB40001B, 16_0027C702,16_90400009,
16_0027C704,16_70400024, 16_0027C706,16_5040001B,
16_0027C70C,16_D040001B, 16_0027C710,16_3460004A,
16_0027C711,16_7D400024, 16_0027C717,16_B0400012,
16_0027DA52,16_DA40001B, 16_0027DDD0,16_25C0A28A,
16_00294652,16_BA200002, 16_002A46CC,16_9C6000D9,
16_002A9323,16_D940001B, 16_002AB643,16_3B600051,
16_002B56C2,16_95200001, 16_002B56C4,16_73200004,
16_002B56C6,16_53200003, 16_002B56CC,16_D5200003,
16_002B56D7,16_B5200002, 16_04330F29,16_58400012,
16_04331872,16_80400009, 16_04331873,16_81600049,
16_043318B2,16_60400024, 16_043318B3,16_61600124,
16_043318F2,16_4040001B, 16_043318F3,16_4140001B,
16_043319B2,16_C040001B, 16_043319B3,16_C16000DB,
16_04331A34,16_2080028A, 16_04331A36,16_21C0A28A,
16_04331B12,16_A0400012, 16_04331B13,16_A1600092,
16_044214A9,16_E760014B, 16_044256A9,16_E660014B,
16_04449E75,16_1E200005, 16_0444DA95,16_1A200005,
16_04459472,16_8A400009, 16_04459473,16_8B600049,
16_044595B2,16_CA40001B, 16_044595B3,16_CB6000DB,
16_04459712,16_AA400012, 16_04459713,16_AB600092,
16_0445D472,16_88400009, 16_0445D5B2,16_C840001B,
16_0445D5B3,16_C96000DB, 16_0445D712,16_A8400012,
16_0445D713,16_A9600092, 16_04471E75,16_1B200005,
16_044756B5,16_1F200005, 16_0451B9C7,16_FA400009,
16_0451B9D3,16_FB40000B, 16_0451D4E2,16_8F600049,
16_0451D4EC,16_CF6000DB, 16_0451D4F7,16_AF600092,
16_0457C893,16_2960004A, 16_0457C895,16_2DA0144A,
16_0457CA34,16_3780028A, 16_0457CB96,16_ED80064B,
16_0458BE33,16_3560004A, 16_045C5884,16_6C400021,
16_045C5886,16_4C400019, 16_045C588C,16_98400019,
16_045C5897,16_99400011, 16_045C58C2,16_6840000C,
16_045C58C6,16_7640001C, 16_045C58CC,16_6A40001C,
16_045C58D7,16_69400014, 16_045C5902,16_4840000B,
16_045C5904,16_56400023, 16_045C590C,16_4A40001B,
16_045C5917,16_49400013, 16_045C59C2,16_F640000B,
16_045C59C4,16_6E400023, 16_045C59C6,16_4E40001B,
16_045C59D0,16_F9600053, 16_045C59D7,16_F7400013,
16_045C5A4C,16_366000CA, 16_045C5A53,16_0880028A,
16_045C5A54,16_24A0144A, 16_045C5AB0,16_0980028A,
16_045C5AD0,16_26A0144A, 16_045C5B22,16_3340000A,
16_045C5B24,16_6D40001A, 16_045C5B2C,16_3240001A,
16_0463E072,16_86400009, 16_0465E073,16_87600049,
16_0465E0B2,16_66400024, 16_0465E0B3,16_67600124,
16_0465E0F2,16_4640001B, 16_0465E0F3,16_476000DB,
16_0465E1B2,16_C640001B, 16_0465E1B3,16_C76000DB,
16_0465E312,16_A6400012, 16_0465E313,16_A7600092,
16_0477C4C4,16_74A0470C, 16_0477C4C6,16_54A036CB,
16_047D5B96,16_EF80064B, 16_04B818F8,16_0AC1B6DB,
16_04F2C5E2,16_92400009, 16_04F2C5EC,16_D240001B,
16_04F2C5F7,16_B2400012, 16_04F5D473,16_89600049,
16_04F81D22,16_8E400009, 16_04F81D24,16_72400024,
16_04F81D26,16_5240001B, 16_04F81D2C,16_CE40001B,
16_04F81D37,16_AE400012, 16_04F8E062,16_9E400019,
16_04F8E06C,16_DE40001B, 16_04F8E071,16_7E40001C,
16_04F8E077,16_3E40001A, 16_04F8E093,16_2860004A,
16_04F8E095,16_2CA0144A, 16_04F8E2C3,16_2EC0A24A,
16_04FBB872,16_84400009, 16_04FBB873,16_85600049,
16_04FBB8B2,16_64400024, 16_04FBB8B3,16_65600124,
16_04FBB8F2,16_4440001B, 16_04FBB8F3,16_456000DB,
16_04FBB9B2,16_C440001B, 16_04FBB9B3,16_C56000DB,
16_04FBBB12,16_A4400012, 16_04FBBB13,16_A5600092,
16_0528BB64,16_75600054, 16_0528BB66,16_55600053,
16_052BD54C,16_DD200003, 16_052BD552,16_BB200002,
16_05528E03,16_2A80024A, 16_05590E03,16_2B80024A,
16_055B9072,16_82400009, 16_055B9073,16_83600049,
16_055B90B2,16_62400024, 16_055B90B3,16_63600124,
16_055B90F2,16_4240001B, 16_055B90F3,16_436000DB,
16_055B91B2,16_C240001B, 16_055B91B3,16_C36000DB,
16_055B9234,16_2280028A, 16_055B9236,16_23C0A28A,
16_055B9312,16_A2400012, 16_055B9313,16_A3600092,
16_05A8D072,16_8C400009, 16_05A8D073,16_8D600049,
16_05A8D1B2,16_CC40001B, 16_05A8D1B3,16_CD6000DB,
16_05A8D312,16_AC400012, 16_05A8D313,16_AD600092
routine MC ERROR (string(23) text)
error ('*', optext.": ".text)
get (sym) while sym # ';'
end
integer function FIND (integer key)
integer a, b, p
a = 0; b = 512
while a <= b cycle
p = (a+b)>>2<<1
result = p if code(p) = key
if key > code(p) then a = p+2 else b = p-2
repeat
result = -1
end
predicate PARSED OPERAND (integer flag)
byte array oper (1 : 128)
integer base, disp, sign, indirect, m, p, size
record(varfm) name v
predicate LITERAL (integername n)
false unless '0' <= sym <= '7'
n = 0
cycle
n = n<<3 + sym-'0'
get (sym)
true unless '0' <= sym <= '7'
repeat
end
predicate REG (integername r)
get (sym); !skip (
false unless literal (r)
false unless 0 <= r <= 15
false if sym # ')'
get (sym)
true
end
routine SET BYTE (integer b)
p = p + 1; oper(p) = b
end
routine SET WORD (integer n)
shortinteger(addr(oper(p+1))) = n
p = p + 2
end
routine SET LONGWORD (integer n)
integer(addr(oper(p+1))) = n
p = p + 4
end
p = 0
indirect = 0; sign = 1
entry mask = entry mask ! 16_ffc
if sym = '@' and flag < 5 start
indirect = 16_10; get (sym)
finish
if sym = '#' start
get (sym)
sign = -1 and get (sym) if sym = '-'
false unless literal (disp)
disp = disp*sign
if 0 <= disp <= 63 and indirect = 0 start
set byte (disp); ->ok
finish
set byte (16_8F)
if flag = 3 or indirect # 0 start
set longword (disp); ->ok
finish
if flag = 1 or flag = 5 start
set byte (disp); ->ok
finish
if flag = 2 or flag = 6 start
set word (disp); ->ok
finish
set longword (disp); set longword (0); ->ok
finish
if sym = '(' start
false unless reg (base) and flag < 5
disp = 0 and -> basedisp if indirect # 0
base = base+16_60
if sym = '+' start
get (sym)
base = base+16_20
finish
set byte (base+indirect)
-> ok
finish
if sym = ' ' start; !tag value
get (sym)
false unless literal(m)
v == var(m)
base = v_base
disp = v_disp
if v_form = 15 start; !label
flush code
if flag = 5 start; !byte disp
put (obj b lab); ca = ca+1
else if flag = 6; !word disp
put (obj w lab); ca = ca+2
else; !pc-rel
define reference (disp, dir pref)
put (obj call); ca = ca + 2
put long (disp)
true
finish
put word (disp)
true
finish
if base = local start
base = fp
base = ap and disp = disp-60 if disp > 0
finish
base = base-1
if sym = '+' or sym = '-' start
sign = sym
get (sym)
false unless literal (m)
m = -m if sign = '-'
disp = disp+m
finish
base disp:
base = base+indirect
size = msize (disp)
if size <= 1 start
set byte (16_a0+base)
set byte (disp)
else if size = 2
set byte (16_c0+base)
set word (disp)
else
set byte (16_e0+base)
set longword (disp)
finish
-> ok
finish
if sym = '-' and indirect = 0 and flag < 5 start
get (sym)
if sym = '(' start
false unless reg (base)
set byte (16_70+base)
-> ok
finish
false unless literal (disp)
disp = -disp
-> bd
finish
false unless literal (disp) and flag < 5
bd: if sym = '(' start
false unless reg (base)
-> base disp
finish
false unless 0 <= disp <= 15
set byte (16_50+disp)
ok: if sym = '[' and flag < 5 start; !indexed
get (sym)
false unless literal (base) and sym = ']'
get (sym)
put number byte (16_40+base)
finish
put number byte (oper(m)) for m = 1, 1, p
true
end
get (sym)
op text = ""; n = 0
cycle
exit if sym = '_'
if length(optext) # 6 start
optext = optext . tostring(sym)
n = n<<5 + sym
finish
get (sym)
repeat
get (sym)
j = find (n)
if j < 0 start
mc error("Unknown opcode")
return
finish
flags = code(j+1)
opcode = flags>>24
operands = flags>>21&7
put code (opcode)
if operands > 0 start
cycle
unless parsed operand (flags&7) start
mc error ("Bad operand")
return
finish
flags = flags>>3
operands = operands-1
exit if operands = 0
if sym # ',' then mc error ("Operands?") else get (sym)
repeat
finish
mc error ("Operands?") if sym # ';'
end
routine PLANT
! Plant in-line code values (from "*=constant")
integer j
for j = 1, 1, stp cycle
lhs == stacked(j)
word (lhs_disp)
drop (lhs)
repeat
stp = 0
end
routine ASSEMBLE (integer amode, labs, names)
!amode : = -1 - recordformat
! = -2 - alternate format starting
! = 0 - procedure definition
! = 1 - procedure spec
switch c (' ' : 127)
record(varfm) name v
record(varfm) name gvar == decvar
integer array string areas (1 : max work)
integer duplic = 0
integer this area = 0
integer last area = 0
integer old mask = entry mask
integer old ca = ca
integer old frame = frame
integer max frame
integer frame base
integer old last local = last local
integer old jump = uncond jump
integer old ivbit = ivbit state
integer gstart = names
integer gfunction = 0; !#0 for string/record functions
integer label start = labs
integer block tag
integer block end tag = 0
integer local lines = diag lines; diag lines = 6
integer local diags = 0
integer events = 0
integer evlow, evep
integer proctype, mainprog = 0
routinespec DUMP DIAG (integer flag)
routinespec LOAD (record(stackfm) name v, integer r)
routinespec LRD (record(stackfm) name v, integer r)
routinespec JUMP TO (integer label, cond, def)
routinespec TEST ZERO (record(stack fm) name d)
routinespec PUSH (record(stackfm) name v, integername n)
!====================== Initialisation =============================
flush code
uncond jump = -1
last movc3 = -1
frame = 0 if amode # -2
frame base = frame; max frame = frame
ca = 0
entry mask = 16_3c; entry mask = 0 if control&1 = 0
ivbit state = 0
if control&ovf check # 0 start
entry mask = iovf bit!entry mask
ivbit state = 1
finish
proctype = potype
if amode = 0 start
level = level + 1
error ('!', "nesting too deep") if level > 6
local = base reg(level)
activity(local) = -1
gfunction = 1 if gvar_type&(strings!records) # 0 and
gvar_form = v in r+proc bit
if level # 0 start
entry mask = entry mask ! regmask(local)
decvar_disp = newtag if decvar_disp = 0
block tag = decvar_disp
block end tag = new tag
select output tank (directives); put (dir header)
select output tank (object)
put (obj header)
put (local-1); put word (block tag)
put word (block end tag)
put word (current line)
if proctype # 0 start; ! external
dump text (externalname)
entry mask = entry mask ! 16_800; ! Save GLA on entry
if command & entrybit # 0 andc
(entryname = "" or externalname = entryname) start
mainprog = mainrt; mainprog = mainfn if decvar_type # 0
define entry (block tag)
finish
finish
define tag (block tag)
lput (obj pdef, block tag) if potype # 0
dump diag (0)
finish
else if amode = -1
gvar_extra = parms
finish
!===================================================================
routine SPEC EXTERNAL (record(varfm) name v)
v_base = pc
select output tank (directives)
put (dir used); put word (v_xno)
select output tank (object)
end
routine DUMP DIAG (integer flag)
integer type, disp, base, indirect
return if amode # 0 or command&diag bit = 0
indirect = 0
base = decvar_base - 1
type = decvar_type
if flag = 0 start; !proc header
put (obj diag p)
local diags = local diags+2
else if decvar_form&15 = v in s
put (obj diag v)
else if decvar_form&15 = a in s
put (obj diag v)
indirect = 128
else
return
finish
local diags = local diags+7+length(var name)
if flag = 0 start
put word (current line)
else
put (type)
disp = decvar_disp
if base = local-1 start
if disp >= 0 start
disp = disp+4 if gfunction # 0
disp = disp+4; base = ap-1
else
base = fp-1
finish
finish
put (base!indirect)
put long (disp)
finish
dump text (var name)
end
routine SET DOPE VECTOR (integer name gdisp)
gfix (3)
gdisp = ga
glongword (1); !dimension
glongword (vlb)
glongword (vub)
vub = vub-vlb+1
glongword (data size)
vlb = vlb*data size
end
routine DEFINE VAR
integer type, form, tf, s, size
integer new, round, dv
own integer prim no = 0, xno = 0
new = 0
decl = getword
if decl = 0 start; !recordformat element
parms = parms - 1; decvar == var(parms); decvar = 0
else
decvar == var(decl)
if decl > names or decvar_xno # 0 start
! Either a new name or one previously %externally spec'd
decvar = 0
names = decl if decl > names
new = 1
finish
finish
var name = ""
cycle
get (s); exit if s = ','
var name = var name.tostring(s) if length(var name) < max ident
repeat
abort (14) if names >= parms
get (tf)
type = tf>>4
form = fmap(tf&15); !convert to internal form
round = 3; data size = 4; ! defaults (integer)
get (discard); size = getword
if type = 1 start; ! integer
type = integers
if size = 2 start
type = byte+integers; round = 0; size = 1
else if size = 3
type = short+integers; round = 1; size = 2
else if size = 4
type = long+integers; round = 7; size = 8
else
size = 4
finish
type = integers if form = procbit+v in r; !integer functions
else if type = 2; ! %real, %longreal
if size = 4 start; !longreal
size = 8; type = reall; round = 7
else
size = 4; type = reals
finish
else if type = 3; ! %string
type = strings
round = 0
size = size + 1 if size # 0; !infiltrate length cell, unless (*)
else if type = 4; ! %record
type = records
decvar_format = size
size = var(size)_length
finish
data size = size; !actual size
decvar_length = data size
get (discard); otype = getlong
duplic = otype&256
spec = otype&8; otype = otype&7; !ignore prot for now
if alias # "" start
external name = alias; alias = ""
else
if otype = 4 start; !system
if length(var name) > max ident-4 start
length(var name) = max ident-4
finish
external name = "SYS$".var name
else
external name = var name
finish
finish
size = 4 if gmode # 0 and amode >= 0 and type # reall
!parameters are longwords
if form&proc bit # 0 start; !procedure
decvar_type = type; decvar_form = form
decvar_header = -1
gtype = 0
gtype = 1 if spec # 0
if otype # 0 and spec # 0 start; !external spec
if otype >= 6 start; !primitive, permanent
prim no = prim no+1
decvar_flags = prim no
return if otype = 6; !primitive
finish
xno = xno + 1
decvar_base = pending; decvar_xno = xno
put (obj pspec); put word (xno); dump text (externalname)
return
finish
if gmode = 0 start; !not a parameter
potype = otype
if new # 0 start
decvar_base = pc
decvar_disp = new tag
finish
return
finish
size = 4
else
if form&(indirect bit!array bit!arrayname bit) # 0 start
size = 4
if form&arrayname bit # 0 start
size = 8; datasize = 8
else if form&indirect bit # 0
data size = 4
finish
round = 3 if form&(indirect bit!arrayname bit) # 0
if type = 0 start; !general type
size = 8
else if form&arrayname bit # 0
decvar_header = -1
finish
finish
finish
decvar_type = type; decvar_form = form
!deal with owns
if otype # 0 start; !own data
owntype = type; ownform = form
if otype = 2 and form&indirect bit # 0 start
otype = 0
else
if spec = 0 start
if form&array bit # 0 start
set dope vector (dv)
decvar_base = gla; decvar_disp = ga
glongword (0); glongword (0)
decvar_header = -2; decvar_zeroad = ga - vlb
flush gla
! %if command & picbit # 0 %start
! head_base = gla; head_disp = ga - 8
! dope_disp = dv
! zeroth_base = gla; zeroth_disp = ga - vlb
! plant2 (moval, zeroth, head); head_disp = head_disp + 4
! plant2 (moval, dope, head)
! %else
put (obj reloc); put long (ga-8); put long (ga-vlb)
put (obj reloc); put long (ga-4); put long (dv)
! %finish
lput (obj ddef, ga-8) if otype > 2
finish
else
xno = xno+1; decvar_xno = xno; decvar_base = pc
s = objdspec; s = obj weak if otype = 5
put (s); put word (xno); dump text (externalname)
! Externalarrays actually arraynames....
decvar_header = -1 if decvar_form&arraybit # 0
finish
finish
owntype = integers if form&indirect bit # 0
owntype = records if form&arrayname bit # 0; !to dump a lot
return
finish
if form = 15 start; !label
jump to (-decl, 32, 0)
return
finish
if form = switch start
data size = 4
gfix (3); dv = ga
glongword (1)
glongword (vlb); glongword (vub)
glongword (4); ! data size
decvar_type = integers; decvar_form = av in s
decvar_base = gla; decvar_disp = dv
decvar_extra = ga-vlb*4
glongword (0) for s = vlb, 1, vub
return
finish
if form = recfm start
gtype = -1
return
finish
return if form&array bit # 0
if gmode = 0 start; !reverse definition
frame = (frame-size)&(¬round)
decvar_disp = frame
last local = frame
else
round = 3 if amode >=0
frame = (frame+round)&(¬round) if control&rec round # 0
decvar_disp = frame
frame = frame+size
finish
decvar_base = local
dump diag (1) if form&arrayname bit = 0
end
routine DEFINE PARAMETERS
integer p, disp
gvar_extra = parms
disp = 64
disp = 68 if gfunction # 0
for p = gstart+1, 1, names cycle
actual == var(p)
parms = parms - 1; formal == var(parms)
formal = actual
actual_disp = actual_disp+disp
if actual_type&(records!strings) # 0 start
!string and record values passed by name
actual_form = a in s if actual_form = v in s
finish
repeat
abort (26) if parms <= names
end
routine AMAP (record(stackfm) name v)
!convert 'v' into a descriptor for the address of 'v'
integer f
const short array map(constant:a in rec) =
-1, -1, avins, -1, vins, avinrec, -1, vinrec
! constant, vinr, vins, avins, ains, vinrec, avinrec, ainrec
monitor (v, "Amap in") if diag&64 # 0
f = map(v_form&15)
abort (15) if f < 0 or v_oper # 0
if f = av in s and v_xno = 0 start
if v_base = 0 start
f = constant
else if v_disp = 0 and v_flags&indexed = 0
f = v in r
finish
finish
v_form = f
if f = v in s or f = v in rec start
v_length = 4
else
v_length = var(v_format)_length if v_type = records
v_length = v_iscale if v_flags&indexed # 0
finish
v_type = integers
monitor (v, "Amap out") if diag&64 # 0
end
routine VMAP (record(stackfm) name v)
integer n
monitor (v, "Vmap in") if diag&64 # 0
if v_oper # 0 start
if (v_oper = add or v_oper = sub) and const (v_link) start
n = v_link_disp; drop (v_link)
n = -n if v_oper = sub
v_oper = 0
if v_form = v in r or v_form = av in s start
v_disp = v_disp + n
else if v_form = v in s and v_type = integers and
v_flags&indexed = 0
v_extra = v_disp; v_disp = n
v_form = av in rec
else
load (v, any); v_disp = n
finish
else
load (v, any)
finish
finish
! load (v, any) %if v_flags&indexed # 0 %and v_form # av in s
if v_form = v in s or v_form = v in rec start
v_form = v_form+2
else if v_form = av in s or v_form = av in rec
v_form = v_form-1
else if v_form = constant
v_form = v in s; v_base = 0
else
load (v, any); v_form = v in s
finish
monitor (v, "Vmap out") if diag&64 # 0
end
routine ADDRESS VAR (integer mode, record(stack fm) name v)
! If v is av in rec then change form of descriptor
! according to mode -
! mode # 0 -> value wanted -> make into v in s + const
! mode = 0 -> want address -> load base
record(stack fm) name c
integer n
return if v_form # av in rec
n = v_disp
if mode # 0 and v_flags = 0 start
v_form = v in s; v_disp = v_extra; v_type = integers
if n # 0 start
c == literal(n); stp = stp - 1
v_oper = add; v_link == c
finish
else
v_disp = v_extra; v_extra = 0; v_type = integers
load (v, any); v_disp = n
v_form = av in s
finish
end
!string constant processing
record(stackfm) map WORK STRING
record(stackfm) name d
this area = this area + 1
if this area > last area start
last area = this area
abort (29) if last area > max work
frame = frame - 256
string areas(last area) = frame
finish
d == descriptor
d_type = strings; d_form = v in s
d_base = local; d_disp = string areas(this area)
result == d
end
routine DUMP STRING (integer max)
integer j, l
l = length(text)
if max = 0 start; !as much as nesc.
return if l = 0
max = l
else; !explicit area
max = max - 1; !ignore length cell
error ('*', "string constant too big") if max < l
finish
gbyte (length(text))
gbyte (charno(text,j)) for j = 1, 1, max
end
routine GET STRING (string(*) name text)
integer n, s
get (n)
length(text) = n
get block (n, charno(text,1))
return if sym = 'G'; !Alias
s = look; !next control item
if n = 0 start; !null string
lstack (null string)
else
lstack (ga)
dump string (0) unless s = '$' or s = 'A'; !own strings
finish
lhs_base = gla
lhs_type = strings
lhs_format = n + 1
end
!jump processing
record(labelfm) map NEW LABEL
labs = labs + 1; abort (16) if labs > max labels
result == labels(labs)
end
record(labelfm) map FIND (integer label)
integer lp
record(labelfm) name l
lp = labs
while lp # label start cycle
l == labels(lp)
result == l if l_id = label
lp = lp - 1
repeat
result == null
end
routine DEFINE LABEL (integer label)
record(labelfm) name l
return if label = 0; !jump round proc
l == find(label)
if l == null start; !not found
l == new label
l_id = label; l_tag = new tag
else if l_tag < 0 and label >= 0
l_tag = new tag
finish
l_tag = l_tag!16_8000
define tag (l_tag&16_7fff)
uncond jump = 0; !you can get here!
end
routine JUMP TO (integer label, cond, def)
const byte array inv (0 : 15) =
0, 1, 4, 5, 2, 3, 6, 7,
0+8,1+8,4+8,5+8,2+8,3+8,6+8,7+8
integer ref
record(labelfm) name lab
invert = 0
return if label = 0 {jump round routine} or uncond jump = ca
cond = inv(cond&15) if cond&16 # 0
lab == find(label)
if lab == null start
lab == new label
lab_id = label
lab_tag = new tag
else if lab_tag < 0 and def # 0
lab_tag = new tag
finish
if cond = 32 start; !from definevar
decvar_disp = lab_tag&16_7fff
return
finish
if cond = jump then ref = dir uref c
else ref = dir cref
flush code
put (obj jump)
put (cond); put word (lab_tag&16_7fff)
define reference (lab_tag&16_7fff, ref)
ca = ca+2; !assume short
uncond jump = ca if cond = jump; !no way past here
end
routine DEFINE SWITCH LABEL
integer tag, switch zero, index
switch zero = var(getword)_extra; tag = new tag
pop lhs; index = lhs_disp; drop (lhs)
define tag (tag); uncond jump = 0
flush gla; put (obj set)
put long (tag); put long (switch zero+index*4)
end
routine SWITCH JUMP
vstack (var(getword))
set both; stp = stp - 2
lrd (lhs, r1); ! index
lrd (rhs, r2); ! address of dope vector
prim (swjump)
uncond jump = ca
end
!loading routines
routine ADDRESS (record(stackfm) name v)
!convert 'v' to a form in which it is directly addressable
own record(stackfm) xvar = 0
integer type, form, disp, len
monitor (v, "Address in") if diag&32 # 0
load (v, any) if v_oper # 0
if v_form >= v in rec start
if v_disp = 0 and
v_form = v in rec and v_flags = 0 = v_xno start
v_form = a in s; v_disp = v_extra
else
type = v_type; form = v_form-3
disp = v_disp; len = v_length
v_type = integers; v_form = v in s; v_disp = v_extra
load (v, any)
v_type = type; v_form = form
v_disp = disp; v_length = len
finish
finish
if v_form = a in s and (v_xno # 0 or v_base = 0 or
v_flags&indexed # 0) start
len = v_length; type = v_type
v_form = v in s; v_length = 4; v_type = integers
load (v, any)
v_form = v in s
v_length = len; v_type = type
finish
load (v, any) if v_form = av in s
if (v_xno # 0 or v_base = 0) and v_flags&xdefer # 0 start
xvar_type = integers; xvar_form = v in s
xvar_xno = v_xno; xvar_base = pc; xvar_disp = v_disp
load (xvar, any)
v_base = xvar_base; v_xno = 0; v_disp = 0;
v_flags = v_flags&(¬xdefer)
finish
if v_flags&indexed # 0 start
if v_form = v in s start
if v_iscale # v_length start
len = v_length; v_length = v_iscale
type = v_type; v_type = integers
v_form = av in s; load (v, any)
v_length = len; v_type = type
v_form = v in s
finish
else
abort (46)
finish
finish
monitor (v, "Address out") if diag&32 # 0
end
routine MOVE ARRAYNAME (record(stackfm) name v, to)
record(stackfm) w = 0
if v_header < 0 start; !header complete
w_base = v_base; w_disp = v_disp
w_extra = v_extra; w_type = v_type
w_xno = v_xno; w_form = v in s
if v_form&15 >= v in rec start
w_form = a in s
w_disp = v_extra
finish
plant2 (movq, w, to)
drop (v)
return
finish
w_base = gla
w_disp = v_header
w_type = integers
w_form = v in s
w_oper = 0
!?PSR?! v_form = v in s; !**************
if to ## spv start
!?PSR?! load (v,r3) %if v_base=r0 %or v_base=r1; !*************
hazard (r0); hazard (r1)
claim (r0); claim (r1)
plant2 (movq, w, regv(r0))
else
plant2 (movq, w, to)
finish
amap (v); !*****************
address (v); !****************
if to ## spv start
plant2 (addl, v, regv(r0))
if to ## regv(r0) start
plant2 (movq, regv(r0), to)
release (r0); release (r1)
finish
else
w_base = sp; w_disp = 0
plant2 (addl, v, w)
finish
release (v_base) if v_form = v in r; !********************
drop (v)
end
routine STRING OP (integer op, record(stackfm) name from, to)
integer old control = control, tl = to_length
record(stackfm) name reg, len
if from_flags&indexed # 0 start
amap (from); load (from, any)
from_form = v in s; from_type = strings
finish
to_length = 1; ! byte context for MOVC3
address (from); address (to)
reg == regv(register(0))
plant2 (movzbl, from, reg)
claim (from_base)
claim (reg_base)
if op&len check # 0 start
test assigned (from)
control = control&(¬ass check); ! So won't be done twice
op = op - len check
len == literal(tl-1)
len_type = byte+integers
plant2 (cmpl+byte, len, reg)
pop drop
prim (test string ovf)
finish
plant1 (incl, reg)
string3 (op, reg, from, to)
release (reg_base)
control = old control
end
routine ASSIGN STRING (record(stackfm) name from, to)
record(stackfm) name len
integer op
if from_format # 0 start; !string constant
address (to)
if from_format = 0+1 start; !null string
plant1 (clrl+byte, to); !*clrb_to
return
finish
len == literal(from_format); stp = stp-1; drop (len)
if 0 # to_length < len_disp start
error ('*', "string constant will overflow destination")
finish
string3 (movc3, len ,from, to)
else
op = movc3
if control&str check # 0 start
if to_type&4 = 0 {dest not work string} and
0 < to_length < 256 {ovf possible} start
op = op ! len check
finish
finish
string op (op, from, to)
finish
end
routine CONC (record(stackfm) name to, with)
record(stackfm) name t
record(stackfm) temp, rest, len
integer to len, wlen, total = 0, op
to len = to_format-1; wlen = with_format-1
if wlen > 0 and to len > 0 start
! Initial concat of const/literal strings
total = wlen + tolen
finish
if to_type&4 = 0 start; ! first one
t == work string; stp = stp - 1
temp = t
t_type = strings!4; ! mark as w/string to skip
assign string (to, t); ! length check
drop (t)
else
temp = to
finish
if wlen = 0 start; ! x."" ???
drop (with)
return
finish
op = 0; ! 'concat' in STRING OP
rest = 0
rest_base = r3
rest_form = v in s; ! r3 points to free byte in temp
claim (r3)
if last movc3 # ca start; ! r3 undefined
if temp_type&4 = 0 and to len >= 0 start
! Can work out start of area for new string
rest = temp
rest_disp = rest_disp + (to len + 1)
release (r3); ! unused..
else
plant2 (movzbl, temp, regv(r3))
temp_index = r3; claim (r3!128)
temp_flags = indexed
temp_disp = temp_disp+1
plant2 (movab, temp, regv(r3))
temp_disp = temp_disp-1
temp_flags = 0
finish
finish
len = 0
len_type = integers; len_length = 4
if wlen > 0 start; ! constant
len_form = constant
len_disp = wlen
else
if with_flags&indexed # 0 start
amap (with); load (with, any)
with_form = v in s
finish
if with_form # v in s start
load (with, any)
with_form = v in s
with_type = strings
finish
if activity(with_base) = 1 start
! use auto inc to skip length byte
with_flags = auto i
op = movc3
finish
claim (with_base)
len_form = v in r
len_base = register (0)
plant2 (movzbl, with, len)
with_flags = 0
claim (len_base)
finish
if total > 0 start; ! Const total length
if total > 255 start
error ('*', "string concatenation results in overflow")
total = 255
finish
plant2 (movb, literal(total), temp)
pop drop
else
iovf off
len_type = byte+integers
plant2 (addb2, len, temp)
prim (test string ovf) if control&str check # 0
iovf on
finish
string3 (op!no ass chk, len, with, rest)
release (len_base)
drop (with)
to = temp
to_type = strings!in work
end
routine FLOAT (record(stackfm) name v)
integer r
monitor (v, "Float in") if diag&2 # 0
address (v)
if v_form = constant and v_oper = 0 start
v_type = reall
v_lrval = v_disp; !float it here
return
finish
load (v, any) if v_type = byte+integers or v_oper # 0
r = fpr
plant2 (cvtld+(v_type&7)*8, v, regv(r))
claim (r); clear (v)
v_base = r; v_disp = 0; v_xno = 0
v_type = reall; v_form = v in r
monitor (v, "Float out") if diag&2 # 0
end
routine EQUATE (record(stackfm) name a, b, integer either)
record(stackfm) name x, y
integer key
switch op (0 : 4)
const byte array map (0 : 24) =
0,2,2,3,3, 1,0,2,3,3, 1,1,0,3,3, 4,4,4,0,1, 4,4,4,2,0
return if a_type = b_type
x == b; y == a
key = (a_type&15)*5+b_type&15
-> op(map(key))
op(1):
return if either = 0
x == a; y == b
op(2):
load (x, any) if x_form # constant
x_type = y_type
return
op(3):
return if either = 0
x == a; y == b
op(4):
float (x)
x_type = y_type if x_form = constant
op(0):
end
predicate SIMPLE SHIFT (record(stackfm) name from, to)
record(stackfm) name with, lit1, lit2
integer pos, size
false unless (from_oper = lsh or from_oper = rsh) and
to_type = integers
with == from_link
pos = -with_disp
false unless pos >= 0 and with_form = constant
from_oper = 0; drop (with)
size = 32
size = 16 if from_type = short+integers
size = 8 if from_type = byte+integers
pos = size if pos > size
size = size - pos; !size of result
address (from); address (to)
lit1 == literal(pos)
lit2 == literal(size); lit2_type = byte+integers
plant4 (extzv, lit1, lit2, from, to)
pop drop; pop drop
clear (from); drop (from)
true
end
routine LOAD (record(stackfm) name v, integer reg)
!load the entity described by 'v' into reg
integer oper, op, other, type, vtype, two op = 0
record(stackfm) name w, rv, x
switch iop (not : brem), rop (not : brem)
abort (37) unless r0 <= reg <= fpr4; !load what???
used(reg) = ca if reg < any; !prevent intermediate use
if v_oper = 0 and v_form = av in rec start
address var (1, v)
finish
type = v_type; vtype = integers; !default
oper = v_oper
monitor (v, "Load ".reg name(reg)) if diag&2 # 0
unless fpr0 <= reg <= fpr4 or floating (v) start
! Load integer
if oper # 0 start; !complex descriptor
v_oper = 0
w == v_link
if oper = exp start
load (v, r1); load (w, r2)
drop (w)
release (r1); release (r2)
prim (exp int)
v_base = r0; claim (r0)
load (v, reg) unless reg = any
return
finish
if oper = rsh or oper = lsh start
! These take BYTE shift counts
load (w, any) if w_flags&indexed # 0 and
w_type # byte+integers
finish
if oper = rsh or oper = remy start
! fiddly - need reg pair...
load (v, register(1)) unless in free reg (v) and
activity(v_base+1) = 0
other = v_base+1
abort (30) if activity(other) < 0
hazard (other); !reg is never r10
if oper = rsh start
plant1 (clrl, regv(other))
else
!rem - sign extend to 2nd register
if const (v) start
plant2 (movl, literal(-(v_disp>>31)), regv(other))
pop drop
else
plant4 (extv, literal(31), literal(1),
regv(v_base), regv(other))
pop drop; pop drop
finish
finish
claim (other)
address (w)
w_type = integers if oper = rsh; ! to prevent loading
else
if v_type = integers start
address (v)
else
load (v, reg); reg = v_base
finish
finish
if oper >= add start
address (w)
load (w, any) if w_type # integers
op = op map(oper)
finish
if oper # rsh start
if reg = any start
if oper >= add and op # 0 start; ! two op possible?
if op&commute # 0 and in free reg (w) start
reg = w_base; x == v; two op = 1
else if in free reg (v)
reg = v_base; x == w; two op = 1
finish
finish
reg = register (0) if reg = any; ! Not yet got one?
else
hazard (reg) unless v_base = reg or
(oper >= add and w_base = reg)
finish
rv == regv(reg)
finish
-> iop(oper)
iop(neg):plant2 (mnegl, v, rv); -> set
iop(not):plant2 (mcoml, v, rv); -> set
iop(mul):
if w_form = constant and (w_disp = 2 or w_disp = 4) start
plant2 (movl, v, rv) if two op = 0
plant2 (addl, rv, rv)
plant2 (addl, rv, rv) if w_disp = 4
-> wset
finish
iop(add):
iop(or ):
iop(xor):
iop(sub):
iop(div):
iop(bic):
if two op # 0 start
plant2 (op - three op, x, rv)
else
plant3 (op, w, v, rv)
finish
-> wset
iop(remy):
plant4 (ediv, w, v, rv, rv)
release (other)
-> wset
iop(lsh):
iop(rsh): ! rsh converted
w_type = byte+integers
w_disp = w_disp&255 if const (w)
iovf off
if oper = lsh start
plant3 (ashl, w, v, rv)
iovf on
else
plant3 (ashq, w, v, v)
iovf on
release (other)
load (v, reg)
clear (w); drop (w)
return
finish
wset: clear (w); drop (w)
-> set
iop(*): abort (33)
else
! just a simple descriptor
amap (v) if type&strings # 0; !only need address of string
if reg = any start; !none in particular
! select an appropriate register
if activity (v_base) = 1 start
! Use own base
return if v_form = v in r; !ok where it is
reg = v_base
else; !any other will do
reg = register(0)
finish
else; !specific register required
if reg = v_base start
return if v_form = v in r
else
hazard (reg)
finish
finish
finish
else
! Load real
vtype = reall
if oper # 0 and not floating(v) start
! integer operation pending
load (v, any); oper = 0
finish
if oper # 0 start
v_oper = 0; w == v_link
if oper = rexp start
load (v, fpr2)
load (w, r4)
drop (w)
release (fpr2); release (r4)
prim (exp real)
v_base = fpr0; claim (fpr0)
load (v, reg) unless reg = any
return
finish
if v_type # reall start
float (v) unless v_type = reals; !??something fishy here??
load (v, reg); reg = v_base
else
address (v)
finish
if oper >= add start
address (w)
float (w) unless floating (w)
load (w, any) unless w_type = reall
clear (w); drop (w)
finish
if reg = any start
if v_form = v in r then reg = v_base else reg = fpr
else
hazard (reg) unless reg = v_base
finish
rv == regv(reg)
-> rop(oper)
rop(neg):plant2 (mnegd, v, rv); -> set
rop(add):plant3 (addd+three op, v, w, rv); -> set
rop(sub):plant3 (subd+three op, w, v, rv); -> set
rop(mul):plant3 (muld+three op, v, w, rv); -> set
rop(rdiv):plant3 (divd+three op, w, v, rv); -> set
rop(*): abort (32)
else
! Simple real object
float (v) and type = reall if type&real bit = 0
if reg = any start
return if v_form = v in r and v_type = reall
reg = fpr
else
return if reg = v_base
hazard (reg)
finish
finish
finish
op = (7+type&7)*8 + vtype&7
op = movl if type = integers or zero (v)
if v_form = av in s or v_form = av in rec start
op = moval + type&7
v_form = v_form - 1
finish
address (v)
scale index (op, v)
plant2 (op, v, regv(reg))
set:
clear (v)
claim (reg)
v_type = vtype
v_form = v in r
v_base = reg
v_disp = 0; v_extra = 0
v_xno = 0; v_flags = 0
end
routine COP (integer op, integername l, integer r)
!perform a compile-time operation
switch c (not : brem)
-> c (op)
c(add): l = l+r; return
c(sub): l = l-r; return
c(bsub): l = r-l; return
c(mul): l = l*r; return
c(div): error ('*', "cannot divide by 0") and r = 1 if r = 0
l = l//r; return
c(remy): error ('*', "cannot take REM (c, 0)") and r = 1 if r = 0
l = l-l//r*r; return
c(bic): l = l&(¬r); return
c(or ): l = l!r; return
c(xor): l = l!!r; return
c(rsh):!!!!!! rsh is same as lsh with shift negated, so << NOT >>
c(lsh): l = l>>(-r); return
c(exp): l = l¬¬r; return
c(neg):
c(not):
c(rdiv):
c(rexp):
c(*):
abort (19)
end
routine OPERATE (integer oper)
integer key, lcon, rcon, wcon, lop, rop, scale, j
record(stackfm) name with, lh, rh
routine LOSE (record(stackfm) name v)
if v_oper > neg start
clear (v_link); drop (v_link)
finish
clear (v); drop (v)
end
routine SWAP
record(stackfm) temp
integer t
temp = lh; lh = rh; rh = temp
t = lcon; lcon = rcon; rcon = t
lop = lh_oper; rop = rh_oper
end
predicate GOOD BASE (record(stack fm) name v, integer mult)
! Is v a suitable candidate for doing addition
! by address op fiddling?
integer f, t, d
! directly usable?
false if v_flags&indexed # 0; ! already indexed
false if v_oper # 0
if v_form = constant and v_type = integers and
not 0 <= v_disp <= 63 and mult # 1 start
v_form = av in s; v_base = 0
finish
f = v_form; t = v_type
true if f = av in s or
(mult # 1 and t = integers and
f = v in s); ! useable directly
false unless f = av in rec or
(mult # 1 and t = integers and f = v in rec)
v_form = v in s; d = v_disp; v_disp = v_extra
if d = 0 and f = v in rec start
v_form = a in s
f = av in rec; ! => av in s
finish
load (v, any)
v_disp = d; v_form = f - rec mod
true
end
if diag&256 # 0 start
print string ("Operate: ")
print string (op name(oper))
newline
finish
if oper <= neg start; !unary
abort (17) if stp <= 0
lh == stacked(stp); lop = lh_oper
monitor (lh, "Oper in TOS") if diag&256 # 0
if const (lh) start
lh_disp = ¬lh_disp+oper-not; ! generates - or ¬ as req.
else if lh_form = constant and lop = 0; ! real constant
lh_lrval = -lh_lrval
else if 0 # lop <= neg; ! unary pending
if oper = lop start; ! -(-A) => A
lh_oper = 0
else
cstack (2*(oper-not)-1); ! neg=8,not=7
operate (add)
finish
else
if lop # 0 start
if oper = neg and lop = sub start
! -(A-B) => B-A
with == lh_link; lh_link == null; oper = 0
with_link == lh; with_oper = sub
stacked(stp) == with
else
load (lh, any)
finish
finish
lh_oper = oper; lh_link == null
finish
-> out
finish
abort (18) if stp <= 1
stp = stp - 1; ! pop one
lcon = 0; rcon = 0; wcon = 0
lh == stacked(stp)
rh == stacked(stp+1)
if diag&256 # 0 start
monitor (lh, "Oper in LHS")
monitor (rh, "Oper in RHS")
finish
! LH oper RH
if const (lh) start
if lh_disp = lnull op(oper) # no null start
! eg 0 + RH
stacked(stp) == rh
drop (lh)
-> out
finish
if lh_disp = 0 and
(oper = rsh or oper = lsh or oper = remy) start
! 0>>anything = 0
! 0<<anything = 0
! rem (0, anything) = 0
lose (rh)
lh_disp = 0
-> out
finish
lcon = 1
finish
if const (rh) start
if rh_disp = rnull op(oper) # no null start
! eg LH // 1
drop (rh)
-> out
else if (oper = rsh and rh_disp > 31) or
(oper = lsh and rh_disp < -31)
! eg J << 45 = 0
lose (lh)
stacked(stp) == rh; rh_disp = 0
-> out
else if oper = remy and |rh_disp| = 1
! rem(x,1) = rem(x,-1) = 0
lose (lh)
stacked(stp) == rh; rh_disp = 0
-> out
finish
rcon = 1
if oper = sub start
rh_disp = -rh_disp
oper = add
finish
finish
if lcon&rcon # 0 and oper # rdiv and oper # rexp start
cop (oper, lh_disp, rh_disp); drop (rh)
-> out
finish
swap if lcon # 0 and comm(oper) # 0; ! get var oper const
lop = lh_oper; rop = rh_oper
if lop # 0 start
! (LH lop WITH) oper RH
with == lh_link
wcon = 1 if lop > neg and const (with)
if wcon&rcon # 0 start
key = trans(oper)!trans(lop)
if key = 0 or (key = 1 and oper = lop) start
cop (oper, with_disp, rh_disp)
drop (rh)
if with_disp = rnull op(lop) # no null start
! Can now remove WITH
lh_oper = 0; drop (with)
finish
-> out
finish
finish
swap if oper = add and rop = 0
finish
load (lh, any) if lh_oper # 0
if rcon # 0 start
if rh_disp = -1 and (oper = mul or oper = xor) start
if oper = mul start
lh_oper = neg; ! A*(-1) -> -A
else
lh_oper = not; ! A!!(-1) -> ¬A
finish
drop (rh); -> out
else if oper = add and lh_type = integers
! a+const (not short lit)
if lh_form = v in r and not -63 <= rh_disp <= 63 start
lh_form = av in s; lh_disp = 0
finish
if (lh_form = av in s or lh_form = av in rec) and
lh_flags&xdefer = 0 start
lh_disp = lh_disp+rh_disp
drop (rh); -> out
finish
else if oper = bic and rh_disp = ¬255 and
lh_flags&indexed = 0 and lh_form # v in r
!int&255 -> byte
address (lh) and test assigned (lh) if lh_type = integers
lh_type = byte+integers
drop (rh); -> out
finish
finish
if oper = add start
! Here LH + (RH {rop X}?)
! Look for various fiddles involving address ops
! and indexing
scale = 1
if rop > neg start
with == rh_link
if const (with) and (rop = mul or rop = lsh) start
j = with_disp
j = 1<<j if rop = lsh
if j = 2 or j = 4 or j = 8 start
scale = j
finish
finish
finish
if good base (lh, scale) start
! OK
else if good base (rh, 1)
swap
else
-> no joy
finish
if scale # 1 start
rh_oper = 0; rop = 0
drop (with)
finish
-> no joy if scale = 1 and lh_form = v in s
load (rh, any)
lh_index = rh_base; release (rh_base); drop (rh)
lh_flags = indexed; claim (lh_index!128)
lh_flags = lh_flags!xdefer if lh_form = v in s
lh_iscale = scale; lh_length = scale
lh_form = av in s
-> out
no joy:
finish
if rop # 0 start
! LH oper (RH rop WITH)
with == rh_link
if rop = neg and (oper = add or oper = sub) start
! A+(-B) -> A-B
oper = add+sub-oper
rh_oper = 0
else
load (rh, any)
finish
finish
lh_oper = oper; lh_link == rh
out: monitor (lh, "Oper out") if diag&256 # 0
end
! Following should really be operations..
routine ADDRESS OP (integer code)
! Evaluate LHS ++ RHS
integer type, len
set both
type = lhs_type; len = lhs_length
error ('*', "object length unspecified for ++ or --") if len = 0
amap (lhs)
cstack (len); operate (mul)
if code = 117 then operate (add) else operate (sub)
vmap (lhs)
lhs_type = type; lhs_length = len
end
routine CONCATENATE
! Evaluate LHS . RHS
set both
conc (lhs, rhs)
stp = stp - 1
end
routine SET MODULUS
! Evaluate |LHS|
!
! Generates the sequence
! Load LHS,Rn
! TSTL Rn
! BGEQ Pos
! MNEGx Rn, Rn
! Pos:
!
! leaving |LHS| in a register
integer op
set lhs
if lhs_form = constant and lhs_oper = 0 start
! Do it in line...
if lhs_type&integers # 0 start
lhs_disp = |lhs_disp|
else if lhs_type = reall
lhs_lrval = -lhs_lrval if lhs_lrval < 0
else
abort (48)
finish
else
load (lhs, any)
test zero (lhs); claim (lhs_base)
word (bgeq+3<<8)
op = mnegl
op = mnegd if lhs_type&real bit # 0
plant2 (op, lhs, lhs); ! 3 bytes..
finish
end
routine ASSIGN (integer assop)
!assop = -1 : parameter assignment
! = 0 : == assignment
! = 1 : = assignment
! = 2 : <- assignment
integer op, oper, work, move, slen, dlen, total, loop ca
integer st, dt, wt
const string(2) array assym (-1 : 2) =
"p=", "==", "= ", "<-"
record(varfm) name vv
record(stackfm) name source, dest, len, w, count
routine SHAPE UP (integer type, record(stackfm) name cc)
! Get cc into a form such that OPERAND won't complain
! about size of constants, eg short = 16_FFFF would be wrong
if type = byte+integers start
cc_disp = cc_disp & 255
else if type = short+integers
cc_disp = cc_disp & 16_FFFF; ! splat top bits
! Sign extend short, ie bits <31:15> all 0 or all 1)
cc_disp = cc_disp!(¬16_FFFF) if cc_disp&16_8000 # 0
finish
cc_type = type
end
dest == stacked(stp-1)
source == stacked(stp)
if diag&128 # 0 start
monitor (source, "Ass ".assym(assop)." srce")
monitor (dest, " dest")
finish
if assop < 0 start; !parameter assignment
load (source, any) if source_oper # 0
dest_extra = dest_extra-1
vv == var(dest_extra)
if vv_form # v in s start
if vv_form&arrayname bit # 0 start
source_oper = 1
else if vv_form &proc bit # 0
unless r6 <= source_base <= r9 start; !not already a param
w == temp(24); stp = stp - 1
w_base = fp; work = w_disp
if source_xno # 0 start; !external
source_form = v in s
plant2 (moval, source, w)
else; !normal routine
hazard (r10)
put code (opcode(moval&255))
flush code
define reference (source_disp, dirpref)
put (obj call); put long (source_disp); ca = ca+2
put number byte (16_5a)
!moval p,r10
entry mask = entry mask ! 16_400; ! save R10
local = local!128; !prevent OPERAND changing it to FP
plant2 (movl, regv(r10), w)
if local = r6!128 then move = movl c
else move = movq
w_disp = w_disp+4
plant2 (move, regv(r6), w)
w_disp = w_disp+8
if local > r7!128 start
if local = r8!128 then move = movl c
else move = movq
plant2 (move, regv(r8), w)
finish
w_disp = w_disp + 8
plant2 (movl, regv(gla), w)
local = local&127
finish
drop (source); source == w; source_disp = work
w_base = local
source_form = av in s
else
source_form = v in s
finish
source_type = integers
else if vv_type = 0; !general type
source_oper = 2
source_oper = 3 if source_type = 0; !also general
else
amap (source)
finish
else if vv_type&real bit # 0
float (source) unless floating (source)
if vv_type = reall and source_type = reals start
load (source, any)
else if vv_type = reals
source_type = reals
finish
finish
if vv_type = records and source_format = 0 start
! Passing rec(*) as value (parameter typed)
source_format = vv_format
finish
source_link == dest_link
dest_link == source
stp = stp-1
return
finish
stp = stp-2
if dest_form&arrayname bit # 0 start
op = dest_form&15
if op >= v in rec then op = v in rec c
else op = v in s
dest_form = op
address (dest)
move arrayname (source, dest)
clear (dest); drop (dest)
return
finish
if assop = 0 start; !==
amap (source); amap (dest)
finish
if same (source, dest) start; ! ????
clear (source); drop (source)
clear (dest); drop (dest)
return
finish
if source_oper = 0 and source_form = av in rec start
address var (1, source)
finish
if dest_type&strings # 0 start
assign string (source, dest)
drop (source); drop (dest)
return
finish
if dest_type = records start
slen = 0
slen = var(source_format)_length if source_type = records
dlen = var(dest_format)_length
if dlen = 0 = slen start; ! Eh ???
clear (source) if source_type = records
clear (dest)
error ('*', "record format not specified")
else
if dlen = 0 start; ! rec = record(n)
work = slen
else if slen = 0; ! rec = 0
work = dlen
else
error ('*', "record format mismatch??") if dlen # slen
work = slen
finish
abort (0) if work < 0; ! more than 1/2 a VM ?????
total = work
work = rem (total, 16_FFFF)
total = (total-work)//16_FFFF;! No of blocks left
work = 16_FFFF and total = total-1 if work = 0
len == literal(work); stp = stp-1
shape up (short+integers, len)
if dest_flags&indexed # 0 and
dest_iscale = 1 and total # 0 start
! If MOVCn required, context is BYTE,
! so fool ADDRESS.
dest_length = 1
finish
address (dest); dest_type = integers
if source_type = records start
op = movc3
if total # 0 start
op = op!no short
if source_flags&indexed # 0 and
source_iscale = 1 start
! same fiddle as above
source_length = 1
finish
finish
address (source); source_type = integers
string3 (op, len, source, dest)
clear (source)
op = 1; ! mark record move
else; ! rec = 0
work = scale type (work)
if work >= 0 and total = 0 start
! Can use short form
plant1 (clrl+work, dest)
else
plant5 (movc5, zerov, gla work, zerov, len, dest)
finish
op = 0; ! marks rec=0
finish
clear (dest)
if total > 0 start; ! more to do...
if total # 1 start; ! need a loop
count == literal(total); stp = stp - 1
load (count, r10)
loop ca = ca
finish
len_disp = -1; ! => 16_FFFF in OPERAND
dest_base = r3; dest_disp = 0; dest_form = v in s
dest_flags = 0; claim (r3)
if op # 0 start; ! rec move
source_base = r1; source_disp = 0; source_form = v in s
source_flags = 0; claim (r1)
plant3 (movc3, len, source, dest)
else
plant5 (movc5, zerov, gla work, zerov, len, dest)
finish
if total # 1 start
plant1 (sobgtr, count)
put number byte (loop ca-(ca+1)); ! byte offset
release (r10)
drop (count)
finish
finish
drop (len)
finish
drop (dest)
drop (source)
return
finish
oper = source_oper
if oper # 0 start
if assop = 2 start
if dest_type&integers # 0 start
iovf off
finish
finish
if oper < add start; !unary
if oper = not and dest_type&real bit # 0 start
! Real = ¬integer
load (source, any)
source_oper = 0
else
op = mnegl; op = mcoml if oper = not
source_oper = 0
equate (dest, source, 0)
if dest_type = source_type # byte+integers start
if same (source, dest) start
address (dest)
source = dest; claim (source_base)
else
address (source); address (dest)
finish
plant2 (op+dest_type&7, source, dest)
clear (source)
drop (source); drop (dest)
iovf on
return
finish
source_oper = oper
finish
else
op = op map(oper)
if op # 0 start; !3-op possible
w == source_link
source_oper = 0
wt = w_type; st = source_type; dt = dest_type
if (dt!wt!st)&real bit = 0 start
! Massage integer constants to permit 3-ops
if const (w) and
fits (w_disp, dt) start
w_type = dt and wt = dt if st = dt
else if const (source) and
fits (source_disp, dt)
source_type = dt and st = dt if wt = dt
finish
finish
unless dt # st = wt start
equate (dest, source, 0)
equate (dest, w, 0)
if source_type = dest_type = w_type start
if same (dest, source) start
address (dest); source = dest
claim (source_base)
address (w)
else if same (dest, w)
address (dest); w = dest
claim (w_base)
address (source)
else if same (source, w); ! a = b + b
address (source); w = source
claim (w_base)
address (dest)
else
address (source)
address (dest)
address (w)
finish
iovf off if dest_type = byte+integers
plant3 (op+dest_type&7, w, source, dest)
iovf on
clear (source); clear (w)
drop (source); drop (dest); drop (w)
return
finish
finish
source_oper = oper
else
drop (dest) and return if simple shift (source, dest)
finish
finish
load (source, any) if source_oper # 0
finish
! Prevent trouble with "byte = intarray(n)": would generate MOVB
! but with source indexed, should be appropriate source length op.
load (source, any) if source_flags&indexed # 0 and
source_type # byte+integers = dest_type
shape up (dest_type, source) if assop = 2 and const (source)
address (dest)
source_type = dest_type if source_form = constant and
dest_type&integers # 0
op = (source_type&7)*8+7*8
op = movl if source_type = dest_type or zero (source)
op = op + dest_type&7
if source_form = av in s or source_form = av in rec start
if dest_type # integers start
load (source, any)
else
source_form = source_form-1; op = moval
finish
finish
address (source)
scale index (op, source)
plant2 (op, source, dest)
clear (source); clear (dest)
drop (source); drop (dest)
iovf on
end
routine LRD (record(stackfm) name v, integer reg)
!load, release and drop
load (v, reg)
release (v_base); !reg could be any!!!!!
drop (v)
end
routine SET STATUS
! This is the top level - load a 'success' result
! into R0 for the CLI's benefit (return pending).
record(stackfm) name res
return if uncond jump = ca
res == literal(1); stp = stp - 1
lrd (res, r0)
end
routine SET RESULT (record(stack fm) name v, integer mode)
integer reg
amap (v) if mode = 'M'; !a map
if gvar_type&(strings!records) # 0 and mode = 'V' start
! Result of string/record function - goes via
! (hidden) first parameter..
lstack (64); ! disp of result addr
lhs_form = a in s
if gvar_type&records # 0 start
lhs_type = records; lhs_format = gvar_format
dstack (v); assign (1)
else
lhs_type = strings; lhs_length = gvar_length
stp = stp - 1
assign string (v, lhs)
drop (lhs)
finish
drop (v)
else
reg = r0
reg = fpr0 if gvar_type&real bit # 0 and mode = 'V'
lrd (v, reg)
finish
end
routine RETURN
return if uncond jump = ca
put code (opcode(ret&255))
uncond jump = ca
end
routine RECORD SELECT
integer n
n = getword; set lhs
vstack (var(var(lhs_format)_extra-n))
set both
stp = stp - 1
monitor (lhs, "Rec sel in") if diag&8 # 0
if lhs_flags&indexed # 0 and
(lhs_flags&xdefer # 0 or
lhs_form = a in s or lhs_form = a in rec) start
! address calc incomplete
address (lhs)
if lhs_flags&xdefer # 0 and rhs_disp # 0 start
amap (lhs)
load (lhs, any)
lhs_form = v in s
finish
finish
if lhs_form = v in s or lhs_form = v in rec start
rhs_disp = rhs_disp+lhs_disp
lhs_form = lhs_form - v in s + rhs_form
rhs_mantissa = rhs_mantissa + lhs_disp; ! For arrays in records
else if lhs_form = a in s or lhs_form = a in rec
if lhs_form = a in s and activity(lhs_base) < 0 start
lhs_extra = lhs_disp
lhs_form = rhs_form + rec mod
else
lhs_form = lhs_form - 2; lhs_type = integers
load (lhs, any)
lhs_form = rhs_form
finish
else if lhs_form <= v in r
lhs_form = rhs_form
else
abort (45)
finish
lhs_disp = rhs_disp
lhs_type = rhs_type
lhs_length = rhs_length
lhs_format = rhs_format
lhs_header = rhs_header
lhs_mantissa = rhs_mantissa
drop (rhs)
monitor (lhs, "Rec sel out") if diag&8 # 0
end
routine ARRAY REF (integer mode)
!mode = 0 - last subscript (or only)
! = 1 - not last subscript
record(stackfm) name a, ind
integer type, len, rlen, c, form, x, idrop
integer aname, icon, ival, hbase, hdisp
if mode # 0 start; !multi-dim
set both
if lhs_oper = 0 start
lhs_oper = 1; lhs_link == null
finish
address (rhs); !index
rhs_link == lhs_link; lhs_link == rhs
stp = stp - 1
return
finish
a == stacked(stp-1)
ind == stacked(stp); idrop = 1; ! index still stacked
if diag&8 # 0 start
monitor (a, "Array base")
monitor (ind, "Array index")
finish
rlen = a_length; type = a_type
form = a_form&15; aname = a_form&arrayname bit
a_type = integers; a_form = v in s
if form >= v in rec start; ! Array or arrayname in record
form = form - 3
a_form = v in rec
finish
! remember where header is - may be needed
if a_header > 0 start
hbase = gla; hdisp = a_header
else
hbase = a_base; hdisp = a_disp
finish
if a_oper = 0 start; ! 1-dim
! constant index?
icon = 0; icon = 1 and ival = ind_disp if const (ind)
! sort out length of actual elements of array (may be %namearray)
len = rlen; len = 4 if form = a in s
! change A into a descriptor for the zeroth element
if a_form = v in rec start
if aname = 0 start; ! array in record
if a_mantissa = 0 start
! ie addr(A(0)) = addr(record)
a_form = a in s; a_disp = a_extra
else
a_disp = a_extra; a_form = v in s
load (a, any)
a_form = v in s; a_disp = a_mantissa
finish
else; ! arrayname in record
a_form = a in rec
address (a)
hbase = a_base; hdisp = a_disp; ! Will have changed
finish
else; ! v in s
if a_header = -1 start
a_form = a in s; ! for arrayname or header complete
else
a_disp = a_mantissa
a_form = v in s
finish
finish
if control&arr check # 0 start; ! Check array index
load (ind, r1)
lstack (hdisp); lhs_base = hbase
lhs_xno = a_xno; stp = stp - 1
if a_header < 0 start; ! Header complete: load in 1 go
hazard (r2); hazard (r3)
plant2 (movq, lhs, regv(r2))
else
lhs_disp = lhs_disp + 4; ! point at dope vector pointer
load (lhs, r3); ! load it: r3 -> dope vector
amap (a); load (a, r2); ! r2 is zero address
release (r2); release (r3)
finish
drop (lhs)
release (r1)
prim (aref)
claim (r1); a_base = r1; a_disp = 0
else; ! No checking
aname = 0; aname = 1 if a_form = a in s
if aname = 0 and (ind_oper = add or ind_oper = sub) and
const (ind_link) start
! a(j+const) -> a(j) ++ const
c = ind_link_disp; c = -c if ind_oper = sub
a_disp = a_disp + c * len
drop (ind_link); ind_oper = 0
finish
if icon # 0 and ival = 0 and aname # 0 and
(form = v in s or activity(a_base) < 0) start
! aname(0) -> @aname
if form = v in s start
form = a in s
else
form = a in rec; a_extra = a_disp; a_disp = 0
finish
else
if len = 0 start; ! %record/%string(*) %arraynames
!get size from dope vector
lstack (hdisp+4); ! disp of dope vector pointer
lhs_base = hbase
lhs_xno = a_xno
load (lhs, any)
lhs_form = v in s; lhs_disp = 12; ! size l/word in dv.
else
cstack (len)
finish
operate (mul)
amap (a); operate (add)
vmap (a)
if form = a in s then form = a_form + 2 c
else form = a_form
idrop = 0; ! ind will have been dropped
finish
finish
stp = stp - 1 and drop (ind) if idrop # 0; ! Not already done
else; ! multi dim - uses the perm
stp = stp - 1
a_oper = 0
! expend stacked indices
address (ind)
push (ind, x)
cycle
ind == a_link; a_link == ind_link
push (ind, x)
repeat until a_link == null
address (a)
hazard (r2); hazard (r3)
plant2 (movq, a, regv(r2))
prim (arefn)
claim (r1); a_base = r1; a_disp = 0; a_form = v in s
finish
a_form = form
a_xno = 0 unless a_base = pc
a_type = type; a_length = rlen
monitor (a, "Array ref") if diag&8 # 0
end
!comparison processing
routine TEST ZERO (record(stackfm) name v)
!check v against zero
record(stackfm) name w
integer d, op
unsigned = 0
if v_oper = bic and v_link_form = constant start
d = ¬v_link_disp
drop (v_link); v_oper = 0
op = bitl
if v_type = byte+integers start
if d&(¬255) # 0 then load (v, any) else op = bitl+byte
else if v_type = short+integers
if d&16_ffff0000 # 0 then load (v, any) else op = bitl+short
finish
address (v)
w == literal(d); stp = stp-1
w_type = v_type
plant2 (op, v, w)
drop (w)
else
address (v)
unsigned = 8 if v_type = byte+integers
plant1 (tstl+v_type&7, v)
finish
clear (v)
end
routine COMPARE (record(stackfm) name left, right, integer mod)
! set the cc from left and right
integer work
record(stackfm) name len, temp
routine CHECK (record(stackfm) name a, b)
! a is a constant string
record(stackfm) len
len = 0
len_disp = a_format
if len_disp = 0+1 start; !null
b_type = byte+integers
test zero (b)
else
address (b)
string3 (cmpc3, len, a, b)
finish
end
if zero (right) start
!************** rubbish %if mod # 0 %and left_oper = sub %start
!************** rubbish ! a - b comp 0 => a comp b
!************** rubbish drop (right); right == left_link; left_oper = 0
!************** rubbish %else
test zero (left); return
!*****************rubbish %finish
finish
if zero (left) start
if mod # 0 and right_oper = sub start
! 0 comp a - b => b comp a
drop (left); left == right_link; right_oper = 0
else
invert = invert!!16
test zero (right); return
finish
finish
unsigned = 0
if right_type&strings # 0 start
unless '=' # look # '#' start
if left_format # 0 start
check (left, right); return
finish
if right_format # 0 start
check (right, left); return
finish
string op (cmpc3, left, right); return
finish
load (left, r10); load (right, r2)
release (r10); release (r2)
prim (scomp)
return
finish
! ???? Why the following, if pass1 won't let one compare records????????
if left_type = records or right_type = records start
work = var(left_format)_length
if work = 0 and right_type = records start
work = var(right_format)_length
finish
len == literal(work); stp = stp - 1
len_type = short+integers
address (left); left_type = integers
address (right); right_type=integers
string3 (cmpc3, len, left, right)
clear (left); clear (right)
drop (len)
return
finish
address (left); address (right)
equate (left, right, 1)
unsigned = 8 if left_type = byte+integers
if short literal(left) >= 0 start
! faster to have it on the right...
invert = invert!!16
temp == right; right == left; left == temp
finish
plant2 (cmpl+left_type&7, left, right)
clear (left); clear (right)
end
routine COMPARE ARRAYNAMES (record(stack fm) name lhs, rhs)
lhs_form = lhs_form&15; rhs_form = rhs_form&15
address (lhs); address (rhs)
plant2 (cmpd, lhs, rhs)
clear (lhs); clear (rhs)
end
routine SET CC
const byte array cc (1:6) = 4, 8, 8+2+1, 8+1, 8+2, 4+2
const byte array cmap(1:6) = '=', '<', '(', '>', ')', '#'
record(stackfm) name pos, one, temp
integer sym, code, r
get (sym)
code = 0
for r = 1,1,6 cycle
code = r and exit if cmap(r) = sym
repeat
abort (34) if code = 0
code = cc(code)
set both
if code&1 # 0 start; !swop first
temp == lhs; lhs == rhs; rhs == temp
finish
compare (lhs, rhs, 1); stp = stp-2
drop (lhs); drop (rhs)
r = register (0)
temp == regv (r)
claim (r)
plant1 (movpsl, temp)
plant2 (mcoml, temp, temp) if code&2 # 0; !invert it
pos == literal(code&(4!8)); stp = stp - 1
one == literal(1); stp = stp - 1
drop (pos); drop (one)
plant4 (extzv, pos, one, temp, temp)
dstack (temp)
end
routine FOR
! compile a %for clause
integer lab, err, fixed, old control
integer sc, sv, ic, iv, lc, lv, x
record(stackfm) name cont, init, incr, last
routine STAB (record(stack fm) name v, integername con, val)
record(stack fm) name w
con = 0
if const (v) start
con = 1
val = v_disp
else
w == temp(4)
dstack (v); v = w
assign (1)
finish
end
stp = stp - 4
cont == stacked(stp+1)
incr == stacked(stp+2)
last == stacked(stp+3)
init == stacked(stp+4)
abort (20) if cont_type&integers = 0
if cont_type # integers start
error ('*', "only %integer %for-loop variables permitted")
cont_type = integers
finish
stab (incr, ic, iv)
stab (last, lc, lv)
sc = 0; sc = 1 and sv = init_disp if const (init)
unless activity(cont_base) < 0 and cont_form = v in s and
cont_flags = 0 start
! Can't use cv directly
amap (cont); stab (cont, x, x); cont_form = a in s
finish
fixed = sc&ic&lc; ! constant bounded loop?
dstack (cont); ! to assign to
if fixed = 0 and control&for check # 0 start
! Need perm call
dstack (init); pop lhs; lrd (lhs, r1)
dstack (incr); pop lhs; lrd (lhs, r2)
dstack (last); pop lhs; lrd (lhs, r3)
prim (for test); ! returns init-incr
dstack (regv(r0))
claim (r0)
else if fixed # 0
! Fixed loop - test for legality
sv = sv - iv
err = 0
if iv = 0 start
err = 1 unless sv = lv; ! x, 0, y
else
if iv > 0 start
err = 1 if sv > lv
else
err = 1 if sv < lv
finish
err = 1 if rem (lv-sv, iv) # 0
finish
error ('*', "%for loop cannot terminate") if err # 0
cstack (sv)
else
dstack (init); dstack (incr); operate (sub)
finish
assign (1)
lab = getword; define label (lab)
! No need to check assigned from here on
old control = control
control = control & (¬ass check)
! %exit %if cont = last
compare (cont, last, 0)
jump to (lab+1, 1, 1)
! cont = cont + incr
dstack (cont); dstack (cont); dstack (incr)
operate (add); assign (1)
control = old control
drop (cont); drop (incr); drop (init); drop (last)
end
!procedure processing
routine PUSH (record(stackfm) name t, integer name n)
integer op, mop, old op
record(stackfm) name w
record(stackfm) ww
monitor (t, "Push") if diag&16 # 0
op = pushl; mop = -1
if t_oper # 0 start; !arraynames or %name
old op = t_oper; t_oper = 0
if old op = 2 start; !general name
push (literal(t_type<<24+t_length), n); stp = stp-1
t_form = t_form & 15
address (t)
amap (t)
else if old op = 1
move arrayname (t, spv)
n = n + 2; return
else
t_form = v in s; mop = movq
drop (t)
finish
else if t_type = integers
address (t) if t_form # av in s
if t_form = constant and -64 <= t_disp < 0 start
! Can use mcoml,mnegl - let PLANT2 fix it
mop = movl;
drop (t); n = n - 1
finish
else
if t_type&(records!strings) # 0 start
if t_type = records start
w == temp(var(t_format)_length)
w_type = records; w_format = t_format
dstack (w); dstack (t); assign (1)
stp = stp - 1
drop (t); t == w
else if t_type = strings; !not already in wk strg
w == work string; stp = stp-1
ww = w
assign string (t, w); drop (t)
t == w; t = ww
finish
t_type = integers; op = pushal
else if t_type&real bit # 0
address (t)
drop (t); clear (t); mop = movd
if t_type = reals start
n = n - 1; mop = movf
finish
else if t_type = long+integers
mop = movq; address (t); drop (t)
else
address (t); clear (t); drop (t)
mop = t_type&7*8+7*8
n = n - 1; !only 1 longword
finish
finish
if mop = -1 start
if t_form = av in s start
op = pushal; t_form = v in s
finish
scale index (op, t)
plant1 (op, t) if op # 0
clear (t); drop (t)
else
scale index (mop, t)
plant2 (mop, t, spv)
n = n + 1; !an extra param
finish
n = n + 1
end
routine CALL (record(stackfm) name v)
!call procedure 'v'
integer reg, n, disp, type, form, pn, pa
record(stackfm) name t, p, w
record(stackfm) ec
switch pri (1 : 31)
const byte array params (1 : 31) =
1(17), 2(2), 0(3), 1, 1(4), 0, 0, 2, 2
const byte array ptype (2 : 8) =
byte+integers, short+integers,
integers, strings, records,
reals, reall
const byte array plen (2 : 8) =
1, 2, 4, 0, 0, 4, 8
monitor (v, "Call") if diag&16 # 0
type = v_type; form = v_form&15
disp = v_disp
pn = v_mantissa
if pn # 0 start; ! %PRIM
pa = params(pn); ! #parameters
if pa > 0 start
t == v_link; t_oper = 0
if pa = 2 start
rhs == t; ! 2nd parameter heads list
t == t_link
t_oper = 0
finish
dstack (t); set lhs
drop (t)
finish
drop (v) if pn < 23; ! No actual external ref
-> pri (pn)
pri(1): !addr
if lhs_form = 15 start; ! of label?
n = register (0); claim (n)
entry mask = entry mask ! reg mask (n)
put code (16_9E); !movab
flush code
define reference (lhs_disp, dir pref)
put (obj call); ca = ca + 2; !assume short
put long (lhs_disp)
put number byte (16_50+n-1); !Rn
lhs_base = n; lhs_disp = 0; lhs_xno = 0
lhs_type = integers; lhs_form = v in r
else
!!!! error ('*' "cannot take address of...") %if .. ??
amap (lhs)
finish
return
pri(2): !byte
pri(3): !short
pri(4): !integer
pri(5): !string
pri(6): !record
pri(7): !real
pri(8): !longreal
load (lhs, any) if pn = 5 and lhs_flags&indexed # 0
vmap (lhs)
lhs_type = ptype(pn)
lhs_length = plen(pn)
lhs_format = 0; ! For strings/records
return
pri(9): !int
pri(10): !intpt
address (lhs)
n = register (0); claim (n)
plant2 (11*8-4*8+lhs_type&7*8+6*(10-pn), lhs, regv(n))
release (lhs_base)
lhs_base = n
lhs_form = v in r; lhs_disp = 0; lhs_xno = 0
lhs_type = integers; lhs_length = 4
return
pri(11): !read ch
pri(12): !read symbol
if lhs_type&(integers!strings) = 0 start
error ('*', "invalid parameter to READ SYMBOL/CH")
lhs_type = integers
finish
prim (rch+pn-11)
abort (47) if lhs_oper # 0
if lhs_type&strings # 0 start
if lhs_form # v in s or lhs_flags # 0 start
amap (lhs); load (lhs, any)
lhs_form = v in s; lhs_type = byte+integers
finish
lhs_flags = auto i if activity(lhs_base) = 1
lhs_type = byte + integers; lhs_length = 1
dstack (lhs); cstack (1); assign (1)
claim (lhs_base)
if lhs_flags = auto i start
lhs_flags = 0
else
lhs_disp = lhs_disp + 1
finish
finish
w == regv(r0); claim (r0); dstack (w)
assign (1)
return
pri(20): !skip item
pn = 22; !=skip symbol
pri(21): !skip ch
pri(22): !skip symbol
prim (rch+pn-21)
return
pri(13): !printch
pri(14): !print symbol
stp = stp - 1
lrd (lhs, r0)
prim (pch+pn-13)
return
pri(15): !tostring
stp = stp-1
w == temp(2); w_type = byte+integers
dstack (w); dstack (w)
dstack (lhs); drop (lhs)
set both; lhs_disp = lhs_disp + 1
assign (1)
cstack (1)
assign (1)
set lhs; lhs_type = strings; lhs_format = 2
return
pri(18): !charno
if control&str check # 0 start
load (lhs, r0); release (r0); ! string address
lrd (rhs, r1); ! character #
prim (char num)
claim (r0)
lhs_form = v in s; lhs_length = 1
lhs_type = byte+integers
return
finish
dstack (rhs); drop (rhs)
operate (add); set lhs
pri(17): !length
vmap (lhs)
lhs_type = byte+integers
lhs_length = 1
return
pri(19): !rem
dstack (rhs); drop (rhs)
operate (remy)
set lhs
pri(16): !float
return; ! already done by ASSIGN!
pri(24): !PUT
pri(25): !PUT WORD
pri(26): !PUT LONG
pri(27): !GET (%integername b)
pri(30): !PUT BLOCK
pri(31): !GET BLOCK
stp = stp - 1; ! no result
lrd (lhs, r0)
lrd (rhs, r1) if pn >= 30
hazard (reg) for reg = r0, 1, r10
v_form = v in s; plant1 (jsb, v); drop (v)
return
pri(28): !GET WORD ()
pri(29): !GET LONG ()
hazard (reg) for reg = r0, 1, r10
v_form = v in s; plant1 (jsb, v); drop (v)
dstack (regv(r0)); claim (r0); ! The result
return
pri(23): !printstring
! main point of this is to prevent loading
! parameter into work string..
! (pity if it's there already!)
stp = stp - 1
v_link == lhs; lhs_link == null
if lhs_type = strings start
! Not already in work string - hurrah!
address (lhs)
test assigned (lhs)
amap (lhs); ! now integer (av in s)
finish
finish
n = 0
t == v_link
while t ## null cycle
p == t_link
push (t, n)
t == p
repeat
if v_type&(strings!records) # 0 and
v_form&15 = v in r start; !stringfn
if v_type&strings # 0 then p == work string c
else p == temp(var(v_format)_length)
p_type = integers
plant1 (pushal, p)
p_type = strings!4; !already in a work string
p_type = records if v_type = records
p_format = v_format
v_type = 0; type = 0
n = n + 1; !an extra hidden parameter
finish
hazard (reg) for reg = r0, 1, r10
if v_base # pc start; !parameter
v_type = integers; v_form = v in s
plant2 (movl, v, regv(r1))
primep (proc enter)
plant1 (calls,literal(n)); popdrop
flush code
put (obj prim ref); put (proc enter); ca=ca+5
else if v_xno # 0
ec = v
ec_form = v in s
plant2 (calls, literal(n), ec); popdrop
else
plant1 (calls, literal(n)); pop drop; !second operand set in p3
flush code
define reference (disp, dir pref)
put (obj call); put long (disp)
ca = ca + 2; !assume short
finish
if type # 0 start; !There's a result
v_type = type; v_form = form
v_base = r0; v_disp = 0; v_xno = 0
claim (r0); dstack (v)
finish
drop (v)
end
!sundries
routine SET LANGUAGE
integer l
l = getword; !ignore!!!
end
routine SET DIAG
integer new diag = getword
diag = new diag&16_3FFF if new diag&(3<<14) = 2<<14
end
routine SET CONTROL
integer new control
! Don't allow %control to turn on things
! which were turned off by command line
! (except for record rounding).
new control = get word
control = new control & (original control!rec round)
end
routine LINE BOUND
! Perform consistency checks and update line counter
abort (23) if stp # 0
abort (24) unless using_link == null
abort (25) if active regs # 0
abort (39) if index regs # 0
flush code; current line = getword
this area = 0; !return work strings
line error = 0
if diag # 0 start
newline
print string ("Line "); write (current line, 0)
newline
finish
end
routine EVENT BLOCK
record(stack fm) name savesp
events = getword; get (discard)
evlow = getword; !finish label
evno = evno + 1
savesp == temp(4); stp = stp - 1
plant2 (movl, regv(sp), savesp); !preserve stack
jump to (evlow, jump, 1); evlow = last ref
evep = new tag; define tag (evep)
uncond jump = 0
plant2 (movl, savesp, regv(sp))
drop (savesp)
end
routine GENERATE SIGNAL
cstack (0) while stp < 2
cstack (getword)
pop lhs; load (lhs, r0); drop (lhs)
pop lhs; load (lhs, r2); drop (lhs)
pop lhs; load (lhs, r1); drop (lhs)
release (r0); release (r1); release (r2)
prim (signal)
uncond jump = ca
end
routine SET BOUNDS
set both
vlb = lhs_disp; vub = rhs_disp
pop drop; pop drop
end
routine DECLARE ARRAY
record(stackfm) d
integer dim, arrays, sp, j, hdisp, dv
dim = getword; get (discard)
arrays = getword; !how many
if gmode # 0 start
parms = parms + arrays
set both
vlb = lhs_disp; vub = rhs_disp
abort (22) if vlb > vub+1
set dope vector (dv)
stp = stp - 2
drop (rhs); drop (lhs)
else
names = names - arrays
set both
if dim = 1 and const (lhs) and const (rhs) and
rhs_disp+1 >= lhs_disp start
!can alocate in-line - trap array-inside-out at run time..??
vlb = lhs_disp; vub = rhs_disp
stp = stp - 2; !unstack them
drop (rhs); drop (lhs)
frame = (frame-arrays*8)&(¬3)
hdisp = frame
dim = 0; !for a marker
set dope vector (dv)
zeroth_base = local
dope_disp = dv
head_base = local; head_disp = hdisp
else
frame = (frame-dim*12)&(¬3)-4
lstack (frame)
pop lhs
d = regv(r4); hazard (r4)
plant2 (moval, lhs, d)
drop (lhs)
d_form = v in s; d_disp = 4-12
for sp = 2, 2, dim<<1 cycle
lhs == stacked(sp-1)
rhs == stacked(sp)
claim (r4)
lrd (lhs, r1); lrd (rhs, r2)
d_disp = d_disp+12
plant2 (movq, regv(r1), d)
repeat
prim (set dv)
word (dim); word (data size)
stp = 0
frame = frame-arrays*8; hdisp = frame
lstack (frame); pop lhs
plant2 (moval, lhs, regv(r3))
drop (lhs)
finish
finish
for j = 1, 1, arrays cycle
if gmode # 0 start
parms = parms - 1; decvar == var(parms)
decvar_disp = frame; decvar_zeroad = frame-vlb
decvar_header = ga; decvar_base = 0
glongword (-vlb); glongword (0)
flush gla
put (obj reloc); put long (ga-4); put long (dv)
frame = frame + vub*data size; !now the total size
else
names = names + 1; decvar == var(names)
decvar_base = local; decvar_header = -1
decvar_disp = hdisp; hdisp = hdisp+8
if dim = 0 start; !in-line
frame = (frame-vub*data size)&(¬7)
zeroth_disp = frame-vlb
decvar_zeroad = frame-vlb; ! zero address for fast access
decvar_header = -2; ! marker for above detail
plant2 (moval, zeroth, head); head_disp = head_disp+4
plant2 (moval, dope, head); head_disp = head_disp+4
else
prim (adec); !bumps r3 note
finish
finish
repeat
end
routine RESOLVE
!compile a string resolution
! S -> A.(B).C
record(stackfm) name s, a, b, c
integer flag, sc, bc, acf
routine TEST ASSIGNED (integer base)
put code (opcode(cmpw&255)); ! cmpw
put number byte (16_60+base-1); ! (base)
put number byte (16_60+gla-1); ! (gla)
prim (test ass)
end
acf = control&ass check; ! assignment checking ?
flag = getword; !<cond><a present><c present>
cstack (0) if flag&1 = 0; !c missing
pop lhs; c == lhs
pop lhs; b == lhs; bc = b_format
cstack (0) if flag&2 = 0; !a missing
pop lhs; a == lhs
pop lhs; s == lhs; sc = s_format
lrd (a, r0)
lrd (c, r1)
lrd (b, r3); test assigned (r3) if bc = 0 # acf
lrd (s, r4); test assigned (r4) if sc = 0 # acf
prim (resolution)
prim (check resolution) if flag&4 = 0
end
routine ADUMP (integer times)
integer j
for j = times-1, -1, 0 cycle
if owntype = integers start
glongword (ownval)
else if owntype = byte+integers
gbyte (ownval)
else if owntype = short+integers
gword (ownval)
else if owntype = strings
dump string (data size)
else if owntype&real bit # 0
glongword (ownval)
glongword (mantissa) if owntype = reall
else
init gla (data size, 1, 0)
finish
repeat
end
routine INITIALISE OWNS
integer aparm = getlong
if stp # 0 start
pop lhs
ownval = lhs_disp; mantissa = lhs_mantissa
drop (lhs)
if owntype&real bit # 0 and
lhs_type&real bit = 0 start
longreal(addr(ownval)) = ownval
finish
else
ownval = 0; mantissa = 0; text = ""
finish
if ownform&array bit # 0 start
if (owntype#strings or text = "") and
owntype&realbit = 0 start
if owntype & integers # 0 start
init gla (aparm, datasize, ownval)
else
init gla (aparm*datasize, 1, 0)
finish
else
adump (aparm)
finish
else if otype = 0; !const
decvar_disp = ownval; decvar_base = 0
decvar_form = decvar_form-2
else
gfix (3)
lput (objddef, ga) if otype >= 3
decvar_base = gla; decvar_disp = ga
adump (1)
dump diag (1) if otype # 2
finish
end
routine ZERO OWN
init gla (vub*datasize, 1, 0)
end
!======================= main loop =======================
NEXT:
get (sym) until sym # nl and sym # ' '
code = sym
abort (21) unless ' ' < sym <= 127
if diag & 2048 # 0 and sym # 'O' start
print string ("Sym='"); print symbol (sym)
print symbol (''''); newline
finish
-> c(code)
c(*): abort (21); !illegal code item
c('k'):code = 1; -> testit
c('t'):code = 6; -> testit
c('='):code = 1; -> jmp
c('<'):code = 2; -> jmp
c('('):code = 3; -> jmp
c('>'):code = 4; -> jmp
c(')'):code = 5; -> jmp
c('#'):code = 6; -> jmp
testit:
plant2 (bitl, literal(1), regv(r0))
pop drop
jmp:
jump to (getword, code+unsigned+invert, 1)
-> next
c(']'): operate (neg); !rsh
operate (rsh); -> next
c('['): operate (lsh); -> next
c('¬'): operate (not); -> next
c('U'): operate (neg); -> next
c('+'): operate (add); -> next
c('-'): operate (sub); -> next
c('!'): operate (or); -> next
c('%'): operate (xor); -> next
c('/'): operate (div); -> next
c('X'): operate (exp); -> next
c('x'): operate (rexp); -> next
c('Q'): operate (rdiv); -> next
c('*'): operate (mul); -> next
c('&'): operate (not);
operate (bic); ->next
c(117): ! ++
c(113): address op (code); -> next; ! --
c('.'): concatenate; -> next
c('v'): set modulus; -> next
c('B'): code = 0; -> bjf
c('F'): code = 1
bjf:
flush code; set line
jump to (getword, jump, code)
-> next
c('J'):
flush code; set line
jump to (-getword, jump, 0)
-> next
c(':'):
define label (getword)
-> next
c('L'):
n = getword
names = n if n > names
define label (-n);
-> next
c('T'):
cstack (-1); -> res
c('K'):
cstack (0)
c('M'):
c('V'):
res:
pop lhs
set result (lhs, code)
! and...
c('R'):
set status if mainprog = mainrt and code ='R'
return
-> next
c('j'): assign (2); -> next
c('S'): assign (1); -> next
c('Z'): assign (0); -> next
c('p'): assign (-1); -> next
c('G'): get string (alias); -> next
c('$'): define var; -> next
c('N'): cstack (getlong); -> next
c(''''):get string (text); -> next
c('D'): get real; -> next
c('n'): record select; -> next
c('a'): array ref (0); -> next
c('i'): array ref (1); -> next
c('d'): declare array; -> next
c('O'): line bound; -> next
c('@'):
v == var(getword)
spec external (v) if v_base = pending
vstack (v)
-> next
c('~'):
get (sym)
if sym = 'A' start
decvar == gvar
assemble (-2, labs, names)
-> next
finish
if sym = 'B' start
-> out
finish
abort (36) unless sym = 'C'
maxframe = frame if frame > maxframe
frame = frame base
-> next
c('E'): pop lhs; call (lhs); -> next
c('C'):
set both
if lhs_form&(arrayname bit!arraybit) # 0 start
compare arraynames (lhs, rhs)
pop drop; pop drop
-> next
finish
amap (lhs); amap (rhs)
c('?'):
set both
compare (lhs, rhs, 1)
pop drop; pop drop
-> next
c('"'):
set both; invert = 16
load (rhs, any) if rhs_flags&indexed # 0
compare (rhs, lhs, 0)
stp = stp - 1; lhs = rhs; drop (rhs)
claim (lhs_base)
-> next
c('c'): set cc; -> next
c('f'): for; -> next
c('l'): set language; -> next
c('r'): resolve; -> next
c('A'): initialise owns; -> next
c('I'): zero own; -> next
c('b'): set bounds; -> next
c('y'): set diag; -> next
c('z'): set control; -> next
c('W'): switch jump; -> next
c('_'): define switch label; -> next
c('o'): event block; -> next
c('e'): generate signal; -> next
c('w'): machine code; -> next
c('P'): plant; -> next
c('m'): prim (monit); -> next
c('s'): prim (stop); uncond jump = ca; -> next
c('{'): gmode = -1
assemble (gtype, labs, names)
-> next
c('}'):
gmode = 0
-> out if amode < 0
define parameters if names > gstart
-> out if amode # 0; !spec
frame = 0
-> next
c('H'):
decvar == begin; decvar_disp = new tag
otype = 0; spec = 0; potype = 3
if level # 0 start; !not initial begin
cstack (decvar_disp)
pop lhs; lhs_base = pc; lhs_type = 0
lhs_header = -1; call (lhs)
potype = 0
finish
var name = "$GO$"; external name = var name
assemble (0, labs, names)
-> next
c(';'):
if level # 0 start
set status if mainprog = mainrt
return
finish
gfix (3)
define tag (block end tag) if block end tag # 0
flush code
flush gla
OUT:
if amode = 0 start
activity(local) = 0; !release the base reg
level = level - 1; local = base reg(level)
activity(local) = -1
frame = frame&(¬7)
if level >= 0 start
select output tank (directives)
local diags = local diags+1
put (dir end); put long (proctype); put word (entry mask)
put word (frame); put word (frame>>16)
put word (local diags); put word (diag lines)
put word (block tag); put long (ca)
select output tank (object); put (obj term)
put word (events)
if events # 0 start
put word (evlow); put word (evep)
finish
finish
else
if amode < 0 start
frame = maxframe if maxframe > frame
if amode = -1 start
gvar_length = frame
else
oldframe = frame
finish
finish
finish
diag lines = local lines
diag size = diag size+local diags
frame = old frame
last local = old last local
uncond jump = old jump
ca = old ca
entry mask = old mask
ivbit state = old ivbit
end
glongword (16_80808080); glongword (16_80808080)
glongword (3+'G'<<8+'L'<<16+'A'<<24); !gla marker
glongword (0); !codebase
glongword (0); !diagbase
glongword (0); !line base
gword (0); !null string
glongword (0)
glongword (0); !event list
assemble (0, 0, 0); !set it going<<<<<<<
gfix (7)
put (obj end)
select output tank (directives)
put (dir sizes)
put long (ga)
put word (newtag-1)
put word (specs)
put word (diag size); put word (evno)
put ('*')
exit (fatal) if errors # 0
control = original control
end
BEGIN
END
end of file