// header file for the NOVA code-generator
// september 1977

GET "LIBHDR"

// nova operation code mnemonics
MANIFEST
$(1 // move data instructions
    F.LDA=#020000
    F.STA=#040000

    // modify memory instructions
    F.ISZ=#010000
    F.DSZ=#014000

    // jump instructions
    F.JMP=#000000
    F.JSR=#004000

    // arithmetic and logical instructions
    F.COM=#100000
    F.NEG=#100400
    F.MOV=#101000
    F.INC=#101400
    F.ADC=#102000
    F.SUB=#102400
    F.ADD=#103000
    F.AND=#103400

    // shift operations
    F.L=#000100
    F.R=#000200
    F.S=#000300

    // base values for carry
    F.Z=#000020
    F.O=#000040
    F.C=#000060

    // bit indicating no load
    F.NL=#000010

    // skip functions
    F.SKP=#000001
    F.SZC=#000002
    F.SNC=#000003
    F.SZR=#000004
    F.SNR=#000005
    F.SEZ=#000006
    F.SBN=#000007

    // indirect bit
    F.I=#002000

    // base register field
    BASE.R0=#000000
    BASE.R1=#000400
    BASE.R2=#001000
    BASE.R3=#001400

    // convenience instructions
    F.NOP=F.JMP+BASE.R1+1  // no operation. is JMP .+1
$)1

MANIFEST
// OCODE keywords
$(  S.TRUE=4; S.FALSE=5
    S.RV=8; S.FNAP=10
    S.MULT=11; S.DIV=12; S.REM=13
    S.PLUS=14; S.MINUS=15; S.QUERY=16; S.NEG=17; S.ABS=19
    S.EQ=20; S.NE=21; S.LS=22; S.GR=23; S.LE=24; S.GE=25
    S.NOT=30; S.LSHIFT=31; S.RSHIFT=32
    S.LOGAND=33; S.LOGOR=34
    S.EQV=35; S.NEQV=36; S.COND=37
    S.LP=40; S.LG=41; S.LN=42; S.LSTR=43; S.LL=44
    S.LLP=45; S.LLG=46; S.LLL=47
    S.NEEDS=48; S.SECTION=49
    S.RTAP=51; S.GOTO=52; S.FOR=56
    S.RETURN=67; S.FINISH=68
    S.SWITCHON=70
    S.GLOBAL=76
    S.SP=80; S.SG=81; S.SL=82; S.STIND=83
    S.JUMP=85; S.JT=86; S.JF=87
    S.ENDFOR=88
    S.LAB=90; S.STACK=91; S.STORE=92
    S.RSTACK=93; S.ENTRY=94
    S.SAVE=95; S.FNRN=96; S.RTRN=97; S.RES=98
    S.DATALAB=100; S.ITEML=101; S.ITEMN=102
    S.ENDPROC=103
    S.DEBUG=109; S.NONE=111
    S.GETBYTE=120; S.PUTBYTE=121
    S.PLS=152; S.PGR=153; S.PLE=154; S.PGE=155
$)

MANIFEST
// selectors
$(  H1=0; H2=1; H3=2
$)

MANIFEST
// register mnemonics
$(  R0=0; R1=1; R2=2; R3=3
$)

MANIFEST
$(  K.NONE=0
    K.NUMB=1; K.LOC=2; K.GLOB=3; K.LAB=4
    K.ABS=5; K.REG=6; K.R3=7
    K.LVLOC=8; K.LVGLOB=9; K.LVLAB=10
    K.DLAB=11; K.LABI=12
$)

MANIFEST
$(  T.HUNK=1000; T.RELOC=1001; T.END=1002
$)

MANIFEST
// page 0 locations
$(  A.WORK=14
    PAGE0PTRS=40
    A.GSAVE=PAGE0PTRS+0
    A.FINISH=PAGE0PTRS+1+F.I
    A.MULT=PAGE0PTRS+3+F.I
    A.DIVREM=PAGE0PTRS+4+F.I
    A.LSHIFT=PAGE0PTRS+5+F.I
    A.RSHIFT=PAGE0PTRS+6+F.I
    PAGE0CODE=50
    A.ENT=PAGE0CODE+1
    A.ENTC=PAGE0CODE+5
    A.PRFC=PAGE0CODE+7
    A.RTN=PAGE0CODE+18
    A.STKCHK=PAGE0CODE+22
    A.CONSTANTS=PAGE0CODE+35
$)

MANIFEST
$(  SECTIONWORD=#123456
$)

GLOBAL
$(  CGSECTS:101
    RDN:102
    RDL:103
    RDGN:104
    NEXTPARAM:105
    INITSTACK:106
    CGERROR:107
    STACK:108
    STORE:109
    SCAN:110
    CGPENDINGOP:111
    MOVETOANYR:112
    MOVETOANYRS:113
    MOVETOANYBUTR3:114
    MOVETOR:115
    STORET:116
    ANYBUT:117
    FREEREG:118
    ITEMUSING:119
    FORGETALL:120
    FORGETREG:121
    FORGETVAR:122
    FORGETALLVARS:123
    REMEM:124
    SETINFO:125
    MOVEINFO:126
    LOADT:127
    LOSE1:128
    REGUSEDBY:129
    ISFREE:130
    S.P.A.R.E:131
    STOREI:132
    FINDOFFSET:133
    STOREIN:134
    ISOFFSET:135
    CGLAB:136
    CGRV:137
    CGMULT:138
    CGDIV:139
    CGSHIFT:140
    CGSTATICS:141
    CGGLOBAL:142
    CGDATA:143
    CGSTRING:144
    ADD:145
    SETKTOR:146
    GETBLK:147
    RTNBLK:148
    CGENTRY:149
    CGSAVE:150
    CGAPPLY:151
    CGRETURN:152
    CGSWITCH:153
    BSWITCH:154
    LSWITCH:155
    SWAPOP:156
    CGBRANCH:157
    GENSKIP:158
    GENSKIPRK:159
    GENSKIPRR:160
    CODE:161
    GENRAX:162
    GENAX:163
    GENSD:164
    GENJMP:165
    INSERTCOUNT:166
    LABREF:167
    INITDATALISTS:168
    CHECKSPACE:169
    INCRSTVP:170
    CHKREFS:171
    SETLAB:172
    DEALWITHKREF:173
    FILLINRELREF:174
    REFINRANGE:175
    REMOVEREFSTO:176
    ADDRJMP:177
    ADDRLDA:178
    ADDRLOC:179
    ADDRGLOB:180
    REFCONST:181
    PAGE0ADDR:182
    ADDKCMP:183
    GETKCMP:184
    ADDKREF:185
    GETKREF:186
    IS8BITINT:187
    OUTPUTSECTION:188
    DBOUTPUT:189
    WRKN:190
    WORKSPACESIZE:199
    ACODEOUT:200
    BCODEOUT:201
    RCODEOUT:202
    NLABREFS:203
    NAMESECTION:204
    TEMPV:205
    TEMPT:206
    ARG1:207
    ARG2:208
    SSP:209
    MAXSSP:210
    MAXGN:211
    PENDINGOP:212
    OP:213
    KREFV:214
    KREFP:215
    KREFT:216
    KCMPV:217
    KCMPP:218
    KCMPT:219
    DLIST:220
    DLISTE:221
    REFLIST:222
    REFLISTE:223
    FREELIST:224
    STV:225
    STVP:226
    DP:227
    PROGSIZE:228
    REG.K:229
    REG.N:230
    PROCSTK:231
    PROCSTKP:232
    PROCSTKT:233
    LABV:234
    LABT:235
    CASEK:236
    CASEL:237
    SWREG:238
    SKIPLAB:239
    PARAMNUMBER:240
    INCODE:241
    COUNTING:242
    COUNTFLAG:243
    CALLCOUNTING:244
    PROFILE:245
    PROCNAMES:246
    STKCHKING:247
    DEBUGGING:248
    LISTING:249
    BINING:250
    RDOSBINING:251
    MAPPING:252
    OCODE:253
    GOSTREAM:254
    SYSOUT:255
$)

.

SECTION "CG10"

GET "CGHDR"

LET START(PARMS) BE
$(1 SYSOUT := FINDOUTPUT("SYSPRINT")
    SELECTOUTPUT(SYSOUT)
    WRITEF("NOVA CG (SEPT 1977)  PARM = '%S'*N", PARMS)
    DEBUGGING := FALSE
    LISTING, BINING, RDOSBINING := FALSE, FALSE, FALSE
    PROFILE, CALLCOUNTING := FALSE, FALSE
    PROCNAMES := TRUE
    MAPPING, STKCHKING := FALSE, TRUE
    WORKSPACESIZE := 3000

    FOR I = 1 TO GETBYTE(PARMS, 0)
    SWITCHON GETBYTE(PARMS, I) INTO
    $(2
    DEFAULT:    LOOP
    CASE 'M':   MAPPING := TRUE; LOOP
    CASE 'P':   PROFILE := TRUE; LOOP
    CASE 'K':   CALLCOUNTING := TRUE; LOOP
    CASE 'N':   PROCNAMES := FALSE; LOOP
                // Nonames option
    CASE 'B':   BINING := TRUE; LOOP
    CASE 'O':   RDOSBINING := TRUE; LOOP
    CASE 'L':   LISTING := TRUE; LOOP
    CASE 'S':   STKCHKING := FALSE; LOOP
                // Suppress stack checking option
    CASE 'D':   DEBUGGING := TRUE; LOOP
    CASE 'W':   I := I+1
                UNLESS I<=GETBYTE(PARMS, 0) BREAK
                $(  LET CH = GETBYTE(PARMS, I)
                    AND D = 0
                    IF '0'<=CH<='9' DO D := CH-'0'
                    IF 'A'<=CH<='F' DO D := CH+10-'A'
                    WORKSPACESIZE := 3000+500*D
                    LOOP
                $)
    $)2

    ACODEOUT, BCODEOUT, RCODEOUT := 0, 0, 0

    OCODE := FINDINPUT("OCODE")
    IF OCODE=0 DO
    $(  CGERROR("TROUBLE WITH 'OCODE' FILE")
        STOP(1)
    $)

    SELECTINPUT(OCODE)
    PROGSIZE := 0

    WRITEF("WORKSPACE SIZE = %N*N", WORKSPACESIZE)
    PROGSIZE := 0
    APTOVEC(CGSECTS, WORKSPACESIZE)
    WRITEF("PROGRAM SIZE = %N WORDS*N", PROGSIZE)
    IF MAPPING DO MAPSTORE()
$)1

