include "Sysinc:com.inc"
! **************************************************************
! * *
! * PERKIN-ELMER 32-bit series IMP compiler *
! * Intermediate-code Assembler *
! * *
! * (General Service Version) *
! * *
! * Interactive Datasystems (Edinburgh) Ltd. *
! * 32, Upper Gilmore Place, *
! * Edinburgh EH3 9NJ *
! * *
! * Copyright (c) MAY 1st. 1980 *
! * All Rights Reserved *
! * *
! **************************************************************
! Known faults:
! Outstanding:
! %longreal is currently treated as %real
! statically sized arrays within stack frame
!
! Optimisations: (intended complete list)
! integer constant folding *done*
! real folding: integer/integer, integer^integer *done*
! literals in shareable code segment *done*
! special treatment of null string *done*
! special treatment of simple append (S = S.T) *done*
! special treatment of S=S.tostring(x) *done*
! suppression of redundant capacity checks *done*
! suppression of redundant unassigned checks *done*
! register usage *done*
! register environments *done*
! k*2 -> k+k, k^2 -> k*k, k^^2 -> k*k *done*
! Pass last param = string or record %value as %name then
! copy within routine *done* (for strings only)
! Detect and omit redundant array bound checks
! ABORT CODES
! ===========
! code routine reason
!
! ?? x: assemble: faulty intermediate code operation 'x'
! ADMP: adump: constant record ?
! AM00: assemble: static block nesting > 5 levels
! AM01: assemble: ('A') unknown constant type
! AM05: assemble: ('u', 'q') unspecified length in ++, --
! AM10: assemble: ('_') switch label outwith declared vector
! AM15: assemble: ('B') intermediate code faulty at %repeat tag
! AM25: assemble: ('F') user label out of range
! AM30: assemble: (':') user label out of range
! AM35: assemble: ('d') wrong no. of dimensions specified
! AM40: assemble: ('d') %const/%own array inside out
! AM45: assemble: ('~') faulty intermediate code in alternate record format
! AM50: assemble: ('}') symbol table overflow (inserting formal parameter specs)
! AM55: assemble: ('}') (OUT:) %record format > 64k bytes
! AMAP: amap: impossible form
! ARF1: array ref: no. of subscripts doesn't match declaration
! ASS1: assign: not at least two items on operand stack
! ASS2: assign: general %name not a %name
! ASS3: assign: record length undefined in 'record = record'
! CLM1: claim: reg > fr14
! CLMD: assemble: ('O') registers still claimed at line flag
! COP1: cop: exponent overflow in folding integer^integer
! COP2: cop: inappropriate operator
! DMP1: select literal area: literal area already selected
! DMP2: select code area: code area already selected
! DMP3: lit byte: literal area not selected
! DMP4: claim literal: literal area currently selected
! DMP5: external link: non-existent reference type
! DROP: drop: descriptor not in use
! DSC1: descriptor: operand stack overflow
! DSC2: descriptor: descriptor free-list empty
! DSC3: descriptor: link-block ('using') free-list empty
! DFV1: define var: symbol table overflow (inserting record element name)
! DFV2: define var: symbol table overflow (inserting non-format item)
! FOR1: compile for: too many nested %for...%cycle .....%repeat pairs
! HAZ1: hazard: attempt to hazard a constant
! HAZ2: hazard: a use is still outstanding
! HDR1: header: %string parameter in %begin ?
! LD1: load: ADDRESS failed to simplify non-trivial address mode
! LD2: load: real variable/integer register
! LD3: load: inappropriate type
! LD4: load: not/neg implemented in operate
! LD5: load: load floating variable into 'any' ?
! LD6: load: real operand with and/or/xor
! LD7: load: real 'neg' implemented in operate
! LD8: load: not a floating register
! LD9: load: real exponent ?
! LIT?: assemble: ('O') literal area still selected at line flag
! NLBL: new label: no free labels
! PICK: pickup (in LOAD) incompatible uses of a register
! POPL: pop lhs: operand stack is already empty
! REL1: release: reg > fr14
! REL2: release: reg not claimed
! RXD1: rxd: no immediate form of instruction
! RXD2: rxd: faulty register specification
! RXD3: rxd: faulty register specification
! RXD4: rxd: non-elementary operand type supplied to 'RXD'
! RXD5: rxd: displacement not aligned on 'type' boundary
! SETB: set both: not at least two items on operand stack
! STK?: assemble: ('O') operand stack not empty at line flag.
! TAG?: block mark: more than 32767 third pass tags generated. See c('_'):
! USNG: assemble: ('O') 'using' list not empty at line flag.
! VMAP: vmap: impossible form
! VSTK: vstack: variable no (symbol table index) out of bounds
! == == == == == == == == == == == == == == == == == ==
! Known Faults:
! READ SYMBOL is not implemented properly
! external linkage dumping is too indiscriminate
! general name parameter types don't match old subsystem
! == == == == == == == == == == == == == == == == == ==
!*****************************************************************************
!
! Options: (enabled when control bit = 1)
!
! 1: Capacity check on all store operations
! Overflow check on integer multiply
! 2: Unassigned check on %string, %integer, %real & %longreal operands
! 4: Array bound checking
! Checks for integrity of %for construction
! 16: Assorted extra checks:
! complete arithmetic overflow checking (*not yet*)
! 32: Permit removal of ALL diagnostic code and optimisations which are
! not 100% safe.
! Diagnostic code removed:
! Unassigned check on P in R string parameter
! Stack limit check
! Risky optimisations:
! Remembering pointers over an assignment via
! another pointer. Aliasing might JUST occur.
! 64: Enable trace option
! 128: No register optimisation: primarily for suppressing compiler faults
!
! NOTE:
! Switch references are always checked
! Stack overflow is checked unless 'TRUSTED' is specified.
!
!******************************************************************************
! N.B. The bit positions in CONTROL corresponding to 256 and 512
! are reserved to control the dumping of diagnostic tables
! by PASS 3.
!
! OPT is set (implicitly) by disabling all explicitly settable
! checks (bits 1,2,4,8,16)
!
! TRUSTED disables all checks and also sets the '32' bit.
!******************************************************************************
begin ; ! 7/32 DIAGNOSTIC ASSEMBLER
!SIZE CONSTANTS
constinteger max vars = 800
constinteger max labels = 80
constinteger max depth = 16
constinteger max stack = 25
constinteger max labdef = 7999
constinteger max refs = 2000
constinteger SetLen = 32 {bytes per set}
constinteger max prim = 23
constinteger max cycle = 30
constinteger max temps = 60
constinteger max use = 20; !limit for klist
constinteger max envirs = 5; !Environments
constinteger max knowledge = max use*(max envirs+1)
conststring (3) program ep = "%GO"; ! Main program external name
conststring (1) system prefix = "$"; ! prefixed to %system routine idents
conststring (6) trace routine = "$TRACE"; ! external called by trace option
conststring (10) read sym fn = "#READSYMFN"; ! linkage name of "read symbol" perm
constinteger ident len = 19; ! Significant chars in internal idents
constinteger extern len = 12; ! Max. length of names in diags/link
!Input/output streams
constinteger in=1
constinteger report=0, direct=1, object=2
! Language mask bits (generally =0 for 'obvious' or IMP interpretation)
! Note that each bit controls compilation of a particular source level
! abstraction and each first pass can select any convenient combination
! of options.
constinteger UNUSED = 1, {currently not used - IMP pass1!!}
non IMP for = 2 {exit on >= final value (zero trip)}
!CONTROL BITS
constinteger check capacity=1
constinteger check unass=2
constinteger check array=4, check for = 4
constinteger check extra=16
constinteger trusted=32
constinteger trace=64
constinteger suppress=128
constinteger check bits = check capacity+check unass+check array+check extra
constinteger bit15 = -32768; ! halfword sign-bit
!SPECIAL ADDRESSES
constinteger unass = 12; ! unassigned pattern at unass(code)
constinteger init gla = 12; ! first usable displacement into gla
constinteger init lit = 8; ! first literal ends at -INITLIT(CODE)
! Derived constants
constinteger for lab base = 8000; ! = MAX LABDEF+1
!REGISTERS
constinteger R0 = 1
constinteger R1 = 2; ! Fn/map result, @final string result
constinteger p3 = R1; ! SPECIAL STRING PARAMETER
constinteger R2 = 3
constinteger R3 = 4
constinteger R4 = 5
constinteger R5 = 6, p2 = R5
constinteger R6 = 7, p1 = R6
constinteger R7 = 8, wsp = R7
constinteger R8 = 9, base1 = R8
constinteger R9 = 10, base2 = R9
constinteger R10 = 11, base3 = R10
constinteger R11 = 12, base4 = R11
constinteger R12 = 13, base5 = R12; ! (unassigned pattern for levels 1:4)
constinteger R13 = 14, gla = R13
constinteger R14 = 15, code = R14
constinteger R15 = 16, link = R15
constinteger FR0 = 17; ! FN RESULT
constinteger FR2 = 18
constinteger FR4 = 19
constinteger FR6 = 20
constinteger FR8 = 21
constinteger FR10 = 22
constinteger FR12 = 23
constinteger FR14 = 24
!PSEUDO REGISTERS
constinteger any = 25
constinteger anyf = 26
constbyteintegerarray actual(0:fr14) = 0,
0, 1, 2, 3, 4, 5, 6, 7,
! R0 R1 R2 R3 R4 P2 P1 WSP
8, 9, 10, 11, 12, 13, 14, 15,
! R8 R9 R10 R11 R12 GLA CODE LINK
0, 2, 4, 6, 8, 10, 12, 14
! FR0 FR2 FR4 FR6 FR8 FR10 FR12 FR14
constbyteintegerarray breg(-1:5) =
0, 0, base1, base2, base3, base4, base5
!DATA FORMS
! EXTERNAL
constinteger recordformat = 4
constinteger switch = 6
constinteger array = 11
constinteger arrayname = 12
constinteger namearray = 13
constinteger namearrayname = 14
! INTERNAL
constinteger constant = 0
constinteger v in r = 1
constinteger av in r = 2
constinteger a in r = 3
constinteger v in s = 4
constinteger av in s = 5
constinteger a in s = 6
constinteger v in rec = 7
constinteger av in rec = 8
constinteger a in rec = 9
constinteger pgm label = 14
!!N.B. FORM=15 denotes %record format
! Flag bits used in conjunction with form:
constinteger quick conc = 1, {optimise: S = S.tostring(symbol) }
P in R = 2, {parameter-in-register}
prim bit = 4, {primitive known to compiler}
assigned = 8, {assigned and known to be}
proc bit = 16, {routine/fn/map/predicate}
abit = 32, {array by value}
anbit = 64, {array by name}
label bit = 128 {data is an address}
constinteger array bits = abit ! anbit; ! for convenience
! All arrays are in fact treated as by name (i.e. with a dope vector) and
! the ABIT bit is misused to indicate that an array is a candidate for
! subscript scaling by the use of 'multiply halfword'
constinteger cheap array bit = abit
! 'FLAG' byte of 'xform':
!=======================================================================!
! label AN A proc assigned prim P in R ------ !
! bit bit bit bit bit !
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !
! 128 64 32 16 8 4 2 1 !
!=======================================================================!
! : !
! : D I M E N S I O N S !
! : (if %array) !
! :______________________________!
! N.B.
! In 'varfm' the 4,2,1 bits are used to hold the number of dimensions
! when the table entry represents an array object. This field is
! unpacked into the 'DIM' field of 'stackfm' by 'VSTACK'
!LABEL CONSTANTS
constinteger define new = 0
constinteger redefine old = 1
constinteger internal tag = -1; ! N.B. This must be <0 and others >=0
!DATA TYPES
constinteger integers = 1
constinteger short = 2
constinteger byte = 3
constinteger general = 4
constinteger strings = 5
constinteger records = 6
constinteger reals = 7
constinteger reall = 7; ! (SET TO 8 FOR LONG REALS)
!Figurative data types used internally (reduce to INTEGERS)
!! %constinteger pointer = -1
!! %constinteger in store const = -2
!LENGTHS
constinteger single=4; ! bytes in single precision %real
constinteger double = single*(reall-reals+1)
constinteger align = 3; ! Basic alignment mask
constinteger reglen=4; ! no. of bytes in GP register
constinteger basic frame = (link-p2+1)*reglen
!OWN INFO
constinteger own = 1
constinteger con = 2
constinteger external = 3
constinteger system = 4
constinteger dynamic = 5
constinteger primrt = 6
constinteger permrt = 7
! Constants used to define sizes of various objects known to pass 3
constinteger short ident = 6; ! characters: related to 'extern len' !!
constinteger basic vdiag = 4; ! halfwords: no. req'd for 'short ident'
constinteger extra vdiag = 2; ! halfwords: basic+extra == extern len
! Define type codes known externally (to pass 3 and user):
constbyteintegerarray gen map(integers:reals+1) =
1, 6, 5, 0, 3, 4, 2, 8
! integer short byte general string record reals reall
!PERM ROUTINES
! ** UNASSIGNED CHECK as a special at 0(code) **
constinteger asschk=1
constinteger iexp=2
constinteger fexp=3; ! floating exponent
constinteger smove=4
constinteger sjam=5
constinteger sconc=6
constinteger sresln=7; ! conditional resolution
constinteger sresv=8; ! check SRESLN succeeded
constinteger scomp=9
constinteger frac part = 10; ! IMP 'frac pt' function
constinteger sfcap=11; ! string capacity exceeded
constinteger substr = 12; ! substring
constinteger aref1=13; ! 1-D with checks
constinteger aref2=14; ! 2-D with checks
constinteger aref3=15; ! n-D with checks
constinteger aref4=16; ! 2-D without checks
constinteger set dv=17; ! set dope vector
constinteger alloc=18; ! claim array space
constinteger swjump=19
constinteger signal=20
constinteger mulchk=21; ! check for 32-bit result from integer multiply
constinteger cap16=22; ! check for 16-bit signed overflow
constinteger cap8=23; ! . . . 8-bit unsigned . .
constinteger fchk1=24; ! %for loop parameter check
constinteger fchk2=25; ! check for %for loop counter fiddling
constinteger pentc=26; ! checked procedure entry
constinteger rcopy=27; ! record copy
constinteger rzero=28; ! clear record
constinteger vschk=29; ! variable shift parameter check
constinteger smovopt=30; ! fast unchecked string move (also see P in R string)
constinteger chmap=31; ! IMP 'charno' %map
constinteger freesp=32; ! IMP 'free space' function
constinteger int fn=33; ! IMP 'int' function
constinteger rcomp = 34 {record compare}
constinteger set comp = 35,
set union = 36,
set difference = 37,
set intersection = 38
constbytearray Set ops(1:3) = Set union, Set Difference, Set intersection
constinteger iocp = 49
constinteger enter trace = 50
!OPERATIONS
! logical => both <= code generator
constinteger not = 1, lw = 1
constinteger neg = 2, st = 2
constinteger add = 3
constinteger sub = 4
constinteger mul = 5
constinteger div = 6
constinteger conc = 7, cmp = 7
constinteger and = 8
constinteger or = 9
constinteger xor = 10
constinteger lsh = 11
constinteger rsh = 12
constinteger mult16 = 13
constinteger rem = 14
constinteger exp = 15
constinteger rexp = 16
constinteger rdiv = 17
!CODE GENERATOR TABLES
! mask bits in 'op index' array
constinteger fw imm=2048, hw imm=4096, sf imm=8192, inv imm=16384
constinteger fw rr=256, fw rx=512, short rx=1024, byte rx=32768
constinteger fp base = rem-1
constshortintegerarray op index(1:40) =
x'FF01',; ! LW: load - 1 + all formats
x'8609',; ! ST: store - 9 + full/half word + byte
x'7F11',; ! ADD: add - 17 + all but byte
x'7F18',; ! SUB: subtract - 24 + all but byte
x'031F',; ! MUL: multiply - 31 + full word formats
x'0321',; ! DIV: divide - 33 + full word formats
x'1F23',; ! CMP: compare - 35 + all but byte and short immediate
x'1F28',; ! AND: and - 40 + .....
x'1F2D',; ! OR: or - 45 + ......
x'1F32',; ! XOR: xor - 52 + ........
x'3037',; ! LSH: left shift - 55 + halfword and shortform
x'303D',; ! RSH: right shift - 61 + halfword and shortform
x'0775',; ! MULT16: 117 + rr + rx + short rx
! ** floating point formats **
x'0F43',; ! LW: load - single and double
x'0A47',; ! ST: store - store reference formats only
x'0F4B',; ! ADD: add - 75 + all formats
x'0F4F',; ! SUB: subtract - 79 + ...
x'0F53',; ! MUL: multiply - 83 + ...
x'0F57',; ! DIV: divide - 87 + ...
x'0F5B',; ! CMP: compare - 91 + ...
! ** specials **
x'0364', ; ! JMP
x'0366', ; ! BAL
x'0267', ; ! LA
x'0268', ; ! LM
x'0269', ; ! STM
x'016B', ; ! FLR
x'016C', ; ! FXR
x'1F5F', ; ! CLW
x'1069', ; ! SRA
x'016E', ; ! CHVR
x'016F', ; ! LBR
x'040A', ; ! STH
x'026F', ; ! SVC
x'0270', ; ! LME
x'0271', ; ! STME
x'1870', ; ! TEST (TI/THI)
x'0476', ; ! LHL (short rx only)
x'0678', ; ! AM (fullword and short rx only)
x'027A', ; ! TBT
x'027B' ; ! SBT
! Each halfword below is treated as 4 groups of 4 bits [a:b:c:d] with the
! following significance.
! a,b: 8-bit machine op-code
! c: special function bits
! 1: this operation sets condition code other than relative
! to zero.
! 2: invert order of operands to provide for example
! STR x,y => LR y,x
! 4: this operation doesn't affect condition code
! d: mask to check alignment of displacement required by this instruction.
constshortintegerarray op code(1:124) =
x'0800', x'5803', x'4801', x'F800', x'C800', x'2400', x'2500', x'D350',
! LR L LH LI LHI LIS LCS LB
x'0820', x'5053', x'4051', 0, 0, 0, 0, x'D250',
! STR ST STH -- -- -- -- STB
x'0A00', x'5A03', x'4A01', x'FA00', x'CA00', x'2600', x'2700',
! AR A AH AI AHI AIS SIS
x'0B00', x'5B03', x'4B01', x'FB00', x'CB00', x'2700', x'2600',
! SR S SH SI SHI SIS AIS
x'1C50', x'5C53',
! MR M
x'1D50', x'5D53',
! DR D
x'0910', x'5913', x'4911', x'F910', x'C910',
! CR C CH CI CHI
x'0400', x'5403', x'4401', x'F400', x'C400',
! NR N NH NI NHI
x'0600', x'5603', x'4601', x'F600', x'C600',
! OR O OH OI OHI
x'0700', x'5703', x'4701', x'F700', x'C700',
! XR X XH XI XHI
0, 0, 0, 0, x'ED00', x'1100',
! -- -- -- -- SLL SLLS
0, 0, 0, 0, x'EC00', x'1000',
! -- -- -- -- SRL SRLS
x'2800', x'6803', x'3800', x'7803',
! LER LE LDR LD
x'2820', x'6053', 0, x'7053',
! STER STE -- STD
x'2A00', x'6A03', x'3A00', x'7A03',
! AER AE ADR AD
x'2B00', x'6B03', x'3B00', x'7B03',
! SER SE SDR SD
x'2C00', x'6C03', x'3C00', x'7C03',
! MER ME MDR MD
x'2D00', x'6D03', x'3D00', x'7D03',
! DER DE DDR DD
x'2910', x'6913', x'3910', x'7913',
! CER CE CDR CD
! Special purpose entries.
x'0510', x'5513', x'4511', x'F510', x'C510',
! CLR CL CLH CLI CLHI
x'0300', x'4300',
! BFCR BFC
x'0100', x'4100',
! BALR BAL
x'E650',
! LA
x'D150',
! LM
x'D050',
! STM
x'2F00',
! FLR
x'2E00',
! FXR
x'EE10',
! SRA
x'1200',
! CHVR
x'9350',
! LBR
x'E110',
! SVC
x'7250',
! LME
x'7150',
! STME
x'F310', x'C310',
! TI THI
x'0C50', x'4C51', x'4C51',
! MHR M(H) MH
x'7301',
! LHL
x'5113', x'6111',
! AM AHM
x'7401', x'7501'
! TBT SBT
!Non-uniform operations for special situations
constinteger jmp=21, always=r0; ! RR(JMP,always,LINK)
constinteger bal=22; ! Branch-and-link
constinteger la =23; ! Load Address (RX format)
constinteger lm=24, stm=25; ! Load/Store Multiple
! ** FLR below is really 25-fpbase **
constinteger flr=26-fpbase, fxr=27; ! Float/Fix (RR format only)
constinteger clw=28; ! Compare Logical (same formats as AND)
constinteger sra=29; ! Shift Right Arithmetic (HW IMM only)
constinteger chvr=30; ! Convert to halfword value (RR only)
constinteger lbr=31; ! Load Byte Register (RR only)
constinteger sth=32; ! Store half-word (Short RX only)
constinteger svc=33; ! Supervisor call (RX format)
constinteger lme=34-fpbase; ! Used in conjunction with SVC
constinteger stme=35-fpbase; ! .... ditto ....
constinteger test=36; ! test halfword? immediate
constinteger LHL=37; ! load unsigned halfword (for switch)
constinteger AM=38; ! add-to-memory (see ASSIGN)
constinteger TBT = 39, SBT = 40
constbytearray Inverted(16:21) =
0, 1, 3, 2, 5, 4
{ = # < > <= >= }
!ASSORTED FUNNY CONSTANTS
constinteger jump=12; ! logical condition code == unconditional jump
constinteger not equal=1; ! . . . branch not equal
constinteger less than=2, greater than=3
constinteger less or equal=4, greater or equal=5
!CODES USED IN OUTPUT FOR 3RD. PASS
constinteger tag def = 1
constinteger r ref = 2; ! Routine/fn/map/predicate reference
constinteger p ref = 3; ! Prim reference
constinteger sw ref = 4; ! Switch reference
constinteger j ref = 5; ! Jump reference
constinteger c ref = 6; ! Conditional (jump) reference
constinteger code item = 7
constinteger gla item = 8
constinteger line flag = 9
constinteger line reset = 10
constinteger var diag = 11
constinteger code area = 12
constinteger lit area = 13
constinteger lit org = 14
constinteger frame patch = 15
constinteger block start = 16
constinteger block end = 17
constinteger prog end = 18
constinteger c rel = 19
constinteger g rel = 20
constinteger extern = 21
! (external references)
constinteger data ref = 4, data defn = 5
constinteger ep ref = 6, ep defn = 7
recordformat varfm(integer disp, c
shortinteger format,extra,length,header, c
(shortinteger xform or byteinteger flag,form),
byteinteger base,type)
record (varfm)array var(0:max vars)
record (varfm)name decvar
record (varfm)name fp, ap
ownrecord (varfm) begin = 0
recordformat stackfm(integer disp,
shortinteger format, extra, length, header, rt,
shortinteger var no, type,
(shortinteger xform or byteinteger flag,form),
(short xbase or byte index, base),
byte dim, oper,
record (stackfm)name link)
record (stackfm)array stak(0:max stack)
record (stackfm)name desc asl
recordformat sptfm(record (stackfm)name v)
record (sptfm)array stacked(1:max depth)
! elements of USING list
recordformat dfm(record (stackfm)name d, record (dfm)name link)
record (dfm)array dlist(0:max stack)
record (dfm)name dasl
record (dfm) using
! for compiling %for/%repeat pairs
recordformat cyclefm(integer cv disp, fv disp, c
shortinteger lab, shadow, initial, cv form, c
byteinteger reg, cv type, cv base, c
fv base, temp base)
record (cyclefm)array for stk(0:max cycle)
record (cyclefm)name for; ! points to currently active level
owninteger for stp=0
! mechanism to minimise no of temporaries allocated
shortintegerarray temps(1:max temps)
owninteger temp base = 0, next temp = 0, new temp = 0
! list terminator
constrecord (*)name null == (0)
recordformat labelfm(shortinteger id, tag)
record (labelfm)array labels(1:max labels)
ownintegerarray activity(0:fr14) = 0(*)
owninteger claimed = 0
ownshortinteger control = check bits & (¬check extra)
ownshortinteger diagnose = 0
! 1: trace calls on descriptor stack handling primitives
! 2: . . . . . . . . . LOAD
! 4: . . . . . . . . . ASSIGN
! 8: . . . . . . . optimisation routines and display generated code
! 16: dump 'knowledge' list every time CHEAPEN is called with '8' bit on
owninteger level = -1
owninteger main ep = 0; ! non-zero if compiling main program
owninteger unassigned rtn = 0; ! non-zero if unassigned check routine pr in
integer j,k,len,n,val,aparm,opr
owninteger ca = 0; ! CODE ADDRESS
owninteger ga = init gla; ! GLA ADDRESS
owninteger lita = 0; ! Literal address: current address
owninteger litmax=0; ! : limit of area claimed so far
owninteger diag1 = 0; ! DIAG TABLES 1
owninteger diag2 = 0; ! DIAG TABLES 2
owninteger cc ca=0, cc reg=0; ! to remember condition code
integer sym, next; ! CODE SYMBOL, NEXT SYMBOL
integer vlb,vub; ! VECTOR LOWER/UPPER BOUND
integer Allocate; ! Flag for array(#0) or arrayformat (=0)
integer Falign {alignment of internal formats}
owninteger current line = 0; ! SOURCE LINE NUMBER
owninteger last line = 0
owninteger stp = 0; ! STACK POINTER
integer data size; ! CURRENT DATA ITEM SIZE
owninteger frame = 0; ! LOCAL STACK FRAME EXTENT
owninteger extra frame = 0; ! ALLOW EXTRA FRAME FOR STATIC ARRAYS
integer parms; ! START OF PARAMETER STACK
integer local; ! LOCAL BASE REGISTER
owninteger invert = 0, swopped = 0; ! CONDITION INVERSION FLAGS
owninteger uncond jump = 0; ! ADDRESS OF CODE HOLE
owninteger gtype = 0; ! 0=RECORDS, 1=PROCEDURE
owninteger gmode = 0; ! NON-ZERO INSIDE PARAMETER LISTS
integer decl; ! LAST-DEFINED DESCRIPTOR
ownshortinteger language mask = 0; ! selects language specific options
integer cheap reg; !Preferred register after ADDRESS
integer otype, owntype, ownform, spec, frozen, potype
integer diag type=0, diag form=0, diag size=0; ! external form/type/size
longreal rvalue
!! Initialised to suppress critical unassigned check when compiling itself
owninteger ownval = 0, mantissa = 0; ! *order critical*
integer oarea
integer dim,dv
integer wdisp, pdisp, gdisp
owninteger block no = 0; ! Ordered by block head
owninteger defns=0, specs=0, relocations=0, var diags=0
owninteger total ca = 0
owninteger last ca = -1; ! Used by 'set line'
owninteger trace flag = 0; ! controls calling of DUMP TRACE routine
integer jtag; ! Set by 'JUMP TO'
ownstring (ident len) external id = "", alias = "", block name = ""
ownstring (ident len) internal id = ""
owninteger faulty=0
owninteger null string = 0
byteintegername cslen
byteintegerarray current string(0:255)
! Register optimisation scratch pad
owninteger Last Gpr = 1,
Last Fpr = Fr0,
Last EO = 1
recordformat kfm(record (kfm)name link, array,
integer disp,
shortinteger reg,
byteinteger type, form, base, ktype)
record (kfm)array knowledge(1:max knowledge)
ownrecord (kfm)name klist == (0), kasl == (0)
integer known regs = 0; ! bit mask: must contain at least ANYF+1 bits
integer in use = 0; !counter to limit active uses
!Environment control
recordformat envfm(integer label, in use, known, record (kfm)name link)
record (envfm)array envir(1:max envirs)
owninteger envp = 0
! Code generation routine specs
routinespec rr(integer op,r1,r2)
routinespec rx(integer op,r1,base,disp)
routinespec rxi(integer op,r1,base,disp)
routinespec rxd(integer op,r1,record (stackfm)name v)
routinespec set line
! >> SHOW <<
routine show(record (stackfm)name v)
write(v_varno,2); print symbol(':')
write(v_type,3); write(v_form,2); write(v_flag,2)
write(v_base,3); write(v_disp,5)
write(v_length,3)
write(v_extra,3); write(v_format,3)
write(v_header,3); write(v_dim,3)
if v_oper # 0 start
write(v_oper,2); newline
print string(" +")
show(v_link)
else
newline
finish
end
! >> ABORT <<
routine abort(integer code)
record (dfm)name dd
integer j
select output(report)
print string("*Compiler error '")
print symbol( (code>>j)&255 ) for j = 24,-8,0
print string("' at line"); write(current line,1)
newline
print string("Please seek assistance!!"); newline
if stp # 0 start
print string("STACK:"); newline
show(stacked(j)_v) for j = 1,1,stp
finish
unless using_link == null start
print string("USING:"); newline
dd == using_link
cycle
show(dd_d)
dd == dd_link; exit if dd == null
repeat
finish
select output(object)
signal 15,15; ! %IF diagnose < 0
end ; ! abort
! >> WARN <<
routine warn(integer n)
switch w(1:8)
select output(report)
print string("*WARNING: line")
write(current line, 1); print string(": ")
-> w(n)
w(1): print string("division by zero"); -> at
w(2): print string("Illegal FOR"); -> at
w(3): print string("Non-local control variable?"); -> at
w(4): print string("Invalid parameter for READ SYMBOL"); -> at
w(5): print string("String constant too long"); -> at
w(6): print string("No. of shifts outwith 0..31"); -> at
w(7): print string("Illegal constant exponent"); -> at
w(8): print string("Numerical constant too big"); -> at
at: newline
select output(object)
end
! >> MONITOR <<
routine monitor(record (stackfm)name v, string (15) text)
select output(report)
print string(text); print symbol(':')
spaces(9-length(text))
show(v)
select output(object)
end
! >> FLOATING <<
predicate floating(record (stackfm)name v)
! check descriptor for floating point quantity
true if (v_type >= reals and v_type # 255) or (v_oper # 0 c
and v_link_type >= reals)
true if v_oper >= rexp
false
end
! >> ZERO <<
predicate zero(record (stackfm)name v)
! CHECK DESCRIPTOR FOR (INTEGER) ZERO
false if v_disp # 0 or v_base # 0 or constant # v_form # AV in S
false if v_oper # 0
true
end
! >> CONST <<
predicate const(record (stackfm)name v)
! CHECK DESCRIPTOR FOR CONSTANT (INTEGER) VALUE
false unless v_form = constant and v_oper = 0
false if v_type > byte
true
end
integerfn Min Record Size(record (stackfm)name A, B)
integer N, M
N = A_Format; N = Var(N)_Length&x'FFFF' if N # 0
M = B_Format; M = Var(M)_Length&x'FFFF' if M # 0
N = M if N = 0 or (M # 0 and M < N)
result = N if N > 0
Abort(m'Rec0')
end
! >> SAME <<
integerfn POWER(integer n)
integer j, ref
ref = 1
for j = 1, 1, 14 cycle
ref = ref<<1
if ref >= n start
if ref = n then result = j else result = -1
finish
repeat
result = -1
end
predicate same(record (stackfm)name v,w)
! Test whether or not V and W describe the same object.
true if v_disp = w_disp and v_base = w_base c
and v_type = w_type and v_form = w_form and v_extra = w_extra
false
end
! >> IN FREE REG <<
predicate in free reg(record (stackfm)name v)
! TRUE if v is in a useable register
false unless v_form = v in r and activity(v_base) <= 1
true
end
! >> TEMP <<
integerfn temp
! Allocate a temporary 4 bytes long
integer t
if next temp = new temp start ; ! no spare temps outstanding
t = (frame+3)&(¬3)
frame = t+4
result = t if new temp = max temps; ! temp buffer overflow
new temp = new temp + 1
temps(new temp) = t
finish
next temp = next temp + 1
result = temps(next temp)&x'FFFF'
end
! >> TAG <<
integerfn tag
integer s1, s2
s1 = next
readsymbol(s2)
readsymbol(next)
result = s1<<8!s2
end
! >> GET D <<
routine get d
longreal p
integer i, n
real ten,one
n = 10 ; rvalue = n {initial base}
n = 1; one = n
n = tag; read symbol(next); ! Skip comma
BASE:
ten = rvalue
rvalue = 0
cycle
sym = next; read symbol(next)
exit if sym = '.'
n = n-1
-> power if sym = '@'
-> base if sym = '_'
sym = sym-'A'+'0'+10 if sym >= 'A'
rvalue = rvalue*ten+(sym-'0')
-> SIGN if n = 0
repeat
p = one
cycle
n = n-1; -> SIGN if n = 0
sym = next; read symbol(next)
-> POWER if sym = '@'
sym = sym-'A'+'0'+10 if sym >= 'A'
p = p/ten
rvalue = rvalue + (sym-'0')*p
repeat
POWER:
n = tag
n = n ! 16_FFFF0000 if n&16_8000 # 0
rvalue = rvalue * (ten^n)
SIGN: ! sign of whole value
if next = 'U' start
read symbol(next)
rvalue = -rvalue
finish
end
! >> RELEASE <<
routine release(integer reg)
! Hazard the value in a register
abort(m'REL1') if reg > fr14
return if reg = 0 or activity(reg) < 0; ! LOCKED
activity(reg) = activity(reg)-1
abort(m'REL2') if activity(reg) < 0
claimed = claimed - 1
end
! >> CLAIM <<
routine claim(integer reg)
! Cherish the value in a register
abort(m'CLM1') if reg > fr14
return if reg = 0 or activity(reg) < 0
activity(reg) = activity(reg)+1
claimed = claimed+1
end
routinespec forget reg(integer mask)
routinespec forget all
routinespec forget var(record (stackfm)name v)
! >> HAZARD <<
routine hazard(integer reg)
! Protect the value in register REG by storing in a temporary.
integer n, t, tot
record (dfm)name p
record (stackfm) u
routine mod(record (stackfm)name v)
switch sw(0:a in rec)
v_base = local
n = n-1
-> sw(v_form)
sw(a in rec):
sw(av in rec):
sw(v in rec):
if tot = 1 start
claim(reg); rx(lw,reg,reg,v_extra)
u_type = integers
v_extra = t
-> OUT2
finish
sw(constant): abort(m'HAZ1')
sw(v in s): if v_disp = 0 start
v_disp = t; v_form = a in s; ->out1
finish
sw(a in s):
sw(av in s):
! change (X in S) to (X in REC)
v_form = v_form + 3; v_extra = t; -> OUT1
sw(v in r): v_form = v in s; v_disp = t
v_type = u_type
OUT1:
v_flag = v_flag ! assigned
OUT2:
end
n = activity(reg); return if n <= 0; ! NOT IN USE OR CLAIMED
tot = n
claimed = claimed - n
activity(reg) = 0
t = temp; ! ** needs a parameter to deal with 8-byte reals **
u_type = integers
u_type = reals if FR0 <= reg <= FR14
p == using_link
cycle
exit if p == null
mod(p_d) if p_d_base = reg
p == p_link
repeat
u_xbase = local; u_disp = t
u_xform = V in S ! (assigned << 8)
rxd(st,reg,u)
forget var(u)
abort(m'HAZ2') if n # 0; ! USE STILL OUTSTANDING
end
! >> HAZARD ALL <<
routine hazard all
integer j
forget reg(-1)
if claimed # 0 start ; ! at least one register claimed
hazard(j) for j = r0,1,fr14
finish
end
! REGISTER OPTIMISATION ROUTINES
constinteger register contents = 1
routine Reset Optimisation Data
integer J
Last Gpr = 1
Last Fpr = Fr0
Last EO = 1
Envp = 0
Known Regs = -1
In Use = 0
Kasl == Null
Klist == Null
for j = 1,1,max knowledge cycle
knowledge(j)_Link == Kasl
Kasl == knowledge(j)
repeat
for j = 1,1,max envirs cycle
Envir(j)_Label = 0
Envir(j)_Link == Null
repeat
end
! >> DUMP OPT LIST <<
routine dump opt list
record (kfm)name p
select output(report)
p == klist
if p == null start
print string("*opt list empty")
newline
else
cycle
write(p_type,1); write(p_form,1)
write(p_disp,3); print symbol('(')
write(p_base,-1); print string(") =")
write(p_reg,1); newline
p == p_link
repeat until p == null
finish
select output(object)
end ; ! dump opt list
! >> K ENTRY <<
record (kfm)map k entry(record (stackfm)name v, integer fuzz)
record (kfm)name p,q
fuzz = ¬fuzz
p == k list
q == null
while not p == null cycle
-> FOUND if (p_disp!!v_disp)&fuzz = 0 and p_base = v_base
q == p
p == p_link
repeat
result == null; ! failure
FOUND:
if not q == null start ; ! promote if not first item already
q_link == p_link
p_link == klist
klist == p
finish
result == klist
end ; ! k entry
! >> NEW KCELL <<
record (kfm)map new kcell
record (kfm)name p, q
integer n
if kasl == null or in use >= max use start ; ! no free cells left
! In extremis so reclaim last item from KLIST.
p == klist; q == null
n = max use
cycle
n = n-1
exit if p_link == null
q == p
p == p_link
repeat
abort(m'OPT1') if n # 0
q_link == null; ! truncate KLIST
p_link == kasl; kasl == p; !give on back
in use = in use-1
finish
p == kasl; kasl == kasl_link
in use = in use+1; abort(m'Opt3') if in use > max use
p = 0
result == p
end ; ! new kcell
! >> ASSOCIATE <<
routine associate(record (stackfm)name v, integer reg)
record (kfm)name p
return if reg = R0 or V_Base = Reg
p == k entry(v,0)
if p == null start ; ! new entry
p == new kcell
p_link == klist
klist == p
else ; ! re-use this cell
forget reg(1<<p_reg)
finish
p_reg = reg
p_base = v_base
p_disp = v_disp
p_type = v_type
p_form = v_form
p_ktype = register contents
known regs = known regs ! (1<<reg)
known regs = known regs ! (1<<p_base) if activity(p_base) >= 0; ! unlocked ?
end ; ! associate
! >> CHEAPEN <<
routine cheapen(record (stackfm)name v, integer mode)
!! modes: >= 0: looking for value
! < 1: looking for address
record (kfm)name p
integer reg, form, type
form = v_form; type = v_type
p == k entry(v,0)
return if p == null
v_flag = v_flag ! assigned if p_form = V in S; ! it's at least assigned
return if p_reg = 0; !*psr* Nothing known
cheap reg = p_reg if form # AinS and p_type = Type
return if mode < 0 and form = V in S; ! V in S on left-hand side
reg = p_reg
if form = A in S and p_type = integers and p_form = V in S start
release(v_base); claim(reg)
v_base = reg; v_disp = 0; v_Xform = V in S {changed to Xform - PSR}
cheapen(v,mode)
else
return if p_type # type or p_form # form
release(v_base); claim(reg)
v_base = reg; v_disp = 0; v_Xform = V in R {changed to Xform - PSR}
finish
if diagnose < 0 start
monitor(v, "CHEAPENED")
dump opt list if diagnose & 16 # 0
finish
end ; ! cheapen
!!! * * * * * This needs to be a bit brighter * * * * *
! >> FORGET VAR <<
routine forget var(record (stackfm)name v)
record (kfm)name p
!!!!! p == k entry(v, align)
!!!!! forget reg(1<<p_reg) %unless p == null
cycle
p == k entry(V, align)
return if p == null
p_base = anyf+1 {invalid entry}
repeat
end ; ! forget var
! >> FORGET REG <<
routine forget reg(integer reg mask)
record (kfm)name p
return if known regs & reg mask = 0; ! for speed: nothing to do
reg mask = reg mask & (¬1); ! R0 = 1 not 0
known regs = known regs & (¬reg mask)
p == klist
if reg mask < 0 start ; ! forget the lot
while not p == null cycle
p_base = anyf+1 if regmask & (1<<p_base) # 0; ! invalidate entry
p_reg = 0
p == p_link
repeat
else ; ! selective forget
while not p == null cycle
p_base = anyf+1 if reg mask & (1<<p_base) # 0; ! invalidate entry
p_reg = 0 if reg mask & (1<<p_reg) # 0; ! forget reg association
p == p_link
repeat
finish
! Clean up any old kcells which can be recovered easily
while klist ## null and klist_base = anyf+1 cycle
p == klist; klist == klist_link
p_link == kasl
kasl == p
in use = in use-1
repeat
abort(m'Use?') if in use < 0
end ; ! forget reg
! >> FORGET ALL <<
routine forget all
record (kfm)name p
if not klist == null start
p == klist
cycle
in use = in use-1
exit if p_link == null
p == p_link
repeat
p_link == kasl
kasl == klist
klist == null
finish
abort(m'Fall') unless in use = 0
known regs = 0
end ; ! forget all
!environment control
record (envfm)map environment(integer label)
record (envfm)name E
integer j
if label > 0 start
for j = 1,1,max envirs cycle
E == envir(j)
result == E if E_label = label
repeat
finish
result == null
end
record (envfm)map new env(record (envfm)name E)
record (kfm)name K
if E == null start
envp = envp+1; envp = 1 if envp > max envirs
e == envir(envp)
finish
k == E_link
unless k == null start
k == k_link while k_link ## null
k_link == kasl
kasl == E_link
finish
E_in use = 0
E_label = 0
E_link == null
result == E
end
record (kfm)map Ecopy(record (kfm)name L)
record (kfm)name K
result == null if l == null
abort(m'Ecop') if kasl == null
k == kasl; kasl == k_link
k = l
k_link == Ecopy(l_link)
result == k
end
routine restore environment(integer label)
record (envfm)name E
record (envfm) temp
temp_link == klist
e == new env(temp) {release current environment}
E == environment(label)
if E == null start
klist == null
known regs = 0
in use = 0
else
klist == Ecopy(E_link)
known regs = E_known
in use = E_in use
finish
end
routine remember environment(integer label)
record (envfm)name E
return if label <= 0
E == environment(label)
E == new env(E)
E_label = label
E_known = known regs
E_in use = in use
E_link == Ecopy(klist)
end
routine merge environment(integer label)
record (ENVFM)name e
record (kfm)name K, end, X
record (kfm) khead
routine MERGE(record (kfm)name K)
record (kfm)name p
p == klist
while p ## null cycle
if p_disp = k_disp and
p_reg = k_reg and
p_base = k_base and
p_form = k_form and
p_type = k_type and
p_ktype= k_ktype start
{*****Beware when array opt is put in***}
end_link == k
end == k
E_known = E_known ! (1<<p_reg) ! (1<<p_base)
E_in use = E_in use+1
return
finish
p == p_link
repeat
k_link == kasl; kasl == k
end
E == environment(label)
if E ## null start
k == E_link
e_link == null
e_in use = 0
e_known = 0
khead_link == null; end == khead
while k ## null cycle
x == k_link
merge(k)
k == x
repeat
end_link == null
e_link == khead_link
finish
end
! >> GPR <<
integerfn gpr
! Get a general (integer) register
constinteger nregs=8
constbyteintegerarray pref(1:nregs) =
P1, P2, R4, R9, R10, R11, R3, R12
integer r,j,mask
mask = known regs
cycle
for j = 1,1,nregs cycle
Last Gpr = Last Gpr-1; Last Gpr = nregs if Last Gpr = 0
r = pref(Last Gpr)
result = r if activity(r) = 0 and mask & (1<<r) = 0
repeat
exit if mask = 0
mask = 0
repeat
hazard(R4)
result = R4
end
! >> EVEN/ODD PAIR <<
integerfn even odd pair
! Get an even/odd (integer) register pair
! the odd register is returned
! registers are hazarded here
constinteger regs = 3
constbyteintegerarray even(1:regs) = r2, r10, r4
integer j,r,mask
mask = known regs
cycle
for j = 1,1,regs cycle
Last EO = Last EO-1; Last EO = regs if Last EO = 0
r = even(Last EO)
result = r+1 if activity(r) = 0 and activity(r+1) = 0 c
and mask & (3<<r) = 0
repeat
exit if mask = 0
mask = 0
repeat
hazard(r2); hazard(r3); result = r3
end
! >> FPR <<
integerfn fpr
! get a floating point register
integer j,mask
mask = known regs
cycle
for j = fr0,1,fr14 cycle
Last Fpr = Last Fpr-1; Last Fpr = fr14 if Last Fpr = fr0-1
result = Last Fpr if activity(Last Fpr) = 0
repeat
exit if mask = 0
mask = 0
repeat
hazard(fr0)
result = fr0
end
!OBJECT FILE HANDLING ROUTINES
! >> PUT <<
routine put(integer n)
print symbol(n>>8); print symbol(n&255)
end
! >> SELECT LITERAL AREA <<
routine select literal area
integer k
print symbol(lit area)
abort(m'DMP1') if ca < 0
k = lita; lita = ca; ca = k
end
! >> SELECT CODE AREA <<
routine select code area
integer k
abort(m'DMP2') if ca > 0
k = lita; lita = ca; ca = k
print symbol(code area)
end
routine phex(integer n)
integer j,k
spaces(2)
for j = 12,-4,0 cycle
k = (n>>j)&15
if k <= 9 then k = k+'0' else k = k-10+'A'
print symbol(k)
repeat
end
! >> DUMP TAG <<
routine dump tag(integer tag, type)
conststring (7)array s(tag def:c ref) =
" defn", " r ref", " p ref", " sw ref", " j ref", " c ref"
select output(report)
print symbol('*'); write(ca,-3)
print string(s(type))
write(tag,1)
newline
select output(object)
end ; ! dump tag
! >> DUMP <<
routine dump(integer p,val)
integer k
select output(report)
if p = m'CA' start
print string("CA "); k = ca
else
print string("GA "); k = ga
finish
write(k-2,-3); print symbol(':')
phex(val)
newline
select output(object)
end ; ! dump
! >> CPUT <<
routine cput(integer n)
! Output one halfword to code area
print symbol(code item)
print symbol(n>>8); print symbol(n&255)
ca = ca+2
dump(m'CA',n) if diagnose < 0
end
! >> GPUT <<
routine gput(integer n)
! Output one halfword to gla area
print symbol(gla item)
print symbol(n>>8); print symbol(n&255)
ga = ga+2
dump(m'GA',n) if diagnose < 0
end
! >> CWORD <<
routine cword(integer n)
cput(n>>16); cput(n)
end
! >> LIT BYTE <<
routine lit byte(integer n)
owninteger v=0,f=0
f = ¬f
if f=0 start
ca = ca+1; cput(v<<8 + n&255)
else
v = n; ca = ca-1
finish
abort(m'DMP3') unless ca <= 0
end
! >> GWORD <<
routine gword(integer n)
gput(n>>16); gput(n&x'FFFF')
end
! >> GWORD REL <<
routine gword rel(integer n)
! Word in GLA modified at load-time by gla base address - used to relocate
! %ownarray headers.
gput(n>>16); gput(n&x'FFFF')
print symbol(g rel); relocations = relocations + 1
end ; ! gword rel
! >> GWORD CREL <<
routine gword crel(integer n)
! Word in GLA modified at load-time by code base address - used to relocate
! %constarray headers
gput(n>>16); gput(n&x'FFFF')
print symbol(c rel); relocations = relocations+1
end ; ! GWORD CREL
! >> GBYTE <<
routine gbyte(integer n)
owninteger v=0, f=0
f = ¬f
if f = 0 start
ga = ga-1; gput(v<<8 + n&255)
else
v = n; ga = ga+1
finish
end
! >> GFIX <<
routine gfix(integer align)
gbyte(0) while ga&align # 0
end
! >> DEFINE TAG <<
routine define tag(integer ref)
integer k
select output(direct)
print symbol(tag def)
print symbol(ref>>8); print symbol(ref&255)
k = ca>>1; ! ******* Halfword units
print symbol(k>>8); print symbol(k&255)
select output(object)
dump tag(ref,tag def) if diagnose < 0
end ; ! define tag
! >> DEFINE REFERENCE <<
routine define reference(integer ref, type)
integer k
set line if current line # last line
select output(direct)
print symbol(type)
print symbol(ref>>8); print symbol(ref&255)
k = ca>>1; ! ******** Halfword units
print symbol(k>>8); print symbol(k&255)
select output(object)
dump tag(ref,type) if diagnose < 0
print symbol(type)
if type = r ref start
print symbol(ref>>8); print symbol(ref&255)
finish
end ; ! define reference
! >> CLAIM LITERAL <<
routine claim literal(integer size,align)
integer k
abort(m'DMP4') if ca < 0 or litmax > 0
if lita&1 # 0 start ; ! odd no. of bytes
select literal area
lit byte(0)
select code area
finish
litmax = -((-litmax+size+align)&(¬align))
lita = litmax
k = (-lita)>>1
print symbol(lit org); put(k); ! Tell pass 3
end ; ! claim literal
! >> SET LINE <<
routine set line
integer flag
return if ca < 0; !in literal area
if current line-last line # 1 then flag = line reset c
else flag = line flag
select output(direct)
print symbol(flag); put(current line) if flag = line reset
if diagnose < 0 start
select output(report)
print string("-->line"); write(current line,1)
newline
finish
select output(object)
print symbol(flag); put(current line) if flag = line reset
last line = current line; last ca = ca
end ; ! set line
! >> DESCRIBE <<
routine describe(integer base,disp, string (ident len)name xsym)
! Generate a full description of the variable specified by (base,disp)
! Assumes that DIAG SIZE, DIAG TYPE, DIAG FORM, OTYPE are appropriately set.
integer size,type
integer j,k
constbyteintegerarray compressed type(0:13) =
1, 2, 3, 4, 5, 0(3), 6, 0(4), 7
! integer real string record byte short long real
length(xsym) = extern len if length(xsym) > extern len
print symbol(length(xsym))
print symbol(charno(xsym,j)) for j = 1,1,length(xsym); ! name
return if base < 0
size = diag size; type = diag type
size = 1 if diag type >= 3 or diag form > 2 or size = 0
type = 1 if diag type <= 0
k = (size-1) << 2 + (type-1)
j = 0
j = x'80' if Otype # 0 and Spec # 0 {external data spec}
print symbol(otype)
print symbol( compressed type(k) << 4 ! DIAG FORM ! J)
j = actual(base)<<20 + disp&x'000FFFFF'
print symbol(j>>16); print symbol(j>>8); print symbol(j)
end ; ! describe
! >> SET DIAG <<
routine set diag(integer base,disp)
! Implicit parameters: DIAG TYPE DIAG FORM DIAG SIZE OTYPE
var diags = var diags + basic vdiag
var diags = var diags + extra vdiag if length(internal id) > short ident
print symbol(var diag); describe(base,disp,internal id)
end
! >> EXTERNAL LINK <<
routine external link(integer ref type,data size,addr)
!Note that ADDR is ignored when defining procedure entry points
! it is assumed that the link is set IMMEDIATELY before the entry point.
integer k
abort(m'DMP5') unless data ref <= ref type <= ep defn
if ref type&1 # 0 then defns = defns+1 else specs = specs+1
print symbol(extern)
print symbol(ref type)
put(data size//2); ! Halfwords for pass3
k = gla; k = code if ref type = ep defn
describe(k,addr//2,external id)
if ref type&1 = 0 start ; !a spec
gword(0); gword(0)
if ref type = ep ref then gword(0) else gword(-1)
finish
end
! >> CLOSE FILES <<
routine close files
select output(direct)
print symbol(prog end)
put(total ca>>1); put((-litmax)>>1); put(ga>>1); ! Halfword units
put(defns); put(specs); put(relocations)
print symbol(0); ! to prevent potential trouble with binary 4 = EOF
close output
select output(object); print symbol(prog end)
close output
end ; ! close files
! code generation routines
! >> RXD <<
! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
! B a s i c C o d e G e n e r a t o r
!
routine RXD(integer op, r1, record (stackfm)name v)
integer index, mask, code, format
integer type, form, base, disp, x
integer k, old ca
record (stackfm) u
constbyteintegerarray type index(integers:reals+1) =
1, 2, 7, 0(3), 1, 0
! integer short byte reals reall
old ca = ca
type = v_type; form = v_form
base = v_base; disp = v_disp; x = v_index
op = op + fp base if r1 >= FR0
mask = op index(op); index = mask&255
set line if last line # current line
if form = constant or form = AV in S start ; ! RXI
abort(m'RXDx') if x # 0
if disp = 0 and base # 0 and LSH # op # RSH and op # SRA start
! optimise: LHI x,0(y) => LR x,y
! remove: LHI x,0(x)
if r1 # base or op # LW start
u_xbase = base; u_disp = 0; ! **** u_disp otherwise unassigned ****
u_form = V in R; rxd(op,r1,u)
return
finish
code = x'10'; !(psr) preserve CC at end - see later
else if op = LW and r1 = base and 15 >= disp >= -15
! LHI x, 15(x) => AIS x,15
! LHI x,-15(x) => SIS x,15
op = add
if disp < 0 start
op = sub; disp = -disp
finish
u_form = constant; u_xbase = 0; u_disp = disp; rxd(op,r1,u)
release(base)
return
else if op = LSH and disp = 1 and base = 0
! SLLS x,1 => AR x,x
claim(r1)
u_xbase = r1; u_disp = 0
u_form = V in R; rxd(add,r1,u); return
else ; ! general case (RXI)
abort(m'RXD1') if mask&FWIMM = 0 and LSH # op # RSH and op # SRA
index = index + 3; ! fullword immediate
format = 0
if 15>=disp>=-15 and base=0 and (SF IMM+INV IMM)&mask # 0 start
if disp >= 0 start
format = 2
else
format = 3; disp = -disp
finish
else if 32767 >= disp >= -32768
format = 1
finish
code = op code(index + format)
if format >= 2 start
cput(code&x'FF00' + actual(r1)<<4 + disp)
else
cput(code&x'FF00' + actual(r1)<<4 + actual(base))
cput(disp>>16) if format = 0; ! fullword immediate ?
cput(disp)
finish
finish
else if form = V in R; ! register-register operation
abort(m'RXD2') if r1 = 0 or base = 0 or x # 0
code = op code(index); ! ** N.B. op code(index + 0) really ......
if code&x'20' # 0 start ; ! STR => LR etc.
k = r1; r1 = base; base = k
finish
cput(code&x'FF00' + actual(r1)<<4 + actual(base))
else ; ! RX (integer,real,short,byte)
abort(m'RXD3') if r1 = 0 or base = R0
format = type index(type); abort(m'RXD4') if format = 0
code = op code(index + format)
abort(m'RXD5') if (code&15)&disp # 0
cput(code&x'FF00' + actual(r1)<<4 + actual(base))
unless 0 <= disp <= 16383 and x = 0 start
cput(x'4000' + actual(x)<<8 + (disp>>16)&255)
finish
cput(disp)
finish
release(base) if base > 0; !(PSR)
release(x) if x # 0
if code&x'40' # 0 start ; ! leaves cond code completely unchanged
cc ca = cc ca + ca - old ca
else if code&x'10' = 0; ! cond code relative to zero ?
cc ca = ca; cc reg = r1
finish
end ; ! of 'RXD'
! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
! >> RR <<
routine rr(integer op,r1,r2)
record (stackfm) v
v_xbase = r2; v_disp = 0
v_type = integers; v_type = reals if r1 >= FR0
v_form = V in R; rxd(op, r1, v)
end
! >> RXI <<
routine rxi(integer op, r1, base, disp)
record (stackfm) v
v_xbase = base; v_disp = disp
v_type = integers
v_form = constant; rxd(op, r1, v)
end
! >> RX <<
routine rx(integer op, r1, base, disp)
record (stackfm) v
v_xbase = base; v_disp = disp
v_type = integers; v_type = reals if r1 >= FR0
v_form = V in S; rxd(op, r1, v)
end
! >> SKIP <<
routine skip(integer half words, condition)
! Plant a short forward jump to skip over unwanted code sequence:
! skips forward the number of halfwords specified NOT COUNTING the
! code dumped to effect the skip
! Must be used with care as it doesn't account automatically for register
! contents.
constshortintegerarray jump(0:5) =
x'2330', x'2130', x'2110', x'2120', x'2320', x'2310'
! BES BNES BMS BPS BNPS BNMS
Condition = Inverted(Condition) if Condition&16 # 0
abort(m'SKP1') unless 0 < halfwords <= 14 and 0 <= condition <= 5
cput( jump(condition) ! (halfwords + 1) )
end
! >> MACHINE CODE <<
routine machine code
constinteger branch = 1
constinteger rr = 2
constinteger indexed = 4
constinteger ri1 = 8
constinteger ri2 = 16
!*delete*
constinteger mc entries = 204
constintegerarray mcop(1:mc entries) =
x'00000041', x'00000042', x'00000043', x'00000044', x'0000004C',
! A B C D L
x'0000004D', x'0000004E', x'0000004F', x'00000053', x'00000058',
! M N O S X
x'00001004', x'00001005', x'00001008', x'00001009', x'0000100C',
! AD AE AH AI AL
x'0000100D', x'00001012', x'00001084', x'00001085', x'00001088',
! AM AR CD CE CH
x'00001089', x'0000108C', x'00001092', x'000010C3', x'000010C5',
! CI CL CR BC BE
x'000010C7', x'000010CC', x'000010CD', x'000010CF', x'000010D0',
! BG BL BM BO BP
x'000010D2', x'000010DA', x'00001144', x'00001145', x'00001148',
! BR BZ DD DE DH
x'00001152', x'00001304', x'00001305', x'00001308', x'00001312',
! DR MD ME MH MR
x'00001341', x'00001342', x'00001344', x'00001345', x'00001348',
! LA LB LD LE LH
x'00001349', x'0000134D', x'00001352', x'00001383', x'00001388',
! LI LM LR OC OH
x'00001389', x'00001392', x'000013C8', x'000013C9', x'000013D2',
! OI OR NH NI NR
x'00001484', x'00001485', x'00001488', x'00001489', x'00001492',
! SD SE SH SI SR
x'00001493', x'00001494', x'000014C2', x'000014C4', x'000014C8',
! SS ST RB RD RH
x'00001549', x'00001553', x'00001582', x'00001584', x'00001588',
! TI TS WB WD WH
x'00001648', x'00001649', x'00001652', x'000400CC', x'00040112',
! XH XI XR ABL AER
x'00040152', x'00040213', x'00040249', x'0004024D', x'0004054C',
! ADR AIS AHI AHM ATL
x'000420D4', x'00042112', x'00042152', x'00042249', x'00042342',
! CBT CER CDR CHI CLB
x'00042348', x'00042349', x'00042352', x'0004300C', x'00043092',
! CLH CLI CLR BAL BCR
x'00043112', x'00043185', x'00043192', x'000431C3', x'00043312',
! BER BGE BGR BFC BMR
x'00043345', x'00043352', x'00043392', x'000433C3', x'000433C5',
! BLE BLR BOR BNC BNE
x'000433CC', x'000433CD', x'000433CF', x'000433D0', x'000433DA',
! BNL BNM BNO BNP BNZ
x'00043452', x'00043543', x'00043648', x'000436D2', x'00045112',
! BPR BTC BXH BZR DER
x'00045152', x'00045252', x'00047352', x'00047652', x'0004C112',
! DDR DHR FLR FXR MER
x'0004C152', x'0004C252', x'0004D093', x'0004D0D2', x'0004D112',
! MDR MHR LCS LBR LER
x'0004D152', x'0004D213', x'0004D249', x'0004D24C', x'0004D304',
! LDR LIS LHI LHL LMD
x'0004D305', x'0004E092', x'0004E249', x'0004F249', x'0004F390',
! LME OCR OHI NHI NOP
x'00052090', x'000520D4', x'00052112', x'00052152', x'00052213',
! SCP SBT SER SDR SIS
x'00052249', x'00052341', x'00052492', x'000524C1', x'000524CC',
! SHI SLA SSR SRA SRL
x'000524D2', x'00052542', x'00052544', x'00052545', x'00052548',
! SRR STB STD STE STH
x'0005254D', x'000525C3', x'000530CC', x'000530D2', x'000530D4',
! STM SVC RBL RBR RBT
x'00053152', x'00053252', x'0005334C', x'000534CC', x'0005354C',
! RDR RHR RLL RRL RTL
x'000550D4', x'00055249', x'000560D2', x'00056152', x'00056252',
! TBT THI WBR WDR WHR
x'00059249', x'010895D2', x'0108D249', x'010C0352', x'010C6112',
! XHI CHVR CLHI BALR BGER
x'010C7092', x'010C7092', x'010C70D3', x'010C71D3', x'010CD112',
! BFCR BFCR BFBS BFFS BLER
x'010CF092', x'010CF112', x'010CF312', x'010CF352', x'010CF392',
! BNCR BNER BNMR BNLR BNOR
x'010CF452', x'010CF6D2', x'010D5092', x'010D50D3', x'010D51D3',
! BNPR BNZR BTCR BTBS BTFS
x'010D9345', x'01111492', x'011190D2', x'01119252', x'011CD152',
! BXLE EPSR EXBR EXHR FLDR
x'011D9152', x'01351497', x'013CE452', x'014883D4', x'0148D241',
! FXDR LPSW NOPR SINT SLHA
x'0148D24C', x'0148D353', x'01493241', x'0149324C', x'01493353',
! SLHL SLLS SRHA SRHL SRLS
x'014950D2', x'01495304', x'01495305', x'424C3C72', x'424C3C76',
! STBR STMD STME CRC12 CRC16
x'4D452592', x'52349353', x'524C9353', x'55340545'
! LPSWR SLHLS SRHLS TLATE
constshortintegerarray opflags(1:mc entries) =
x'5A04', x'4305', x'5904', x'5D04', x'5804', x'5C04', x'5404', x'5604',
! A B C D L M N O
x'5B04', x'5704', x'7A04', x'6A04', x'4A04', x'FA10', x'D501', x'5104',
! S X AD AE AH AI AL AM
x'0A02', x'7904', x'6904', x'4904', x'F910', x'5504', x'0902', x'4285',
! AR CD CE CH CI CL CR BC
x'4335', x'4225', x'4285', x'4215', x'4245', x'4225', x'0303', x'4335',
! BE BG BL BM BO BP BR BZ
x'7D04', x'6D04', x'4D04', x'1D02', x'7C04', x'6C04', x'4C04', x'1C02',
! DD DE DH DR MD ME MH MR
x'E604', x'D304', x'7804', x'6804', x'4804', x'F810', x'D104', x'0802',
! LA LB LD LE LH LI LM LR
x'DE04', x'4604', x'F610', x'0602', x'4404', x'F410', x'0402', x'7B04',
! OC OH OI OR NH NI NR SD
x'6B04', x'4B04', x'FB10', x'0B02', x'DD04', x'5004', x'D704', x'DB04',
! SE SH SI SR SS ST RB RD
x'D904', x'F310', x'E004', x'D604', x'DA04', x'D804', x'4704', x'F710',
! RH TI TS WB WD WH XH XI
x'0702', x'6504', x'2A02', x'3A02', x'2602', x'CA08', x'6104', x'6404',
! XR ABL AER ADR AIS AHI AHM ATL
x'7704', x'2902', x'3902', x'C908', x'D404', x'4504', x'F510', x'0502',
! CBT CER CDR CHI CLB CLH CLI CLR
x'4104', x'0281', x'0333', x'4315', x'0223', x'4304', x'0213', x'4325',
! BAL BCR BER BGE BGR BFC BMR BLE
x'0283', x'0243', x'4385', x'4235', x'4385', x'4315', x'4345', x'4325',
! BLR BOR BNC BNE BNL BNM BNO BNP
x'4235', x'0223', x'4204', x'C004', x'0333', x'2D02', x'3D02', x'0D02',
! BNZ BPR BTC BXH BZR DER DDR DHR
x'2F02', x'2E02', x'2C02', x'3C02', x'0C02', x'2502', x'9302', x'2802',
! FLR FXR MER MDR MHR LCS LBR LER
x'3802', x'2402', x'C808', x'7304', x'7F04', x'7204', x'9E02', x'C608',
! LDR LIS LHI LHL LMD LME OCR OHI
x'C408', x'4205', x'E304', x'7504', x'2B02', x'3B02', x'2702', x'CB08',
! NHI NOP SCP SBT SER SDR SIS SHI
x'EF00', x'9D02', x'EE00', x'EC00', x'ED00', x'D204', x'7004', x'6004',
! SLA SSR SRA SRL SRR STB STD STE
x'4004', x'D004', x'E104', x'6704', x'9702', x'7604', x'9B02', x'9902',
! STH STM SVC RBL RBR RBT RDR RHR
x'EB00', x'EA00', x'6604', x'7404', x'C308', x'9602', x'9A02', x'9802',
! RLL RRL RTL TBT THI WBR WDR WHR
x'C708', x'1202', x'C508', x'0102', x'0313', x'0302', x'1302', x'2202',
! XHI CHVR CLHI BALR BGER BFCR BFCR BFBS
x'2302', x'0323', x'0383', x'0233', x'0313', x'0383', x'0343', x'0323',
! BFFS BLER BNCR BNER BNMR BNLR BNOR BNPR
x'0233', x'0202', x'2002', x'2102', x'C104', x'9502', x'9402', x'3402',
! BNZR BTCR BTBS BTFS BXLE EPSR EXBR EXHR
x'3F02', x'3E02', x'C205', x'0203', x'E201', x'CF08', x'CD08', x'1102',
! FLDR FXDR LPSW NOPR SINT SLHA SLHL SLLS
x'CE08', x'CC08', x'1002', x'9202', x'7E04', x'7104', x'5E04', x'5F04',
! SRHA SRHL SRLS STBR STMD STME CRC12 CRC16
x'1801', x'9102', x'9002', x'E704'
! LPSWR SLHLS SRHLS TLATE
!*end*
string (7) opcode
record (varfm)name v
integer op, base, disp, index, flags, p, n, reg
routine mc error(string (255) s)
selectoutput(0)
printsymbol('*')
write(current line, 3)
space
printstring(opcode)
printstring(": ")
printstring(s)
newline
selectoutput(object)
while sym # ';' cycle
sym = next; readsymbol(next)
repeat
end
routine get opcode
opcode = ""; op = 0
cycle
sym = next; readsymbol(next)
exit if sym = '_'
if length(opcode) # 6 start
op = op<<6!!sym
opcode = opcode.tostring(sym)
finish
repeat
sym = next; readsymbol(next)
end
integerfn find opcode
integer high, low, p
high = mc entries; low = 1
while high >= low cycle
p = (high+low)>>1
result = p if mcop(p) = op
if mcop(p) > op then high = p-1 else low = p+1
repeat
mc error("unknown operation")
result = 0
end
predicate value(integername n)
n = 0
false unless '0' <= sym <= '7'
cycle
n = n<<3!(sym-'0')
sym = next; readsymbol(next)
true unless '0' <= sym <= '7'
repeat
end
predicate register(integername r)
false unless value(r)
false unless 0 <= r <= 15
true
end
predicate deal with plus minus
integer sign, n
true unless sym = '+' or sym = '-'
sign = sym; sym = next; readsymbol(next)
unless value(n) start
mc error("invalid offset")
false
finish
n = -n if sign = '-'
disp = disp+n
true
end
base = -1; index = -1; disp = 0
get opcode
p = find opcode; return if p = 0
flags = opflags(p)
if flags&branch # 0 start
reg = flags>>4&15; !cond-code
else unless register(reg)
mc error("register 1?"); return
else if sym # ','
mc error("comma missing"); return
else
sym = next; readsymbol(next)
finish
if flags&rr # 0 start
unless register(base) start
mc error("register 2?"); return
finish
else if sym = ' '; !named operand
n = tag
sym = next; readsymbol(next)
v == var(n)
disp = v_disp
if v_form = pgm label start ; !%label
define reference(disp&X'FFF', r ref); !make it look like a routine
disp = 0; Base = Code
return unless deal with plus minus
else
base = actual(v_base) unless v_base = 0
return unless deal with plus minus
if sym = '(' start
->ix if base > 0
->ib
finish
finish
else
if sym = '-' and deal with plus minus start
!only needs the side-effect of deal with ..
else unless value(disp)
mc error("displacement?"); return
finish
return unless deal with plus minus
if sym = '(' start
ib: sym = next; readsymbol(next)
unless register(base) start
mc error("base register?"); return
finish
if sym = ',' start
ix: sym = next; readsymbol(next)
if flags&indexed = 0 start
mc error("no double indexed form"); return
finish
unless register(index) start
mc error("index register?"); return
finish
finish
if sym # ')' start
mc error(") missing"); return
finish
sym = next; readsymbol(next)
finish
finish
if sym # ';' start
mc error("form?"); return
finish
base = 0 if base < 0
index = 0 if index < 0
base = index and index = 0 if base = 0 and index # 0
cput(flags&x'FF00'+reg<<4+base)
if flags&ri1 # 0 start
cput(disp&x'FFFF')
else if flags&ri2 # 0 and flags&branch = 0
cput(disp>>16); cput(disp&x'FFFF')
else if flags&rr = 0
if disp>>14 # 0 or index > 0 start
mc error("no RX3 form") and return if flags&indexed = 0
cput(x'4000'+index<<8+disp>>16&x'FF')
finish
cput(disp&x'FFFF')
finish
end
! >> SET DOPE VECTOR <<
routine set dope vector
integer t
t = vub-vlb+1
claim literal(4*reglen,3)
select literal area
dv = ca
cword(1)
cword(vlb); cword(vub)
cword(data size)
select code area
vub = t*data size; vlb = vlb*data size
end
! >> PERM <<
routine perm(integer n)
constinteger g0=1, g1=2, g2=4, g3=8, g4=16, g5=32, g6=64; ! General Registers
constinteger f0=128, f2=256; ! Floating Registers
constinteger prot = (-1)<<15; ! protect stack around call
constshortintegerarray rmap(0:8) = R0, R1, R2, R3, R4, P2, P1, FR0, FR2
integer k,r,h
!
! **** N.B. The following table must match the properties of the perm
! routines in use.
constinteger perm routines = 50
constshortintegerarray hazard reg(1:perm routines) =
0, ; ! 1: ASSCHK
G0+G3, ; ! 2: IEXP
G0+F0+F2, ; ! 3: REXP
G0+G3+G4, ; ! 4: SMOVE
G0+G3+G5, ; ! 4: SJAM
G0+G1+G2+G3+G4+G5, ; ! 6: SCONC
G0+G5+G6, ; ! 7: SRESLN
0, ; ! 8: SRESV
G0+G3+G4+G5, ; ! 9: SCOMP
F0+F2, ; ! 10: FRAC PT
0, ; ! 11: SFCAP
G0+G1+G2+G3+prot, ; ! 12: SUBSTR
G0+G1+G2, ; ! 13: AREF1
G0+G1+G4, ; ! 14: AREF2
G0+G1+G4+G5, ; ! 15: AREF3
G0+G1+G4, ; ! 16: AREF4
G0+G1+G2+G3, ; ! 17: SETDV
G0+G5, ; ! 18: ALLOC
0, ; ! 19: SWJMP
0, ; ! 20: SIGNAL
0, ; ! 21: MULCHK
0, ; ! 22: CAP16
0, ; ! 23: CAP8
G0+G1, ; ! 24: FCHK1
0, ; ! 25: FCHK2
G2+G3+G4, ; ! 26: PENTC
G0+G3, ; ! 27: RCOPY
G0+G3, ; ! 28: RZERO
0, ; ! 29: VSCHK
G0+G3+G4, ; ! 30: SMOVOPT
G0+G1, ; ! 31: CHMAP
G1, ; ! 32: FREESP
G1+F2, ; ! 33: INT
G0+G3+G4+G5, ; ! 34: RECORD COMPARE
G0+G1+G2+G3+G4+G5+G6, ; ! 35: SET COMPARE
G0+G3, ; ! 36: SET UNION
G0+G3, ; ! 37: SET DIFFERENCE
G0+G3, ; ! 38: SET INTERSECTION
0, ; ! 39:
0, ; ! 40:
0, ; ! 41:
0, ; ! 42:
0, ; ! 43:
0, ; ! 44:
0, ; ! 45:
0, ; ! 46:
0, ; ! 47:
0, ; ! 48:
G0+G1+G2+G3+G4+G5+G6+F0+F2, ; ! 49: IOCP
G0+G1+G2+G3+G4+G5+G6+F0+F2 ; ! 50: ENTER TRACE
h = hazard reg(n); ! property mask for nth. perm routine
if claimed # 0 start ; ! maybe something to do .. perhaps
k = h&x'7FFF'; ! register mask
r = 0
while k # 0 cycle
hazard(rmap(r)) if k&1 # 0
k = k>>1
r = r+1
repeat
finish
! forget all registers which are at risk
r = ( ((h&(F0+F2)) << (FR0-P1)) ! (h&127) ) << 1; ! ** N.B. P1 == G6
forget reg(r)
rxi(ADD,wsp,0,wdisp) if h < 0 and wdisp # 0
define reference(n&255,p ref)
rx(bal,link,code,n&255)
if h < 0 start
rxi(SUB,wsp,0,wdisp) if wdisp # 0
wdisp = wdisp + basic frame + 256; ! protect it
finish
end
! >> DUMP TRACE <<
routine DUMP TRACE
if current line # last line start
trace flag = 0
perm(enter trace); cput(current line)
finish
end
! >> ASSEMBLE <<
! AMODE:
! -2: alternate record format
! -1: record format
! 0: procedure
! 1: %spec
! 2: initial call
routine Assemble(integer amode, labs, names)
switch c(33:127), Pc('A':'Z')
recordformat evfm(integer low, high, events, label)
record (evfm) event = 0
record (varfm)name v
record (varfm)name gvar {procedure var}
record (stackfm)name lhs, rhs, x
integer old frame, old extra frame, old jump
integer old temp base, old next temp
integer true frame base, putative frame base, max frame, alt first, alt align=0
integer old var diags
integer gstart {first descriptor at this level}
integer label start {first label for this level}
owninteger free tag = 0
integer max local = 0
integer max parm = 0
integer min parm = 0 {P1, P2 parameter registers used ?}
integer mark assigned = 1 {mark VAR table entries as 'assigned' if # 0}
integer Closed = Assigned {assume it can't return}
integer Return Label = 0 {label on return code}
integer px = 0
integer proc ca = ca
integer sw list = 0
integer last a = -1
integer line size = 0
integer block index
integer j, k, t
routinespec compile to string(record (stackfm)name v)
routinespec pop lhs
routinespec lrd(record (stackfm)name v, integer reg)
routinespec load(record (stackfm)name v, integer reg)
routinespec assign(integer assop)
routinespec array ref(integer mode)
routinespec operate(integer n)
routinespec compare(record (stackfm)name l,r, integer next)
routinespec test zero(record (stackfm)name v)
routinespec header(record (varfm)name v)
routinespec block mark(integer mark)
integerfnspec new tag
old jump = uncond jump; uncond jump = -1
old var diags = var diags; var diags = 0
label start = labs
old frame = frame; old extra frame = extra frame; extra frame = 0
old temp base = temp base; old next temp = next temp
temp base = new temp; Next Temp = New Temp
forget the lot:
pdisp = 0; wdisp = 0; gdisp = -1; event_events = 0
abort(m'-1 ?') unless gdisp = -1; !************????????????
gvar == decvar; gstart = names
if amode >= 0 start ; ! NOT A RECORDFORMAT
frame = basic frame; ca = 0
level = level+1; abort(m'AM00') if level > 5 and spec = 0
local = breg(level)
activity(local) = -1
gdisp = (p1-p2)*reglen
Reset Optimisation Data if Spec = 0
if amode = 0 start ; ! procedure, proc. parameter, %begin block
block no = block no + 1; block index = block no
block mark(block start)
if sym = 'H' start ; ! %BEGIN block
gdisp = -1
if level = 1 start ; ! Initial %begin ?
external id = program ep; ! linkage to program entry
otype = external; potype = otype
finish
header(gvar)
finish
finish
else
if amode = -1 start ; ! record format
gvar_extra = parms
frame = 0
finish
true frame base = frame
putative frame base = (frame+align)&(¬align)
frame = putative frame base
max frame = frame
alt first = parms-1; ! note start of this alternative list
finish
! >> BLOCK MARK <<
routine block mark(integer mark)
integer k, limit
k = direct
cycle
select output(k)
print symbol(mark)
if mark = block start start
print symbol(block index)
if k = object start ; ! procedure head diagnostics
put(current line); last line = -15; !force a reset
describe(-1,0,block name); ! internal name for procedure
finish
else if k = direct; ! %and mark = block end (by implication)
abort(m'TAG?') if free tag > 32767; ! too many pass3 tags
put(ca>>1); ! code size for this block (half words)
put(var diags); ! var. diags local to this block
frame = (frame+align)&(¬align)
k = frame + extra frame; ! include in-frame array space
if control & trusted = 0 start
! using checked (perm) entry sequence
k = k>>2; ! to full word units
limit = 65535; ! treated as unsigned 16 bits by perm
else
! in-line entry sequence
limit = 32767; ! must be positive 2's complement (byte units)
finish
abort(m'FRM?') unless 0 < k <= limit
put(k)
print symbol(actual(local)); ! current display register
put(event_events); ! events-trapped mask
put(event_label); ! Event block ep
put(event_low); ! Event block %finish
total ca = total ca + ca
finish
exit if k = object
k = object
repeat
last ca = -1
end ; ! block mark
! >> SET FRAME PATCH <<
routine set frame patch
if diagnose < 0 start
select output(report)
print string(" Block index"); write(block index,1)
newline
select output(object)
finish
print symbol(frame patch)
end ; ! set frame patch
! >> DEFINE VAR <<
routine define var
integer type, form, tf, size, format, s, new, round, dimension
integer ignore; ! ** used to control dumping of diags **
record (stackfm) temp
integer k
!!!*** N.B. On machines with the PDP-11/VAX perversion relating to the order
! of register bytes in store, the following table will have to
! be changed as will a few constants in this routine.
! The relevant piece of record format to consider is:
! (%shortinteger xform %or %byteinteger flag,form)
! which must have the effect of mapping 'flag' onto the
! more significant byte of 'xform'.
constshortintegerarray fmap(0:18) = 0,
V in S, {simple variable}
A in S, {name: pointer variable}
pgm label, {label ** SPECIAL **}
15, {record format **SPECIAL**}
0, {unused}
0, {switch}
proc bit<<8 + 0, {routine}
proc bit<<8 + V in R, {function}
proc bit<<8 + V in S, {map}
proc bit<<8 + 5, {predicate}
abit<<8 + V in S, {array}
anbit<<8 + V in S, {array name}
(abit+label bit)<<8 + V in S, {name array}
(anbit+label bit)<<8 + V in S, {name array name}
! external manifestations of array forms
abit<<8 + V in REC, {external array}
anbit<<8 + V in REC, {external array name}
(abit+label bit)<<8 + V in REC, {external name array}
(anbit+label bit)<<8 + V in REC {external name array name}
constbyteintegerarray vsize(0:8) = 0,4,2,1,8,0,0,4,8
owninteger prim no = 0
ignore = 0
ignore = 1 if amode < 0 or amode = 1; ! no diags for specs of any kind!!
internal id = ""; new = 0; round = align
decl = tag
if decl = 0 start ; ! RECORD FORMAT ELEMENT NAME
parms = parms-1; abort(m'DFV1') if parms <= names
decvar == var(parms)
decvar = 0; !(psr)
else
abort(m'DFV2') if decl >= parms
decvar == var(decl)
if decl > names start
names = decl; new = 1
decvar = 0
finish
finish
cycle
sym = next; read symbol(next); exit if sym = ','
if length(internal id) # extern len start
internal id = internal id.to string(sym)
finish
repeat
ignore = 1 if internal id = ""
tf = tag; read symbol(next)
type = tf>>4; form = tf&15
size = tag; read symbol(next)
diag type = type; diag form = form; diag size = size
if type = integers and size # 1 start ; ! INTEGER
type = byte and round = 0 if size = 2
type = short and round = 1 if size = 3
size = vsize(type)
else if type = 2; ! REAL
type = reals
! *** for 8/32, 'round = 3' below should be changed to 'round = 7'
!????????????? type = reall %and round = 3 %if size = 4; ! LONG REAL
size = vsize(type)
else if type = 4; ! record
type = records
format = size
decvar_format = format; size = var(format)_length&x'FFFF' if format <= names
else if type = 3; ! string
type = strings
round = 0
decvar_length = size
size = size + 1
else
size = vsize(type)
finish
decvar_length = size if type # strings
decvar_type = type; decvar_xform = fmap(form)
otype = tag
spec = (otype>>3)&1; dimension = otype>>8&255; otype = otype&7
if otype # 0 start ; ! Set external linkage name if appropriate
if otype >= external start
if alias # "" start
external id = alias
else if otype = system
external id <- system prefix.internal id
else
external id = internal id
finish
otype = external if otype <= dynamic {external, system, dynamic}
finish
finish
alias = ""
if 7 <= form <= 10 start ; ! PROCEDURE
gtype = spec
if otype # 0 and spec # 0 start ; ! external spec
if otype = primrt start
primno = primno + 1
decvar_flag = decvar_flag ! prim bit
decvar_header = prim no; ! *** THIS NEEDS FIXING ***
return if prim no # 2; ! not READ SYMBOL
otype = external; external id = read sym fn; ! see "CALL"
finish
gfix(align)
decvar_disp = ga; decvar_base = gla
external link(ep ref, 0, ga)
return
finish
if gmode = 0 start ; ! NOT A PARAMETER
potype = otype
if new # 0 start ; ! NEW NAME
decvar_disp = new tag; ! Procedure ID
finish
block name = internal id if spec = 0
return
finish
ignore = 1
otype = 0; size = 4; data size = 4; ! procedure parameter
else
data size = size
if form # 1 start
Round = Align
if type = 0 start ; ! General %name
ignore = 1
decvar_extra = gmode; ! FOR LABELS
type = general; size = 8
decvar_type = general
else if form = array or form = name array
ignore = 1
size = 0
data size = reglen if form = name array
else if form = array name or form = name array name
ignore = 1
size = 2*reglen; round = align; ! array header
decvar_header = -1
abort(m'DFV3') unless 0 < dimension <= 7
decvar_flag = decvar_flag ! dimension; ! 'dim' in low order 3 bits
else
size = 4; ! integer (etc) %name
finish
finish
finish
if otype # 0 start ; ! OWN DATA
if otype = con start ; ! CONST INTEGER ETC.
data size = 0 if type=strings and form=1; ! use actual size
if form = 2 or form = arrayname or form = namearrayname start
otype = 0; ! Treat as special later
else
ignore = 1; ! no diags for named constants
finish
else
gfix(round)
set diag(gla,ga) if ignore # 1
finish
own type = type; own form = form
own type = integers and data size = 4 if form = 2
decvar_header = -1
if spec = 0 start
if form = array or form = name array start
own form = array; ! to simplify subsequent test at 'A'
decvar_flag = decvar_flag&(¬array bits)!(anbit!1); ! 1-D %name
! mark as candidate for MHR subscript scaling if bounds do not
! exceed -32768 <= x <= 32767 and data size <= 32767
decvar_flag = decvar_flag ! cheap array bit if c
0 < decvar_length <= 32767 and c
-32768 <= vlb {<= 32767} and c
{-32768 <=} vub <= 32767
{Note: vlb <= vub-1}
gfix(align)
set dope vector; ! N.B. changes vlb, vub
if otype # con start
decvar_disp = ga; decvar_base = gla
gword rel(ga+8-vlb); ! @A(0) (in gla area)
gword crel(dv); ! @dope vector (in code area)
else ; ! %const ...... %array
claim literal(vub,align); ! no header this time (it's in GLA)
select literal area
decvar_disp = ga; decvar_base = gla
gword crel(ca-vlb)
gword crel(dv)
select code area
finish
external link(data defn,0,ga-8) if otype = external
finish
else
{to RECORD variant with 1-dim bit set, if nesc}
decvar_xform = (decvar_xform+3) ! (assigned<<8)
decvar_xform = decvar_Xform!1<<8 if Form >= Array
decvar_base = gla; decvar_disp = 0; decvar_extra = ga+8
external link(data ref,0,ga)
finish
return
finish
if form = 3 start ; !%label
decvar_disp = new tag
return
finish
if form = switch start
decvar_extra = vlb; decvar_length = vub-vlb+1
decvar_format = free tag + 1; ! base tag
claim literal((vub-vlb+1+2)*2,1)
decvar_base = code; decvar_disp = litmax
select literal area
cput(vlb); cput(vub); ! switch bounds
for s = vlb,1,vub cycle
free tag = free tag + 1
define reference(free tag,sw ref)
cput(free tag)
repeat
select code area
return
finish
if form = record format start
if gmode # 0 start
frame = decvar_length if decvar_length > frame
else
gtype = -1; spec = -1
finish
return
finish
decvar_base = local
if gdisp >= 0 and decvar_flag & array bits = 0 c
and ( (decvar_form = a in s and decvar_type # general) c
or (decvar_form = v in s and decvar_type <= byte) ) start
decvar_disp = gdisp; gdisp = gdisp - reglen
decvar_disp = decvar_disp + decvar_type if c
decvar_form = v in s and short <= decvar_type <= byte
decvar_flag = decvar_flag ! P in R; ! Parameter in Register
min parm = min parm + 1; ! for use by 'HEADER'
if control & suppress = 0 start
temp_form = decvar_form; temp_type = decvar_type
temp_xbase = decvar_base; temp_disp = decvar_disp
if temp_form = A in S start
temp_form = V in S; temp_type = integers
finish
associate(temp, p1 - (min parm-1))
finish
else
frame = (frame+round)&(¬round)
max local = frame
decvar_disp = frame
frame = frame + size
alt align = alt align ! round
finish
set diag(local,decvar_disp) if ignore = 0
end ; ! define var
! >> CHECKABLE <<
predicate checkable(record (stackfm)name v)
! Presumes test on 'CONTROL&CHECK UNASS' in line for speed
! Note that a string temporary (v_type = 0) yields FALSE
false if v_form = constant or v_form = AV in S
false if v_flag & assigned # 0
true if v_type = integers or v_type = strings or v_type >= reals
false
end ; ! checkable
! >> DESCRIPTOR <<
! N.B. Note that the record zero operation is used, among
! other things, to set the link field to NULL. This
! equivalence between binary zero and NULL links must
! be maintained.
record (stackfm)map descriptor
record (dfm)name d
record (stackfm)name v
stp = stp+1; abort(m'DSC1') if stp > max depth
v == desc asl; abort(m'DSC2') if v == null
d == dasl; abort(m'DSC3') if d == null
desc asl == v_link; v = 0
dasl == d_link; d_link == using_link; using_link == d
d_d == v
result == v
end
! >> DROP <<
routine drop(record (stackfm)name descriptor)
record (dfm)name p,q
p == using
cycle
q == p_link
abort(m'DROP') if q == null
exit if q_d == descriptor
p == q
repeat
p_link == q_link
q_link == dasl; dasl == q
descriptor_link == desc asl; desc asl == descriptor
end
! >> VSTACK <<
routine vstack(integer var no)
record (varfm)name w
abort(m'VSTK') unless 0 <= var no <= max vars
w == var(varno)
lhs == descriptor
stacked(stp)_v == lhs
lhs_base = w_base
lhs_disp = w_disp
lhs_format = w_format
lhs_extra = w_extra
lhs_type = w_type
lhs_length = w_length
lhs_header = w_header
lhs_link == null
lhs_type = w_type; lhs_xform = w_xform
lhs_dim = w_flag&7; ! in case it's an array
lhs_varno = varno
monitor(lhs, "V stack") if diagnose&1 # 0
end
! >> SSTACK <<
routine sstack(record (stackfm)name v)
record (stackfm)name t
t == descriptor; t = v
stacked(stp)_v == t
monitor(t, "S STACK") if diagnose&1 # 0
end
! >> C STACK <<
routine c stack(integer n)
rhs == descriptor
rhs_base = 0
rhs_disp = n
rhs_type = integers
rhs_form = constant
stacked(stp)_v == rhs
monitor(rhs, "C stack") if diagnose&1 # 0
end
! >> C LOAD <<
routine cload(integer value, reg)
c stack(value)
pop lhs
lrd(lhs,reg)
end
! >> SSET <<
routine sset(integer base, disp, xform, extra)
rhs == descriptor
rhs_base = base
rhs_disp = disp
rhs_type = integers
rhs_xform = xform
rhs_extra = extra
rhs_link == null
stacked(stp)_v == rhs
monitor(rhs, "SSET") if diagnose&1 # 0
end
! >> SET LHS <<
routine set lhs
lhs == stacked(stp)_v
monitor(lhs, "SET LHS") if diagnose&1 # 0
end
! >> SET BOTH <<
routine set both
abort(m'SETB') if stp <= 1
lhs == stacked(stp-1)_v
rhs == stacked(stp)_v
if diagnose&1 # 0 start
monitor(lhs, "BOTH LHS")
monitor(rhs, "BOTH RHS")
finish
end
! >> POP LHS <<
routine pop lhs
abort(m'POPL') if stp <= 0
lhs == stacked(stp)_v
stp = stp-1
monitor(lhs, "POP LHS") if diagnose&1 # 0
end
! >> POP DROP <<
routine pop drop
pop lhs
monitor(lhs, "POP DROP") if diagnose&1 # 0
drop(lhs)
end
!STRING PROCESSING
! >> DUMP STRING <<
routine dump string(integer max)
integer j
if max = 0 start ; ! DUMP AS MUCH AS NEEDED
max = cslen+1
else ; ! DUMP NO MORE THAN MAX
if cslen+1 > max start
! String constant too long - warn and truncate
if cslen # x'80' or current string(1) # x'80' start
warn(5); current string(0) = max-1
finish
finish
finish
if otype = con start
select literal area
lit byte(current string(j)) for j = 0,1,max-1
select code area
else ; ! %own
gbyte(current string(j)) for j = 0,1,max-1
finish
end
! >> GET STRING <<
routine get string
integer l
l = next; !length
cslen = 0
while l > 0 cycle
l = l-1
read symbol(next)
cslen = (cslen+1)&255; current string(cslen) = next
repeat
readsymbol(next)
if next # 'A' and next # '$' start
if next = '.' and cslen = 1 and
control&(check capacity!check unass) = 0 start
cstack(current string(1))
Rhs_Flag = Rhs_Flag!Quick Conc
return
finish
cstack(0); rhs_type = strings
otype = con; ! anonymous %const
rhs_base = code; rhs_xform = VinS!(assigned<<8); rhs_format = cslen+1
if cslen # 0 or null string = 0 start
claim literal(cslen+1,1); ! Alignment req'd for buffer flushing
rhs_disp = lita; dump string(0)
null string = rhs_disp if null string = 0 = cslen
else
rhs_disp = null string
finish
else
cstack(0); ! explicit string initialisation
finish
end
! >> REAL CONSTANT <<
integerfn real constant(integer force)
owninteger last = 0, next = 0
integer j,k
ownintegerarray val(0:31) = 0(32)
ownshortintegerarray index(0:31) = 0(32)
k = integer(addr(rvalue))
if otype # con start
gfix(3); gword(k)
result = ga-4
finish
! deal with %const anonymous or not
if force = 0 start
j = last
cycle
-> FOUND if val(last) = k
last = (last+1)&31
exit if last = j
repeat
claim literal(single,single-1); ! anonymous value not in cache
finish
next = (next+1)&31; last = next
select literal area
val(last) = k; index(last) = ca
cword(k)
select code area
FOUND:
result = index(last)
end ; ! real constant
!LABEL PROCESSING
! >> NEW TAG <<
integerfn new tag
free tag = free tag + 1
result = free tag
end
! >> NEW LABEL <<
record (labelfm)map new label
labs = labs+1; abort(m'NLBL') if labs > max labels
result == labels(labs)
end
! >> FIND <<
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
! >> DEFINE LABEL <<
routine define label(integer label)
integer ltag, new
record (labelfm)name l
record (envfm)name E
cc ca = 0 {must forget condition code}
new = 0
return if label = 0; ! JUMP AROUND PROCEDURE
if label < 0 start
ltag = -label
new = 1
else
l == find(label)
if l == null start
l == new label
l_id = label; l_tag = new tag
new = 1
else
if l_tag < 0 and label >= 0 start
l_tag = new tag
new = 1
finish
finish
l_tag = l_tag ! bit15
ltag = l_tag
finish
if new # 0 start
e == environment(label)
e_label = 0 if e ## null
finish
define tag(ltag & x'7FFF')
merge environment(label) if uncond jump # ca
restore environment(label)
if trace flag # 0 start
dump trace if next # ':' and next # 'L'
finish
uncond jump = 0; ! YOU CAN GET HERE !
mark assigned = 0; ! can't be sure any more
end ; ! define label
! >> JUMP TO <<
routine jump to(integer label, cond, def)
record (labelfm)name lab
integer ref
invert = 0
Cond = Inverted(Cond) if Cond&16 # 0
if def >= 0 start ; ! Compiler defined label
return if label = 0; ! jump round routine
if label < 0 start
j tag = -label
else
lab == find(label)
if lab == null start
lab == new label
lab_id = label; lab_tag = new tag
remember environment(label)
else if lab_tag < 0 and def = redefine old
lab_tag = new tag
remember environment(label)
else
merge environment(label) if lab_tag > 0
finish
j tag = lab_tag&x'7FFF'
finish
else ; ! Tag internal to pass 2
jtag = label; ! *** N.B. This is %not a pass1-visible label ***
finish
if cond = jump then ref = j ref else ref = c ref
define reference(j tag,ref)
cput(jtag<<4 + cond&15); cc ca = cc ca + 2; ! these two bytes can't change CC
if cond = jump start
uncond jump = ca; ! no way past here
trace flag = control&trace if next = ':'; ! to catch 'else', 'repeat' etc
else
trace flag = control&trace; ! maybe trace flow on next line
finish
mark assigned = 0
end ; ! jump to
! >> FLOAT <<
routine float(record (stackfm)name v, integer r)
! Convert 'v' into floating point form
integer k
!!!!!%longreal x
r = fpr if r = anyf
if const(v) start
if v_disp = 0 start
hazard(r); claim(r)
rr(sub,r,r); claim(r)
v_type = reall; v_form = v in r; v_base = r
else
rvalue = v_disp; ! ** IMPLICIT FLOATING **
otype = con; k = real constant(0)
v_xform = (assigned<<8) ! V in S; v_type = reals
v_base = code; v_disp = k
finish
else
load(v,any)
rr(flr,r,v_base); claim(r)
v_form = v in r; v_type = reall
v_base = r
finish
end
! >> LRD <<
routine lrd(record (stackfm)name v, integer reg)
! load, release and drop
load(v,reg)
release(v_base)
drop(v)
end
! >> QUICK LOAD <<
routine QUICK LOAD(integer reg, form, base, disp)
record (stackfm) v
v = 0
v_type = integers; v_form = form
v_base = base; v_disp = disp
load(v, reg)
end
! >> REDUCE <<
routine reduce(record (stackfm)name v)
integer type, xform, disp, base
xform = v_xform - 3; ! X in REC => X in S
type = v_type
disp = v_disp; base = v_base
v_disp = v_extra; v_type = integers; v_form = v in s
load(v,any)
v_type = type; v_xform = xform & (¬(assigned<<8))
v_disp = disp
end
! >> AMAP <<
routine amap(record (stackfm)name v)
! convert V into a descriptor for the address of V
integer f
constshortintegerarray map(0:15) =
-1, -2, -3, -4, av in s, -5, v in s, av in rec, -6, v in rec,
-7, -8, -9, -10, -11 {PGM LABEL}, -12 {record format}
f = map(v_form)
if f < 0 start
abort(m'AMAP') unless v_form = pgm label
! Deal with ADDR(pgm label)
f = gpr; forget reg(1<<f)
define reference(v_disp&x'FFF',r ref)
rx(LA,f,code,0)
v_type = integers; v_xform = VinR
v_base = f; v_disp = 0
claim(f)
return
finish
if (f = VinREC or f = AVinREC) and v_disp = 0 start {eliminate redundant LOAD}
if f = VinREC then f = AinS else f = VinS
v_disp = v_extra
finish
v_type = integers; v_form = f
end
! >> AMAPS <<
routine amaps(record (stackfm)name v)
integer t,l
t = v_type; l = v_length
amap(v)
return if t # strings; ! put length in top byte
reduce(v) if v_form >= V in REC
load(v,any) if v_form = V in S or v_Form = AinS
!! It must be: const, V in R or AV in S
v_disp = v_disp + l<<24
v_form = AV in S
end
! >> VMAP <<
routine vmap(record (stackfm)name v)
! The inverse of AMAP: i.e. vmap(amap(x)) => x
integer mod, f, t
constshortintegerarray map(0:8) =
v in s, v in s, -1, -2, a in s, v in s, -3, a in rec, v in rec
mod = 0
if v_oper # 0 start
if (v_oper=add or v_oper=sub) and const(v_link) start
mod = v_link_disp
mod = -mod if v_oper = sub
v_oper = 0; drop(v_link)
finish
load(v,any)
else if v_form = a in s or v_form = a in rec
T = V_Type
Amap(V)
load(v,any)
V_Type = T; V_Form = VinS
finish
f = map(v_form); abort(m'VMAP') if f < 0
v_form = f
v_disp = v_disp + mod
end ; ! v map
! >> ADDRESS <<
routine address(record (stackfm)name v, integer mode)
! convert V into a form in which it is directly addressable
! MODE parameter specifies what type of result is required.
! >= 0 : a value (RHS)
! < 0 : a name (LHS)
! Further, if MODE > 0, the value is taken to specify the target register
! for any LOAD which may be generated.
integer type, form, reg, d, cr
ownrecord (stackfm)name last == (0); ! ***** null actually ****** UGH
monitor(v, "ADDRESS") if diagnose&2 # 0
reg = mode
if reg <= 0 start
reg = any
reg = anyf if v_type >= reals or (v_oper # 0 and floating(v))
finish
cr = reg; !*psr*
if v_oper # 0 start ; ! compound object
if v_oper = ADD and const(v_link) and v_type <= BYTE start
d = v_link_disp; drop(v_link)
v_oper = 0
load(v,reg)
v_disp = d; v_form = AV in S
else
load(v,reg)
finish
->SET CR
finish
form = v_form; type = v_type
if form >= V in REC start
reduce(v); form = v_form
finish
if control & suppress = 0 start
cheap reg = cr
cheapen(v,mode)
cr = cheap reg
form = v_form
finish
->SET CR if form = V in R or form = constant
if form = AV in S start
if v_base = 0 start
v_form = constant
else if v_disp = 0
v_form = V in R
finish
->SET CR
finish
if form = A in S start
v_form = V in S; v_type = integers
load(v,any)
v_type = type; v_xform = (v_flag&(¬assigned))<<8 ! V in S; v_disp = 0
form = V in S
finish
if not last == v start ; ! *** FRIG: to prevent mutually recursive loop
last == v
if mode >= 0 and ((control&check unass#0 and v_type#strings c
and checkable(v)) or v_type = byte) start
load(v,reg)
finish
last == null
finish
SET CR:
cheap reg = cr
end ; ! address
! >> LOAD <<
routine load(record (stackfm)name v, integer r)
! load the entity described by V into register R
record (stackfm)name w
switch f(constant:a in rec), iop(not:rdiv), rop(not:rdiv)
record (stackfm) z
record (stackfm)name temp rhs
integer op, d, type, temp, n, uflag
constbyteintegerarray twin(R0:R15) =
R1,R0, R3,R2, R5,R4, R7,R6, R9,R8, R11,R10, R13,R12, R15,R14
routine PICKUP(record (stackfm)name V)
integer old
load(v, r)
if R = Any or R = AnyF start
old = R; R = V_Base
return if Activity(R) = 1 or (Activity(R)=2 and W_Base = R)
if old = Any then R = Gpr else R = Fpr
Load(V, R)
else
abort(m'Pick') if activity(r) # 1
finish
end
monitor(v, "LOAD") if diagnose&2 # 0
-> realv if floating(v) or fr0 <= r <= fr14 or r = anyf
op = v_oper; v_oper = 0
if op # 0 start
w == v_link; {address(w,0)}; ! records reduced here
load(w,any) if w_base = r # v_base; ! *** FRIG: to avoid problem
! with HAZARD and e.g. -> sw( -A(j) )
-> iop(op)
finish
amap(v) if v_type = 0 or v_type = strings or v_type = records
address(v,r)
if r = any start
return if v_form = VinR
if v_form = AV in S and activity(v_base) = 1 and -15 <= v_disp <= 15 start
r = v_base
else
r = gpr
finish
else
if v_base = r start
if activity(r) > 1 start {protect other uses}
release(r); v_base = 0
hazard(r)
claim(r); v_base = r
finish
else
hazard(r)
finish
finish
-> f(v_form)
f(av in rec):
f(a in rec):
f(v in rec):
f(A in S):
abort(m'LD1'); ! These forms should have been simplified by ADDRESS
f(av in s):
f(constant):
abort(m'LD2') if v_type >= reals
rxi(lw,r,v_base,v_disp)
forget reg(1<<r); associate(v,r) if r # v_base; ! e.g.LHI 12,1(12)
CSETI:
v_type = integers
CSET:
v_form = v in r
v_base = r; v_disp = 0
claim(r)
return
f(v in r):
return if v_base = r
rr(lw,r,v_base); forget reg(1<<r)
v_base = r
claim(r)
return
f(v in s):
uflag = control & check unass
if integers < v_type < reals start
abort(m'LD3') if short # v_type # byte
uflag = 0
else
uflag = 0 if v_Flag&assigned # 0 or not checkable(v) or v_Type = 255
finish
if V_Type = 255 start
V_Type = Short
Rxd(LHL, r, v)
Forget reg(1<<r)
else
rxd(lw,r,v)
forget reg(1<<r); associate(v,r)
finish
if uflag # 0 start
if v_type < reals start
v_type = integers
if level # 5 start
rr(clw,r,r12)
else
rx(clw,r,code,unass)
finish
else
v_type = reall
rx(cmp,r,code,unass)
finish
rr(bal,link,code)
v_flag = v_flag & (¬assigned); ! only one level remembered (1 bit !!)
finish
-> CSET
! integer operations
iop(and):
if control&check unass = 0 and w_form = constant start
address(v, r)
if w_disp = x'FFFF' start
if v_form = VinS and (v_type = integers or v_type = short) start
v_disp = v_disp+2 if v_type = integers
LOADL:
v_type = 255
drop(w)
Load(V, R)
return
finish
else if w_disp = 255
drop(w)
if v_form = VinR start
r = gpr if r = any
rr(LBR, r, v_base)
->CSETI
finish
if v_type = integers start
v_disp = v_disp+3
else if v_type = short
v_disp = v_disp+1
finish
v_type = byte
load(v, r)
return
finish
finish
{** Drops through **}
iop(add):
iop(sub):
iop(or):
iop(xor):
pickup(v) {sets R}
address(w, 0) {**Moved down one line**}
rxd(op,r,w)
-> end op
iop(rsh):
if control&check unass = 0 and w_form = constant and w_disp = 16 start
address(v, r)
->LOADL if v_form = VinS and v_type = integers
finish
iop(lsh):
if w_form # constant and control&check capacity # 0 start
load(w,r2); perm(vschk)
finish
pickup(v) {sets R}
if w_form = constant start
warn(6) unless 0 <= w_disp <= 8*reglen-1
else ; ! variable shift
load(w,any) if w_form # V in R
w_disp = 0
finish
rxi(op,v_base,w_base,w_disp)
-> end op
! these operations are changed immediately into binary subtracts
! and should themselves never appear in LOAD
! -x => 0 - x
! ¬x => -1 - x (assumes 2's complement)
iop(not):
iop(neg):
abort(m'LD4')
iop(div):
if w_form = constant start
n = power(w_disp)
if n > 0 start
Pickup(V) {make sure it's in the correct register}
Test Zero(v); r = v_base
claim(r)
d = 1; d = 2 if n > 4; ! 1 or 2 halfwords
skip(d, greater or equal)
rxi(ADD, v_base, 0, ¬((-1)<<n))
rxi(SRA, v_base, 0, n)
->END OP
finish
finish
{** Drops through **}
! *** N.B. ***
! The multiply routine below is not intended for use in array subscript
! calculation as it will include an overflow check. Currently all in-line
! subscript scaling uses shift or 'multiply halfword' instructions.
iop(mul):
iop(rem):
if r = any start
n = 0; n = 1 if op = MUL
if in free reg(v) and actual(v_base)&1 = n c
and activity(twin(v_base)) = 0 start
temp = v_base
temp = twin(temp) if op # MUL
else
temp = even odd pair
finish
else
if actual(r)&1 # 0 and activity(twin(r)) = 0 start
temp = r
else
temp = even odd pair
finish
finish
n = twin(temp)
claim(n); load(v,temp)
release(n); hazard(n); claim(n)
d = op
if op # MUL start
rr(lw,n,temp); claim(temp)
rxi(sra,n,0,31); ! propagate sign
d = div
finish
forget reg( (2+1)<<n ); ! forget N,TEMP (adjacent)
address(w, 0)
! Note complication below because machine op-code only caters
! for the cases INTEGER*INTEGER, INTEGER//INTEGER, rem(INTEGER,INTEGER)
! Short, byte and constant multipliers must therefore be preloaded
! into a register
load(w,any) if w_form = constant or w_form = AV in S or w_type # integers
rxd(d,n,w)
release(n)
if op = MUL start
if control & check capacity # 0 start ; ! overflow check
if n # R0 start
claim(n); rr(LW,r0,n)
finish
perm(mulchk)
finish
else if op = rem
! Interested in remainder not dividend
claim(n); release(temp)
d = temp; temp = n; n = d
finish
v_base = temp; v_disp = 0; v_form = v in r
load(v,r) if temp # r
-> end op
! Special multiply routine used for array subscript scaling where all values
! involved are in range: -32768 <= x <= +32767
iop(mult16):
if r = v_base or v_type = byte start
load(v,any)
else
address(v,0)
load(v,any) if v_form # V in S and v_form # V in R and v_form # constant
finish
v_disp = v_disp+reglen//2 if v_type = integers; ! ** halfword instruction!! **
pickup(w); ! scale factor (data size) - & sets R
rxd(mult16,r,v)
v_base = r; v_disp = 0; v_xform = V in R
-> end op
iop(exp):
load(v,r3); load(w,r2)
release(r3); release(r2)
perm(iexp)
claim(r1); v_base = r1
-> end op
iop(conc):
address(v, r)
if v_type # 0 start
pdisp = basic frame if pdisp = 0
! N.B. Must %not corrupt LHS/RHS in LOAD
temp rhs == rhs
sset(wsp,pdisp,V in S,0); rhs_type = strings; rhs_length = 255
rhs == temp rhs
sstack(v); v_Base = 0
assign(1)
claim(r2)
v_type = strings; v_form = VinS
v_base = r2; v_disp = 0
v_length = 255; ! it's a temporary now
pdisp = pdisp + 256; ! ... so protect it
finish
if w_flag & quick conc # 0 start ; ! S = S.tostring(sym)
z = v; claim(z_base); z_type = byte
load(z, any)
rxi(LW, z_base, z_base, 1); claim(z_base) {length+1}
load(w, any) {character}
v_index = z_base; v_type = byte; v_form = VinS
rxd(ST, w_base, v); release(w_base)
claim(v_base); v_index = 0
rxd(ST, z_base, v)
else
load(v, r2)
load(w,r1); release(r1); release(r2)
n = v_length; n = 255 if n = 0
perm(sconc); cput(n)
v_form = VinS
finish
claim(v_base)
v_type = 0
if r # any and r # 0 start ; ! not from OPERATE
load(v,r); v_type = 0; v_form = v in s
finish
drop(w)
return {Note: nothing to forget}
! floating operations
REALV:
abort(m'LD5') if r = any; ! should be floating register
op = v_oper; v_oper = 0
if op # 0 start
w == v_link
-> rop(op)
rop(not):
rop(lsh):
rop(rsh):
rop(and):
rop(or):
rop(xor):
rop(conc):
rop(mult16):
abort(m'LD6'); ! inappropriate operator
rop(rdiv):
op = div
rop(div):
rop(add):
rop(sub):
rop(mul):
if w_type < reals start
float(w, anyf)
if w_form = V in R # v_form and v_type >= reals c
and (op = add or op = mul) start
z = v; v = w; w = z; ! interchange
finish
finish
Pickup(v); r = v_base
Address(W, 0)
rxd(op,r,w)
-> end op
rop(neg):
abort(m'LD7'); ! should have been modified by OPERATE
finish
float(v, r) if v_type < reals
address(v, r) {AFTER float to prevent optimising constants}
{e.g. I=0; R=0}
if v_form = v in r start
return if r = anyf or v_base = r
hazard(r); rr(lw,r,v_base)
v_base = r; claim(r)
return
finish
if r = anyf start
r = fpr
else
hazard(r) unless r = v_base
finish
abort(m'LD8') unless fr0 <= r <= fr14
-> f(v_form)
rop(rexp):
abort(m'LD9') if w_type >= reals
load(v,fr2); load(w,r1)
release(fr2); release(r1)
perm(fexp); ! floating exponent
claim(fr0); v_base = fr0
END OP:
V_Type = Integers if V_Type <= Byte
forget reg(1<<v_base)
drop(w)
end ; ! load
! >> COP <<
routine cop(integer op, record (stackfm)name lh,rh)
! perform a compile-time operation
constinteger fp tens=70; ! max powers of ten available in floating point
integer l,r
switch s(1:rdiv)
integerfn p10(integer n); ! approximate powers of ten in 'n'
integer value, power
value = 1; power = 0
cycle
result = power if value >= n
value = value*10
power = power+1
abort(m'COP1') if power > 100
repeat
end
l = lh_disp; r = rh_disp
-> s(op)
s(NEG):
s(NOT):
s(CONC): abort(m'COP2')
s(ADD): l = l+r; -> EXIT
s(SUB): l = l-r; -> EXIT
s(OR): l = l!R; -> EXIT
s(AND): l = l&r; -> EXIT
s(XOR): l = l!!R; -> EXIT
s(LSH): l = l<<r; -> EXIT
s(MUL): l = l*r; -> EXIT
s(MULT16): l = l*r; -> EXIT
s(RSH): l = l>>r; -> EXIT
s(EXP): l = l^^r; -> EXIT
s(DIV): warn(1) and r = 1 if r = 0
l = l//r; -> EXIT
s(REM): warn(1) and r = 1 if r = 0
l = l-l//r*r; -> EXIT
s(REXP):
warn(7) and r = 0 if p10(|l|) * r > fp tens
rvalue = l^r; ! **** implicit floating ****
-> REAL
s(RDIV):
warn(1) and r = 1 if r = 0
rvalue = l/r; ! **** implicit floating ****
REAL:
otype = con; l = real constant(0)
lh_base = code
lh_type = reall; lh_form = V in S
EXIT:
lh_disp = l
end
! >> OPERATE <<
routine operate(integer oper)
! perform the operation OPER on the top two elements of the stack.
! (single element for unary operators)
record (stackfm)name lh,rh,with
integer key,lcon,rcon,wcon,lop
constbyteintegerarray transitive(add:rdiv) =
0,0,1,15(2),1(3),15(2),1,15(4)
constbyteintegerarray commutative(add:rdiv) =
1,0,1,0,0,1(3),0(2),1,0(4)
constshortintegerarray nop value(add:rdiv) =
0,0,1(2),0,-1,0(4),1,1(4)
routine pickup(record (stackfm)name v)
if floating(v) then load(v,anyf) else load(v,any)
end
stp = stp-1
lcon = 0; rcon = 0; wcon = 0
lh == stacked(stp)_v
if const(lh) start
lcon = 1
else if lh_type # strings and lh_type # 0
address(lh, 0) if lh_oper = 0
finish
rh == stacked(stp+1)_v
if const(rh) start
rcon = 1
if oper = sub start
oper = add; rh_disp = -rh_disp
finish
finish
if lh_oper # 0 start
lop = lh_oper
with == lh_link
wcon = 1 if const(with)
if wcon&rcon # 0 start ; !! fold
key = transitive(oper)!transitive(lop)
if key = 0 or (key = 1 and oper = lop) start
with_disp = -with_disp and lop = add if lop = sub
cop(oper,rh,with); drop(with)
lh_link == rh
lh_oper = lop
-> STRIP NOP
finish
finish
pickup(lh)
finish
if rcon # 0 start
if lcon#0 or (oper=ADD and lh_type=INTEGERS and
(lh_form=VinR or lh_form=AVinS)) start
lh_form = AV in S if lh_form = VinR
cop(oper,lh,rh); drop(rh)
return
finish
finish
if rh_oper # 0 start
pickup(rh)
else if rcon # 0 and rh_disp = 2
! treat *2 (real & integer) and ^2, ^^2 specially
if oper = mul or oper = exp or oper = rexp start
if oper = mul then oper = add else oper = mul
rh = lh; rcon = 0; claim(rh_base)
finish
finish
if commutative(oper) # 0 and ( lcon # 0 c
or ( lh_form # VinR and rh_form = VinR and
activity(rh_base) >= 0 ) ) start
rh_link == lh
stacked(stp)_v == rh
rh_oper = oper
! keep various items valid for use at STRIP NOP:
with == rh; rh == lh; lh == with
rcon = lcon
else
lh_oper = oper; lh_link == rh
finish
STRIP NOP:
if rcon # 0 start
if rh_disp = nop value(oper) start
lh_oper = 0; drop(rh)
else if oper = MUL and control&check capacity = 0
key = power(rh_disp)
if key > 0 start
lh_oper = lsh; rh_disp = key
finish
finish
finish
end ; ! operate
! >> ASSIGN <<
routine assign(integer assop)
! ASSOP = -1: parameter assignment
! 0: == assignment
! 1: = assignment
! 2: <- assignment
! 3: Unchecked string move - either for speed or P in R
constbyteintegerarray string move(-1:3) = SMOVE, 0, SMOVE, SJAM, SMOVOPT
record (stackfm)name lh,rh,x
record (stackfm) temp
integer n,p,t,op,insert,form,lhdisp
insert = 0
abort(m'ASS1') if stp < 2
rh == stacked(stp)_v
lh == stacked(stp-1)_v
form = lh_form; ! to avoid the ravages of amap, load etc
if diagnose&4 # 0 start
monitor(lh, "ASS LH")
monitor(rh, "ASS RH")
finish
if assop < 0 start ; ! Parameter
if lh_flag & prim bit # 0 start ; ! Special - prim routine
temp = lh; lh = rh; rh = temp
p disp = 0
return
finish
lh_extra = lh_extra - 1
vstack(lh_extra); lh == stacked(stp)_v
form = lh_form; lh disp = lh_disp; ! preserve original values
assop = 0 if lh_form # v in s
if lh_flag & p in r = 0 start ; ! not an in-register parameter
p disp = lh_disp + lh_length
p disp = p disp+1 if lh_type = strings and Form = VinS
lh_disp = lh_disp + wdisp; ! adjust for nested calls
finish
if lh_flag & proc bit # 0 start ; ! Procedure parameter
assop = 1
lh_type = integers; lh_form = v in s
rh_type = integers; rh_form = av in s
if rh_base # 0 and rh_base # gla start ; ! param already
rh_form = v in s
else if rh_base = gla; ! non-local external
rh_disp = rh_disp-5*reglen; !dummy environment
else ; ! local routine
p = (frame+3)&(¬3)
frame = p+8*reglen
t = rh_disp; !proc tag
rh_disp = p; rh_base = local
define reference(t, r ref)
rx(la, link, code, 0)
rx(stm, r8, local, p)
finish
finish
finish
stp = stp-2
if rh_flag & array bits # 0 start ; ! Arrayname
p disp = lh_disp + 2*reglen
hazard(r0)
address(lh,-1); address(rh,-1)
if rh_header = -1 start ; ! Simple case
rx(lw,r0,rh_base,rh_disp); ! @A(0)
else ; ! Array-in-record
rxi(lw,r0,rh_base,rh_disp)
rx(add,r0,gla,rh_header)
rh_disp = rh_header; rh_base = GLA
finish
if lh_type = strings and lh_length = 0 start ; ! %string(*)%arrayname
RXI(ADD,r0,0,rh_length<<24); ! length in top byte
finish
forget reg(1<<r0)
rx(st,r0,lh_base,lh_disp)
claim(rh_base); rx(lw,r0,rh_base,rh_disp+reglen)
claim(lh_base); rx(st,r0,lh_base,lh_disp+reglen)
drop(lh); drop(rh)
return
finish
if lh_type = general start ; ! general %name parameter
abort(m'ASS2') unless assop = 0
if rh_type = general start
amap(lh); address(lh,-1)
amap(rh); address(rh,-1)
hazard(r0)
rx(lw,r0,rh_base,rh_disp)
rx(st,r0,lh_base,lh_disp)
claim(lh_base); claim(rh_base)
rx(lw,r0,rh_base,rh_disp+reglen)
rx(st,r0,lh_base,lh_disp+reglen)
drop(lh); drop(rh)
return
finish
t = rh_type
rh_flag = rh_flag ! assigned; ! pointer proper may never be used !!!!!
n = rh_length; n = n+1 if t = strings; ! logical => physical length
amaps(rh); lrd(rh,any); p = rh_base
rx(st,p,lh_base,lh_disp)
claim(lh_base)
cload((n<<4) + genmap(t),p)
rx(st,p,lh_base,lh_disp+reglen)
drop(lh)
return
finish
if assop = 0 start ; ! ==
amap(lh); ! destination
if lh_length = 0 then amaps(rh) else amap(rh); ! %string(*)%name ?
finish
if Lh_Type = Records start
n = Min Record Size(Lh, Rh)
if rh_Form # Constant start
lrd(rh,r1); ! source area
op = rcopy; ! copy record
else
drop(rh)
op = rzero; ! clear record
finish
lrd(lh,r2); ! destination area
cload(n>>2,R3); ! R3 = no. of WORDS to copy/zero
perm(op)
return
finish
if lh_type = strings and lh_flag & p in r = 0 start
if assop > 0 and rh_format = 1 start ; ! null string as zero byte ?
drop(rh)
lh_type = byte; sstack(lh); drop(lh)
cstack(0); assign(assop)
return
finish
p = lh_length
if assop # 2 and same(lh,rh) start ; ! S = S or S = S.T
if rh_oper = 0 start
drop(lh); drop(rh); ! S = S
else
rh_length = p
release(lh_base); drop(lh)
rh_type = 0{; address(rh,-1)}; lrd(rh,0) {0 = special for CONC}
finish
else if Control&Trusted # 0 and
assop # 2 and
Rh_Oper # 0 and
not Same(Lh, Rh) and
not Same(Lh, Rh_Link)
x == Rh_Link; Rh_Oper = 0
Load(Lh, R2); Lrd(Rh, R1)
Perm(String Move(3))
Lh_Form = VinS; Lh_Type = 0
Lh_Oper = Conc; Lh_Link == X
Lrd(Lh, 0)
else ; ! general case
rh_flag = rh_flag&(¬quick conc); ! quicky not possible after all.
! use fast string move if 'trusted' or capacity exceeded is impossible
! and unassigned is not requested or impossible.
if assop # 2 start ; ! not jam transfer
assop = 3 if control & trusted # 0 c
or ( p >= rh_length c
and (control&check unass = 0 or not checkable(rh)) )
finish
if rh_oper = 0 start ; !simple, so protect lhs first: s(j)=t
lrd(lh, r2); lrd(rh, r1)
else ; !simplify rh first: s = t.u
lrd(rh, r1); lrd(lh, r2)
finish
perm( string move(assop) )
cput(p) if assop # 3; ! max. length of destination for check ?
finish
return
finish
if lh_flag & p in r # 0 start
p = p1; p = p2 if lh disp < reglen; p = p3 if lh_type = strings
load(rh,p) if rh_oper # 0
drop(lh)
lh == stacked(stp)_v
rh_oper = p; ! target register
rh_link == lh_link; lh_link == rh
address(lh, -1)
else
! Test for case where add-to-memory can profitably be used.
! Note that the effective no-op of self-assignment can be detected easily
address(lh, -1)
if control & check bits = 0 and rh_type <= short C
and (rh_oper = 0 or rh_oper = ADD) and same(lh,rh) start
if rh_oper = 0 start ; ! assignment-to-self
release(rh_base); drop(rh)
release(lh_base); drop(lh)
return
finish
! General case: add-to-memory
x == rh; rh == rh_link
release(x_base); drop(x)
load(rh,any)
address(lh,-1); rxd(AM,rh_base,lh)
forget var(lh)
release(rh_base); drop(rh); drop(lh)
return
finish
! test for assignment of small constants to %short and %byte
t = rh_type
if rh_base = 0 and rh_form = constant and rh_Oper = 0 start
if -32768 <= rh_disp <= 32767 start
if rh_disp&(¬255) = 0 start
t = byte
else
t = short
finish
finish
finish
! . . . then suppress capacity check if LH is real or length RH is
! not greater than length LH.
n = assop
assop = 2 if lh_type > byte or lh_type <= t
if Lh_Form = VinR start {special by PSR - is it safe????}
Load(Rh, Lh_Base)
Assop = 2
else
p = cheap reg {preferred register}
float(rh, p) if lh_type >= reals and not floating(rh)
{Float here to prevent optimising the integer value}
address(rh, p) {see where it is}
load(rh, p) unless rh_form = VinR
p = rh_base
address(lh, -1) unless lh_form = VinS
rxd(ST, p, lh)
if control & suppress = 0 start
t = activity(lh_base)
if t < 0 or control&trusted # 0 start
forget var(lh)
if mark assigned # 0 and lh_base = local start ; ! set 'assigned' ?
var(lh_varno)_flag = var(lh_varno)_flag ! assigned
finish
else
forget all
finish
lh_flag = lh_flag ! (rh_flag & assigned)
associate(lh,p) if n # 2; ! not jam transfer
finish
release(p)
finish
drop(lh); drop(rh)
finish
if assop = 1 and control&check capacity # 0 start
if lh_type = short start
claim(p); rr(chvr,p,p)
perm(cap16); ! Test for 16-bit overflow
else
rxi(TEST,p,0,¬255); ! should give zero result
perm(cap8); ! Test for 8-bit overflow
finish
finish
end ; ! assign
! >> LOAD PARAMS <<
routine load params(record (stackfm)name v)
! called at c('E') to load in-register parameters set by ASSIGN above
integer reg
record (stackfm)name next
return if v == null
reg = v_oper
v_oper = 0
next == v_link
load(v,reg)
load params(next)
release(reg)
drop(v)
end ; ! load params
! >> ARRAY REF <<
routine array ref(integer mode)
! Array references are by perm call except in the case of unchecked 1-D arrays
! which either:
! (i) have a data size which is an integral power of 2, not greater than 16384.
! or:
! (ii) have data size <= 32768 and constant bounds -32768 <= x <= 32767.
integer flags, p, type, base, assbit
integer mult, shift; ! ** PRESUMED SET BY 'UNCHECKED REF'
record (stackfm)name temp
predicate special case
shift = power(mult)
true if shift >= 0 or flags & cheap array bit # 0 or Base = 0
false
end ; ! special case
routine unchecked ref
integer header, length, format, extra
header = lhs_header; length = lhs_length; format = lhs_format
extra = 0
if rhs_oper = ADD or (rhs_oper = 0 and
(rhs_form = AV in S or rhs_form = Constant)) start
if rhs_oper = ADD start
if rhs_link_form = constant or rhs_link_form = AV in S start
extra = rhs_link_disp
if rhs_link_form = AV in S start ; ! => VinR + const (see below)
rhs_link_form = VinR
rhs_link_disp = 0
else ; ! simple constant
rhs_oper = 0
drop(rhs_link)
finish
finish
else ; ! AV in S (treat as VinR + constant)
extra = rhs_disp; rhs_disp = 0
rhs_form = VinR if rhs_form = AVinS
finish
extra = extra * mult
finish
if shift >= 0 start
cstack(shift); operate(lsh)
else
cstack(mult); operate(mult16)
finish
lhs_type = integers; ! address calculation
if lhs_header >= 0 start ; ! array-in-record
amap(lhs); ! address of record containing array
sset(gla,lhs_header,v in s,0)
operate(add)
finish
operate(add)
set lhs
! ! ***** F R I G *****
! load(lhs,any) %if lhs_oper = 0; ! Force load: zero subscript folded out
! ! ***** F R I G *****
! vmap(lhs)
! lhs_disp = lhs_disp + extra
! lhs_type = type
! lhs_format = format; lhs_length = length
! lhs_xform = assbit ! V in S
! lhs_form = A in S %if flags & label bit # 0
if Extra # 0 start
Cstack(Extra); Operate(Add)
Set Lhs
finish
Vmap(Lhs)
Vmap(Lhs) if Flags&Label Bit # 0 {namearray}
Lhs_Type = Type
Lhs_Format = Format
Lhs_Length = Length
Lhs_Xform = Lhs_Form!Assbit
end
if mode # 0 start ; ! multi-dimensional: ingest non-terminal subscripts
set both; stp = stp-1
load(rhs,any) if rhs_oper # 0
rhs_link == lhs_link
lhs_link == rhs
lhs_oper = lhs_oper+1
return
finish
set both
abort(m'ARF1') if lhs_oper+1 # lhs_dim; ! No. of subscripts ?
flags = lhs_flag; ! protect from ravages of AMAP
lhs_flag = lhs_flag & (¬(label bit + array bits))
base = lhs_base; type = lhs_type; assbit = lhs_xform & (assigned<<8)
if (control & check array = 0 and lhs_oper = 0) or
Base = 0 start ; ! unchecked 1-D
mult = lhs_length
mult = mult+1 if lhs_type = strings
mult = 4 if Flags&Label Bit # 0; !namearray
if special case start ; ! sets 'shift' as a side-effect
unchecked ref; return
finish
finish
stp = stp-1
if lhs_oper = 0 start ; ! 1-D
load(rhs,r1); drop(rhs)
p = aref1
else if lhs_oper = 1; ! 2-D
load(lhs_link,r1); drop(lhs_link)
load(rhs,r2); drop(rhs)
p = aref2
p = aref4 if control & check array = 0
else ; ! 3-D or more
load(rhs, any) if rhs_oper # 0 {**psr**}
rhs_link == lhs_link; ! tack on last subscript
for p = pdisp,reglen,pdisp+(lhs_oper-1)*reglen cycle
temp == rhs_link
lrd(rhs,any) {**psr**}
rx(ST,rhs_base,wsp,p) {**psr**}
rhs == temp
repeat
load(rhs,r1); ! r1 = first subscript
rhs_form = AV in S; rhs_base = wsp; rhs_disp = pdisp
load(rhs,r2); ! r2 = addr(subscript list)
drop(rhs)
p = aref3
finish
lhs_oper = 0
amap(lhs)
if lhs_header >= 0 start ; ! array-within-record
sset(gla,lhs_header,av in s,0)
load(rhs,r3); drop(rhs); stp = stp-1
else
load(lhs,r3)
finish
release(r1); release(r3)
release(r2) unless p = aref1
perm(p)
claim(r1)
if lhs_header >= 0 start ; ! array-in-record
sset(lhs_base,lhs_disp,lhs_form,lhs_extra); ! address of record
lhs_base = r1; lhs_disp = 0; lhs_form = VinR; ! array component
lhs_type = integers; ! an address to be amapped
operate(add); ! record address + array component
else
lhs_base = r1; lhs_disp = 0
finish
vmap(lhs)
lhs_type = type
lhs_xform = assbit ! V in S
lhs_form = A in S if flags & label bit # 0
end ; ! array ref
! >> TEST ZERO <<
routine test zero(record (stackfm)name v)
record (stackfm)name w
integer cr
cr = any
cr = anyf if floating(v)
if v_oper = AND and sym = '?' and const(v_link) start
! if x & const = 0 . . . . . . .
w == v_link; v_oper = 0
load(v,cr)
rxd(TEST,v_base,w)
drop(w); release(v_base)
else
load(v,cr)
if ca # cc ca or cc reg # v_base start
rr(lw,v_base,v_base)
else
release(v_base)
finish
finish
end ; ! test zero
routine Compare Records(record (stackfm)name L, R, integer N)
Amap(l); Load(l, R1)
Amap(r); Load(r, R2)
Cload(n, R3); Set Both {***beware of CLOAD and Lhs}
Release(R1); Release(R2)
Perm(Rcomp)
end
! >> COMPARE REALS <<
routine compare reals(record (stackfm)name l,r)
load(l,anyf)
address(r,0)
float(r, anyf) unless floating(r)
rxd(cmp,l_base,r)
release(l_base)
end ; ! compare reals
! >> COMPARE STRINGS <<
routine compare strings(record (stackfm)name l,r)
record (stackfm)name temp
if l_base = code and l_disp = null string start
temp == r; r == l; l == temp
invert = invert !! 16
finish
if r_base = code and r_disp = null string start
load(l,any) if l_oper # 0
l_type = byte
test zero(l)
else
load(r,r2) if r_oper # 0
load(l,r1); load(r,r2)
release(r1); release(r2)
perm(scomp)
finish
l_type = strings; l_form = v in s
p disp = 0
end ; ! compare strings
! >> COMPARE <<
routine compare(record (stackfm)name l,r, integer next)
swopped = 0
if l_type = 0 or l_type = strings start
compare strings(l,r); return
finish
if zero(r) start
test zero(l); return
finish
if zero(l) start
test zero(r); invert = invert !! 16
return
finish
if floating(l) or floating(r) start
compare reals(l,r); return
finish
if L_Type = Records start
Compare Records(L, R, Min Record Size(L, R))
return
finish
address(l,0); load(l,any)
address(r,0)
if '=' # next # '#' start
rxd(cmp,l_base,r)
else
rxd(clw,l_base,r)
finish
release(l_base)
end ; ! compare
! >> RESOLVE <<
routine resolve(integer flag)
!S -> A.(B).C
record (stackfm)name s,a,b,c
integer p,q
cstack(0) if flag&1 = 0; ! C missing
pop lhs; c == lhs
pop lhs; b == lhs
cstack(0) if flag&2 = 0; ! A missing
pop lhs; a == lhs
pop lhs; s == lhs
load(s,r3); load(a,r2); load(b,r1); load(c,r4)
p = a_length; !!!!! p = 255 %if p = 0
q = c_length; !!!!! q = 255 %if q = 0
release(r3); drop(s)
release(r2); drop(a)
release(r1); drop(b)
release(r4); drop(c)
perm(sresln); cput( (p<<8) + (q&255) ); ! conditional resolution
if flag&4 = 0 start ; ! unconditional
perm(sresv); ! verify it succeeded
finish
end ; ! resolve
! >> HEADER <<
routine header(record (varfm)name v)
frame = basic frame if frame < basic frame
define tag(v_disp&x'FFF')
rx(stm, p2+2-minparm, wsp, (2-minparm)*reglen)
if potype >= external start
!===== the order of the next two statements is critical =====
external link(ep defn,0,0)
rx(st,link,wsp,(link-p2)*reglen)
if control&unass # 0 and unassigned rtn = 0 start
! Force inclusion of unassigned check routine if not already present
unassigned rtn = 1
select output(direct)
print symbol(p ref); put(asschk); put(0)
select output(object)
finish
finish
rr(lw,local,wsp)
if v_header # 0 start ; ! special string parameter (P in R)
abort(m'HDR1') if v == begin
sset(local,v_header,V in S,0); rhs_type = strings
sset(p3,0,VinR,0)
claim(P3); ! parameter nominally at 0(P3)
assign(3); ! SMOVOPT
if control&trusted # 0 start ; ! suppress check if 'TRUSTED'
v_header = 0
else
Cput(x'0812') {preserve R2 for later}
finish
finish
frame = (frame+align)&(¬align); ! ensure non-parameter locals are aligned
if control & trusted = 0 start ; ! stack overflow check
perm(pentc); ! checked procedure entry *** mustn't corrupt R2 ***
cput(frame); ! parameter size
cput(0); ! padding:- gets overwritten
else
rxi(add,wsp,0,basic frame); ! 2nd. halfword gets overwritten
finish
set frame patch; ! Total size
! Use base reg(5) to hold unassigned pattern ( except at level 5 !! )
if level # 5 and control & check unass # 0 start
rx(lw,base5,code,unass)
activity(base5) = -1; ! lock it
finish
if v_header # 0 start ; ! check P in R string
Cput(x'0821') {*LR_2,1}
perm(smove)
cput(ap_length); ! 'AP' set at '}'
v_header = 0
finish
if control&trace # 0 start ; ! trace option enabled
if v == begin and potype >= external start ; ! main program %begin
external id = trace routine
external link(ep ref,0,ga)
perm(enter trace); cput(0); ! initialise user-supplied routine
finish
trace flag = control&trace
finish
event = 0
end ; ! header
! >> RETURN <<
routine return
return if uncond jump = ca; ! can't get here ?
if Return Label # 0 start
Jump To(Return Label, Jump, Define New)
else
Return Label = x'7001' {something positive and unique}
Define Label(Return Label)
rx(lm,wsp,local,(wsp-p2)*reglen)
rr(jmp,always,link)
finish
uncond jump = ca
Closed = 0 {can get back now}
end ; ! return
routine compile to string(record (stackfm)name v)
{Delay if possible so S = S.tostring(k) can be optimised in LOAD}
if next = '.' and control&(check capacity!check unass) = 0 start
v_flag = v_flag ! quick conc
return
else if const(v)
current string(0) = 1; current string(1) = v_disp&255
claim literal(2,0); otype = con; dump string(0)
v_base = code; v_disp = litmax
else
load(v,any)
frame = (frame+1)&(¬1)
rr(lbr,R0,v_base)
rxi(add,R0,0,1<<8)
rx(sth,R0,local,frame)
v_base = local; v_disp = frame; frame = frame+2
finish
v_type = strings; v_xform = VinS ! (assigned<<8); v_length = 1
end
! >> CALL <<
routine call(record (stackfm)name v)
switch b(1:max prim)
! 1 = rem
! 2 = read symbol
! 3 = float
! 4 = to string
! 5 = substring
! 6 = free space
! 7 = SVC; ! *** MOUSES specific ***
! 8 = addr
! 9 = integer
! 10 = short integer
! 11 = byte integer
! 12 = string
! 13 = record
! 14 = real
! 15 = long real
! 16 = length
! 17 = charno
! 18 = int
! 19 = int pt
! 20 = IOCP; ! *** temporary ***
! 21 = type of; ( type of general name parameter )
! 22 = size of; ( physical length in bytes )
! 23 = frac pt; ! *** replaces IOCP above in the fullness of time ***
constbyteintegerarray new type(9:17) =
integers, short, byte, strings, records, reals, reall, byte, byte
constbytearray New Size(integers:reall) = 4,2,1,8,255,0,4
integer t,l,p
if v_flag & prim bit # 0 start ; ! built-in primitive
l = 0; t = v_header; sym = 0; ! 'sym=0' used as flag elsewhere
if t = 2 start ; ! 'read symbol'
v_flag = v_flag & (¬prim bit)
v_header = 0; ! otherwise looks like "P in R" in "HEADER" q.v.
else
drop(v)
finish
set lhs
-> b(t)
b(1): ! REM
operate(rem); return
b(2): ! READ SYMBOL
call(v)
sset(r1,0,VinR,0)
if lhs_type = records or lhs_type = general start
warn(4)
! *** subsequently, force a call on external routine form of
! read symbol and leave it to generate the error
! *** FRIG ***
cload(5,r0); cload(5,r1); perm(signal)
set lhs; lhs_type = byte; ! to prevent compiler failing
! *** FRIG ***
finish
claim(rhs_base)
compile to string(rhs) if lhs_type = strings
assign(1)
return
b(3): ! FLOAT
float(lhs, anyf); return
b(4): ! TO STRING
compile to string(lhs)
return
b(8): ! ADDR
t = Lhs_Type
amap(lhs)
if T = Strings and Lhs_Form # AVinS and Lhs_Form # AVinRec start
Load(Lhs, Any)
Lhs_Form = VinS
Forget Reg(1<<Lhs_Base)
Rxd(LA, Lhs_Base, Lhs); Claim(Lhs_Base)
Lhs_Form = VinR
finish
return
b(16): ! LENGTH
cstack(0)
b(17): ! CHARNO
set both
amap(lhs)
if control&check array = 0 c
or (const(rhs) and t-16 <= rhs_disp <= lhs_length) start
operate(add); set lhs; !LHS&RHS reversed in operate??
else
load(lhs,r1); load(rhs,r2)
drop(rhs); stp = stp-1
release(r1); release(r2)
!!**** charno(s,j) where S is %String(*)%name won't work: change perm as well
perm(chmap); cput(lhs_length & 255)
claim(r1)
set lhs; lhs_base = r1; lhs_disp = 0; lhs_xform = VinR
finish
-> map it
b(12): ! STRING
!!!!! l = 255
b(9):b(10):b(11): ! INTEGER, SHORT, BYTE
b(13): ! RECORD
b(14):b(15): ! REAL, LONG REAL
map it:
vmap(lhs); lhs_type = new type(t)
lhs_length = new size(Lhs_Type)
return
b(19): ! INT PT
load(lhs,anyf)
p = gpr; hazard(p)
rr(fxr,p,lhs_base); claim(p)
lhs_base = p; lhs_type = integers; lhs_xform = VinR
return
b(18): ! INT
p = intfn; ! perm routine
t = integers; ! resulting type
l = R1; ! result register
-> PERM1823
b(23): ! FRAC PT
p = frac part
t = reall
l = FR2
PERM1823:
load(lhs,fr2); release(fr2)
perm(p)
claim(l); ! result register
set lhs
lhs_base = l; lhs_xform = VinR; lhs_type = t
return
b(5): ! substring(S,from,to)
load(lhs,r3); drop(lhs); stp = stp-1
set both; stp = stp-2
load(lhs,r1); load(rhs,r2); drop(lhs); drop(rhs)
release(r1); release(r2); release(r3)
perm(substr); claim(r1)
sset(r1,0,v in s,0); rhs_type = strings
return
b(21): ! type of(..)
b(22): ! size of(..)
if lhs_type # general start ; ! type explicitly specified
if t = 21 start ; ! type of
p = gen map(lhs_type)
else
p = lhs_length; p = p+1 if lhs_type = strings
finish
release(lhs_base)
lhs_type = integers; lhs_form = constant
lhs_base = 0; lhs_disp = p
else
lhs_disp = lhs_disp + reglen; ! reference property-word
lhs_xform = (assigned<<8) ! V in S; lhs_type = integers
if t = 21 start ; ! type of
cstack(15); operate(and)
else ; ! size of
cstack(4); operate(rsh)
finish
finish
return
b(6): ! free space
perm(freesp); claim(r1)
sset(r1,0,VinR,0)
return
b(7): ! SVC (MOUSES SPECIFIC)
hazard(p) for p = fr0,1,fr14
set both; stp = stp-2
load(lhs,any) unless const(lhs);
address(rhs,-1)
rx(lme,fr0,rhs_base,rhs_disp); claim(rhs_base)
rx(svc,r0,lhs_base,lhs_disp)
rx(stme,fr0,rhs_base,rhs_disp)
drop(lhs); drop(rhs)
forget reg(-1)
return
b(20): ! IOCP *** temporary ***
load(lhs,r4); ! required function
release(r4); drop(lhs); stp = stp-1
perm(iocp)
return
finish
! -- normal routine calls --
wdisp = (wdisp+align)&(¬align); !keep WSP aligned
hazard all if V_Flag&Assigned = 0 {beware - it returns}
if v_base # 0 start ; ! non-local
if v_base # gla start
t = new tag; define reference(t, r ref)
rx(la, link, code, 0)
finish
rx(STM,p2,wsp,wdisp)
rxi(ADD,wsp,0,wdisp) if wdisp # 0
if v_base = gla start ; ! external
rx(lm,gla,gla,v_disp)
rr(bal, link, link)
else ; ! procedure-as-parameter
quick load(r2, VinS, v_base, v_disp); forget reg(1<<R2)
rx(lm,r8,r2,0)
rx(bal, link, link, 4); !skip initial STM
define tag(t)
finish
else ; ! local routine
rxi(ADD,wsp,0,wdisp) if wdisp # 0; ! protect stacked parameters ?
define reference(v_disp&x'FFF',r ref)
rx(bal,link,code,0)
rxi(SUB,wsp,0,wdisp) if wdisp # 0; ! reset protection
Uncond Jump = Ca if V_Flag&Assigned # 0 {it doesn't return}
finish
wdisp = v_header; p disp = v_rt
drop(v) if v_type = 0; ! not function or map
end ; ! call
! >> COMPILER OP <<
!***** RE=ORGANISE 'call', 'prim' and this routine *****
routine compiler op(integer n)
record (stackfm)name p
p == descriptor; stp = stp-1 {DESCRIPTOR increments it!!}
p_flag= prim bit; p_header = n
abort(m'CMOP') unless 0 < n <= max prim
call(p)
end
! >> COMPILE FOR <<
routine compile for
record (stackfm)name cv, iv, inc, fv
integer lab, safe, n, reg, shadow
routine stab(record (stackfm)name v, integer type)
integer t,r
return if const(v)
load(v,any); r = v_base
t = temp
v_base = local; v_disp = t
v_type = type; v_xform = (assigned<<8) ! V in S
rx(ST,r,local,t); release(r)
associate(v,r) if control & suppress = 0
end
routine set(record (stackfm)name v,integer reg)
record (stackfm)name r
sstack(v); r == stacked(stp)_v
lrd(r,reg)
stp = stp-1
end
cv == stacked(stp-3)_v
inc == stacked(stp-2)_v
fv == stacked(stp-1)_v
lab = tag
abort(m'FOR1') if for stp = max cycle
for stp = for stp + 1; for == for stk(for stp)
n = next temp; ! remember current point in temp stack
shadow = -1; shadow = temp if control & check for # 0
stab(fv,integers); stab(inc,integers)
for_temp base = temp base
if n # next temp start ; ! protect shadow, FV, INC ?
temp base = new temp
finish
safe = 0
sstack(inc); operate(sub)
iv == stacked(stp)_v; ! iv = iv - inc
if cv_form # v in s or activity(cv_base) >= 0 start
n = cv_type
amap(cv)
stab(cv, n)
cv_form = a in s
finish
stp = stp-4
if const(fv) and const(iv) and const(inc) start
if inc_disp # 0 start
n = fv_disp-iv_disp
if n !! inc_disp >= 0 and (n//inc_disp)*inc_disp = n start
safe = 1
finish
finish
if safe = 0 start
warn(2); ! constant faulty %for parameters
else
safe = fv_disp - iv_disp; ! null cycle ?
finish
finish
reg = iv_base
if reg <= r2 start
reg = gpr {**cannot return r0,r1,r2}
else
reg = any
finish
load(iv,reg); reg = iv_base
if safe = 0 and control & check for # 0 start
set(iv,r0); claim(reg)
set(fv,r1); set(inc,r2)
perm(fchk1); ! Check %for parameters before entry
finish
if safe = 0 start ; ! non-constant or null cycle
sstack(cv); sstack(iv); assign(1); claim(reg)
for_initial = for lab base + for stp
jump to(for_initial,jump,redefine old)
finish
define label(lab); trace flag = control&trace
sstack(cv)
sstack(iv); sstack(inc); operate(add); ! CV + INC
drop(iv); drop(inc)
set lhs; load(lhs,reg); ! to make sure ASSIGN doesn't use wrong register
assign(1)
rx(st,reg,local,shadow) if shadow >= 0
for_lab = lab; for_reg = reg; for_shadow = shadow
for_cvbase = cv_base; for_cvdisp = cv_disp
for_cvtype = cv_type; for_cvform = cv_xform
for_fvbase = fv_base; for_fvdisp = fv_disp
drop(cv); drop(fv)
end ; ! for
cycle ; ! --- main loop ---
sym = next; read symbol(next)
-> c(sym)
c('l'): language mask = tag; continue ; ! Select language dependent options
c('O'):
abort(m'STK?') if stp # 0
abort(m'USNG') unless using_link == null
abort(m'CLMD') if claimed # 0
abort(m'LIT?') if ca < 0; ! 'select code/literal area' misused
wdisp = 0; p disp = 0
next temp = temp base
current line = tag
if control&trace # 0 start
if next = ':' or next = 'L' start
trace flag = 1
else if trace flag # 0
dump trace
finish
finish
continue
c('$'): define var; continue
c('b'):
pop drop; vub = lhs_disp
pop drop; vlb = lhs_disp
continue
routine adump
switch c(integers:8),g(integers:8); ! 8 =REALS+1 !!!!!
constintegerarray low(integers:8) = 0,-32768, 0, 0(*)
constintegerarray high(integers:8) = 0, 65535, 255, 0(*)
integer j
if high(owntype) # 0 and control & check capacity # 0 start
warn(8) unless low(owntype) <= ownval <= high(owntype)
finish
-> g(owntype) if otype # con
select literal area if strings # owntype < reals
-> c(owntype)
g(integers): gword(ownval); return
c(integers): cword(ownval); -> exit
c(reals):c(8):
g(reals):g(8): j = real constant(1); return
g(byte): gbyte(ownval); return
c(byte): lit byte(ownval); -> exit
g(short): gput(ownval); return
c(short): cput(ownval); -> exit
c(strings):
g(strings): dump string(data size); return
g(records): gput(0) for j = 1,1,data size>>1
return
c(records): abort(m'ADMP')
exit: select code area
end ; ! adump
c('A'):
aparm = tag
if stp # 0 start
decvar_flag = decvar_flag ! assigned; ! explicit initialisation
pop drop
if own type >= reals start
rvalue = lhs_disp if lhs_type < reals
ownval = integer(addr(rvalue))
mantissa = integer(addr(rvalue)+4)
else
ownval = lhs_disp; ! a string
finish
else ; ! initialise to UNASSIGNED pattern
if own type = byte start
own val = x'80'
else if own type = short
own val = x'FFFF8080'
else if owntype # strings
ownval = x'80808080'; mantissa = x'80808080'
else
cslen = x'80'; current string(1) = x'80'
finish
finish
if own form = array or own form = name array start
adump for j = 1,1,aparm
else
if otype = 0 start
decvar_flag = decvar_flag & (¬assigned); ! %const .... %name
decvar_disp = ownval; decvar_base = 0
! %CONSTINTEGERNAME -> INTEGER
! A in S -> V in S, A in REC -> VinREC
if Decvar_Form = VinS start
Decvar_Form = Constant
else
Set Diag(0, Ownval) if Decvar_Form = AinS
decvar_form = decvar_form + (v in s - a in s)
finish
else
decvar_base = gla; decvar_disp = ga
if otype >= external start
decvar_flag = decvar_flag & (¬assigned)
external link(data defn,data size,ga)
else if otype = con ; ! %const
if decvar_type = strings start
claim literal(cslen+1,1)
j = litmax; dump string(0)
else if decvar_type >= reals
j = real constant(0); ! ** N.B. %fn + side-effect **
else
abort(m'AM01')
finish
decvar_base = code; decvar_disp = j
continue
finish
adump
finish
finish
continue
c(''''): get string; continue
c('G'): get string
alias = ""
for j = 1, 1, cslen cycle
alias = alias.tostring(current string(j))
repeat
pop drop
continue
c('N'): cstack(tag<<16!tag); continue
c('D'):
get d
cstack(0) and continue if rvalue = 0
continue if next = 'A'
otype = con; ! anonymous %const
j = real constant(0); ! N.B. ** %fn + side-effect **
sset(code,j,v in s,0); rhs_type = reals
continue
c('n'):
j = tag; set lhs
vstack( var(lhs_format)_extra - j )
set both; stp = stp-1
if rhs_form # 15 start ; ! not record format
if lhs_form = v in s or lhs_form = VinRec start
rhs_disp = lhs_disp + rhs_disp
lhs_xform = lhs_form - v in s + rhs_xform
else
if lhs_form = a in rec start
lhs_form = VinRec; lhs_type = integers
load(lhs,any)
lhs_xform = rhs_xform
else
if lhs_form <= VinR start
lhs_xform = rhs_xform; ! ????
else
lhs_extra = lhs_disp
lhs_xform = rhs_xform+3
finish
finish
finish
lhs_disp = rhs_disp
lhs_type = rhs_type
lhs_rt = rhs_rt
lhs_header = rhs_header
finish
lhs_length = rhs_length; lhs_format = rhs_format
lhs_dim = rhs_dim
drop(rhs)
continue
c('@'):
vstack(tag)
if lhs_flag & proc bit # 0 and next # 'p' c
and lhs_flag&prim bit = 0 start
lhs_rt = p disp
lhs_header = wdisp
w disp = (p disp+align)&(¬align)
p disp = 0
finish
continue
c('E'):
pop lhs; x == lhs
load params(x_link)
call(x)
if x_type # 0 and sym # 0 start ; ! fn/map - SYM=0: see 'CALL'!?!?!?!?
sstack(x); drop(x); set lhs
if lhs_type >= reals then opr = fr0 else opr = r1
lhs_base = opr; lhs_disp = 0
claim(opr)
if lhs_form = VinR c
and (lhs_type = strings or lhs_type = records) start
lhs_base = R1; lhs_form = V in S
if next # 'S' and next # 'p' and next # '?' start
if lhs_type = strings start
n = 256; lhs_length = 255
else
n = var(lhs_format)_length
finish
pdisp = basic frame if pdisp = 0
lhs_base = wsp; lhs_disp = pdisp
sstack(lhs); ! a copy for 'ASSIGN' below
sset(r1,0,V in S,0); ! N.B. sets RHS implicitly
if lhs_type = strings start
rhs_type = strings
else
rhs_type = records; rhs_format = lhs_format
finish
assign(1)
pdisp = pdisp + n; ! protect stacked temporary
lhs_type = 0 if lhs_type = strings
finish
finish
finish
continue
c('M'):
c('V'):
set lhs
opr = r1
if sym = 'V' start
if gvar_type >= reals start
opr = FR0
else if gvar_type = records and zero(lhs); ! recordfn result = 0
lhs_type = records; lhs_form = V in S
lhs_base = wsp; lhs_disp = 0
lhs_format = gvar_format
sstack(lhs); ! duplicate
cstack(0)
assign(1); ! construct zero record
set lhs
finish
else
amaps(lhs)
finish
lrd(lhs,opr); stp = stp-1
if sym = 'V' start
if gvar_type = strings and gvar_length > 0 start
cload(gvar_length,r0)
perm(sfcap); ! string function capacity
else if control & check capacity # 0
if gvar_type = short start
claim(opr); rr(CHVR,opr,opr)
perm(cap16)
else if gvar_type = byte
rxi(TEST,opr,0,¬255)
perm(cap8)
finish
finish
finish
c('R'):
return
continue
c('K'): ! %false
k = 0; -> true false
c('T'): ! %true
k = -1
true false:
cload(k,r1)
return
continue
c('a'): array ref(0); continue
c('i'): array ref(1); continue
c('.'): operate(conc); continue
c('+'): operate(add); continue
c('¬'): k = -1; -> not neg; ! NOT
c('U'): k = 0; ! NEG
not neg:
pop lhs; cstack(k); sstack(lhs); drop(lhs)
c('-'): operate(sub); continue
c('!'): operate(or); continue
c('%'): operate(xor); continue
c('&'): operate(and); continue
c('['): operate(lsh); continue
c(']'): operate(rsh); continue
c('*'): operate(mul); continue
c('/'): operate(div); continue
c('Q'): operate(rdiv); continue
c('X'): operate(exp); continue
c('x'): operate(rexp); continue
c('v'):
set lhs
if floating(lhs) start
load(lhs,anyf); opr = fpr
else
load(lhs,any); opr = gpr
finish
pop lhs
k = lhs_base
load(lhs,opr)
n = new tag
jump to(n,greater or equal,internal tag)
cstack(0); sstack(lhs); drop(lhs)
operate(sub)
set lhs; load(lhs,k)
define tag(n)
continue
c('j'): assign(2); continue
c('S'): assign(1); continue
c('Z'): assign(0); continue
c('p'): assign(-1); continue
c('u'): !++
c('q'): !--
if sym = 'u' then k = add else k = sub
set both
t = lhs_type; j = lhs_length
j = j+1 if t = strings
amap(lhs)
abort(m'AM05') if j = 0
if j = 2 start
cstack(1); j = lsh
else if j = 4
cstack(2); j = lsh
else
cstack(j); j = mul
finish
operate(j)
operate(k)
set lhs
vmap(lhs); lhs_type = t
continue
c('='):
c('k'): opr = 0; -> cond
c('#'):
c('t'): opr = 1; -> cond
c('<'): opr = 2; -> cond
c('>'): opr = 3; -> cond
c('('): opr = 4; -> cond
c(')'): opr = 5; -> cond
cond:
val = tag
jump to(val,opr+invert,redefine old); invert = 0
continue
c('C'):
set both
t = lhs_type
amap(lhs); amap(rhs)
if t = strings and (lhs_form = V in S or lhs_form = VinREC c
or rhs_form = V in S or rhs_form = VinREC) start
operate(xor)
cstack(8); operate(lsh)
cstack(0)
finish
c('?'):
set both
compare(lhs,rhs, next); stp = stp-2
drop(lhs); drop(rhs)
continue
c('"'):
set both; invert = 16
compare(rhs,lhs, next)
stp = stp-1; lhs = rhs; drop(rhs)
claim(lhs_base)
continue
c('r'): resolve(tag); continue
c('_'):
uncond jump = 0; mark assigned = 0
forget all
v == var(tag); pop drop
j = lhs_disp - v_extra; ! this label - lower bound
abort(m'AM10') unless 0 <= j < v_length; ! within vector ?
define tag((v_format + j)!x'8000'); ! N.B. marked as a switch defn.
continue
c('W'):
v == var(tag)
if control & trusted = 0 start ; ! checked switch via PERM
pop lhs
lrd(lhs,r1)
rxi(lw,r2,code,v_disp)
perm(swjump)
else
cstack(1); operate(lsh); ! subscript X 2
pop lhs
k = v_disp+2*2-v_extra*2
if const(lhs) start
k = k+lhs_disp
j = 0
else
load(lhs, Any)
j = Lhs_Base
finish
lhs_base = code; lhs_index = j; lhs_disp = k
lhs_type = short; lhs_form = V in S
rxd(LHL,r1,lhs); claim(r1)
drop(lhs)
rr(ADD,r1,r1); claim(r1)
rr(ADD,r1,code)
rr(JMP,always,r1)
finish
uncond jump = ca
continue
c('B'):
val = tag
if val # for_lab start ; ! not %for .... %repeat
jump to(val,jump,define new)
else
sset(for_cvbase,for_cvdisp,for_cvform,0)
hazard(for_reg)
pop lhs
lhs_type = for_cvtype; lhs_flag = lhs_flag ! assigned
lrd(lhs,for_reg)
if for_shadow >= 0 start
rx(clw,for_reg,local,for_shadow)
perm(fchk2)
finish
if for_initial # 0 start
define label(for_initial); for_initial = 0
finish
if for_fvbase = 0 start ; ! constant
if for_fvdisp = 0 start ; ! zero
claim(for_reg); rr(lw,for_reg,for_reg)
else
rxi(clw,for_reg,for_fvbase,for_fvdisp)
finish
else
rx(clw,for_reg,for_fvbase,for_fvdisp)
finish
jump to(val,not equal,define new)
abort(m'AM15') if next # ':'
read symbol(next); define label(tag)
if for_shadow >= 0 start
if level # 5 start
rx(st,r12,local,for_shadow)
else
rx(lw,for_reg,code,unass)
rx(st,for_reg,local,for_shadow)
forget reg(1<<for_reg)
finish
finish
temp base = for_temp base; ! unprotect shadow, FV, INC
for stp = for stp-1; abort(m'AM20') if for stp < 0
for == for stk(for stp)
finish
continue
c('F'):
val = tag; abort(m'AM25') if val >= for lab base
jump to(val,jump,redefine old)
continue
integerfn user label(integer lab)
record (varfm)name v
if lab > names start
names = lab
v == var(lab)
v = 0
v_form = pgm label
v_disp = new tag
result = -v_disp
finish
result = -var(lab)_disp
end
c('J'):
jump to(user label(tag),jump,define new)
continue
c('L'):
define label(user label(tag))
continue
c(':'):
j = tag; abort(m'AM30') if j >= for lab base
define label(j); continue
c('f'):
compile for; continue
c('w'): mark assigned = 0; machine code; forget reg(-1); continue
c('P'):
pop drop; cput(lhs_disp); forget reg(-1)
continue
c('y'): ! %diagnose n
j = tag
diagnose = 0
if (j>>14)&3 = 2 start ; ! it's for pass 2
diagnose = j&x'3FFF'
diagnose = diagnose ! ((-1)<<15) if diagnose&4 # 0; ! only for speed
else
!***** should pass onto next pass ******
finish
continue
c('z'):
control = tag; continue
c('m'):
j = -1; -> SIGNAL EVENT
c('s'):
if control&trace # 0 start
perm(enter trace); cput(0); ! close off user-supplied routine
finish
j = 0; -> SIGNAL EVENT
c('e'):
j = tag
SIGNAL EVENT:
cstack(0) while stp < 2
pop lhs; lrd(lhs,r2)
pop lhs; lrd(lhs,r1)
cload(j,R0)
perm(signal)
uncond jump = ca
continue
c('o'):
event_events = tag; ! events trapped
read symbol(next); k = tag
j = (frame+align)&(¬align); frame = j+reglen
rx(ST,wsp,local,j); ! for use below
jump to(k,jump,redefine old); event_low = j tag; ! skip event body
forget all
event_label = new tag
define tag(event_label); ! entry point
rx(LW,wsp,local,j)
continue
c('h'): ! compiler op(n)
compiler op(tag)
continue
c('g'): !array formats
c('d'):
! array allocation and dope vector dumping.
Allocate = Sym-'g' {0=format}
! GMODE: =0 -> simple array, # 0 -> array-in-record
! When OPT is specified, in-line code is dumped to
! allocate 1-D constant-bounded arrays
dim = tag; abort(m'AM35') unless 0 < dim <= 7
read symbol(next); n = tag
if gmode = 0 then names = names-n else parms = parms+n
set both
dv = 0; ! used as a flag subsequently
t = -1
! **** The test for OPT must come out once this optimisation is
! implemented correctly ****
if control&checkbits=0 and dim = 1 and lhs_disp <= rhs_disp+1 start
if const(rhs) and const(lhs) start
t = 0; ! candidate for cheap allocation at least
if 0 < data size <= 32767 c
and -32768 <= lhs_disp <= 32767 c
and -32768 <= rhs_disp <= 32767 start
dim = dim ! cheap array bit; ! stuffed in below
finish
finish
finish
if gmode # 0 or t >= 0 start
vlb = lhs_disp; vub = rhs_disp
abort(m'AM40') if vlb > vub+1; ! null array, A(1:0) allowed
set dope vector
stp = stp-2; drop(lhs); drop(rhs)
if gmode = 0 start ; ! constant-bounded 1-D simple array
quick load(R4, AVinS, code, dv); release(R4)
vub = (vub+align) & (¬align); ! to preserve stack-front alignment
finish
else
frame = (frame+align)&(¬align); k = frame; Frame = Frame+Reglen
quick load(R4, AVinS, local, K); release(R4)
stp = 0
for j = 1,1,dim<<1 cycle ; ! N.B. not changed above on this path
stp = stp+1; set lhs
claim(r4); lrd(lhs,any)
rx(st,lhs_base,r4,frame-k); frame = frame+reglen
frame = frame+reglen if j&1 = 0; ! LEAVE HOLE FOR MULTIPLIER
repeat
perm(set dv)
cput(dim); cput(data size)
stp = 0
finish
if dv = 0 start
quick load(R2, AVinS, local, frame)
release(R2)
forget reg(1<<r2)
finish
for j = 1,1,n cycle
if gmode = 0 start
names = names+1; decvar == var(names)
else
parms = parms-1; decvar == var(parms)
finish
decvar_disp = frame
decvar_flag = decvar_flag ! dim; ! may also set 'cheap array bit'
if gmode = 0 start ; ! array not in record
decvar_header = -1; decvar_base = local
decvar_flag = decvar_flag ! anbit; ! force arrayname
if dv = 0 start
if Allocate # 0 start
perm(alloc); ! general method of allocation
else
RX(ST, R4, Local, Frame+Reglen)
RX(ST, R1, Local, Frame+0)
finish
else
! dope-vector was dumped statically above
! Note that the data area for each array is allocated within
! the high address end of the static frame startingat the top
! and working downwards. Pass3 patches in the displacement req'd
! from 'local'
rx(ST,r4,local,frame+reglen); ! @DV
if Allocate # 0 start
rxi(LW,r0,wsp,-vlb); ! @A(0) for Jth array
rxi(ADD,wsp,0,vub); !****temp fix****
else
rxi(LW,R0,0,-vlb)
finish
rx(ST,r0,local,frame+0); ! plug into header
finish
frame = frame + 2*reglen; ! 2-word header
else ; ! array-in-record
gfix(align); !*****psr*****
decvar_header = ga; decvar_base = 0
gword(-vlb); ! relative to start of array
gword crel(dv); ! relative to code base
frame = frame+vub if Allocate # 0
finish
repeat
continue
c('^'): {Set Format}
Set Lhs
Lhs_Type = Records
Lhs_Format = Tag
continue
routine Temp Set
Frame = (Frame+Align)&(¬Align)
Sset(Local, Frame, VinS, 0)
Rhs_Type = Records
Rhs_Format = Max Vars
Frame = Frame+SetLen
end
c('I'): {ESCAPE for Pascal etc.}
sym = next; readsymbol(next)
->Pc(Sym) if 'A' <= Sym <= 'Z'
Abort(M'I ?' - ' '<<8 +Sym<<8)
Pc('A'): {Compare}
Pc('D'): {Compare records}
Pc('K'): {Test set membership}
cload(0, R6); claim(R6)
set both
j = next; readsymbol(next)
if Sym = 'A' start
if j <= 1 then k = '=' else k = '<'
compare(lhs, rhs, k)
else if Sym = 'K'
Load(Lhs, Any); Address(Rhs, -1)
Rhs_Type = Integers
Rxd(Tbt, Lhs_Base, Rhs)
Release(Lhs_Base)
else
k = next; readsymbol(next)
Compare Records(Lhs, Rhs, K)
finish
stp = stp-2; drop(lhs); drop(rhs)
skip(1, j+invert); ! short forward jump
Invert = 0
rxi(ADD, R6, 0, 1); ! reduces to halfword: AIS R6,1
forget reg(1<<r6); CC CA = 0
sset(R6, 0, VinR, 0)
continue
Pc('B'): {Create space}
sym = next; readsymbol(next)
ownform = array; Owntype = byte
Claim Literal(Sym, Align)
Select Literal Area
Decvar_Disp = Ca; Decvar_Base = Code
Select Code Area
continue
Pc('C'):
! 'refer to' FORTRAN parameter in CALL
! If parameter is not a simple variable, then store into a
! temporary to make it so. Either way, convert to descriptor for
! address of simple variable for final parameter
set lhs
unless lhs_form = VinS and lhs_oper = 0 start
t = any; t = anyf if floating(lhs)
load(lhs,t)
hazard(lhs_base); ! force into store temporary
finish
continue
Pc('I'): {Add to set}
Set Both
Lrd(Rhs, Any)
Address(Lhs, -1)
Lhs_Type = Integers
Rxd(Sbt, Rhs_base, Lhs); Claim(Lhs_Base)
Lhs_Type = Records
Stp = Stp-1
continue
Pc('G'): {Make set null}
Pc('H'): {assign set}
k = Tag if Sym = 'H'
if Next # 'S' start
Temp Set
Sstack(Rhs)
Rhs_Type = 0 {show it's a temporary}
else
Readsymbol(Next)
finish
if Sym = 'G' then Cstack(0) else Vstack(k)
Assign(1)
continue
Pc('J'): {Compare sets}
Set Both
Lrd(Lhs, R1)
Lrd(Rhs, R2)
Perm(Set Comp)
if Next <= 1 start {#, =}
cput(0)
else if Next = 3 {<=}
cput(2)
else {Next = 2} {>=}
cput(1)
finish
Stp = Stp-2
Sset(R6, 0, VinR, 0); Claim(R6)
Rxi(Xor, R6, 0, 1) if Next = 0 {#}
Readsymbol(Next)
continue
Pc('L'): {Set operation}
Pop Lhs; X == Lhs
Set Lhs
if Lhs_Type # 0 start {needs to be made temporary}
Pop Lhs
Temp Set
Sstack(Lhs); Drop(Lhs)
Assign(1)
Sset(Local, Frame-SetLen, VinS, 0)
Rhs_Type = 0
Set Lhs
finish
Load(Lhs, R1)
Lrd(X, R2)
Perm(Set Ops(next)); Readsymbol(Next)
continue
Pc('S'): {Swop top of stack elements}
Set Both
Stacked(Stp-1)_V == RHS
Stacked(Stp)_V == LHS
continue
Pc('N'): {check not NIL}
if Control&Check Unass # 0 start
Set Lhs; Test Zero(Lhs); Claim(Lhs_Base)
RR(Bal, Link, Code)
finish
continue
Pc('W'): {Stack WSP}
Cstack(0)
Rhs_Form = VinR
Rhs_Base = Wsp
continue
c('~'): ! alternate record format
sym = next; read symbol(next)
if sym = 'A' start ; ! alt start
decvar == gvar
assemble(-2,labs,names)
Alt Align = Alt Align!Falign
else if sym = 'B'; ! alt end
-> OUT
else
abort(m'AM45') if sym # 'C'; ! faulty intermediate code
max frame = frame if frame > max frame
frame = putative frame base
finish
continue
c('{'):
gmode = -1
assemble(gtype,labs,names)
continue
c('}'):
gmode = 0
-> OUT if amode < 0; ! end of %record %format defn.
-> OUT if gvar_flag & primbit # 0; ! prim routine reference
if names > gstart start
gvar_extra = parms
for j = gstart+1,1,names cycle
ap == var(j)
parms = parms-1; fp == var(parms)
fp = ap; fp_base = wsp
ap_flag = ap_flag & (¬p in r) ! assigned if ap_flag&array bits = 0
repeat
abort(m'AM50') if parms < names
if ap_type = strings and ap_xform & (array bits<<8 + 255) = V in S c
and ap_base # 0 start
gvar_header = ap_disp
fp_flag = fp_flag ! P in R; ! mark as 'in-register' param
finish
finish
gdisp = -1; ! so locals are properly placed
max parm = frame; !start of local space
-> OUT if amode # 0
header(gvar)
continue
c('H'):
decvar == begin; decvar_disp = new tag
otype = 0; spec = 0; potype = 0
if level # 0 start ; ! not outermost %begin
cstack(decvar_disp)
pop lhs; lhs_type = 0; call(lhs)
finish
block name = "BLOCK"; ! Fix up diagnostic name for "%begin" block
assemble(0,labs,names)
continue
repeat ; ! --- end of main loop ---
! To catch the sinners!!
C(*):
abort(m'?? '<<8 ! sym)
routine ALIGN ALTERNATIVES
! Routine to fix up alternate record definitions - implicit parameters in:
! true frame base, putative frame base, max frame, alt first, alt align
integer n, mod, j
record (varfm)name v
Falign = Alt Align
n = putative frame base - true frame base
return if n = 0 or alt align = align; ! no padding or fullword req'd
if alt align = 0 start ; ! byte alignment possible
mod = n
else ; ! at least %short req'd
return if n = 1; ! can't move it back
mod = 2; ! n = 2,3
finish
! now strip out extra unnecessary alignment
for j = parms,1,alt first cycle
v == var(j)
v_disp = v_disp - mod
repeat
max frame = max frame - mod
end ; ! align alternatives
c(';'):
if level # 0 start
if uncond jump # ca or (gvar_type = 0 and control&trusted = 0) start
if control&trace # 0 and level = 1 start
perm(enter trace); cput(0); ! close down user-supplied routine
finish
return
finish
else ; ! level 0: flush literals and gla
gbyte(0) if ga&1 # 0
claim literal(0,0) if lita&1 # 0
finish
Gvar_Flag = Gvar_Flag!Closed
block mark(block end)
Reset Optimisation Data
OUT:
if amode >= 0 start ; ! end of declarative block
activity(local) = 0 unless local = base5; ! release old base register
level = level-1; local = breg(level)
else ; ! end of record format defn
align alternatives
frame = max frame if max frame > frame
if amode = -2 start ; ! end of alternative only
old frame = frame
else
frame = (frame+align)&(¬align); ! **** temporary ****
abort(m'AM55') unless frame>>16 = 0 {only 16 bits worth}
gvar_length <- frame
finish
finish
frame = old frame; extra frame = old extra frame
uncond jump = old jump; ca = proc ca
var diags = old var diags
new temp = temp base
next temp = old next temp
temp base = old temp base
last line = -15
end ; ! assemble
! -------- it all starts here ---------
control = IMPCOM_flags & 255; ! set compilation options
control = control & (¬check bits) if control & trusted # 0; ! force OPT
select input(in)
select output(object)
print symbol(init gla>>1); ! Initial GLA allocation
print symbol(init lit>>1); ! specify literal area available to pass 3
claim literal(init lit,align); ! set literal base and initialise pass 3
var(0) = 0; ! for %RECORD(*) . . . . .
var(max vars)_Length = SetLen {for sets}
parms = max vars
cslen == current string(0)
activity(wsp) = -1; activity(code) = -1; activity(0) = -1
activity(gla) = -1; activity(link) = -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
for stk(j) = 0 for j = 0,1,max cycle
for stp = 0; for == for stk(0)
read symbol(next); ! Prime SYM/NEXT pair
Spec = 0
decvar == begin
assemble(2,0,0)
close files
signal 15,3 if faulty # 0
endofprogram