// Header file for the LSI 4 code-generator
// October 1978

GET "LIBHDR"

//  Machine instruction mnemonics

MANIFEST $(

            // Single length memory reference
            // Generated by GENS(F, R, M, A)

            f.l    = #X8000
            f.st   = #X8400
            f.add  = #X8800
            f.sub  = #X8C00
            f.exch = #X9000
            f.and  = #X9400
            f.or   = #XB400
            f.xor  = #X9800
            f.csk  = #XB800
            f.jmp  = #X9C00
            f.ims  = #XDC00
            f.jst  = #XBC00

            // Double length memory reference
            // Generated by GENE(F, R, M, A)

            f.mul  = #X0700
            f.div  = #X0701
            f.addc = #X0702
            f.subc = #X2702
            f.cea  = #X0704
            f.csm  = #X0705
            f.ld   = #X0706
            f.std  = #X0707
            f.le   = #X0708
            f.ste  = #X0709
            f.adde = #X070A
            f.sube = #X070B
            f.exche= #X070C
            f.jmpe = #X070D
            f.jste = #X270D
            f.imse = #X470D
            f.dmse = #X670D
            f.ande = #X070E
            f.ore  = #X270E
            f.xore = #X070F
            f.cske = #X270F

            // Immediate
            // Generated by GENI(F, R, A)

            f.lbni = #X0800
            f.lbpi = #X0900
            f.subi = #X0A00
            f.addi = #X0B00
            f.csln = #X0C00
            f.cski = #X0D00
            f.xori = #X1700
            f.andi = #X1800
            f.ori  = #X1900

            // Register-register
            // Generated by GENRR(F, S, D)

            f.nop  = #X0000
            f.lr   = #X0000
            f.neg  = #X0001
            f.addr = #X0002
            f.subr = #X0003
            f.andr = #X0004
            f.xorr = #X0005
            f.csmr = #X0006
            f.orr  = #X0007
            f.exchr= #X0008
            f.comp = #X0009
            f.csn  = #X000A
            f.cskr = #X000B

            // Register bit change
            // Generated by GENBIT(F, B, R)

            f.sbit = #X000C
            f.rbit = #X000D
            f.cbit = #X000E
            f.tbit = #X000F

            // Shift instructions
            // Generated by GENSH(F, R, S)

            f.sll  = #X0E00
            f.srl  = #X0E08
            f.sra  = #X0E0C
            f.srda = #X0F0C

            // Conditional jumps
            // Generated by GENB(F, R, L)

            f.jeq  = #X1100
            f.jne  = #X1180
            f.jgt  = #X1200
            f.jle  = #X1280
            f.jge  = #X1300
            f.jlt  = #X1380
            f.ijeq = #X1400
            f.ijne = #X1480
            f.jeqd = #X1500
            f.jned = #X1580

            // Control instructions

            f.xnx = #X030A

            // Addressing modes
            m.rel = #X200
            m.i   = #X100
            m.x   = #X080
            m.y   = #X040

         $)

MANIFEST $( // Standard addresses
            a.stkchk  =  #X2C + m.i
            a.lshift  =  #X27 + m.i
            a.rshift  =  #X28 + m.i
            a.rtn     =  #X24
            a.prfc    =  #X2B + m.i
            a.gbyte   =  #X29 + m.i
            a.pbyte   =  #X2A + m.i
         $)

MANIFEST $( // Relocatable binary types
            t.hunk    =  1000
            t.reloc   =  1001
            t.end     =  1002
            t.ext     =  1005

            ext.ref   =   129
         $)


MANIFEST $( // Data types. (Packed into two bits)
            d.itemn  =  0
            d.iteml  =  1
            d.blkl   =  2
            d.blkn   =  3
         $)


MANIFEST $( 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
         $)

MANIFEST
// Basic constants

$(

yes =  TRUE
no  = FALSE

// selectors
  h1=0; h2=1; h3=2
$)

MANIFEST  $(
// Register mnemonics
r.a=0; r.q=1; r.y=2; r.x=3; r.l=4; r.p = 5
$)

MANIFEST
$(  k.none=0
    k.numb=1; k.loc=2; k.glob=3; k.lab=4
    k.reg=6; k.ry=7
    k.lvloc=8; k.lvglob=9; k.lvlab=10
    k.jlab=11; k.abs = 12
$)

MANIFEST
$(  sectionword= 12345
$)

GLOBAL $( rc            :   150
          verstream     :   152
          ocodestream   :   153
          codestream    :   154
          datvec        :   155

          ocodefile     :   158
          keepocode     :   159

          cgworksize    :   160
          naming        :   162
          callcounting  :   163
          profcounting  :   164
          stkchking     :   165
          altobj        :   167

          workspace     :   180
          switchspace   :   181
          tempfile      :   182
          err.p         :   183
          err.l         :   184
          reg.locked    :   190
          progsize      :   191
          registers     :   192
          reg.k         :   193
          reg.n         :   194
          tempv         :   195
          tempt         :   196
          maxssp        :   197
          ssp           :   198
          arg1          :   199
          arg2          :   200
          maxgn         :   201
          krefv         :   202
          kreft         :   203
          krefp         :   204
          reflist       :   205
          refliste      :   206
          ereflist      :   207
          nlabrefs      :   208
          dlist         :   209
          dliste        :   210
          kcmpv         :   211
          kcmpp         :   212
          kcmpt         :   213
          procstk       :   214
          procstkp      :   215
          procstkt      :   216
          freelist      :   217
          labv          :   218
          labt          :   219
          paramnumber   :   220
          skiplab       :   221
          countflag     :   222
          incode        :   223
          stv           :   224
          stvp          :   225
          op            :   226
          pendingop     :   227
          namesection   :   228
          dp            :   229
          casek         :   230
          casel         :   231
          swreg         :   232
          maxused       :   233
          any.globals   :   234
          needslist     :   235

          rdn           :   250
          rdl           :   251
          rdgn          :   252
          nextparam     :   253
          initstack     :   254
          cgerror       :   255
          stack         :   256
          store         :   257
          scan          :   258
          cgpendingop   :   259
          cgdyadic      :   260
          bitpos        :   261
          movetoaqy     :   262
          movetoaq      :   263
          movetor       :   264
          storet        :   265
          anybut        :   266
          freereg       :   267
          itemusing     :   268
          forgetall     :   269
          forgetreg     :   270
          forgetvar     :   271
          forgetallvars :   272
          remem         :   273
          setinfo       :   274
          moveinfo      :   275
          argreg        :   276
          loadt         :   277
          lose1         :   278
          regusedby     :   279
          isfree        :   280
          storei        :   281
          findoffset    :   282
          storein       :   283
          cglab         :   284
          cgrv          :   285
          cgmult        :   286
          cgdiv         :   287
          cgshift       :   288
          cgstatics     :   289
          cgglobal      :   290
          cgdata        :   291
          cgstring      :   292
          cgerefs       :   293
          cgentry       :   294
          cgsave        :   295
          cgapply       :   296
          cgreturn      :   297
          cgswitch      :   298
          cgbranch      :   299
          setrtok       :   300
          getblk        :   301
          rtnblk        :   302
          revop         :   303
          code          :   304
          gensh         :   305
          gens          :   306
          gene          :   307
          gensore       :   308
          genrr         :   309
          genbit        :   310
          genb          :   311
          genjmp        :   312
          insertcount   :   313
          labref        :   314
          initdatalists :   315
          checkspace    :   316
          incrstvp      :   317
          chkrefs       :   318
          setlabel      :   319
          unsetlabel    :   320
          dealwithkref  :   321
          fillinrelref  :   322
          fillineref    :   323
          removerefsto  :   324
          gengoto       :   325
          genm          :   326
          mref          :   327
          eref          :   328
          addkcmp       :   329
          getkcmp       :   330
          addkref       :   331
          getkref       :   332
          geteref       :   333
          outputsection :   334
          dboutput      :   335
          refinrange    :   336
          geni          :   337
          loadarg       :   338
          cggetbyte     :   339
          cgputbyte     :   340
          collapse      :   341
          cgdatawords   :   342
          getdatablk    :   343
          putdatablkitem:   344
          cgdatablks    :   345
       $)

.
SECTION "CG10"

GET "BCPL-CG"