AND CGSECTS(WORKVEC, VECSIZE) BE
$(1 LET P = WORKVEC

    NAMESECTION := P; P := P+4 // section name string

    TEMPV := P; P := P+3*100
    TEMPT := P

    MAXSSP, MAXGN := 0, 0

    INITSTACK(2)

    KREFV, KREFP := P, P; P := P+3*128
    KREFT := P

    KCMPV, KCMPP := P, P; P := P+3*32
    KCMPT := P

    INITDATALISTS()

    REG.K := P; P := P+4
    REG.N := P; P := P+4
    FORGETALL()

    PROCSTKP, PROCSTKT := 0, 2*10
    PROCSTK := P; P := P+PROCSTKT

    DP := WORKVEC+VECSIZE
    FREELIST := 0

    LABV := P; P := P+(DP-P)/10+10
    LABT := P
    PARAMNUMBER := LABT-LABV
    FOR LP = LABV TO LABT-1 DO !LP := -1
    SKIPLAB := 0
    COUNTFLAG := FALSE
    INCODE := FALSE

    STV := P
    STVP := 0

    IF STV>DP DO
    $(  CGERROR("INSUFFICIENT WORKSPACE")
        STOP(1)
    $)

    CODE(0, 0)
    CODE(SECTIONWORD, 0)
    OP := RDN()
    IF OP=0 RETURN
    TEST OP=S.SECTION
    THEN
    $(2 LET N = RDN() // actual string length
        LET V = VEC 15 // holds up to first 7 characters
                       // of section name followed by
                       // today's date in form 'DD/MM/YY'
        FOR I=1 TO N DO
        $(3 LET K = RDN()
            IF I<=7 DO V!I := K
        $)3
        PUTBYTE(NAMESECTION, 0, (N>7 -> 7, N))
        // section name length
        FOR I = 1 TO GETBYTE(NAMESECTION, 0) DO
        PUTBYTE(NAMESECTION, I, (V!I&#177)!TABLE
            '?', '?', '?', '?', '?', '?', '?', '?',
            '?', '?', '?', '?', '?', '?', '?', '?',
            '?', '?', '?', '?', '?', '?', '?', '?',
            '?', '?', '?', '?', '?', '?', '?', '?',
           '*S', '!','*"', '#', '$', '%', '&','*'',
            '(', ')','**', '+', ',', '-', '.', '/',
            '0', '1', '2', '3', '4', '5', '6', '7',
            '8', '9', ':', ';', '<', '=', '>', '?',
            '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
            'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
            'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
            'X', 'Y', 'Z', '[', '\', ']', '|', '_',
            '?', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
            'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
            'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
            'X', 'Y', 'Z', '', '|', '', '~', '?')
        FOR I=N+1 TO 7 DO V!I := #40 // ASCII space
        FOR I = 8 TO 15 DO V!I := #40 // ASCII space
                                      // date info not
                                      // supported yet
        V!0 := 15 // string length
        FOR I=0 TO 14 BY 2 DO CODE((V!I<<8)+V!(I+1), 0)
        OP := RDN()
    $)2 // section name
    ELSE NAMESECTION := 0
    SCAN()
    IF DEBUGGING DO DBOUTPUT()
    STV!0 := STVP
    OUTPUTSECTION()
    PROGSIZE := PROGSIZE+STVP
    IF LISTING DO
    $(  SELECTOUTPUT(ACODEOUT)
        WRITES(".END*N")
        SELECTOUTPUT(SYSOUT)
    $)
$)1 REPEAT

AND RDN() = VALOF
// read in OCODE operator or argument
// argument may be of form Ln
$(1 LET A, SIGN = 0, '+'
    LET CH = 0
    CH := RDCH() REPEATWHILE CH='*S' \/ CH='*N' \/ CH='L'

    IF CH=ENDSTREAMCH RESULTIS 0

    IF CH='-' DO
    $(  SIGN := '-'
        CH := RDCH()
    $)

    WHILE '0'<=CH<='9' DO
    $(  A := 10*A+CH-'0'
        CH := RDCH()
    $)

    IF SIGN='-' DO A := -A
    RESULTIS A
$)1

AND RDL() = RDN()
// read in OCODE label

AND RDGN() = VALOF
// read in global number
$(1 LET G = RDN()
    IF MAXGN<G DO MAXGN := G
    // MAXGN is highest referenced global
    RESULTIS G
$)1

AND NEXTPARAM() = VALOF
// yields next available compiler generated label
$(1 PARAMNUMBER := PARAMNUMBER-1
    RESULTIS PARAMNUMBER
$)1

AND INITSTACK(N) BE
// initialise simulated stack
$(1 ARG2, ARG1 := TEMPV, TEMPV+3
    SSP := N
    PENDINGOP := S.NONE
    H1!ARG2, H2!ARG2, H3!ARG2 := K.LOC, SSP-2, SSP-2
    H1!ARG1, H2!ARG1, H3!ARG1 := K.LOC, SSP-1, SSP-1
    IF MAXSSP<SSP DO MAXSSP := SSP
$)1

AND CGERROR(N,A) BE
$(1 WRITES("*N****ERROR: ")
    WRITEF(N,A)
    NEWLINE()
$)1

AND STACK(N) BE
// move simulated stack pointer (SSP) to N
$(1 IF MAXSSP<N DO MAXSSP := N
    IF N>=SSP+4 DO
    $(  STORE(0, SSP-1)
        INITSTACK(N)
        RETURN
    $)

    WHILE N>SSP DO LOADT(K.LOC, SSP)

    UNTIL N=SSP DO
    $(  IF ARG2=TEMPV DO
        $(  TEST N=SSP-1
            THEN
            $(  SSP := N
                H1!ARG1 := H1!ARG2
                H2!ARG1 := H2!ARG2
                H3!ARG1 := SSP-1
                H1!ARG2 := K.LOC
                H2!ARG2 := SSP-2
                H3!ARG2 := SSP-2
            $)
            ELSE INITSTACK(N)
            RETURN
        $)

        ARG1, ARG2 := ARG1-3, ARG2-3
        SSP := SSP-1
    $)
$)1

AND STORE(A, B) BE
// store simulated stack items involving registers first
// then store remaining items on second scan
$(1 FOR P = TEMPV TO ARG1 BY 3 DO
    $(  LET S=H3!P
        IF S>B BREAK
        IF S>=A & (H1!P=K.REG \/ H1!P=K.R3) DO STORET(P)
    $)
    FOR P = TEMPV TO ARG1 BY 3 DO
    $(  LET S=H3!P
        IF S>B BREAK
        IF S>=A DO STORET(P)
    $)
$)1

.

SECTION "CG20"

GET "CGHDR"

LET SCAN() BE
// switch on all possible OCODE operators
$(1 IF DEBUGGING DO DBOUTPUT()
    SWITCHON OP INTO
    $(2
    ERR:
    DEFAULT:    CGERROR("IN SCAN %N", OP); ENDCASE

    CASE 0:     RETURN // end of file reached

    CASE S.DEBUG:
                DEBUGGING := NOT DEBUGGING; ENDCASE

    CASE S.NEEDS: // ignore NEEDS directive
                FOR I = 1 TO RDN() DO RDN(); ENDCASE

    CASE S.LP:  LOADT(K.LOC, RDN()); ENDCASE
    CASE S.LG:  LOADT(K.GLOB, RDGN()); ENDCASE
    CASE S.LL:  LOADT(K.LAB, RDL()); ENDCASE

    CASE S.LN:  LOADT(K.NUMB, RDN()); ENDCASE

    CASE S.LSTR:CGSTRING(RDN()); ENDCASE

    CASE S.TRUE:LOADT(K.NUMB, -1); ENDCASE
    CASE S.FALSE:
                LOADT(K.NUMB, 0); ENDCASE

    CASE S.LLP: LOADT(K.LVLOC, RDN()); ENDCASE
    CASE S.LLG: LOADT(K.LVGLOB, RDGN()); ENDCASE
    CASE S.LLL: LOADT(K.LVLAB, RDL()); ENDCASE

    CASE S.SP:  STOREIN(K.LOC, RDN()); ENDCASE
    CASE S.SG:  STOREIN(K.GLOB, RDGN()); ENDCASE
    CASE S.SL:  STOREIN(K.LAB, RDL()); ENDCASE
    CASE S.STIND:
                STOREI(); ENDCASE

    CASE S.RV:  CGRV(); ENDCASE

    CASE S.MULT:  CASE S.DIV:  CASE S.REM:
    CASE S.PLUS:  CASE S.MINUS:  CASE S.NEG:  CASE S.ABS:
    CASE S.EQ:  CASE S.NE:  CASE S.LS:
    CASE S.GR:  CASE S.LE:  CASE S.GE:
    CASE S.PLS: CASE S.PGE: CASE S.PGR: CASE S.PLE:
    CASE S.LSHIFT:  CASE S.RSHIFT:
    CASE S.LOGAND:  CASE S.LOGOR:
    CASE S.EQV:  CASE S.NEQV:  CASE S.NOT:
                CGPENDINGOP()
                PENDINGOP := OP
                ENDCASE

    CASE S.JUMP:CGPENDINGOP()
                STORE(0, SSP-1)
                GENJMP(RDL())
                ENDCASE

    CASE S.ENDFOR:
                CGPENDINGOP()
                PENDINGOP := S.LE
                OP := S.JT
                // simulate 'LE JT Ln'
    CASE S.JT:  CASE S.JF:
                CGBRANCH(OP, RDL())
                COUNTFLAG := PROFILE
                ENDCASE

    CASE S.GOTO:CGPENDINGOP()
                STORE(0, SSP-2)
                GENAX(F.JMP, ADDRJMP(ARG1), R0)
                INCODE := FALSE
                FORGETALL()
                STACK(SSP-1)
                ENDCASE

    CASE S.QUERY:
                CGPENDINGOP()
                STACK(SSP+1)
                ENDCASE

    CASE S.LAB: CGPENDINGOP()
                STORE(0, SSP-1)
                FORGETALL()
                CGLAB(RDL(), 20)
                INCODE := TRUE
                COUNTFLAG := PROFILE
                ENDCASE

    CASE S.STACK:
                CGPENDINGOP()
                STACK(RDN())
                ENDCASE

    CASE S.STORE:
                CGPENDINGOP()
                STORE(0, SSP-1)
                ENDCASE

    CASE S.ENTRY:
                CGENTRY()
                ENDCASE

    CASE S.SAVE:CGSAVE(RDN())
                PROCSTK!PROCSTKP := MAXSSP
                IF STKCHKING DO
                $(  CHKREFS(2)
                    GENAX(F.JSR, A.STKCHK, R0)
                    PROCSTK!(PROCSTKP+1) := STVP
                    CODE(0, 0)
                $)
                PROCSTKP := PROCSTKP+2
                IF PROCSTKP>=PROCSTKT GOTO ERR
                MAXSSP := SSP
                ENDCASE

    CASE S.FNAP:  CASE S.RTAP:
                CGAPPLY(OP, RDN())
                ENDCASE

    CASE S.RTRN:  CASE S.FNRN:
                CGRETURN(OP)
                ENDCASE

    CASE S.ENDPROC:
                $(3 LET N = RDN()

                    PROCSTKP := PROCSTKP-2
                    IF STKCHKING DO
                        PROCSTK!(PROCSTKP+1)!STV := MAXSSP
                    MAXSSP := PROCSTK!PROCSTKP
                    CGSTATICS()
                    ENDCASE
                $)3

    CASE S.RES: CGPENDINGOP()
                STORE(0, SSP-2)
                MOVETOR(ARG1, R0)
                GENJMP(RDL())
                FORGETALL()
                STACK(SSP-1)
                ENDCASE

    CASE S.RSTACK:
                INITSTACK(RDN())
                LOADT(K.REG, R0)
                ENDCASE

    CASE S.FINISH:
                CGPENDINGOP()
                GENAX(F.JMP, A.FINISH, R0)
                INCODE := FALSE
                FORGETALL()
                ENDCASE

    CASE S.SWITCHON:
                APTOVEC(CGSWITCH, RDN()*2-1)
                ENDCASE

    CASE S.GLOBAL:
                CGGLOBAL(RDN())
                RETURN

    CASE S.DATALAB:  CASE S.ITEML:
                CGDATA(OP, RDL()); ENDCASE
    CASE S.ITEMN:
                CGDATA(OP, RDN())
    $)2
    OP := RDN()
$)1 REPEAT

.

SECTION "CG30"

GET "CGHDR"

LET CGPENDINGOP() BE
// compile code to deal with any pending operator
// setting PENDINGOP to S.NONE
$(1 LET R, F, RAND1, RAND2 = -1, 0, ARG1, ARG2
    LET SW = FALSE
    SWITCHON PENDINGOP INTO
    $(2
    DEFAULT:    CGERROR("IN CGPENDINGOP %N", OP)
    CASE S.NONE:RETURN

    // comparision is ARG2 <PENDINGOP> ARG1
    CASE S.EQ:  CASE S.NE:  CASE S.LS:
    CASE S.GR:  CASE S.LE:  CASE S.GE:
    CASE S.PLS: CASE S.PGE: CASE S.PGR: CASE S.PLE:
                GENSKIP(PENDINGOP)
                R := ANYBUT(-1)
                GENSD(F.ADC+F.SKP, R, R)
                GENSD(F.SUB, R, R)
                FORGETREG(R)
                PENDINGOP := S.NONE
                LOADT(K.REG, R)
                RETURN

    CASE S.EQV: SW := TRUE
    CASE S.NEQV:MOVETOANYRS()
                $(3 LET RS = H2!ARG1
                    LET S = 0
                    R := H2!ARG2
                    S := 4-RS-R
                    FREEREG(S)
                    MOVETOR(ARG2, R)
                    GENSD(F.MOV, R,  S)  // S := R
                    GENSD(F.AND+F.Z+F.L, RS, S)
                    // if R=0 source is -2(R & RS)!
                    GENSD(F.ADD, RS, R)
                    GENSD(F.SUB, S, R)
                    // RS XOR R = R+RS-2(R&RS)
                    IF SW DO GENSD(F.COM, R, R)
                    FORGETREG(S)
                    ENDCASE
                $)3

    CASE S.PLUS:IF H1!ARG2=K.NUMB DO
                    RAND1, RAND2 := ARG2, ARG1
                IF H1!RAND2=K.NUMB DO
                // special case of <constant>+<constant>
                $(3 LET N = H2!RAND2+H2!RAND1
                    STACK(SSP-1)
                    H1!ARG1, H2!ARG1 := K.NUMB, N
                    PENDINGOP := S.NONE
                    RETURN
                $)3
                R := MOVETOANYR(RAND2)
                IF H1!RAND1=K.NUMB DO
                $(  ADD(H2!RAND1, R, R)
                    LOSE1(R)
                    RETURN
                $)
                MOVETOANYRS()
                R := H2!ARG2
                GENSD(F.ADD, H2!ARG1, R)
                ENDCASE

    CASE S.MINUS:
                IF H1!ARG1=K.NUMB & H1!ARG2=K.NUMB DO
                // special case of <constant>-<constant>
                $(3 LET N = H2!ARG2-H2!ARG1
                    STACK(SSP-1)
                    H1!ARG1, H2!ARG1 := K.NUMB, N
                    PENDINGOP := S.NONE
                    RETURN
                $)3
                R := MOVETOANYR(ARG2)
                IF H1!ARG1=K.NUMB DO
                $(  ADD(-H2!ARG1, R, R)
                    LOSE1(R)
                    RETURN
                $)
                MOVETOANYRS()
                R := H2!ARG2
                GENSD(F.SUB, H2!ARG1, R)
                ENDCASE

    CASE S.MULT:R := CGMULT(); ENDCASE

    CASE S.REM: SW := TRUE
    CASE S.DIV: R := CGDIV(SW)
                ENDCASE

    CASE S.LOGOR:
                SW := TRUE
    CASE S.LOGAND:
                MOVETOANYRS()
                $(3 LET RS = H2!ARG1
                    R := H2!ARG2

                    IF SW DO
                    $(  GENSD(F.COM, RS, RS)
                        TEST REG.K!RS=K.NUMB
                        THEN REG.N!RS := NOT REG.N!RS
                        ELSE FORGETREG(RS)
                    $)
                    // A!B = A&~B + B
                    GENSD(F.AND, RS, R)
                    IF SW DO GENSD(F.ADC, RS, R)
                $)3
                ENDCASE

    CASE S.NEG: SW := TRUE
    CASE S.NOT: R := MOVETOANYR(ARG1)
                GENSD((SW -> F.NEG, F.COM), R, R)
                TEST REG.K!R=K.NUMB
                THEN REG.N!R := SW -> -REG.N!R,
                    NOT REG.N!R
                ELSE FORGETREG(R)
                PENDINGOP := S.NONE
                RETURN

    CASE S.ABS: R := MOVETOANYR(ARG1)
                CHKREFS(2)
                GENSD(F.NL+F.MOV+F.L+F.SZC, R, R)
                GENSD(F.NEG, R, R)
                TEST REG.K!R=K.NUMB
                THEN REG.N!R := REG.N!R<0 ->
                    -REG.N!R, REG.N!R
                ELSE FORGETREG(R)
                PENDINGOP := S.NONE
                RETURN

    CASE S.LSHIFT:
                SW := TRUE
    CASE S.RSHIFT:
                R := CGSHIFT(SW)
    $)2
    FORGETREG(R)
    LOSE1(R)
$)1

.

SECTION "CG40"

GET "CGHDR"

LET MOVETOANYR(A) = VALOF
// move simulated stack item A to some suitable register
$(1 LET K, N = H1!A, H2!A
    IF K=K.REG RESULTIS N
    FOR I = R0 TO R3 DO
        IF K=REG.K!I & N=REG.N!I & ISFREE(I) DO
        $(  H1!A, H2!A := K.REG, I
            RESULTIS I
        $)
    IF K=K.R3 UNLESS ISFREE(R0) \/ ISFREE(R1) DO
    $(  MOVETOR(A, R3)
        RESULTIS R3
    $)
    RESULTIS MOVETOR(A, ANYBUT(-1))
$)1

AND MOVETOANYRS() BE
// moves ARG1 and ARG2 to any registers
$(1 LET A1, A2 = ARG1, ARG2
    IF H1!A1=K.REG & H2!A1=R3 DO A1, A2 := ARG2, ARG1
    MOVETOANYBUTR3(A1)
    MOVETOANYR(A2)
$)1

AND MOVETOANYBUTR3(A) = VALOF
$(1 LET K, N = H1!A, H2!A
    LET R0FREE, R1FREE = TRUE, TRUE
    LET ITEMUSINGR0R1 = -1
    LET S = -1 // will hold the chosen register
    IF K=K.REG & N\=R3 RESULTIS N // no work to do
    FOR T = TEMPV TO ARG1 BY 3 IF H1!T=K.REG DO
    $(2 LET R = H2!T
        UNLESS R0<=R<=R1 LOOP
        IF ITEMUSINGR0R1=-1 DO ITEMUSINGR0R1 := T
        TEST R=R0
        THEN R0FREE := FALSE
        ELSE R1FREE := FALSE
    $)2
    // attempt to choose a suitable register
    IF R1FREE & REG.K!R1=K.NONE DO S := R1
    IF R0FREE & REG.K!R0=K.NONE DO S := R0
    IF N=REG.N!R1 & K=REG.K!R1 & R1FREE DO S := R1
    IF N=REG.N!R0 & K=REG.K!R0 & R0FREE DO S := R0
    IF S=-1 DO
    $(  IF R1FREE DO S := R1
        IF R0FREE DO S := R0
    $)
    UNLESS S=-1 RESULTIS MOVETOR(A, S)
    STORET(ITEMUSINGR0R1)
$)1 REPEAT