LET start() BE
  $( err.p, err.l := level(), stop.label

     workspace, switchspace, tempfile := 0,0,0

     writef("LSI 4 CG (October 1978)*N*
            *Workspace size = %N*N", cgworksize)

     ocodestream := findinput(ocodefile)
     IF ocodestream = 0 THEN
       $( cgerror("can't open %S", ocodefile)
          collapse(20)
       $)

     selectinput(ocodestream)

     progsize := 0
     maxused := 0

     workspace := getvec(cgworksize)

     IF workspace = 0 THEN
       $( cgerror("can't get workspace")
          collapse(20)
       $)

     cgsects(workspace, cgworksize)

     writef("Program size = %N words*N", progsize)
     writef("Maximum workspace used = %N words*N", maxused)

     collapse(0)

stop.label:
     RETURN


  $)



AND collapse(n) BE
  $( IF ocodestream \= 0 THEN
       $( endread()
          ocodestream := 0
       $)
     IF workspace \= 0 THEN
       freevec(workspace)
     IF switchspace \= 0 THEN
       freevec(switchspace)
     rc := n
     longjump(err.p, err.l)
  $)


AND cgsects(workvec, vecsize) BE
$(  LET p = workvec

    //                   A     Q     Y     X     L     P
    registers := TABLE #B000,#B100,#B110,#B010,#B101,#B001

    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.locked := p; p := p + 4
    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   := no
    any.globals := no
    incode      := no
    needslist   :=  0

    stv := p
    stvp := 0

    IF (stv - dp) > 0 THEN
      $( cgerror("Insufficient workspace")
         collapse(20)
      $)

    code(0, 0)
    code(sectionword, 0)

    op := rdn()
    IF op=0 RETURN

    $( LET v = VEC 17
       LET n = ?
       TEST op = s.section THEN
         $( n := rdn() // Actual length of SECTION name
            FOR i = 1 TO n DO
              $( LET k = rdn()
                 IF i <= 7 THEN v!i := k
              $)
            IF n>7 THEN n := 7
            putbyte(namesection, 0, n)
            FOR i = 1 TO n DO putbyte(namesection, i, v!i)
            FOR i = n + 1 TO 8 DO v!i := #40
            op := rdn()
         $)
        ELSE
         $( FOR i = 0 TO 8 DO
              v ! i := "************** " % i
            namesection := 0
         $)
       FOR i = 9 TO 17 DO v!i := datvec % (i - 8)
       v!0 := 17 // string length
       FOR i=0 TO 16 BY 2 DO code((v!i<<8)+v!(i+1), 0)
    $)

    scan()

    stv!0 := stvp

    IF any.globals THEN
      $( outputsection()
         progsize := progsize+stvp
      $)

   dp := vecsize + 1 - dp + stvp + stv
   IF dp > maxused THEN
     maxused := dp

$)  REPEAT

AND rdn() = VALOF
// Read in OCODE operator or argument
// Argument may be of form Ln
$(  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
$)

AND rdl() = rdn()
// read in OCODE label

AND rdgn() = VALOF
// read in global number
  $( LET g = rdn()
     IF maxgn<g THEN maxgn := g
     // MAXGN is highest referenced global
     RESULTIS g
  $)

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

AND initstack(n) BE
  // Initialise simulated stack
  $( 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 THEN maxssp := ssp
  $)

AND cgerror(n,a) BE
  $( writes("*N++++ Error: ")
     writef(n,a)
     newline()
  $)

AND stack(n) BE
// Move simulated stack pointer (SSP) to N
$(  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
    $)
$)

AND store(a, b) BE
$(  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.ry) 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)
    $)
$)

.

SECTION "CG20"

GET "BCPL-CG"

LET scan() BE
  // Switch on all possible OCODE operators
  $( SWITCHON op INTO
       $( 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:
            $( LET len = rdn()
               LET v   = dp - 4
               LET w   = ext.ref
               LET p   = 0
               dp      := v - 1
               checkspace()
               !dp       := needslist
               needslist := dp
               FOR i = 1 TO (len < 7 -> 7, len) DO
                 $( LET c = i > len -> ' ', rdn()
                    w := (w << 8) + c
                    IF i <= 7 & (i & 1) \= 0 THEN
                      $( v ! p := w
                         p     := p + 1
                      $)
                 $)
            $)
            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.putbyte:
            cgpendingop()
            cgputbyte(); 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.eq:      CASE s.ne:      CASE s.ls:
          CASE s.gr:      CASE s.le:      CASE s.ge:
          CASE s.lshift:  CASE s.rshift:  CASE s.abs:
          CASE s.logand:  CASE s.logor:   CASE s.getbyte:
          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.minus
            cgpendingop()
            loadt(k.numb, 0)
            pendingop := s.le
            op := s.jt
            // Simulate 'LN 0 LE JT Ln'

          CASE s.jt:  CASE s.jf:
            cgbranch(op, rdl())
            countflag := profcounting
            ENDCASE

          CASE s.goto:
            cgpendingop()
            store(0, ssp-2)
            gengoto(f.jmp, f.jmpe)
            incode := no
            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 := procstkp > 0
            countflag := profcounting
            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 THEN
              $( chkrefs(2)
                 gens(f.jst, 0, a.stkchk)
                 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:
            $( LET n = rdn()
               procstkp := procstkp-2
               IF stkchking DO
                 procstk!(procstkp+1)!stv := maxssp
               maxssp := procstk!procstkp
               cgstatics(no)
               ENDCASE
            $)

          CASE s.res:
            cgpendingop()
            store(0, ssp-2)
            movetor(arg1, r.a)
            genjmp(rdl())
            forgetall()
            stack(ssp-1)
            ENDCASE

          CASE s.rstack:
            initstack(rdn())
            loadt(k.reg, r.a)
            ENDCASE

          CASE s.finish:
            cgpendingop()
            // Simulate STOP(0)
            stack(ssp + 2)
            loadt(k.numb, 0)
            loadt(k.glob, 2)
            cgapply(s.rtap,ssp - 4)
            incode := no
            forgetall()
            ENDCASE

          CASE s.switchon:
            $( LET n = 2 * rdn() - 1
               switchspace := getvec(n)
               IF switchspace = 0 THEN
                 $( cgerror("can't get workspace for SWITCHON")
                    collapse(20)
                 $)
               cgswitch(switchspace, n)
               freevec(switchspace)
               switchspace := 0
               ENDCASE
            $)

          CASE s.global:
            $( LET ng = rdn()
               IF ng > 0 THEN
                 any.globals := yes
               cgglobal(ng)
            $)
            RETURN

          CASE s.datalab:
            cgdatawords(rdl())
            LOOP
       $)
     op := rdn()
  $) REPEAT

.

SECTION "CG30"

GET "BCPL-CG"

LET cgpendingop() BE
  // Generates code for any pending operator.
  // The simulated stack is left correct, and
  //  'pendingop' is set to s.none.
  $( LET sw = no

     SWITCHON pendingop INTO

       $( DEFAULT:
            cgerror("in CGPENDINGOP %N", op)

          CASE s.none:
            RETURN

          CASE s.eq: CASE s.ne: CASE s.ls:
          CASE s.le: CASE s.ge: CASE s.gr:
            cgrelop(pendingop)
            ENDCASE

          CASE s.plus: CASE s.minus:
            // Optimize 'address' +- const.
            $( LET a1, a2 = arg1, arg2
               IF h1 ! a2 = k.numb THEN
                 $( a1 := arg2
                    a2 := arg1
                 $)
               IF (h1!a2 = k.lvloc | h1!a2 = k.lvglob) &
                 h1 ! a1 = k.numb THEN
                 $( h2 ! arg2 := h2 ! a2 +
                      (pendingop=s.plus -> h2!a1, - h2!a1)
                    h1 ! arg2 := h1 ! a2
                    stack(ssp - 1)
                    ENDCASE
                 $)
               IF cgdyadic(pendingop, no) &
                 pendingop = s.minus THEN
                 // Operands reversed: negate result.
                 genrr(f.neg, h2 ! arg1, h2 ! arg1)
               ENDCASE
            $)

          CASE s.mult:
            cgmult()
            ENDCASE

          CASE s.rem:
            sw := yes

          CASE s.div:
            cgdiv(sw)
            ENDCASE

          CASE s.getbyte:
            cggetbyte()
            ENDCASE

          CASE s.logand:
            sw := yes

          CASE s.logor: CASE s.eqv: CASE s.neqv:
            // Use bit-change instructions if possible.
            $( LET a1, a2 = arg1, arg2
               IF h1 ! a2 = k.numb THEN
                 $( a1 := arg2
                    a2 := arg1
                 $)
               IF h1 ! a1 = k.numb THEN
                 $( LET n = h2 ! a1 NEQV sw
                    IF [n & (n - 1)] = 0 THEN
                      $( LET b = bitpos(n)
                         LET r = movetoaqy(a2)
                         LET f = (pendingop - s.logand) !
                         TABLE f.rbit,f.sbit,f.cbit,f.cbit
                         IF n \= 0 THEN
                           $( genbit(f,b,r)
                              forgetreg(r)
                           $)
                         lose1(r)
                         GOTO lop.done
                      $)
                 $)

               cgdyadic(pendingop, yes)

             lop.done:
               IF (h1 ! arg1 = k.reg) &
                  (pendingop = s.eqv) THEN
                 $( LET r = h2 ! arg1
                    genrr(f.comp,r,r)
                    forgetreg(r)
                 $)
               ENDCASE
            $)

          CASE s.lshift:
            sw := yes

          CASE s.rshift:
            cgshift(sw)
            ENDCASE

          CASE s.neg:
            sw := yes

          CASE s.not:
            $( LET r = movetoaqy(arg1)
               genrr((sw -> f.neg, f.comp), r,r)
               TEST reg.k ! r = k.numb THEN
                 reg.n ! r := NOT reg.n ! r - sw
                ELSE
                 forgetreg(r)
               ENDCASE
            $)

          CASE s.abs:
            $( LET r,l = movetoaqy(arg1), nextparam()
               genb(f.jge,r,l)
               genrr(f.neg,r,r)
               setlabel(l)
               unsetlabel()
               TEST reg.k ! r = k.numb THEN
                 reg.n ! r := ABS reg.n ! r
                ELSE
                 forgetreg(r)
            $)

       $)

     pendingop := s.none

  $)


AND bitpos(n) = VALOF
  // Delivers bit position (0 - 15) of
  //  the single bit in a power of two.
  $( LET b = -1
     $( n := n >> 1
        b := b + 1
     $) REPEATUNTIL n = 0
     RESULTIS b
  $)


AND cgdyadic(op, cant.use.y) = VALOF
  // Generates code for dyadic operator 'op'.
  //  op = 0 means a comparison and CSKs are
  //  generated.
  // yes is returned if the operands were
  //  reversed.
  $( LET r1, r2 = argreg(arg1), argreg(arg2)
     LET a1, a2, rev, optab = arg1, arg2, no, ?

     IF (h1 ! arg1 = k.numb = h1 ! a2) & (op \= 0) THEN
       $( evalconst(op)
          RESULTIS no
       $)

     // Now select a register.  Priority is given
     //  to a operand already in a register,
     //  either as K.REG or from the slave.

     IF r2 < 0 & r1 >= 0 THEN
         $( r2 := r1
            a2 := arg1
            a1 := arg2
            rev := yes
            r1 := -1
         $)

     TEST r2 >= 0 THEN // At least one already in reg.
       IF r2 = r.y & (cant.use.y | h1 ! a1 = k.glob) THEN
         $( r2 := movetoaq(a2)
            IF r2 = r1 THEN
              r1 := -1
         $)
      ELSE
       // Neither in register: prefer to load
       //  constant.
       $( IF h1 ! a1 = k.numb THEN
            $( a2 := arg1
               a1 := arg2
               TEST op = s.minus THEN
                 $( h2 ! a2 := - h2 ! a2
                    op := s.plus
                 $)
                ELSE
                 rev := yes
            $)

          TEST cant.use.y | (h1 ! a1 = k.glob) THEN
            r2 := movetoaq(a2)
           ELSE
            r2 := movetoaqy(a2)
       $)

     // Now we have 'a2' in register 'r2'.
     // Do the operation.


     h1 ! a2, h2 ! a2 := k.reg, r2

     optab := ftables(op)

     TEST r1 >= 0 THEN
       genrr(optab ! 3, r1, r2)
      ELSE

       $( LET k, n = h1 ! a1, h2 ! a1

          SWITCHON k INTO

            $( CASE k.lvloc:
               CASE k.lvlab:
               CASE k.lvglob:
                 genrr(optab ! 3, movetoaqy(a1), r2)
                 ENDCASE

               CASE k.numb:
                 IF n = 0 & op \= s.logand & op \= 0 THEN
                   // Value <op> 0 : No effect
                   ENDCASE
                 IF -255 <= n <= 0 & op = s.minus THEN
                   // x - -n = x + n
                   $( n := -n
                      op := s.plus
                      optab := ftables(op)
                   $)
                 TEST op = s.minus THEN
                   IF 1 <= n <= 256 THEN
                     $( geni(optab ! 2, r2, 256 - n)
                        ENDCASE
                     $)
                  ELSE
                   IF 0 <= n <= 255 THEN
                     $( geni(optab ! 2, r2, n)
                        ENDCASE
                     $)

               CASE k.lab: CASE k.glob:
               CASE k.loc: CASE k.ry: CASE k.abs:
                 genm(optab ! 0, optab ! 1, r2, k, n, 0)

            $)
       $)

     IF op \= 0 THEN
       $( forgetreg(r2)
          lose1(r2)
       $)

     RESULTIS rev

  $)

AND evalconst(op) BE
  // Evaluates arg2 <op> arg1, where both
  //  arg1 and arg2 are known to be constants.
  $( LET n2, n1 = h2 ! arg2, h2 ! arg1
     LET n = VALOF
       SWITCHON op INTO
         $( CASE s.plus:   RESULTIS n2 + n1
            CASE s.minus:  RESULTIS n2 - n1
            CASE s.logand: RESULTIS n2 & n1
            CASE s.logor:  RESULTIS n2 | n1
            CASE s.neqv:   RESULTIS n2 NEQV n1
            CASE s.eqv:    RESULTIS n2 EQV  n1
         $)
     stack(ssp - 1)
     h2 ! arg1 := n
  $)


AND ftables(op) = VALOF
  // Delivers TABLE of function codes for
  //  each operator.
  // op = 0 indicates CSK.
  SWITCHON op INTO
    $( CASE s.plus:
         RESULTIS TABLE f.add, f.adde, f.addi, f.addr
       CASE s.minus:
         RESULTIS TABLE f.sub, f.sube, f.subi, f.subr
       CASE s.logand:
         RESULTIS TABLE f.and, f.ande, f.andi, f.andr
       CASE s.logor:
         RESULTIS TABLE f.or,  f.ore,  f.ori,  f.orr
       CASE s.neqv: CASE s.eqv:
         RESULTIS TABLE f.xor, f.xore, f.xori, f.xorr
       CASE 0:
         RESULTIS TABLE f.csk, f.cske, f.cski, f.cskr
    $)


AND cgrelop(op) BE  // arg2 <op> arg1 -> yes or no.
  $( LET r, a1, a2, reversed = ?, arg1, arg2, no

     IF h1 ! a2 = k.numb THEN
       $( reversed := yes
          a2 := arg1
          a1 := arg2
       $)

     pendingop := s.none

     TEST (h1 ! a1 = k.numb) & (h2 ! a1) = 0 THEN
       $( // Special case of comparison with zero.
          // Each case is treated differently,
          //  and some rather contorted code is
          //  produced.
          LET label = 0

          r := movetoaqy(a2)

          IF reversed THEN
            op := revop(op)

          UNLESS (op = s.ls) | (op = s.ge) THEN
            label := nextparam()

          SWITCHON op INTO

            $( CASE s.eq:
                 //       JEQD   R,$+2
                 //       COPY   =0,R
                 genb(f.jeqd,r,label)
                 setrtok(r,0)
                 ENDCASE

               CASE s.ne:
                 //       JEQ    R,$+2
                 //       COPY   =-1,R
                 genb(f.jeq,r,label)
                 setrtok(r,-1)
                 ENDCASE

               CASE s.gr:
                 //       JEQ    R,$+3
                 genb(f.jeq,r,label)

               CASE s.ge:
                 //       COMP   R,R
                 genrr(f.comp,r,r)

               CASE s.ls:
                 //       SHIFT  R,RA,15
                 gensh(f.sra,r,15)
                 ENDCASE

               CASE s.le: // Rather horrible!
                 //       JEQD   R,$+3
                 //       ADD    =1,R
                 //       SHIFT  R,RA,15
                 genb(f.jeqd,r,label)
                 geni(f.addi,r,1)
                 gensh(f.sra,r,15)

            $)

          IF label \= 0 THEN
            $( setlabel(label)
               unsetlabel()
            $)

       $)
      ELSE

       TEST (op = s.eq) | (op = s.ne) THEN
         // Use subtract for = and ~=.
         $( cgdyadic(s.minus,no)
            TEST h1 ! arg1 = k.numb THEN
              h2 ! arg1 := (h2 ! arg1 = 0) = (op = s.eq)
             ELSE
              $( loadt(k.numb,0)
                 cgrelop(op)
              $)
            RETURN
         $)
        ELSE
         // General comparison (with CSK)
         $( LET eqval = (op = s.gr) | (op = s.ls) -> 0,-1
            r := unwantedreg()
            reg.locked ! r := yes
            freereg(r)
            setrtok(r,eqval)
            chkrefs(6) // CSKE!
            IF cgdyadic(0,yes) THEN
              op := revop(op)
            reg.locked ! r := no

            SWITCHON op INTO
              $( CASE s.gr: CASE s.le:
                   gens(f.jmp,0,m.rel+#X80+1)
                   setrtok(r,NOT eqval)
                   ENDCASE

                 CASE s.ls: CASE s.ge:
                   setrtok(r,NOT eqval)
                   genrr(f.lr,r.a,r.a)
              $)
         $)

     forgetreg(r)
     lose1(r)

  $)


AND unwantedreg() = VALOF
  $( LET r1, r2 = argreg(arg1), argreg(arg2)
     IF r1 < 0 THEN
       IF h1 ! arg1 = k.glob | h1 ! arg1 = k.ry THEN
         r1 := r.y
     IF r2 < 0 THEN
       IF h1 ! arg2 = k.glob | h1 ! arg2 = k.ry THEN
         r2 := r.y
     RESULTIS anybut(r1, r2)
  $)
.

SECTION "CG40"

GET "BCPL-CG"

LET movetoaqy(a) = VALOF
// move simulated stack item A to some suitable register
$(  LET k, n = h1!a, h2!a
    IF k=k.reg RESULTIS n
    FOR i = r.a TO r.y 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.ry UNLESS isfree(r.a) \/ isfree(r.q) DO
    $(  movetor(a, r.y)
        RESULTIS r.y
    $)
    RESULTIS movetor(a, anybut(-1, -1))
$)

AND movetoaq(a) = VALOF
$(  LET k, n = h1!a, h2!a
    LET r.afree = NOT reg.locked ! r.a
    LET r.qfree = NOT reg.locked ! r.q
    LET itemusingr.ar.q = -1
    LET s = -1 // will hold the chosen register
    IF k=k.reg & n\=r.y RESULTIS n // no work to do
    FOR t = tempv TO arg1 BY 3 IF h1!t=k.reg DO
    $(  LET r = h2!t
        UNLESS r.a<=r<=r.q LOOP
        IF itemusingr.ar.q=-1 DO itemusingr.ar.q := t
        TEST r=r.a
        THEN r.afree := no
        ELSE r.qfree := no
    $)
    // attempt to choose a suitable register
    IF r.qfree & reg.k!r.q=k.none DO s := r.q
    IF r.afree & reg.k!r.a=k.none DO s := r.a
    IF n=reg.n!r.q & k=reg.k!r.q & r.qfree DO s := r.q
    IF n=reg.n!r.a & k=reg.k!r.a & r.afree DO s := r.a
    IF s=-1 DO
    $(  IF r.qfree DO s := r.q
        IF r.afree DO s := r.a
    $)
    UNLESS s=-1 RESULTIS movetor(a, s)
    storet(itemusingr.ar.q)
$)  REPEAT

AND movetor(a, r) = VALOF
  // Move SS item 'a' to register 'r'.
  $( LET k, n, s = h1 ! a, h2 ! a, ?
     IF regusedby(a) \= r THEN
       freereg(r)
     s := argreg(a)
     IF n = reg.n ! r & k = reg.k ! r THEN
       // Prefer 'r'
       s := r
     IF s >= 0 THEN // Already in reg!
       $( IF s \= r THEN
            $( genrr(f.lr, s, r)
               moveinfo(s, r)
            $)
          GOTO ret
       $)

     SWITCHON k INTO

       $( CASE k.numb:
            setrtok(r, n)
            ENDCASE

          CASE k.lvloc:
            gene(f.cea, r, m.x, n)
            ENDCASE

          CASE k.lvlab:
            gene(f.cea, r, m.rel, eref(k,n))
            ENDCASE

          CASE k.lvglob:
            setrtok(r, n)
            genrr(f.addr, r.l, r)
            ENDCASE

          CASE k.loc: CASE k.glob:
          CASE k.lab: CASE k.ry: CASE k.abs:
            genm(f.l, f.le, r, k, n, 0)

       $)

     setinfo(r, k, n)
ret: h1 ! a, h2 ! a := k.reg, r
     RESULTIS r
  $)

AND storet(a) BE
// stores simulated stack item A in true stack location
$(  LET s, r = h3!a, ?
    IF h1!a=k.loc & h2!a=s RETURN
    // item already there

    r := movetoaqy(a)
    gensore(f.st, f.ste, r, m.x, s)
    forgetvar(k.loc, s)
    remem(r, k.loc, s)
    h1!a, h2!a := k.loc, s
$)

AND anybut(r1, r2) = VALOF
  // Return any free register except 'r1' and 'r2'
  $( FOR i = r.a TO r.q DO
       IF r1\=i & r2 \= i & reg.k!i=k.none &
         isfree(i) THEN
         RESULTIS i

     FOR i = r.a TO r.q DO
       IF r1 \= i & r2 \= i & isfree(i) THEN
         RESULTIS i

    IF r1\=r.y & r2 \= r.y  & isfree(r.y) THEN
      RESULTIS r.y
     FOR t = tempv TO arg1 BY 3 DO
       $( LET s = regusedby(t)
          IF s=-1 | s=r1 | s = r2 THEN LOOP
         storet(t)
         // This will free S and so
         RESULTIS s
       $)
  $)

AND freereg(r) BE
  $( LET t = itemusing(r)
     IF t=-1 THEN RETURN
     storet(t)
  $)

AND itemusing(r) = VALOF
$(  FOR p = tempv TO arg1 BY 3
        IF (r=h2!p & h1!p=k.reg) \/
            (r=r.y & h1!p=k.ry) RESULTIS p
    RESULTIS -1
$)

AND forgetall() BE
  FOR r = r.a TO r.y DO
    reg.k!r, reg.n!r, reg.locked!r := k.none, 0, no

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 = r.a  TO r.y
    IF reg.n!r = n & reg.k!r = k THEN forgetreg(r)

AND forgetallvars() BE
  // Called after BCPL indirect assignment
  FOR r = r.a TO r.y DO
    $( LET k = reg.k!r
       IF k=k.loc | k=k.glob | k=k.lab | k=k.abs THEN
         forgetreg(r)
    $)

AND remem(r, k, n) BE
  IF reg.k!r=k.none THEN
    reg.k!r, reg.n!r := k, n

AND setinfo(r, k, n) BE
  TEST k=k.reg | k=k.ry 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


AND argreg(a) = VALOF
  // Returns register containing 'a', either via
  //  SS or the slave.
  TEST h1 ! a = k.reg THEN
    RESULTIS h2 ! a
   ELSE
    $( LET k, n = h1 ! a, h2 ! a
       FOR r = r.a TO r.y DO
         IF reg.k ! r = k & reg.n ! r = n THEN
           IF isfree(r) THEN
             RESULTIS r
       RESULTIS -1
    $)


.

SECTION "CG50"

GET "BCPL-CG"

LET loadt(k, n) BE
// load item (K, N) onto the simulated stack
$(  cgpendingop()
    arg2 := arg1
    arg1 := arg1+3
    IF arg1=tempt DO
    $(  cgerror("IN LOADT")
        collapse(20)
    $)
    h1!arg1, h2!arg1, h3!arg1 := k, n, ssp
    ssp := ssp+1
    IF maxssp<ssp DO maxssp := ssp
$)

AND lose1(r) BE
// replace top two items of simulated stack
// by contents of register R
  $( stack(ssp-1)
     h1!arg1, h2!arg1 := k.reg, r
  $)

AND regusedby(t) = h1!t=k.reg -> h2!t,
                   h1!t=k.ry -> r.y, -1

AND isfree(r) = VALOF
$(  IF r=r.x | reg.locked!r THEN RESULTIS no
    FOR t = tempv TO arg1 BY 3
        IF regusedby(t)=r RESULTIS no
    RESULTIS yes
$)

AND storei() BE
// Compile indirect assignment
$(  LET k, r, m = findoffset(), 0, 0
    store(0, ssp-3)
    r := movetoaq(arg2)
    TEST h1 ! arg1 = k.numb THEN
      k := k + h2 ! arg1
     ELSE
      $( movetor(arg1, r.y)
         m := m.y
      $)
    gensore(f.st, f.ste, r, m, k)
    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 Y corresponds to the value of
    // item ARG1
    stack(ssp-2)
$)

AND findoffset() = VALOF  // used by STOREI and CGRV
$(  IF pendingop=s.minus & h1!arg1=k.numb DO
        pendingop, h2!arg1 := s.plus, -h2!arg1
    IF pendingop=s.plus DO
    $(  LET k, n, a = k.none, 0, 0
        IF h1 ! arg2 = k.numb THEN
          k, n, a := h1!arg1, h2!arg1, h2!arg2
        IF h1 ! arg1 = k.numb THEN
          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
        $)
    $)
    cgpendingop()
    RESULTIS 0
$)

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
$(  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
    $(
    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
                      $( chkrefs(4)
                         TEST m > 0 THEN
                           genm(f.ims, f.imse, 0, k, n, 0)
                          ELSE
                           genm(0,     f.dmse, 0, k, n, 0)
                         code(f.nop, 0)
                         forgetvar(k, n)
                      $)
                    pendingop := s.none
                    stack(ssp-2)
                    RETURN
                $)3
    $)

    cgpendingop()


    TEST k = k.glob THEN
      r := movetoaq(arg1)
     ELSE
      r := movetoaqy(arg1)
    genm(f.st, f.ste, r, k, n, 0)
    forgetvar(k, n)
    remem(r, k, n)
    stack(ssp-1)
$)