AND MOVETOR(A, R) = VALOF
// move simulated stack item A to register R
$(1 LET K, N, S = 0, 0, -1
    UNLESS REGUSEDBY(A)=R DO FREEREG(R)
    K, N := H1!A, H2!A
    IF K=K.REG
        TEST N=R
        THEN RESULTIS R
        ELSE
        $(  GENSD(F.MOV, N, R)
            MOVEINFO(N, R)
            GOTO RET
        $)

    FOR I = R3 TO R0 BY -1 DO
        IF K=REG.K!I & N=REG.N!I DO S := I

    IF K=REG.K!R & N=REG.N!R DO S := R // prefer R

    IF S>=0 DO  // found in slave
    $(  UNLESS S=R DO
        $(  GENSD(F.MOV, S, R)
            MOVEINFO(S, R)
        $)
        GOTO RET
    $)
    IF K=K.NUMB DO
    $(  SETKTOR(N, R)
        GOTO RET
    $)
    IF K=K.LVLOC DO
    $(  ADD(N-128, R2, R)
        GOTO RET
    $)
    IF K=K.LVGLOB DO
    $(2 LET D = 0
        FOR I = R0 TO R3 DO
            IF K.LVGLOB=REG.K!I DO S, D := I, REG.N!I
        IF S=-1 DO
        $(  GENRAX(F.LDA, R, A.GSAVE, R0)
            SETINFO(R, K.LVGLOB, 128)
            S, D := R, 128
        $)
        ADD(H2!A-D, S, R)
        GOTO RET
    $)2

    GENRAX(F.LDA, R, ADDRLDA(K, N), R0)
    SETINFO(R, K, N)

RET:H1!A, H2!A := K.REG, R
    RESULTIS R
$)1

AND STORET(A) BE
// stores simulated stack item A in true stack location
$(1 LET S = H3!A  // stack addr of item to be stored
    IF H1!A=K.LOC & H2!A=S RETURN
    // item already there

    IF S<=255 DO
    // item is addressable using R2
    $(2 LET R = MOVETOANYR(A)
        GENRAX(F.STA, R, (S-128) & 255, R2)
        FORGETVAR(K.LOC, S)
        REMEM(R, K.LOC, S)
        H1!A, H2!A := K.LOC, S
        RETURN
    $)2

    // it is necessary to use R3
    $(3 LET T = ITEMUSING(R3)
        LET SLK, SLN = REG.K!R3, REG.N!R3
        IF T=-1 DO  // this means that R3 is free
        $(4 LET R = MOVETOANYBUTR3(A)
            // will not disturb most recent of R0, R1
            GENRAX(F.STA, R, ADDRLOC(S), R0)
            // does not change either R0 or R1
            FORGETVAR(K.LOC, S)
            REMEM(R, K.LOC, S)
            H1!A, H2!A := K.LOC, S
            RETURN
        $)4

        // T is using R3 so move it to WORK
        UNLESS H1!T=K.REG DO // T is of type K.R3
        $(  MOVETOR(T, R3) // to force H1!T = K.REG
            SLK, SLN := K.NONE, 0 // note that R3 no
                                  // longer contains
                                  // useful information
        $)
        GENRAX(F.STA, R3, A.WORK, R0)
        H1!T, H2!T := K.ABS, A.WORK

        // at this point R3 is free
        MOVETOANYBUTR3(A)
        // may call FREEREG(R0 or R1) but ok
        STORET(A)  // compiles an STA using R3
        IF H1!T=K.ABS DO
        $(  MOVETOR(T, R3)
            FORGETREG(R3)
            UNLESS (SLK=K.LOC & SLN=S) \/ SLK=K.NONE DO
                SETINFO(R3, SLK, SLN)
        $)
    $)3
$)1

AND ANYBUT(R) = VALOF
// return any free register except R
$(1 FOR I = R0 TO R1 DO
        IF R\=I & REG.K!I=K.NONE & ISFREE(I) RESULTIS I

    FOR I = R0 TO R1 IF R\=I & ISFREE(I) RESULTIS I

    IF R\=R3 & REG.K!R3=K.NONE & ISFREE(R3) RESULTIS R3
    FOR T = TEMPV TO ARG1 BY 3 DO
    $(2 LET S = REGUSEDBY(T)
        IF S=-1 \/ S=R LOOP
        TEST R=R3 & H3!T>255 & ISFREE(R3)
        THEN
        $(3 LET SLK, SLN = REG.K!R3, REG.N!R3
            GENRAX(F.STA, R3, A.WORK, R0)
            STORET(T) // will change R3 but not WORK
            GENRAX(F.LDA, R3, A.WORK, R0)
            FORGETREG(R3)
            UNLESS SLK=K.LOC & SLN=H3!T DO
                SETINFO(R3, SLK, SLN)
        $)3
        ELSE STORET(T) // will not corrupt R
        // this will free S and so
        RESULTIS S
    $)2
$)1

AND FREEREG(R) BE
$(1 LET T = ITEMUSING(R)
    IF T=-1 RETURN
    IF H1!T=K.R3 DO MOVETOANYBUTR3(T)
    STORET(T)
$)1

AND ITEMUSING(R) = VALOF
$(1 FOR P = TEMPV TO ARG1 BY 3
        IF (R=H2!P & H1!P=K.REG) \/
            (R=R3 & H1!P=K.R3) RESULTIS P
    RESULTIS -1
$)1

AND FORGETALL() BE
$(1 FOR R = R0 TO R3 DO REG.K!R, REG.N!R := K.NONE, 0
    REG.K!2, REG.N!2 := K.LVLOC, 128
$)1

AND FORGETREG(R) BE REG.K!R, REG.N!R := K.NONE, 0

AND FORGETVAR(K, N) BE  // K is K.LOC, K.GLOB or K.LAB
    FOR R = R0 TO R3
        IF REG.N!R=N & REG.K!R=K DO FORGETREG(R)

AND FORGETALLVARS() BE
// called after BCPL indirect assignment
    FOR R = R0 TO R3 DO
    $(1 LET K = REG.K!R
        IF K=K.LOC \/ K=K.GLOB \/ K=K.LAB DO
            FORGETREG(R)
    $)1

AND REMEM(R, K, N) BE IF REG.K!R=K.NONE DO
    REG.K!R, REG.N!R := K, N

AND SETINFO(R, K, N) BE
    TEST K=K.REG \/ K=K.R3 \/ K=K.ABS
    THEN FORGETREG(R)
    ELSE REG.K!R, REG.N!R := K, N

AND MOVEINFO(S, D) BE REG.K!D, REG.N!D := REG.K!S, REG.N!S

.

SECTION "CG50"

GET "CGHDR"

LET LOADT(K, N) BE
// load item (K, N) onto the simulated stack
$(1 CGPENDINGOP()
    ARG2 := ARG1
    ARG1 := ARG1+3
    IF ARG1=TEMPT DO
    $(  CGERROR("IN LOADT")
        STOP(1)
    $)
    H1!ARG1, H2!ARG1, H3!ARG1 := K, N, SSP
    SSP := SSP+1
    IF MAXSSP<SSP DO MAXSSP := SSP
$)1

AND LOSE1(R) BE
// replace top two items of simulated stack
// by contents of register R
$(1 PENDINGOP := S.NONE
    STACK(SSP-1)
    H1!ARG1, H2!ARG1 := K.REG, R
$)1

AND REGUSEDBY(T) = H1!T=K.REG -> H2!T,
                   H1!T=K.R3 -> R3, -1

AND ISFREE(R) = VALOF
$(1 IF R=R2 RESULTIS FALSE
    FOR T = TEMPV TO ARG1 BY 3
        IF REGUSEDBY(T)=R RESULTIS FALSE
    RESULTIS TRUE
$)1

AND STOREI() BE
// compile indirect assignment
$(1 LET K, R = FINDOFFSET(), 0
    STORE(0, SSP-3)
    // at this point
    // EITHER R0 or R1 is free
    // OR ARG2 is in R0 or R1
    R := MOVETOANYBUTR3(ARG2)
    MOVETOR(ARG1, R3) // this will not disturb R
    GENRAX(F.STA, R, K, R3)
    FORGETALLVARS()
    // an indirect assignment may alter any word of store
    // - in particular the word corresponding to item
    // ARG1. reluctantly, therefore, we must not
    // remember that R3 corresponds to the value of
    // item ARG1
    STACK(SSP-2)
$)1

AND FINDOFFSET() = VALOF  // used by STOREI and CGRV
$(1 IF PENDINGOP=S.MINUS & H1!ARG1=K.NUMB DO
        PENDINGOP, H2!ARG1 := S.PLUS, -H2!ARG1
    IF PENDINGOP=S.PLUS DO
    $(2 LET K, N, A = K.NONE, 0, 0
        IF ISOFFSET(ARG2) DO
            K, N, A := H1!ARG1, H2!ARG1, H2!ARG2
        IF ISOFFSET(ARG1) DO
            K, N, A := H1!ARG2, H2!ARG2, H2!ARG1
        UNLESS K=K.NONE DO
        $(  STACK(SSP-1)
            H1!ARG1, H2!ARG1 := K, N
            PENDINGOP := S.NONE
            RESULTIS A
        $)
    $)2
    CGPENDINGOP()
    RESULTIS 0
$)1