AND cglab(n, len) BE
  // Sets label 'n' for data of length 'len'
  $( UNLESS incode THEN
       $( LET nref = 0
          $( LET p = krefv
             WHILE p \= krefp DO
               TEST (h2!p=k.lab|h2!p=k.jlab) & h3!p=n THEN
                 $( IF nref = 0 THEN
                      nref := p
                    p := p + 3
                 $)
                ELSE BREAK
             // 'p' is for a label other than 'n'
             IF refinrange(p, len) THEN
               BREAK
             IF nref \= 0 & h1 ! nref <= stvp THEN
               $( dealwithkref(nref)
                  nref := 0
                  LOOP
               $)
             dealwithkref(p)
          $) REPEAT
       $)
     setlabel(n)
  $)

AND cgrv() BE
// Make top stack item addressable by Y
  $( LET n = findoffset()
     TEST h1 ! arg1 = k.numb THEN
       h1 ! arg1, h2 ! arg1 := k.abs, h2 ! arg1 + n
      ELSE
       $( movetor(arg1, r.y)
          h1!arg1, h2!arg1 := k.ry, n
       $)
  $)

AND cgmult() BE
  $( LET a1, a2 = arg1, arg2

     IF h1 ! a2 = k.numb THEN
       $( a1 := arg2
          a2 := arg1
       $)

     movetor(a2,r.q)

     IF h1 ! a1 = k.numb THEN
       $( LET n  = h2 ! a1
          LET an = ABS n
          IF [an & (an - 1)] = 0 THEN
            $( TEST an = 0 THEN
                 setrtok(r.q, 0)
                ELSE
                 IF an \= 1 THEN
                   gensh(f.sll,r.q,bitpos(an))
               IF n < 0 THEN
                 genrr(f.neg,r.q,r.q)
               GOTO mul.done
            $)
       $)

     IF h1 ! a1 = k.lvlab | h1 ! a1 = k.lvloc |
        h1 ! a1 = k.reg   | h1 ! a1 = k.lvglob THEN
       storet(a1)

     freereg(r.a)
     setrtok(r.a, 0)

     genm(0, f.mul, r.q, h1 ! a1, h2 ! a1, 0)
     forgetreg(r.a)

mul.done:
     forgetreg(r.q)

     lose1(r.q)

  $)