AND STOREIN(K, N) BE
// compile assignment to a simple variable (K, N)
// the only operations that can be optimised
// are S+:=1, S-:=1
$(1 LET B = (H1!ARG1=K & H2!ARG1=N) -> 1,
        (H1!ARG2=K & H2!ARG2=N) -> 2, 0
    LET R, ADDR = 0, 0
    LET RAND1, RAND2 = ARG1, ARG2
    IF B=1 DO RAND1, RAND2 := ARG2, ARG1

    UNLESS B=0 SWITCHON PENDINGOP INTO
    $(2
    CASE S.NONE:IF B=1 DO
                $(  STACK(SSP-1)
                    RETURN
                $)  // case X := X
                ENDCASE

    CASE S.MINUS:
                IF B=1 ENDCASE  // reverse subtract!
                UNLESS H1!RAND1=K.NUMB ENDCASE
                // case X := X-k
                PENDINGOP := S.PLUS
                H2!RAND1 := -H2!RAND1

    CASE S.PLUS:IF H1!RAND1=K.NUMB THEN
                $(3 LET M = H2!RAND1
                    UNLESS -1<=M<=1 ENDCASE
                    UNLESS M=0 DO
                    $(  GENAX((M>0 -> F.ISZ, F.DSZ),
                            ADDRLDA(K, N), R0)
                        CODE(F.NOP, 0)
                        FORGETVAR(K, N)
                    $)
                    PENDINGOP := S.NONE
                    STACK(SSP-2)
                    RETURN
                $)3
    $)2

    CGPENDINGOP()
    SWITCHON K INTO // K=K.LAB, K.GLOB or K.LOC
    $(4
    CASE K.LAB: R := MOVETOANYR(ARG1)
                ADDR := REFCONST(K.LAB, N)
                ENDCASE
    CASE K.GLOB:R := MOVETOANYBUTR3(ARG1)
                ADDR := ADDRGLOB(N)
                ENDCASE
    CASE K.LOC: TEST N<=255
                THEN R := MOVETOANYR(ARG1)
                ELSE R := MOVETOANYBUTR3(ARG1)
                ADDR := ADDRLOC(N)
    $)4
    GENRAX(F.STA, R, ADDR, R0)
    FORGETVAR(K, N)
    REMEM(R, K, N)
    STACK(SSP-1)
$)1

AND ISOFFSET(A) = H1!A=K.NUMB & (-128 <= H2!A <= 127) ->
    TRUE, FALSE

AND CGLAB(N, LEN) BE
// used for LAB and DATALAB
// optimises case where there are outstanding
// references to Ln
$(1 UNLESS INCODE DO
    $(2 LET P = KREFV
        WHILE P\=KREFP & N=H3!P &
            (H2!P=K.LAB \/ H2!P=K.LABI) &
            STVP-H1!P<126 DO P := P+3
        // P does not point to a ref that will
        // be resolved by SETLAB(N)
        IF REFINRANGE(P, LEN) BREAK
        DEALWITHKREF(P)
        // this won't set SKIPLAB
    $)2 REPEAT
    SETLAB(N)
$)1

AND CGRV() BE
// make top stack item addressable by R3
$(1 LET N = FINDOFFSET()
    MOVETOR(ARG1, R3)
    H1!ARG1, H2!ARG1 := K.R3, N
$)1

AND CGMULT() = VALOF
$(1 LET R = MOVETOANYBUTR3(ARG1)
    FREEREG(R3)
    MOVETOR(ARG2, R1-R)
    GENAX(F.JSR, A.MULT, R0)
    FORGETALL()
    RESULTIS R1
$)1

AND CGDIV(ISREM) = VALOF
$(1 MOVETOR(ARG1, R0)
    MOVETOR(ARG2, R1)
    FREEREG(R3)
    MOVETOR(ARG2, R1) // incase FREEREG dumped it
    GENAX(F.JSR, A.DIVREM, R0)
    FORGETALL()
    RESULTIS ISREM -> R0, R1
$)1

AND CGSHIFT(ISLEFT) = VALOF
$(1 IF H1!ARG1=K.NUMB & H2!ARG1=1 DO
    $(2 LET R = MOVETOANYR(ARG2)
        GENSD(F.MOV+F.Z+(ISLEFT -> F.L, F.R), R, R)
        FORGETREG(R)
        RESULTIS R
    $)2
    MOVETOR(ARG1, R1)
    MOVETOR(ARG2, R0)
    FREEREG(R3)
    MOVETOR(ARG2, R0) // incase FREEREG dumped it
    GENAX(F.JSR, (ISLEFT -> A.LSHIFT, A.RSHIFT), R0)
    FORGETALL()
    RESULTIS R0
$)1

.

SECTION "CG60"

GET "CGHDR"

LET CGSTATICS() BE
$(1 LET D = DLIST
    UNTIL D=0 DO
    $(2 LET LEN = 0
        LET L = H1!D
        UNLESS H2!D=S.DATALAB DO CGERROR("IN CGSTATICS")
        UNTIL L=0 \/ H2!L=S.DATALAB DO
        $(  LEN := LEN+1
            L := H1!L
        $)
        CGLAB(H3!D, LEN)
        D := H1!D
        UNTIL D=0 \/ H2!D=S.DATALAB DO
        $(3 LET NEXT, K, N = H1!D, H2!D, H3!D
            TEST K=S.ITEMN
            THEN CODE(N, 0)
            ELSE CODE(0, N)
            RTNBLK(D)
            D := NEXT
        $)3
    $)2
    DLIST := 0
    DLISTE := @DLIST
$)1

AND CGGLOBAL(N) BE
$(1 CGSTATICS()
    CHKREFS(128)
    // force resolving of ALL outstanding references
    CODE(0, 0)
    FOR I = 1 TO N DO
    $(  CODE(RDGN(), 0)
        CODE(LABV!RDL(), 0)
    $)
    CODE(MAXGN, 0)
$)1

AND CGDATA(K, N) BE
$(1 LET P = GETBLK()
    H2!P, H3!P := K, N
    !DLISTE := P
    DLISTE := P
$)1

AND CGSTRING(N) BE
$(1 LET L, W = NEXTPARAM(), N<<8
    LOADT(K.LVLAB, L)
    CGDATA(S.DATALAB, L)
    $(  UNLESS N=0 DO W := W \/ RDN()
        CGDATA(S.ITEMN, W)
        IF N<=1 RETURN
        N, W := N-2, RDN()<<8
    $) REPEAT
$)1

AND ADD(N, RS, RD) BE
$(1 LET SLK, SLN = REG.K!RS, REG.N!RS
    TEST REG.K!RD=K.NUMB & REG.N!RD=N
    THEN GENSD(F.ADD, RS, RD)
    ELSE TEST N=0
    THEN
    $(  UNLESS RS=RD DO
        $(  GENSD(F.MOV, RS, RD)
            MOVEINFO(RS, RD)
        $)
    $)
    ELSE TEST N=1 \/ N=2 THEN
    $(  GENSD(F.INC, RS, RD)
        IF N=2 DO GENSD(F.INC, RD, RD)
    $)
    ELSE TEST N=-1 DO
    $(  GENSD(F.NEG, RS, RD)
        GENSD(F.COM, RD, RD)
    $)
    ELSE
    $(  TEST RS=RD
        THEN
        $(  RS := ANYBUT(RD)
            SETKTOR(N, RS)
        $)
        ELSE SETKTOR(N, RD)
        GENSD(F.ADD, RS, RD)
    $)
    FORGETREG(RD)
    IF SLK=K.NUMB \/ SLK=K.LVLOC \/ SLK=K.LVGLOB DO
        REMEM(RD, SLK, SLN+N)
$)1

AND SETKTOR(K, R) = VALOF
// load register R with constant K
$(1 IF REG.N!R=K & REG.K!R=K.NUMB RESULTIS R
    SWITCHON K INTO
    $(2
    DEFAULT:    GENRAX(F.LDA, R, REFCONST(K.NUMB, K), R0)
                ENDCASE
    CASE -2:    GENSD(F.ADC+F.Z+F.L, R, R); ENDCASE
    CASE -1:    GENSD(F.ADC, R, R); ENDCASE
    CASE 0:     GENSD(F.SUB, R, R); ENDCASE
    CASE 1:     GENSD(F.SUB+F.Z+F.L, R, R); ENDCASE
    CASE #077777:
                GENSD(F.ADC+F.Z+F.R, R, R); ENDCASE
    CASE #100000:
                GENSD(F.SUB+F.Z+F.R, R, R); ENDCASE
    $)2
    SETINFO(R, K.NUMB, K)
    RESULTIS R
$)1

AND GETBLK() = VALOF
$(1 LET P = FREELIST
    TEST P=0
    THEN
    $(  DP := DP-3
        CHECKSPACE()
        P := DP
    $)
    ELSE FREELIST := H1!FREELIST
    !P := 0
    RESULTIS P
$)1

AND RTNBLK(P) BE
$(1 !P := FREELIST
    FREELIST := P
$)1

.

SECTION "CG70"

GET "CGHDR"

LET CGENTRY() BE
$(1 LET N = RDN()
    LET L = RDL()
    LET V = VEC 7
    CHKREFS(20)
    V!0 := 7  // string length
    FOR I = 1 TO N DO
    $(2 LET K=RDN()
        IF I <= 7 DO V!I := K
    $)2
    FOR I = N+1 TO 7 DO V!I := #40  // ASCII space
    IF PROCNAMES FOR I = 0 TO 6 BY 2 DO
        CODE((V!I<<8)+V!(I+1), 0)

    SETLAB(L)
    INCODE := TRUE

// entry sequence

    GENRAX(F.LDA, R1, 0, R3)
    GENSD(F.ADD, R1, R2)
    GENRAX(F.STA, R3, ADDRLOC(0), R0)
    GENAX(F.JSR, (CALLCOUNTING -> A.ENTC, A.ENT), R0)
    IF CALLCOUNTING DO
    $(  CODE(0, 0)
        CODE(0, 0)
    $)
$)1

AND CGSAVE(N) BE
$(1 FORGETALL()
    IF N>2 DO SETINFO(R0, K.LOC, 2)
    INITSTACK(N)
$)1

AND CGAPPLY(OP, K) BE
$(1 CGPENDINGOP()
    $(2 LET BASE = H3!TEMPV
        STORE(K+3, SSP-2)  // store args 2,3,...

        // now deal with non-args
        FOR T = TEMPV TO ARG2 BY 3 DO
        $(  IF H3!T>K BREAK
            IF REGUSEDBY(T)>=0 DO STORET(T)
        $)

        // deal with loading of R0
        IF K+2<=SSP-2 DO  // if argument
            TEST K+2>=BASE
            THEN MOVETOR(TEMPV+(K+2-BASE)*3, R0)
            ELSE GENRAX(F.LDA, R0, ADDRLOC(K+2), R0)
    $)2
    GENAX(F.JSR, ADDRJMP(ARG1), R0)
    CODE(K, 0)
    FORGETALL()
    STACK(K)
    IF OP=S.FNAP DO LOADT(K.REG, R0)
$)1

AND CGRETURN(OP) BE
$(1 CGPENDINGOP()
    IF OP=S.FNRN DO
    $(  MOVETOR(ARG1, R0)
        STACK(SSP-1)
    $)
    GENAX(F.JMP, A.RTN, R0)
    INCODE := FALSE
    INITSTACK(SSP)
$)1

.

SECTION "CG80"

GET "CGHDR"

LET CGSWITCH(V, M) BE
// compile code for SWITCHON
// N=number of cases
// D=default label
$(1 LET N = (M+1)/2
    LET D = RDL()
    LET NUMNEG = 0 // number of negative case constants
    CASEK, CASEL := V-1, V+N-1
    // vectors CASEK and CASEL will be accessed using
    // offsets 1 to N

    // sort case constants into arithmetic order
    $(2 LET NEXTNEG, NEXTPOS = 1, N
        FOR I = 1 TO N DO
        $(3 LET K = RDN()
            LET L = RDL()
            TEST K>=0
            THEN
            $(4 LET J = NEXTPOS
                UNTIL J=N DO
                $(  IF K<CASEK!(J+1) BREAK
                    CASEK!J := CASEK!(J+1)
                    CASEL!J := CASEL!(J+1)
                    J := J+1
                $)
                CASEK!J, CASEL!J := K, L
                NEXTPOS := NEXTPOS-1
            $)4
            ELSE
            $(5 LET J = NEXTNEG
                UNTIL J=1 DO
                $(  IF K>CASEK!(J-1) BREAK
                    CASEK!J := CASEK!(J-1)
                    CASEL!J := CASEL!(J-1)
                    J := J-1
                $)
                CASEK!J, CASEL!J := K, L
                NEXTNEG := NEXTNEG+1
                NUMNEG := NUMNEG+1
            $)5
        $)3
    $)2

    CGPENDINGOP()
    STORE(0, SSP-2)
    SWREG := MOVETOANYR(ARG1)
    STACK(SSP-1)

    TEST 4*N-6>CASEK!N/2-CASEK!1/2 // care with overflow
    // want to try 3 ?
    THEN LSWITCH(1, N, D)
    ELSE
    $(  UNLESS NUMNEG=0 \/ NUMNEG=N DO
        // unless all case constants of same sign
        // arrange numbers in logical order
        $(6 LET MIN = N-NUMNEG<NUMNEG -> N-NUMNEG, NUMNEG
            FOR I = 1 TO MIN IF CASEK!I<0 DO
            $(7 LET P = I-NUMNEG
                LET SAVEK, SAVEL = CASEK!I, CASEL!I
                CASEK!I := 0 // positive end marker
                $(  P := P+N
                    $(8 LET TK, TL = CASEK!P, CASEL!P
                        CASEK!P, CASEL!P := SAVEK, SAVEL
                        SAVEK, SAVEL := TK, TL
                        P := P-NUMNEG
                    $)8 REPEATWHILE P>0
                $) REPEATWHILE SAVEK<0
            $)7
        $)6
        // now produce binary chop code
        // on these logical values
        BSWITCH(1, N, D)
        GENJMP(D)
    $)
$)1

AND BSWITCH(P, Q, D) BE
// binary chop instance
    TEST Q-P>6
    THEN
    $(1 LET M = NEXTPARAM()
        LET T = (P+Q)/2
        GENSKIPRK(S.PLE, SWREG, CASEK!T)
        GENJMP(M)
        INCODE := TRUE
        BSWITCH(P, T-1, D)
        GENJMP(D)
        CGLAB(M, 0)
        INCODE := TRUE
        GENSKIPRK(S.EQ, SWREG, CASEK!T)
        GENJMP(CASEL!T)
        INCODE := TRUE
        BSWITCH(T+1, Q, D)
    $)1
    ELSE FOR I = P TO Q DO
    $(  GENSKIPRK(S.EQ, SWREG, CASEK!I)
        GENJMP(CASEL!I)
        INCODE := TRUE
    $)

AND LSWITCH(P, Q, D) BE
// label vector instance
$(1 LET L = NEXTPARAM()
    GENSKIPRK(S.GR, SWREG, CASEK!P)
    GENJMP(D)
    INCODE := TRUE
    GENSKIPRK(S.LS, SWREG, CASEK!Q)
    GENJMP(D)
    INCODE := TRUE
    $(2 LET R = SWREG=R3 -> R0, R3
        CHKREFS(4)
        GENRAX(F.LDA, R, 3, R1)
        GENSD(F.ADD, (SWREG=R3 -> R, SWREG), R3)
        // redesign ?
        GENAX(F.JMP+F.I, 0, R3)
        INCODE := FALSE
        CODE(-CASEK!P, L)
        FORGETALL()
        INCODE := FALSE
    $)2

    CGLAB(L, CASEK!Q-CASEK!P+1)

    FOR K=CASEK!P TO CASEK!Q
        TEST CASEK!P=K
        THEN
        $(  CODE(0, CASEL!P)
            P := P+1
        $)
        ELSE CODE(0, D)
$)1

.

SECTION "CG90"

GET "CGHDR"

LET SWAPOP(OP) = VALOF
    SWITCHON OP INTO
    $(1
    DEFAULT:    RESULTIS OP
    CASE S.GE:  RESULTIS S.LE
    CASE S.LS:  RESULTIS S.GR
    CASE S.GR:  RESULTIS S.LS
    CASE S.LE:  RESULTIS S.GE
    CASE S.PGE: RESULTIS S.PLE
    CASE S.PLS: RESULTIS S.PGR
    CASE S.PGR: RESULTIS S.PLS
    CASE S.PLE: RESULTIS S.PGE
    $)1


AND CGBRANCH(OP, L) BE
// entry after JT or JF!
$(1 LET F = 0
    LET R = 0
    LET B = OP=S.JT
    SWITCHON PENDINGOP INTO
    $(2
    DEFAULT:    CGPENDINGOP()
    CASE S.NONE:LOADT(K.NUMB, 0)
    CASE S.NE:  B := NOT B
    CASE S.EQ:  F := B -> S.EQ, S.NE
                ENDCASE
    CASE S.LS:  B := NOT B
    CASE S.GE:  F := B -> S.GE, S.LS
                ENDCASE
    CASE S.LE:  B := NOT B
    CASE S.GR:  F := B -> S.GR, S.LE
                ENDCASE
    CASE S.PLS: B := NOT B
    CASE S.PGE: F := B -> S.PGE, S.PLS
                ENDCASE
    CASE S.PLE: B := NOT B
    CASE S.PGR: F := B -> S.PGR, S.PLE
    $)2
    PENDINGOP := S.NONE

    GENSKIP(F)
    GENJMP(L)
    INCODE := TRUE
$)1

AND GENSKIP(OP) BE
// used in CGPENDINGOP and CGBRANCH
$(1 LET A1, A2 = ARG1, ARG2
// compiles code to skip instruction UNLESS A2 <OP> A1
// if either A1 or A2 is a constant it moves the other
// to a register and calls GENSKIPRK(F, R, K)
    STORE(0,SSP-3)
    IF H1!A1=K.NUMB DO
    $(2 LET T = A2
        A2 := A1
        A1 := T
        OP := SWAPOP(OP)
    $)2
    TEST H1!A2=K.NUMB
    THEN GENSKIPRK(OP, MOVETOANYR(A1), H2!A2)
    ELSE
    $(3 LET S = MOVETOANYBUTR3(A1)
        GENSKIPRR(OP, S, MOVETOANYR(A2))
    $)3
    STACK(SSP-2)
$)1

AND GENSKIPRK(OP, R, K) BE
$(1 LET F = 0
    IF K=-1 DO F := F.NL+F.Z+
        VALOF SWITCHON OP INTO
        $(2
        CASE S.EQ:  RESULTIS F.INC+F.SNR
        CASE S.NE:  RESULTIS F.INC+F.SZR
        CASE S.LS:  RESULTIS F.MOV+F.SNC+F.L
        CASE S.GE:  RESULTIS F.MOV+F.SZC+F.L
        CASE S.GR:  RESULTIS F.INC+F.SZC+F.L
        CASE S.LE:  RESULTIS F.INC+F.SNC+F.L
        CASE S.PLS: // always false
                    RESULTIS F.MOV+F.SKP
        CASE S.PGE: // always true
                    CHKREFS(2); RETURN
        CASE S.PGR: RESULTIS F.COM+F.SZR
        CASE S.PLE: RESULTIS F.COM+F.SNR
        $)2
    IF K=0 DO F := F.NL+F.Z+
        VALOF SWITCHON OP INTO
        $(3
        CASE S.EQ:  RESULTIS F.MOV+F.SNR
        CASE S.NE:  RESULTIS F.MOV+F.SZR
        CASE S.LS:  RESULTIS F.NEG+F.SZC+F.L
        CASE S.GE:  RESULTIS F.NEG+F.SNC+F.L
        CASE S.GR:  RESULTIS F.MOV+F.SZC+F.L
        CASE S.LE:  RESULTIS F.MOV+F.SNC+F.L
        CASE S.PLS: RESULTIS F.MOV+F.SZR
        CASE S.PGE: RESULTIS F.MOV+F.SNR
        CASE S.PGR: // always false
                    RESULTIS F.MOV+F.SKP
        CASE S.PLE: // always true
                    CHKREFS(2); RETURN
        $)3
    TEST F=0
    THEN
    $(4 LET S = -1
        FOR I = R0 TO R3
            IF REG.K!I=K.NUMB & REG.N!I=K DO
            $(  S := I; BREAK
            $)
        GENSKIPRR(OP, R,
            [S=-1 -> SETKTOR(K, ANYBUT[R]), S])
    $)4
    ELSE
    $(  CHKREFS(3)
        GENSD(F, R, R)
    $)
$)1