AND cgdiv(remainder) BE
  $( IF h1 ! arg1 = k.reg   | h1 ! arg1 = k.lvloc |
        h1 ! arg1 = k.lvlab | h1 ! arg1 = k.lvglob THEN
       storet(arg1)

     movetor(arg2,r.a)
     freereg(r.q)
     gensh(f.srda,r.q,16)
     genm(0, f.div, r.q, h1 ! arg1, h2 ! arg1, 0)
     forgetreg(r.a)
     forgetreg(r.q)
     lose1((remainder -> r.a, r.q))
  $)


AND cgshift(left) BE
  $( LET r = ?
     TEST h1 ! arg1 = k.numb THEN
       $( LET n = h2 ! arg1
          r := movetoaqy(arg2)
          TEST 0 <= n <= 16 THEN
            IF n \= 0 THEN
              $( gensh((left -> f.sll,f.srl),r,n)
                 forgetreg(r)
              $)
           ELSE
            setrtok(r, 0)
       $)
      ELSE
       $( movetor(arg1,r.q)
          movetor(arg2,r.a)
          freereg(r.y)
          gens(f.jst,0,(left -> a.lshift, a.rshift))
          forgetall()
          r := r.a
       $)
     lose1(r)
  $)


AND cggetbyte() BE
  $( movetor(arg1,r.q)
     movetor(arg2,r.y)
     freereg(r.a)
     gens(f.jst,0,a.gbyte)
     forgetall()
     lose1(r.a)
  $)


AND cgputbyte() BE
  $( movetor(arg1,r.q)
     loadarg(ssp-3,h3!tempv,r.a)
     movetor(arg2,r.y)
     gens(f.jst,0,a.pbyte)
     forgetall()
     stack(ssp-3)
  $)

.

SECTION "CG60"

GET "BCPL-CG"

LET cgstatics() BE
  // Generate all STATIC (length 1) items
  $( LET d = @ dlist
     UNTIL !d = 0 DO
       $( LET data = !d
          LET k = h2 ! data >> 14
          TEST k = d.iteml | k = d.itemn THEN
            $( LET l = h2 ! data & #X3FFF
               cglab(l, 1)
               TEST k = d.itemn THEN
                 code(h3 ! data, 0)
                ELSE
                 code(0, h3 ! data)
               IF ! data = 0 THEN
                 dliste := d
               ! d := ! data
               rtnblk(data)
            $)
           ELSE
            d := data
       $)
  $)


AND cgdatablks() BE
  // Generate all multi-word items.
  //  i.e. Strings, tables and label vectors
  $( LET d = dlist
     UNTIL d = 0 DO
       $( LET k, l = h2 ! d >> 14, h2 ! d & #X3FFF
          LET n    = h3 ! d
          labv ! l := stvp
          FOR j = -1 TO -n BY -1 DO
            TEST k = d.blkl THEN
              code(0, d ! j)
             ELSE
              code(d ! j, 0)
          d := h1 ! d
       $)
  $)


AND cgglobal(n) BE
  $( cgstatics()
     chkrefs(200)
     cgerefs()
     cgdatablks()
     code(0, 0)
     FOR i = 1 TO n DO
       $( code(rdgn(), 0)
          code(labv!rdl(), 0)
       $)
     code(maxgn, 0)
  $)


AND cgdata(l, k, n) BE
  $( LET p = getblk()
     LET d = k = s.iteml -> d.iteml, d.itemn
     h2 ! p, h3 ! p := (d << 14) + l, n
     !dliste := p
     dliste := p
  $)


AND cgstring(n) BE
  $( LET l, w = nextparam(), n << 8
     LET b    = getdatablk(l, s.itemn)
     loadt(k.lvlab, l)
     $( IF n \= 0 THEN
          w := w | rdn()
        putdatablkitem(b, w)
        IF n <= 1 THEN
          RETURN
        n, w := n - 2, rdn() << 8
     $) REPEAT
  $)


AND cgdatawords(labno) BE
  $( LET type = rdn()
     LET dl   = type = s.iteml
     LET b, n = ?, ?

     IF type \= s.itemn & NOT dl THEN
       $( op := type
          getdatablk(labno, s.itemn)
          RETURN
       $)

     n := dl -> rdl(), rdn()
     op := rdn()
     IF op \= type THEN
       $( cgdata(labno, type, n)
          RETURN
       $)

     b := getdatablk(labno, type)

     putdatablkitem(b, n)

     $( n := dl -> rdl(), rdn()
        putdatablkitem(b, n)
        op := rdn()
     $) REPEATWHILE op = type
  $)