AND GENSKIPRR(OP, S, D) BE
$(1 LET F = F.NL+F.Z+
        VALOF SWITCHON OP INTO
        $(2
        CASE S.EQ:  RESULTIS F.SUB+F.SNR
        CASE S.NE:  RESULTIS F.SUB+F.SZR
        CASE S.GR:  $(3 LET T = S
                        S := D
                        D := T
                    $)3
        CASE S.LS:  RESULTIS F.SUB+F.SZC+F.L
        CASE S.LE:  $(4 LET T = S
                        S := D
                        D := T
                    $)4
        CASE S.GE:  RESULTIS F.SUB+F.SNC+F.L
        CASE S.PLS: RESULTIS F.SUB+F.SNC
        CASE S.PGE: RESULTIS F.SUB+F.SZC
        CASE S.PGR: RESULTIS F.ADC+F.SZC
        CASE S.PLE: RESULTIS F.ADC+F.SNC
        $)2

    CHKREFS(3)
    GENSD(F, S, D)
$)1

AND CODE(A, L) BE
// compile a word
$(1 UNLESS L=0 DO LABREF(L, STVP)
    STV!STVP := A
    IF DEBUGGING DO
    $(  WRITEF("CODE:%O6", A)
        UNLESS L=0 DO WRITEF(" (L%N)", L)
        NEWLINE()
    $)
    INCRSTVP()
$)1

AND GENRAX(OP, R, A, X) BE
// compile a memory reference instruction
    IF INCODE DO
    $(  IF COUNTFLAG DO INSERTCOUNT()
        CHKREFS(1)
        CODE(OP+A+(R<<11)+(X<<8), 0)
    $)

AND GENAX(OP, A, X) BE
// compile a memory modify or jump instruction
    IF INCODE DO
    $(  IF COUNTFLAG DO INSERTCOUNT()
        CHKREFS(1)
        CODE(OP+A+(X<<8), 0)
    $)

AND GENSD(OP, RS, RD) BE
// compile an arithmetic or logical insruction
    IF INCODE DO
    $(  IF COUNTFLAG DO INSERTCOUNT()
        CHKREFS(1)
        CODE(OP+(RS<<13)+(RD<<11), 0)
    $)

AND GENJMP(L) BE
$(1 GENAX(F.JMP, REFCONST(K.LAB, L), R0)
    INCODE := FALSE
$)1

AND INSERTCOUNT() BE
// produce code for profile option
$(1 COUNTFLAG := FALSE
    FREEREG(R3)
    CHKREFS(3)
    GENAX(F.JSR, A.PRFC, R0)
    FORGETREG(R3)
    CODE(0, 0)
    CODE(0, 0)
$)1

AND LABREF(L, A) BE
$(1 LET P = GETBLK()
    H2!P, H3!P := L, A
    !REFLISTE := P
    REFLISTE := P
    NLABREFS := NLABREFS+1
$)1

AND INITDATALISTS() BE
$(1 REFLIST := 0
    REFLISTE := @REFLIST
    NLABREFS := 0
    DLIST := 0
    DLISTE := @DLIST
$)1

AND CHECKSPACE() BE
IF STV+STVP>=DP DO
$(1 CGERROR("PROGRAM TOO LARGE %N WORDS COMPILED", STVP)
    STOP(1)
$)1

AND INCRSTVP() BE
$(1 STVP := STVP+1
    CHECKSPACE()
    UNLESS KCMPP=KCMPV IF H1!KCMPV+128<STVP DO
    $(  REMOVEREFSTO(H1!KCMPV, H2!KCMPV, H3!KCMPV)
        KCMPP := KCMPP-3
        FOR P = KCMPV TO KCMPP-1 DO P!0 := P!3
    $)
$)1

.

SECTION "CG100"

GET "CGHDR"

LET CHKREFS(N) BE
$(1 UNTIL REFINRANGE(KREFV, N) DO DEALWITHKREF(KREFV)
    IF SKIPLAB=0 RETURN
    SETLAB(SKIPLAB)
    SKIPLAB := 0
    INCODE := TRUE
$)1

AND SETLAB(N) BE
$(1 LABV!N := STVP
    $(2 LET P = GETKREF(K.LAB, N)
        IF P=-1 BREAK
        FILLINRELREF(P, STVP, 0)
    $)2 REPEAT
    $(3 LET P = GETKREF(K.LABI, N)
        IF P=-1 BREAK
        FILLINRELREF(P, STVP, 0)
    $)3 REPEAT
$)1

AND DEALWITHKREF(T) BE
$(1 LET P, K, N, IND = H1!T, H2!T, H3!T, 0
    KREFP := KREFP-3  // remove item from KREFV
    FOR Q = T TO KREFP-1 DO Q!0 := Q!3
    SWITCHON K INTO
    $(2
    CASE K.LAB: K, IND := K.DLAB, F.I
    CASE K.LABI:$(3 LET A = GETKCMP(K, N)
                    IF A>=0 DO
                    $(  FILLINRELREF(P, A, IND)
                        RETURN
                    $)
                $)3
    $)2
    // we must compile a word
    IF INCODE DO  // we must compile a jump round it
    $(  SKIPLAB := NEXTPARAM()
        ADDKREF(K.LAB, SKIPLAB)
        CODE(F.JMP+BASE.R1, 0)
        INCODE := FALSE
    $)
    FILLINRELREF(P, STVP, IND)
    ADDKCMP(K, N)
    TEST K=K.NUMB
    THEN CODE(N, 0)
    ELSE CODE((K=K.LABI -> #100000, 0), N)
$)1

AND FILLINRELREF(P, A, BITS) BE
    STV!P := STV!P+BITS+(A-P & 255)

AND REFINRANGE(P, N) = P=KREFP -> TRUE,
    (H1!P+126)>=STVP+N

AND REMOVEREFSTO(A, K, N) BE
$(1 LET P = 0  // used to hold address of
               // referencing instruction
    SWITCHON K INTO
    $(2
    CASE K.DLAB:// can be used to satisfy (K.LAB, N) refs
                $(  P := GETKREF(K.LAB, N)
                    IF P=-1 BREAK
                    FILLINRELREF(P, A, F.I)
                $) REPEAT
    CASE K.LABI:
    CASE K.NUMB:$(  P := GETKREF(K, N)
                    IF P=-1 RETURN
                    FILLINRELREF(P, A, 0)
                $) REPEAT
    $)2
$)1

AND ADDRJMP(A) = VALOF
$(1 LET K, N = H1!A, H2!A
    UNLESS INCODE RESULTIS 0
    IF COUNTFLAG DO INSERTCOUNT()
    CHKREFS(2)
    SWITCHON K INTO
    $(2
    CASE K.NUMB: CASE K.REG:
    CASE K.LVLOC: CASE K.LVGLOB: CASE K.LVLAB:
                MOVETOR(A, R3)
                CHKREFS(2)
                RESULTIS (0)+BASE.R3
    CASE K.R3:  RESULTIS F.I+(N&255)+BASE.R3
    CASE K.LOC: RESULTIS F.I+ADDRLOC(N)
    CASE K.GLOB:RESULTIS F.I+ADDRGLOB(N)
    CASE K.LAB: RESULTIS F.I+REFCONST(K.LABI, N)
    $)2
$)1

AND ADDRLDA(K, N) = VALOF
$(1 UNLESS INCODE RESULTIS 0
    IF COUNTFLAG DO INSERTCOUNT()
    CHKREFS(2)
    SWITCHON K INTO
    $(2
    CASE K.NUMB:RESULTIS REFCONST(K.NUMB, N)
    CASE K.LOC: RESULTIS ADDRLOC(N)
    CASE K.GLOB:RESULTIS ADDRGLOB(N)
    CASE K.LAB: RESULTIS REFCONST(K.LAB, N)
    CASE K.ABS: RESULTIS (N)+BASE.R0
    CASE K.R3:  RESULTIS (N&255)+BASE.R3
    CASE K.LVLAB:
                RESULTIS REFCONST(K.DLAB, N)
    DEFAULT:    CGERROR("IN ADDRLDA %N", K)
                RESULTIS 0
    $)2
$)1

AND ADDRLOC(N) = VALOF
$(1 UNLESS INCODE RESULTIS 0
    IF COUNTFLAG DO INSERTCOUNT()
    CHKREFS(2)
    FOR R = R2 TO R3  // try to use R2 or R3
        IF REG.K!R=K.LVLOC & IS8BITINT(N-REG.N!R)
            RESULTIS (N-REG.N!R & 255)+(R<<8)
    // we need to use R3
    FREEREG(R3)

    IF REG.K!R3=K.NUMB &
        IS8BITINT(N-128+REG.N!R3) DO
    $(  ADD(REG.N!R3, R2, R3)
        LOOP
    $)
    ADD((N-128) & -64, R2, R3)
$)1 REPEAT

AND ADDRGLOB(N) = VALOF
$(1 UNLESS INCODE RESULTIS 0
    IF COUNTFLAG DO INSERTCOUNT()
    CHKREFS(2)
    IF REG.K!R3=K.LVGLOB & IS8BITINT(N-REG.N!R3)
        RESULTIS (N-REG.N!R3 & 255)+BASE.R3
    // we must change R3
    FREEREG(R3)
    UNLESS REG.K!R3=K.LVGLOB DO
    $(  GENRAX(F.LDA, R3, A.GSAVE, R0)
        SETINFO(R3, K.LVGLOB, 128)
        LOOP
    $)
    ADD((N-REG.N!R3) & -64, R3, R3)
$)1 REPEAT

AND REFCONST(K, N) = VALOF
$(1 LET A = 0
    UNLESS INCODE RESULTIS 0
    // ensure that the instruction using
    // (K, N) will be compiled at STVP
    IF COUNTFLAG DO INSERTCOUNT()
    CHKREFS(2)
    SWITCHON K INTO
    $(2
    CASE K.NUMB:// ref to integer constant N
                A := PAGE0ADDR(N)
                IF A>=0 RESULTIS A
    CASE K.DLAB:// ref to word containing constant
                // (K, N) e.g. LDA r,=Ln
                A := GETKCMP(K, N)
                IF A>=0 RESULTIS RELADDR(A)
                ENDCASE
    CASE K.LABI:// indirect ref to word labelled
                // Ln, e.g JMP @Ln
    CASE K.LAB: // ref to word labelled Ln
                // e.g. JMP Ln or LDA r,Ln
                A := LABV!N
                IF A>=0 & IS8BITINT(A-STVP)
                    RESULTIS RELADDR(A)
                ENDCASE
    $)2
    ADDKREF(K, N)
    RESULTIS BASE.R1
$)1

AND PAGE0ADDR(N) = VALOF
    FOR I = 0 TO 1000 DO
    $(1 LET C = I!TABLE 2,3,4,5,6,7,8,9,10,11,12,13,14,15,
            128,256,384,512,#40,#60,#71,#101,#132
            //              *S,'0','9', 'A', 'Z'
        IF C=N RESULTIS A.CONSTANTS+I
        IF C=#132 RESULTIS -1  // no page0 constant
    $)1

AND RELADDR(A) = (A-STVP & 255)+BASE.R1

AND ADDKCMP(K, N) BE
$(1 IF KCMPP=KCMPT DO
    $(  REMOVEREFSTO(H1!KCMPV, H2!KCMPV, H3!KCMPV)
        KCMPP := KCMPP-3
        FOR P = KCMPV TO KCMPP-1 DO P!0 := P!3
    $)
    H1!KCMPP, H2!KCMPP, H3!KCMPP := STVP, K, N
    KCMPP := KCMPP+3
    IF K=K.NUMB \/ K=K.DLAB DO
    $(2 LET P = GETKREF(K, N)
        IF P=-1 BREAK
        FILLINRELREF(P, STVP, 0)
    $)2 REPEAT
$)1

AND GETKCMP(K, N) = VALOF
// returns address of recently compiled constant (K, N)
$(1 FOR P = KCMPP-3 TO KCMPV BY -3
       IF H3!P=N & H2!P=K RESULTIS H1!P
    RESULTIS -1
$)1

AND ADDKREF(K, N) BE
$(1 IF KREFP=KREFT DO
    $(  CGERROR("IN ADDKREF")
        STOP(1)
    $)
    H1!KREFP, H2!KREFP, H3!KREFP := STVP, K, N
    KREFP := KREFP+3
$)1

AND GETKREF(K, N) = VALOF
// returns address of instruction making reference (K, N)
// and removes item from KREFV
$(1 FOR P = KREFV TO KREFP-3 BY 3
        IF H3!P=N & H2!P=K DO
    $(  LET A = H1!P
        KREFP := KREFP-3
        FOR Q = P TO KREFP-1 DO Q!0 := Q!3
        RESULTIS A
    $)
    RESULTIS -1
$)1

AND IS8BITINT(A) = -128<=A<=127 -> TRUE, FALSE


.

SECTION "CG110"

GET "CGHDR"

LET OUTPUTSECTION() BE
// output octal assembly text
$(1 LET RL = REFLIST
    UNTIL RL=0 DO
    $(3 LET L = H2!RL
        LET LABVAL = LABV!L
        LET A = H3!RL
        IF LABVAL=-1 DO CGERROR("LABEL L%N UNSET", L)
        STV!A := STV!A+LABVAL
        RL := !RL
    $)3
    IF LISTING DO
    $(4 IF ACODEOUT=0 DO ACODEOUT := FINDOUTPUT("CODE")
        IF ACODEOUT=0 DO ACODEOUT := SYSOUT
        SELECTOUTPUT(ACODEOUT)
        UNLESS NAMESECTION=0 DO
        $(  IF PROGSIZE=0 DO
                WRITEF(".TITLE %S*N", NAMESECTION)
            WRITEF(".ENT %S*N", NAMESECTION)
        $)
        WRITES(".NREL*N")
        UNLESS NAMESECTION=0 DO
            WRITEF("%S:*N", NAMESECTION)
        WRITES("B:*N;*N")
        RL := REFLIST
        FOR P = 0 TO STVP-1 DO
        $(5 LET W = STV!P & #177777
            WRITEF("%O6", W)
            IF RL\=0 & H3!RL=P
            THEN
            $(  WRITES("+B")
                RL := !RL
            $)
            NEWLINE()
        $)5
        WRITEF(";END %S*N", NAMESECTION=0 ->
            "", NAMESECTION)
        SELECTOUTPUT(SYSOUT)
    $)4
    IF BINING DO CGERROR("BINING NOT IMPLEMENTED")
    IF RDOSBINING DO
    $(6 LET WRWRD(WORD) BE
        $(  WRCH(WORD & 255)
            WRCH(WORD>>8)
            // note we output low order byte first
        $)
        AND RADIX40(NAME, CODE) BE
        $(  LET T = VEC 5
            AND H, L, CRY = ?, ?, ?
            FOR I = 1 TO 5 DO T!I := 0
            FOR I = 1 TO GETBYTE(NAME, 0) IF I<=5 DO
            $(  LET CH = GETBYTE(NAMESECTION, I)
                T!I := 38 // question mark character
                FOR J = 1 TO 37
                    IF CH=GETBYTE("0123456789*
                    *ABCDEFGHIJKLMNOPQRSTUVWXYZ.", J) DO
                    $(  T!I := J; BREAK
                    $)
            $)
            H := MULDIV(T!0*40+T!1, 125, 64)
            RESULT2 := RESULT2<<9
            L := (T!2*40+T!3)*40+T!4
            CRY := (H REM 2)+(L<0 -> 1, 0)
            L := L & #077777
            L := L+RESULT2
            CRY := CRY+(L<0 -> 1, 0)
            H := (H>>1)+CRY/2
            L := L & #077777
            IF (CRY REM 2)=1 DO L := L \/ #100000
            CODE!0 := (H<<5)+(L>>11)
            CODE!1 := L<<5
        $)
        IF RCODEOUT=0 DO
            RCODEOUT := FINDOUTPUT("RDOSCODE")
        IF RCODEOUT=0 DO
        $(  CGERROR("FAILED TO FIND 'RDOSCODE'")
            RETURN
        $)

        // TITLE block
        $(  LET BLOCK = VEC 9
            LET CHECKSUM = 0
            BLOCK!1 := #7 // block type indicant
                          // TITLE symbol
            BLOCK!2 := -3 // word count
                          // (symbol+equivalence)
            BLOCK!3 := 0
            BLOCK!4 := 0
            BLOCK!5 := 0

            BLOCK!6 := 0 // future checksum

            RADIX40((NAMESECTION=0 -> ".MAIN",
                NAMESECTION), BLOCK+7) // section name
            BLOCK!8 := BLOCK!8+4 // flag as TITLE symbol

            BLOCK!9 := 0 // equivalence
                         // (whatever that is)

            FOR I = 1 TO 9 DO CHECKSUM := CHECKSUM+BLOCK!I

            BLOCK!6 := -CHECKSUM // sum of all words in the
                                 // block should be zero
            FOR I = 1 TO 9 DO WRWRD(BLOCK!I)
        $)

        // RELOCATABLE DATA block:
        FOR P = 0 TO STVP-1 BY 14 DO
        $(7 LET BLOCK = VEC 21 // max. block size is 21
            LET CHECKSUM = 0
            LET WRDCNT = STVP-P>=14 -> 14, STVP-P
            LET RL = REFLIST
            LET PP = P

            // format the block
            BLOCK!1 := #2 // block type indicant
                          // (relocatable data)
            BLOCK!2 := -WRDCNT-1 // (-1 for address word)
            FOR I = 0 TO 2 DO
            $(8 LET TEMP = 0
                FOR J = 12 TO 0 BY -3 DO
                $(  TEST I=0 & J=12
                    THEN TEMP := #040000 // relocatable
                    ELSE TEMP := TEMP+VALOF
                        TEST RL\=0 & H3!RL=PP
                        THEN
                        $(  RL := !RL
                            RESULTIS 2<<J // relocatable
                        $)
                        ELSE RESULTIS 1<<J // absolute
                    PP := PP+1 // increment proper P
                $)
                BLOCK!(3+I) := TEMP
            $)8
            BLOCK!6 := 0 // will be set to the checksum
                         // for the block
            BLOCK!7 := P // address of data
            FOR I = 0 TO WRDCNT-1 DO
                BLOCK!(8+I) := STV!(P+I)

            // set checksum.
            // checksum is such that the sum of all words
            // in the block is zero
            FOR I = 1 TO 7+WRDCNT DO
                CHECKSUM := CHECKSUM+BLOCK!I
                // **beware of overflow**
            BLOCK!6 := -CHECKSUM

            // output block
            FOR I = 1 TO 7+WRDCNT DO WRWRD(BLOCK!I)
        $)7

        SELECTOUTPUT(SYSOUT)
    $)6
$)1

AND DBOUTPUT() BE
$(1 WRITES("SMSTK: ")
    FOR P = ARG1 TO TEMPV BY -3 DO WRKN(H1!P, H2!P)
    UNLESS KREFV=KREFP DO
    $(  WRITES("*NKREFV: ")
        FOR P = KREFV TO KREFP-3 BY 3 DO
        $(  WRITEF("%N:", H1!P)
            WRKN(H2!P, H3!P)
        $)
    $)
    UNLESS KCMPV=KCMPP DO
    $(  WRITES("*NKCMPV: ")
        FOR P = KCMPV TO KCMPP-3 BY 3 DO
        $(  WRITEF("%N:", H1!P)
            WRKN(H2!P, H3!P)
        $)
    $)
    WRITEF("*NSTVP=%N OP=%N PDOP=%N SSP=%N ", STVP,
        OP, PENDINGOP, SSP)
    FOR R = R0 TO R3 UNLESS R=R2 \/ REG.K!R=K.NONE DO
    $(  WRITEF("R%N=", R)
        WRKN(REG.K!R, REG.N!R)
    $)
    NEWLINE()
$)1

AND WRKN(K, N) BE
$(1 LET S = VALOF
        SWITCHON K INTO
        $(2
        DEFAULT:    RESULTIS "?"
        CASE K.NONE:RESULTIS "Z"
        CASE K.NUMB:RESULTIS "N"
        CASE K.LOC: RESULTIS "P"
        CASE K.GLOB:RESULTIS "G"
        CASE K.LAB: RESULTIS "L"
        CASE K.REG: RESULTIS "R"
        CASE K.R3:  RESULTIS "I"
        CASE K.LVLOC:
                    RESULTIS "@P"
        CASE K.LVGLOB:
                    RESULTIS "@G"
        CASE K.LVLAB:
                    RESULTIS "@L"
        CASE K.DLAB:RESULTIS "DL"
        CASE K.LABI:RESULTIS "LI"
        $)2
    WRITEF("%S%N ", S, N)
$)1