AND getdatablk(label, type) = VALOF
  $( LET d = type = s.iteml -> d.blkl, d.blkn
     dp := dp - 3
     checkspace()
     dp ! 0, dp ! 2 := 0, 0
     dp ! 1 := (d << 14) + label
     ! dliste := dp
     dliste   := dp
     RESULTIS dp
  $)


AND putdatablkitem(b, n) BE
  $( dp := dp - 1
     checkspace()
     ! dp := n
     b ! 2 := b ! 2 + 1
  $)



AND cgerefs() BE
  // Satisifies all remaining extended references.
  UNTIL ereflist = 0 DO
    $( LET n = h3 ! ereflist
       $( LET p = geteref(n)
          IF p = 0 THEN
            BREAK
          fillineref(p, stvp)
       $) REPEAT
       code(n, 0)
    $)



AND setrtok(r, k) = VALOF
  // Can load byte in range -256 to +255.
  $( IF reg.n ! r = k & reg.k ! r = k.numb THEN
       RESULTIS r
     TEST -256 <= k <= -1 THEN
       geni(f.lbni,r,k & #XFF)
      ELSE
       TEST 0 <= k <= 255 THEN
         geni(f.lbpi,r,k)
        ELSE
         gens(f.l,r,mref(k.numb,k))
     setinfo(r,k.numb,k)
     RESULTIS r
  $)

AND getblk() = VALOF
$(  LET p = freelist
    TEST p=0
    THEN
    $(  dp := dp-3
        checkspace()
        p := dp
    $)
    ELSE freelist := h1!freelist
    !p := 0
    RESULTIS p
$)

AND rtnblk(p) BE
$(  !p := freelist
    freelist := p
$)

.

SECTION "CG70"

GET "BCPL-CG"

LET cgentry() BE
$(  LET n = rdn()
    LET l = rdl()
    LET v = VEC 7
    chkrefs(20)
    v!0 := 7  // string length
    FOR i = 1 TO n DO
    $(  LET k=rdn()
        IF i <= 7 DO v!i := k
    $)
    FOR i = n+1 TO 7 DO v!i := #40  // ASCII space
    IF naming FOR i = 0 TO 6 BY 2 DO
        code((v!i<<8)+v!(i+1), 0)

    setlabel(l)
    incode := yes

    // Entry sequence

    code(0, 0)  // Return link!
    gens(f.l, r.y, m.rel + #X80 - 2)
    gens(f.add, r.x, m.y)
    gens(f.st, r.y, m.x)
    IF naming THEN
      $( genrr(f.lr, r.p, r.y)
         gens(f.st, r.y, m.x + 1)
      $)
    IF callcounting DO
      insertcount()
$)

AND cgsave(n) BE
  $( LET j = n - 3
     IF j > 1 THEN j := 1
     forgetall()
     FOR r = 0 TO j DO
       $( gens(f.st, r.a + r, r + 2 + m.x)
          setinfo(r.a + r, k.loc, r + 2)
       $)
     initstack(n)
  $)

AND cgapply(op, k) BE
  $( cgpendingop()
     $( LET base = h3!tempv
        LET notloaded = VEC 1
        LET a = ssp - k - 4
        store(k+4, ssp-2)  // store args 3,...

        // Now deal with non-args
        FOR t = tempv TO arg2 BY 3 DO
          $( IF h3!t>k THEN BREAK
             IF regusedby(t)>=0 THEN storet(t)
          $)

        IF a > 1 THEN a := 1

        notloaded ! 0, notloaded ! 1 := yes, yes

        FOR r = 0 TO a DO
          IF isfree(r + r.a) THEN
            $( loadarg(k + 2 + r, base, r + r.a)
               notloaded ! r := no
            $)
        FOR r = 0 TO a DO
          IF notloaded ! r THEN
            loadarg(k + 2 + r, base, r + r.a)
     $)
     chkrefs(4)
     gengoto(f.jst, f.jste)
     IF incode THEN
       code(k, 0)
     forgetall()
     stack(k)
     IF op = s.fnap THEN loadt(k.reg, r.a)
  $)


AND loadarg(s, base, r) BE
  TEST s >= base THEN
    movetor(tempv + (s - base) * 3, r)
   ELSE
    $( freereg(r)
       gensore(f.l, f.le, r, m.x, s)
       forgetreg(r)
    $)


AND cgreturn(op) BE
  $( cgpendingop()
     IF op=s.fnrn THEN
       $( movetor(arg1, r.a)
          stack(ssp-1)
       $)
     gens(f.jmp, 0, a.rtn)
     incode := no
     initstack(ssp)
  $)

.

SECTION "CG80"

GET "BCPL-CG"

LET cgswitch(v, m) BE
  // Compile code for SWITCHON
  // N: number of cases
  // D: default label
  $( LET n = (m+1)/2
     LET d = rdl()
     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
     FOR i = 1 TO n DO
       $( LET k = rdn()
          LET l = rdl()
          LET j = i
          WHILE j > 1 DO
            $( IF k > casek ! (j - 1) THEN
                 BREAK
               casek ! j := casek ! (j - 1)
               casel ! j := casel ! (j - 1)
               j := j - 1
            $)
          casek ! j, casel ! j := k, l
       $)

     cgpendingop()
     store(0, ssp-2)

     // Comparison is probably not right yet!!!!!!!!
     TEST 4*n-10>casek!n/2-casek!1/2 THEN
       lswitch(1, n, d)
      ELSE
       $( swreg := movetoaq(arg1)
          bswitch(1, n, d)
          stack(ssp - 1)
          genjmp(d)
          forgetreg(swreg)
       $)
  $)

AND bswitch(p, q, d) BE
  // Binary chop instance
  TEST q > p THEN
    $( LET m = nextparam()
       LET t = (p + q)/2
       incode := yes
       loadt(k.numb, casek ! t)
       chkrefs(4)
       cgdyadic(0, yes)
       stack(ssp - 1)
       gens(f.jmp, 0, m.rel + #X82) // JMP $+3
       genjmp(m)
       incode := yes
       genjmp(casel ! t)
       bswitch(p, t - 1, d)
       genjmp(d)
       cglab(m, 0)
       bswitch(t + 1, q, d)
    $)
   ELSE
    IF p = q THEN
      $( incode := yes
         loadt(k.numb, casek ! q)
         pendingop := s.eq
         cgbranch(s.jt, casel ! p)
         loadt(k.reg, swreg)
      $)


AND lswitch(p, q, d) BE
  $( LET l = nextparam()
     LET b = ?
     swreg := movetoaq(arg1)
     loadt(k.numb, casek ! p)
     pendingop := s.ls
     cgbranch(s.jt, d)
     loadt(k.reg, swreg)
     loadt(k.numb, casek ! q)
     pendingop := s.gr
     cgbranch(s.jt, d)
     loadt(k.reg, swreg)
     movetor(arg1, r.y)
     stack(ssp - 1)
     gene(f.jmpe, 0, m.y+m.i+m.rel, eref(k.lab,l)-casek!p)
     b := getdatablk(l, s.iteml)
     FOR k = casek ! p TO casek ! q DO
       TEST casek ! p = k THEN
         $( putdatablkitem(b, casel ! p)
            p := p+1
         $)
        ELSE
         putdatablkitem(b, d)
  $)

.

SECTION "CG90"

GET "BCPL-CG"

LET revop(op) = VALOF
    SWITCHON op INTO
    $(
    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
    $)


AND cgbranch(op, l) BE
  $( LET b = op = s.jt
     LET a1, a2, f = ?, ?, ?
     LET r, reversed = ?, no

     SWITCHON pendingop INTO
       $( DEFAULT:
            cgpendingop()
            loadt(k.numb,0)
            pendingop := s.ne

          CASE s.eq: CASE s.ne: CASE s.ls:
          CASE s.le: CASE s.ge: CASE s.gr:
            f := b -> pendingop, compop(pendingop)
       $)

     store(0, ssp - 3)

     a1, a2 := arg1, arg2

     IF h1 ! a2 = k.numb THEN
       $( reversed := yes
          a1 := arg2
          a2 := arg1
       $)

     TEST h1 ! a1 = k.numb & h2 ! a1 = 0 THEN
       // Comparison with zero!
       $( IF reversed THEN
            f := revop(f)
          r := movetoaqy(a2)
          genb((f - s.eq) !
          [TABLE f.jeq,f.jne,f.jlt,f.jgt,f.jle,f.jge],r,l)
       $)
      ELSE
       TEST (f = s.eq) | (f = s.ne) THEN
         $( cgdyadic(s.minus,no)
            TEST h1 ! arg1 = k.numb THEN
              IF (h2 ! arg1 \= 0) = (f = s.ne) THEN
                genjmp(l)
             ELSE
              genb((f = s.eq -> f.jeq,f.jne),h2!arg1,l)
            stack(ssp-1)
            pendingop := s.none
            RETURN
         $)
        ELSE
         $( chkrefs((f = s.gr | f = s.ls -> 7,8))
            IF cgdyadic(0, yes) THEN
              f := revop(f)
            TEST f = s.gr | f = s.ge THEN
              $( TEST f = s.gr THEN
                   gens(f.jmp, 0, m.rel + #X80 + 1)
                  ELSE
                   gens(f.jmp, 0, m.rel + #X80 + 2)
                 genjmp(l)
                 incode := yes
              $)
             ELSE
              $( genjmp(l)
                 incode := yes
                 TEST f = s.ls THEN
                   code(f.nop, 0)
                  ELSE
                   gens(f.jmp, 0, m.rel + #X80 + 1)
              $)
            IF f = s.le | f = s.ge THEN
              genjmp(l)
            incode := yes
         $)

     stack(ssp - 2)
     pendingop := s.none

  $)

AND compop(op) = (op - s.eq) !
  [TABLE s.ne, s.eq, s.ge, s.le, s.gr, s.ls]


AND code(a, l) BE
// compile a word
$(  UNLESS l=0 DO labref(l, stvp)
    stv!stvp := a
    incrstvp()
$)

AND gensh(op, r, bits) BE // Eg. SHIFT AQ,RA,16
  IF incode THEN
    $( chkrefs(1)
       code(op + (registers!r<<12) + ((bits-1)<<4),0)
    $)

AND gens(op, r, a) BE // Eg. ADD 2(Y),A
  IF incode THEN
    $( chkrefs(1)
       code(op + (registers ! r << 12) + a,0)
    $)

AND gene(op, r, mode, a) BE // Eg. MUL LAB,AQ
  IF incode THEN
    $( chkrefs(2)
       code(op + (registers ! r << 12) + (mode >> 2),0)
       code(a,0)
    $)

AND gensore(op.s, op.e, r, mode, a) BE
  TEST (0 <= a <= 63) & (op.s \= 0) THEN
    gens(op.s, r, mode + a)
   ELSE
    gene(op.e, r, mode, a)

AND genrr(op, s, d) BE
  IF incode THEN
    $( chkrefs(1)
       code(op + (registers!d<<12) + (registers!s<<4),0)
    $)

AND geni(op, r, imop) BE // Eg. ADD =1,A
  IF incode THEN
    $( chkrefs(1)
       code(op + (registers!r<<12) + imop, 0)
    $)

AND genbit(op, bit, r) BE // Eg. CBIT 13,A
  IF incode THEN
    $( chkrefs(1)
       code(op + (registers ! r << 12) + (bit << 4),0)
    $)

AND genb(op, r, l) BE
  gens(op, r, mref(k.jlab, l))


AND genjmp(l) BE
$(  gens(f.jmp, 0, mref(k.lab, l))
    incode := no
$)

AND insertcount() BE
// produce code for profcounting option
$(  countflag := no
    freereg(r.y)
    chkrefs(3)
    gens(f.jst, 0, a.prfc)
    forgetreg(r.y)
    code(0, 0)
    code(0, 0)
$)

AND labref(l, a) BE
$(  LET p = getblk()
    h2!p, h3!p := l, a
    !refliste := p
    refliste := p
    nlabrefs := nlabrefs+1
$)

AND initdatalists() BE
$(  reflist := 0
    ereflist := 0
    refliste := @reflist
    nlabrefs := 0
    dlist := 0
    dliste := @dlist
$)

AND checkspace() BE
  IF (stv + stvp - dp) >= 0 THEN
    $( cgerror("program too large after %N words", stvp)
       collapse(20)
    $)

AND incrstvp() BE
  $( stvp := stvp + 1
     checkspace()
     $( IF kcmpp = kcmpv THEN
          BREAK
        UNLESS h1!kcmpv < stvp THEN
          BREAK
        removerefsto(h1!kcmpv,h2!kcmpv,h3!kcmpv)
        kcmpp := kcmpp - 3
        FOR p = kcmpv TO kcmpp - 1 DO
          p ! 0 := p ! 3
     $) REPEAT
  $)


.

SECTION "CG100"

GET "BCPL-CG"

LET chkrefs(n) BE
  $( IF countflag THEN
       insertcount()
     UNTIL refinrange(krefv, n) DO
       dealwithkref(krefv)
     IF skiplab=0 THEN RETURN
     setlabel(skiplab)
     unsetlabel()
     skiplab := 0
     incode := yes
  $)

AND setlabel(n) BE
  $( // Try to remove JMP $+1's
     IF ((krefp - krefv) >= 3) & NOT incode THEN
       $( LET lk = krefp - 3
          LET a, k = h1 !lk, h2 ! lk
          a := a - (k = k.jlab -> 64, 128)
          IF (a = stvp-1) & k \= k.numb & h3!lk = n THEN
            $( stvp := stvp - 1
               krefp := lk
            $)
       $)
     labv!n := stvp
     $( LET p = getkref(k.lab, n)
        IF p = 0 THEN
          BREAK
        fillinrelref(p, stvp, 0, k.lab)
     $) REPEAT
     $( LET p = getkref(k.jlab, n)
        IF p = 0 THEN
          BREAK
        fillinrelref(p, stvp, 0, k.jlab)
     $) REPEAT
  $)

AND unsetlabel() BE
  $( labv ! paramnumber := -1
     paramnumber := paramnumber + 1
  $)


AND dealwithkref(t) BE
  $( LET p, k, n, ind = h1 ! t, h2 ! t, h3 ! t, 0
     krefp := krefp - 3
     FOR q = t TO krefp - 1 DO
       q ! 0 := q ! 3

     SWITCHON k INTO
       $( CASE k.lab:
            ind := m.i

          CASE k.jlab:
            $( LET a = getkcmp(k, n)
               IF a \= 0 THEN
                 $( fillinrelref(p, a, ind, k)
                    RETURN
                 $)

             $)
        $)

     IF incode THEN
       $( skiplab := nextparam()
          addkref(k.lab, skiplab, 128)
          code(f.jmp + m.rel, 0)
          incode := no
       $)

     fillinrelref(p, stvp, ind, k)
     addkcmp(k, n)

     SWITCHON k INTO
       $( CASE k.lab:
            code(0, n)
            ENDCASE

          CASE k.numb:
            code(n, 0)
            ENDCASE

          CASE k.jlab:
            addkref(k.lab, n, 128)
            code(f.jmp + m.rel, 0)

       $)

  $)


AND fillinrelref(p, a, bits, k) BE
  TEST k = k.jlab THEN
    $( p := p - 64
       stv ! p := stv ! p + a - p + #X3F
    $)
   ELSE
    $( p := p -128
       stv ! p := stv ! p + a - p + #X7F + bits
    $)


AND fillineref(p, a) BE
  stv ! p := stv ! p + a - p - 1


AND refinrange(p, n) =
  p = krefp -> yes,
  (p+3-krefp)<0 & h1!p+1>=h1!(p+3) -> refinrange(p+3,n+1),
  h1 ! p > stvp + n

AND removerefsto(a, k, n) BE
  $( LET bits = (k = k.lab -> m.i, 0)
     a := a - (k = k.jlab -> 63, 127)
     $( LET p = getkref(k, n)
        IF p = 0 THEN
          BREAK
        fillinrelref(p, a, bits, k)
     $) REPEAT
  $)



AND gengoto(f.short, f.extended) BE
  // Used for GOTO and calls.
  $( LET k, n = h1 ! arg1, h2 ! arg1
     SWITCHON k INTO

       $( CASE k.lvloc: CASE k.lvlab:
          CASE k.reg:   CASE k.lvglob:
          CASE k.loc:
            movetor(arg1, r.y)
            gens(f.short, 0, m.y)
            ENDCASE

          CASE k.lab: // Relative indirect reference!
            $( LET a, d = labv ! n, ?
               chkrefs(1)
               d := a - stvp
               IF a >= 0 & (-127 <= d <= 128) THEN
                 $( gens(f.short, 0, m.i+m.rel+#X80+d-1)
                    ENDCASE
                 $)
               f.short := 0
            $)

          CASE k.numb: CASE k.abs:
          CASE k.glob: CASE k.ry:
            genm(f.short, f.extended, 0, k, n, m.i)
       $)

  $)


AND movgtoy() BE
  IF reg.k ! r.y \= k.lvglob | reg.n ! r.y \= 0 THEN
    $( freereg(r.y)
       genrr(f.lr, r.l, r.y)
       setinfo(r.y, k.lvglob, 0)
    $)


AND genm(f.short, f.extended, r, k, n, mode) BE
  // Generates memory reference instruction.
  $( LET m = (k = k.abs -> 0, m.x)

     SWITCHON k INTO

       $( DEFAULT:
            cgerror("in GENM %N", k)
            ENDCASE

          CASE k.numb: CASE k.lab:
            TEST f.short = 0 THEN
              gene(f.extended, r, m.rel + mode, eref(k,n))
             ELSE
              gens(f.short, r, mode + mref(k,n))
            ENDCASE

          CASE k.glob:
            movgtoy()

          CASE k.ry:
            m := m.y

          CASE k.loc: CASE k.abs:
            gensore(f.short, f.extended, r, mode + m, n)

       $)

  $)


AND mref(k, n) = VALOF
  TEST incode THEN
    $( LET max, mode = 128, m.rel
       chkrefs(1)
       SWITCHON k INTO
         $( CASE k.numb:
              $( LET a = getkcmp(k, n)
                 IF a \= 0 THEN
                   RESULTIS reladdr(a)
                 ENDCASE
              $)

            CASE k.jlab:
              mode, max := 0, 64

            CASE k.lab:
              $( LET a = labv ! n
                 IF a > 0 & (- max < (a-stvp) <= max) THEN
                   TEST k = k.lab THEN
                     RESULTIS reladdr(a)
                    ELSE
                     RESULTIS a - stvp + #X3F
                 ENDCASE
              $)

         $)
       addkref(k, n, max)
       RESULTIS mode
    $)
   ELSE
    RESULTIS 0


AND reladdr(a) = m.rel + a - stvp + #X7F



AND eref(k, n) = VALOF
  // Extended ref to (K, N)
  $( IF NOT incode THEN
       RESULTIS 0
     chkrefs(2)
     TEST k = k.numb THEN
       $( LET a = getkcmp(k, n)
          TEST a \= 0 THEN
            RESULTIS a - stvp - 2
           ELSE
            $( LET p = getblk()
               !p := ereflist
               ereflist := p
               h2 ! p := stvp + 1
               h3 ! p := n
            $)
       $)
      ELSE
       labref(- n, stvp + 1)

     RESULTIS 0
  $)


AND addkcmp(k, n) BE
  $( IF kcmpp = kcmpt THEN
       $( removerefsto(h1!kcmpv, h2!kcmpv, h3!kcmpv)
          kcmpp := kcmpp - 3
          FOR p = kcmpv TO kcmpp-1 DO p!0 := p!3
       $)
     $( LET l = stvp + (k = k.jlab -> 63, 127)
        LET c = kcmpp - 3
        WHILE (c - kcmpv) >= 0 & l < h1 ! c DO
          c := c - 3
        c := c + 3
        FOR k = kcmpp - 1 TO c BY -1 DO
          k ! 3 := k ! 0
        kcmpp := kcmpp + 3
        h1 ! c, h2 ! c, h3 ! c := l, k, n
     $)
     IF k = k.numb THEN
       $( $( LET p = getkref(k, n)
             IF p = 0 THEN
               BREAK
             fillinrelref(p, stvp, 0, k)
          $) REPEAT
          $( LET p = geteref(n)
             IF p = 0 THEN
               BREAK
             fillineref(p, stvp)
          $) REPEAT
       $)
  $)

AND getkcmp(k, n) = VALOF
// returns address of recently compiled constant (K, N)
$(  FOR p = kcmpp-3 TO kcmpv BY -3
       IF h3!p=n & h2!p=k THEN
         RESULTIS h1 ! p - (k = k.jlab -> 63, 127)
    RESULTIS 0
$)

AND addkref(k, n, max) BE
  $( LET l = stvp + max
     LET r = krefp - 3
     IF krefp = kreft THEN
       $( cgerror("in ADDKREF")
          collapse(20)
       $)
     WHILE (r - krefv) >= 0 & l < h1 ! r DO
       r := r - 3
     r := r + 3
     FOR k = krefp - 1 TO r BY -1 DO
       k ! 3 := k ! 0
     krefp := krefp + 3
     h1 ! r, h2 ! r, h3 ! r := l, k, n
  $)

AND getkref(k, n) = VALOF
// returns address of instruction making reference (K, N)
// and removes item from KREFV
$(  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 0
$)

AND geteref(n) = VALOF
  $( LET e = @ ereflist
     UNTIL ! e = 0 DO
       $( LET r = ! e
          IF h3 ! r = n THEN
            $( LET p = h2 ! r
               !e := h1 ! r
               rtnblk(r)
               RESULTIS p
            $)
          e := r
       $)
     RESULTIS 0
  $)

.

SECTION "CG110"

GET "BCPL-CG"

LET outputsection() BE
  // Output hex assembly text
  $( LET rl = reflist
     LET nr = 0
     UNTIL rl = 0 DO
       $( LET l = h2 ! rl
          LET ln = ABS l
          LET labval = labv ! ln
          LET a = h3 ! rl
          IF labval=-1 THEN
            cgerror("label l%N unset", l)
          stv!a := stv!a + (l < 0 -> labval-a-1, labval)
          IF l >= 0 THEN nr := nr + 1
          rl := !rl
       $)
     selectoutput(codestream)
     TEST altobj DO
       $( LET nl = needslist
          IF namesection \= 0 DO
            writef(" TITL %S*N", namesection)
          writes(" REL 0*N")
          writes("B EQU $*N")
          IF nl \= 0 THEN
            writes("***N")
          UNTIL nl = 0 DO
            $( LET v = nl + 1
               LET w = !v
               LET p = 0
               nl   :=!nl
               writes(" EXTR ")
               FOR j = 1 TO 7 DO
                 TEST (j & 1) = 0 THEN
                   wrch(w >> 8)
                  ELSE
                   $( wrch(w & 255)
                      p := 1 + p
                      w := v ! p
                   $)
               newline()
            $)
          rl := reflist
          writes("***N")
          FOR p = 0 TO stvp-1 BY 8 DO
            $( LET t, c = p + 7, ' '
               IF t >= stvp THEN
                 t := stvp - 1
               writes(" DATA")
               FOR loc=p TO t DO
                 $( writef("%C:%X4",c,stv!loc & #XFFFF)
                    c := ','
                    IF rl \= 0 & h3 ! rl = loc THEN
                      $( IF h2 ! rl > 0 THEN
                           writes("+B")
                         rl := !rl
                      $)
                 $)
               newline()
            $)
          writes(" END*N")
       $)
      ELSE
       $( LET hu, re, en = t.hunk, t.reloc, t.end
          writewords(@ hu, 1)
          writewords(@ stvp, 1)
          writewords(stv,stvp)
          writewords(@ re, 1)
          writewords(@ nr, 1)
          rl := reflist
          UNTIL rl = 0 DO
            $( IF h2 ! rl >= 0 THEN
                 writewords(h3+rl,1)
               rl := h1 ! rl
            $)
          IF needslist \= 0 THEN
            $( LET ex = t.ext
               LET nl = needslist
               LET ze = 0
               writewords(@ ex, 1)
               UNTIL nl = 0 DO
                 $( LET v = nl + 1
                    nl   :=!nl
                    writewords(v, 4)
                    writewords(@ ze, 1)
                 $)
               writewords(@ ze, 1)
            $)
          writewords(@ en, 1)
       $)
     selectoutput(verstream)
  $)

/* Debugging code
AND dboutput() BE
$(  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 = r.a TO r.y DO
      UNLESS reg.k!r = k.none DO
       $( writef("R%C=", r ! [TABLE 'A', 'Q', 'Y'])
          wrkn(reg.k!r, reg.n!r)
       $)
    newline()
$)

AND wrkn(k, n) BE
$(  LET s = VALOF
        SWITCHON k INTO
        $(
        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.ry:  RESULTIS "I"
        CASE k.lvloc:
                    RESULTIS "@P"
        CASE k.lvglob:
                    RESULTIS "@G"
        CASE k.lvlab:
                    RESULTIS "@L"
        CASE k.jlab:RESULTIS "J"
        $)
    writef("%S%N ", s, n)
$)

   Debugging code */


