/*****************************************************************************\
*                           Systems Research Group                            *
*******************************************************************************


                       #####    ######              ######  
                      #######  ########            ######## 
                     ##        ##                  ##       
                     ##        ##  ####   #######  #######  
                     ##        ##    ##            ##    ## 
                     ##        ##    ##            ##    ## 
                      #######  ########             ######  
                       #####    ######               ####   


*******************************************************************************
*   I. D. Wilson           Last Modified   -   IDW   -   21/02/85             *
\*****************************************************************************/



SECTION "CG-6"


GET "LIBHDR"
GET "bcpl.cghdr"



LET code.ss.1( inst, r )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), regname( r ) )

    zbyte( inst  |  (regbits( r ) << 4) )
$)



AND code.ss.2( esc, inst, r )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), regname( r ) )

    zbyte( esc )
    zbyte( inst  |  (regbits( r ) << 4) )
$)



AND code.s.1( inst, r )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), regname( r ) )

    zbyte( inst  |  regbits( r ) )
$)



AND code.rr.1( inst, r1, r2 )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), regname( r1 ), regname( r2 ) )

    zbyte( inst  |  (regbits( r1 ) << 3)  |  regbits( r2 ) )
$)



AND code.rn.2( inst, r, n )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), regname( r ), n )

    zbyte( inst  |  (regbits( r ) << 3) )
    zbyte( n )
$)



AND code.rn.3( inst, r, nn )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), regname( r ), nn )

    zbyte( inst  |  (regbits( r ) << 4) )
    zbyte( byte0( nn ) )
    zbyte( byte1( nn ) )
$)



AND code.i.1( inst )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ) )

    zbyte( inst )
$)



AND code.i.2( esc, inst )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ) )

    zbyte( esc )
    zbyte( inst )
$)



AND code.im.1( inst, monf )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), monfname( monf ) )

    zbyte( inst )
$)



AND code.m.1( monf )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( "    DEFB  #X%X2  ; %S", monf, monfname( monf ) )

    zbyte( monf )
$)



AND code.n.1( n )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( "    DEFB  #X%X2", n )

    zbyte( n )
$)



AND code.n.2( nn )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( "    DEFW  #X%X4", nn )

    zbyte( byte0( nn ) )
    zbyte( byte1( nn ) )
$)



AND code.l.2( l, nn )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( "    DEFW  L%N", l )

    addlabelref( l )

    zbyte( byte0( nn ) )
    zbyte( byte1( nn ) )
$)



AND code.il.2( inst, l, n )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), l )

    zbyte( inst )
    zbyte( n )
$)



AND code.r.2( esc, inst, r )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), regname( r ) )

    zbyte( esc )
    zbyte( inst  |  regbits( r ) )
$)



AND code.il.3( inst, l, nn )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), l )

    zbyte( inst )

    addlabelref( l )

    zbyte( byte0( nn ) )
    zbyte( byte1( nn ) )
$)



AND code.ir.3( esc, inst, r, offset )  BE  IF  incode  THEN
$(
    LET sign  =  "+"
    LET offs  =  offset
    
    IF  offset < 0  THEN
    $(
        offs  :=  -offs
        sign  :=  "-"
    $)
    
    IF  listing  THEN  writel( mnemonic( inst ), escname( esc ), sign, offs, regname( r ) )

    zbyte( esc )
    zbyte( inst  |  regbits( r ) )
    zbyte( offset )
$)



AND code.ri.3( esc, inst, r, offset )  BE  IF  incode  THEN
$(
    LET sign  =  "+"
    LET offs  =  offset
    
    IF  offset < 0  THEN
    $(
        offs  :=  -offs
        sign  :=  "-"
    $)
    
    IF  listing  THEN  writel( mnemonic( inst ), regname( r ), escname( esc ), sign, offs )

    zbyte( esc )
    zbyte( inst  |  (regbits( r ) << 3) )
    zbyte( offset )
$)



AND code.rl.3( inst, r, l, nn )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), regname( r ), l )

    zbyte( inst  |  (regbits( r ) << 4) )
    
    addlabelref( l )

    zbyte( byte0( nn ) )
    zbyte( byte1( nn ) )
$)



AND code.li.3( inst, l, nn )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), l )

    zbyte( inst )

    addlabelref( l )

    zbyte( byte0( nn ) )
    zbyte( byte1( nn ) )
$)



AND code.rl.4( esc, inst, r, l, nn )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), regname( r ), l )

    zbyte( esc )
    zbyte( inst  |  (regbits( r ) << 4) )
    
    addlabelref( l )

    zbyte( byte0( nn ) )
    zbyte( byte1( nn ) )
$)



AND code.lr.4( esc, inst, r, l, nn )  BE  IF  incode  THEN
$(
    IF  listing  THEN  writel( mnemonic( inst ), l, regname( r ) )

    zbyte( esc )
    zbyte( inst  |  (regbits( r ) << 4) )

    addlabelref( l )

    zbyte( byte0( nn ) )
    zbyte( byte1( nn ) )
$)



AND setlabel( label )  BE
$(
    //  Set the label entry for this label to the current location value.

    UNLESS  0 <= label <=  maxlabel  DO  cgerror( "setlabel( %N )", label )
    UNLESS  labeladdr!label = NIL    DO  cgerror( "setlabel( %N )", label )

    labeladdr!label  :=  currentloc

    IF  listing  THEN  writel( "L%N:", label )

    setlabelrefs( label )
$)



AND writel( format, arg1, arg2, arg3, arg4 )  BE
$(
//  Print out listing information to the list stream.

    LET o  =  output()
        
    selectoutput( liststream )

    writef( format, arg1, arg2, arg3, arg4 )
    newline()
        
    selectoutput( o )
$)



AND regbits( r )  =  (TABLE   #B10,       //  HL
                              #B01,       //  DE
                              #B00,       //  BC
                             #B111,       //  A
                             #B000,       //  B
                             #B001,       //  C
                             #B010,       //  D
                             #B011,       //  E
                             #B100,       //  H
                             #B101,       //  L
                             #B110)!r     //  (HL)



AND zbyte( byte )  BE
$(
    update( currentloc, byte )

    currentloc  :=  currentloc + 1
$)



AND byte0( word )  =  word  &  #XFF



AND byte1( word )  =  (word >> 8)  &  #XFF



AND update( location, byte )  BE
$(
    LET address  =  location - programbase
    LET chunk    =  address  /  bytesperchunk
    LET offset   =  address REM bytesperchunk

    TEST  chunk < maxchunks  THEN
    $(
        LET buffer  =  memchunks!chunk
        
        IF  buffer = NIL  THEN
        $(
            buffer           :=  getstore( wordsperchunk )
            memchunks!chunk  :=  buffer
        $)
        
        buffer % offset  :=  byte
    $)
    ELSE  cgerror( "Program too large" )
$)



AND regname( r )  =  VALOF
$(
    SWITCHON  r  INTO
    $(
        CASE r.hl   :  RESULTIS  "HL"
        CASE r.de   :  RESULTIS  "DE"
        CASE r.bc   :  RESULTIS  "BC"
        CASE r.a    :  RESULTIS  "A"
        CASE r.b    :  RESULTIS  "B"
        CASE r.c    :  RESULTIS  "C"
        CASE r.d    :  RESULTIS  "D"
        CASE r.e    :  RESULTIS  "E"
        CASE r.h    :  RESULTIS  "H"
        CASE r.l    :  RESULTIS  "L"
        CASE r.ihl  :  RESULTIS  "(HL)"

        DEFAULT     :  cgerror( "regname( %N )", r )
    $)
$)



AND escname( esc )  =  VALOF
$(
    SWITCHON  esc  INTO
    $(
        CASE esc.dd  :  RESULTIS  "IX"
        CASE esc.fd  :  RESULTIS  "IY"
        
        DEFAULT      :  cgerror( "escname( %N )", esc )
    $)
$)



AND monfname( monf )  =  VALOF
$(
    SWITCHON  monf  INTO
    $(
        CASE m.apply      :  RESULTIS  "M.APPLY"
        CASE m.fixup      :  RESULTIS  "M.FIXUP"
        CASE m.loadix     :  RESULTIS  "M.LOADIX"
        CASE m.loadiy     :  RESULTIS  "M.LOADIY"
        CASE m.storeix    :  RESULTIS  "M.STOREIX"
        CASE m.storeiy    :  RESULTIS  "M.STOREIY"  
        CASE m.setlink0   :  RESULTIS  "M.SETLINK0"
        CASE m.setlink1   :  RESULTIS  "M.SETLINK1"
        CASE m.setlink2   :  RESULTIS  "M.SETLINK2"
        CASE m.setlink3   :  RESULTIS  "M.SETLINK3"
        CASE m.return     :  RESULTIS  "M.RETURN"
        CASE m.finish     :  RESULTIS  "M.FINISH"
        CASE m.loadlvix   :  RESULTIS  "M.LOADLVIX"
        CASE m.loadlviy   :  RESULTIS  "M.LOADLVIY"
        CASE m.multiply   :  RESULTIS  "M.MULTIPLY"
        CASE m.divide     :  RESULTIS  "M.DIVIDE"
        CASE m.rem        :  RESULTIS  "M.REM"
        CASE m.lshift     :  RESULTIS  "M.LSHIFT"
        CASE m.rshift     :  RESULTIS  "M.RSHIFT"
        CASE m.eq         :  RESULTIS  "M.EQ"
        CASE m.ne         :  RESULTIS  "M.NE"
        CASE m.ls         :  RESULTIS  "M.LS"
        CASE m.gr         :  RESULTIS  "M.GR"
        CASE m.le         :  RESULTIS  "M.LE"
        CASE m.ge         :  RESULTIS  "M.GE"
        CASE m.rdivide    :  RESULTIS  "M.RDIVIDE"
        CASE m.rrem       :  RESULTIS  "M.RREM"
        CASE m.rlshift    :  RESULTIS  "M.RLSHIFT"
        CASE m.rrshift    :  RESULTIS  "M.RRSHIFT"
        CASE m.abs        :  RESULTIS  "M.ABS"
        CASE m.linsearch  :  RESULTIS  "M.LINSEARCH"

        CASE m.default    :  RESULTIS  "M.DEFAULT"

        DEFAULT           :  cgerror( "monfname( %N )", monf )
    $)
$)



AND mnemonic( inst )  =  VALOF
$(
    SWITCHON  inst  INTO
    $(
        CASE i.inc    :  RESULTIS  "    INC   %S"
        CASE i.dec    :  RESULTIS  "    DEC   %S"
        CASE i.and    :  RESULTIS  "    AND   %S"
        CASE i.or     :  RESULTIS  "    OR    %S"
        CASE i.xor    :  RESULTIS  "    XOR   %S"
        CASE i.sbchl  :  RESULTIS  "    SBC   HL,%S"
        CASE i.addhl  :  RESULTIS  "    ADD   HL,%S"
        CASE i.ldrr   :  RESULTIS  "    LD    %S,%S"
        CASE i.cpl    :  RESULTIS  "    CPL"
        CASE i.ldrn   :  RESULTIS  "    LD    %S,#X%X2"
        CASE i.ldrnn  :  RESULTIS  "    LD    %S,#X%X4"
        CASE i.ldrll  :  RESULTIS  "    LD    %S,L%N"
        CASE i.push   :  RESULTIS  "    PUSH  %S"
        CASE i.pop    :  RESULTIS  "    POP   %S"
        CASE i.ret    :  RESULTIS  "    RET"
        CASE i.jpihl  :  RESULTIS  "    JP    (HL)"
        CASE i.exx    :  RESULTIS  "    EXX"
        CASE i.jr     :  RESULTIS  "    JR    L%N-$"
        CASE i.jrz    :  RESULTIS  "    JR    Z,L%N-$"
        CASE i.jrnz   :  RESULTIS  "    JR    NZ,L%N-$"
        CASE i.jrc    :  RESULTIS  "    JR    C,L%N-$"
        CASE i.jrnc   :  RESULTIS  "    JR    NC,L%N-$"
        CASE i.jp     :  RESULTIS  "    JP    L%N"
        CASE i.jpz    :  RESULTIS  "    JP    Z,L%N"
        CASE i.jpnz   :  RESULTIS  "    JP    NZ,L%N"
        CASE i.jpc    :  RESULTIS  "    JP    C,L%N"
        CASE i.jpnc   :  RESULTIS  "    JP    NC,L%N"
        CASE i.jpp    :  RESULTIS  "    JP    P,L%N"
        CASE i.jpm    :  RESULTIS  "    JP    M,L%N"
        CASE i.ldri   :  RESULTIS  "    LD    %S,(%S%S%N)"
        CASE i.ldir   :  RESULTIS  "    LD    (%S%S%N),%S"
        CASE i.ldhll  :  RESULTIS  "    LD    HL,(L%N)"
        CASE i.ldrl   :  RESULTIS  "    LD    %S,(L%N)"
        CASE i.srl    :  RESULTIS  "    SRL   %S"
        CASE i.rr     :  RESULTIS  "    RR    %S"
        CASE i.ldlhl  :  RESULTIS  "    LD    (L%N),HL"
        CASE i.ldlr   :  RESULTIS  "    LD    (L%N),%S"
        CASE i.nop    :  RESULTIS  "    NOP"
        CASE i.cpir   :  RESULTIS  "    CPIR"

        CASE i.rst00  :  RESULTIS  "    RST   #X00  ; %S"
        CASE i.rst08  :  RESULTIS  "    RST   #X08  ; %S"
        CASE i.rst10  :  RESULTIS  "    RST   #X10  ; %S"
        CASE i.rst18  :  RESULTIS  "    RST   #X18  ; %S"
        CASE i.rst20  :  RESULTIS  "    RST   #X20  ; %S"
        CASE i.rst28  :  RESULTIS  "    RST   #X28  ; %S"
        CASE i.rst30  :  RESULTIS  "    RST   #X30  ; %S"
        CASE i.rst38  :  RESULTIS  "    RST   #X38  ; %S"

        DEFAULT       :  cgerror( "mnemonic( %N )", inst )
    $)
$)



AND addlabelref( label )  BE
$(
//  Add a reference to label "label" for the current location.

    UNLESS  0 <= label <= maxlabel  DO  cgerror( "addlabelref( %N )", label )

    labelrefs!label  :=  block2( labelrefs!label, currentloc )
$)



AND printdebuginfo()  BE
$(
//  Print out as much information as possible about the state of the current
//  world.

    LET o  =  output()

    selectoutput( sysout )

    writef( "*NDebug at #X%X4*N", currentloc )

    writes( "*NSimulated stack:*N" )
    printstack( arg1 )

    writes( "*NRegister slave:*N" )
    FOR  r = r.hl  TO  r.bc  DO  printregister( r )

    newline()

    selectoutput( o )
$)



AND printstack( arg )  BE
$(
//  Print out the stack information for the current stack node.

    UNTIL  arg = NIL  DO
    $(
        writes( arg = arg1  ->  "Arg1  ",
                arg = arg2  ->  "Arg2  ",
                                "      " )

        writef( "%I4  ", arg!a.ssp )
        printnode( arg!a.node )
        newline()

        arg  :=  arg!a.link
    $)
$)



AND printregister( r )  BE
$(
//  Print information about the register "r".

    LET info  =  rinfo!r
    LET chs   =  rchseq!r
    LET chn   =  rchnode!r
    
    writef( "%S  ", regname( r ) )
    
    UNTIL  info = NIL  DO
    $(
        //  Now write out the list of slave information associated with
        //  this register.
        
        LET t  =  info!l.type
        LET v  =  info!l.value
        
        writes( "  " )
        printtv( t, v )
        
        info  :=  info!l.link
    $)
    
    //  If the register is cherished, then we should print out what it
    //  is cherished as.
    
    UNLESS  chs = 0  DO  writef( "  ChSeq=%N", chs )

    UNLESS  chn = NIL  DO
    $(
        writes( "  ChNode=" )
        printnode( chn )
    $)

    newline()
$)



AND printnode( node )  BE
$(
//  Print the information contained in this node.

    LET type  =  node!n.type

    SWITCHON  type  INTO
    $(
        CASE t.cherished  :  wrch( '[' )
                             printnode( node!n.arg1 )
                             wrch( ']' )
                             ENDCASE


        CASE t.local      :  CASE t.global     :
        CASE t.label      :  CASE t.number     :
        CASE t.lv.local   :  CASE t.lv.global  :
        CASE t.lv.label   :  CASE t.register   :
        CASE t.stack      :

                             printtv( type, node!n.arg1 )
                             writef( ":%N", node!n.arg2 )
                             ENDCASE


        CASE s.plus       :  CASE s.minus      :
        CASE s.logand     :  CASE s.logor      :
        CASE s.eqv        :  CASE s.neqv       :
        CASE s.lshift     :  CASE s.rshift     :
        CASE s.mult       :  CASE s.div        :
        CASE s.rem        :  CASE s.eq         :
        CASE s.ne         :  CASE s.ls         :
        CASE s.gr         :  CASE s.le         :
        CASE s.ge         :  CASE s.getbyte    :

                             wrch( '(' )
                             printnode( node!n.arg1 )
                             writes( opstr( type ) )
                             printnode( node!n.arg2 )
                             wrch( ')' )
                             ENDCASE


        CASE s.neg        :  CASE s.not        :
        CASE s.abs        :  CASE s.rv         :

                             writes( opstr( type ) )
                             wrch( '(' )
                             printnode( node!n.arg1 )
                             wrch( ')' )
                             ENDCASE


        DEFAULT           :  cgerror( "printnode( %N )", type )
    $)
$)



AND printtv( type, value )  BE
$(
    SWITCHON  type  INTO
    $(
        CASE t.local      :  writef( "P%N", value )     ;  ENDCASE
        CASE t.global     :  writef( "G%N", value )     ;  ENDCASE
        CASE t.label      :  writef( "L%N", value )     ;  ENDCASE
        CASE t.number     :  writef( "%N", value )      ;  ENDCASE
        CASE t.lv.local   :  writef( "LP%N", value )    ;  ENDCASE
        CASE t.lv.global  :  writef( "LG%N", value )    ;  ENDCASE
        CASE t.lv.label   :  writef( "LL%N", value )    ;  ENDCASE
        CASE t.register   :  writes( regname( value ) ) ;  ENDCASE
        CASE t.stack      :  writef( "S%N", value )     ;  ENDCASE

        DEFAULT           :  cgerror( "printtv( %N )", type )
    $)
$)



AND opstr( op )  =  VALOF
$(
    SWITCHON  op  INTO
    $(
        CASE s.plus       :  RESULTIS  " + "
        CASE s.minus      :  RESULTIS  " - "
        CASE s.logand     :  RESULTIS  " & "
        CASE s.logor      :  RESULTIS  " | "
        CASE s.eqv        :  RESULTIS  " EQV "
        CASE s.neqv       :  RESULTIS  " NEQV "
        CASE s.lshift     :  RESULTIS  " << "
        CASE s.rshift     :  RESULTIS  " >> "
        CASE s.mult       :  RESULTIS  " ** "
        CASE s.div        :  RESULTIS  " / "
        CASE s.rem        :  RESULTIS  " REM "
        CASE s.eq         :  RESULTIS  " = "
        CASE s.ne         :  RESULTIS  " \= "
        CASE s.ls         :  RESULTIS  " < "
        CASE s.gr         :  RESULTIS  " > "
        CASE s.le         :  RESULTIS  " <= "
        CASE s.ge         :  RESULTIS  " >= "
        CASE s.getbyte    :  RESULTIS  " % "
        CASE s.neg        :  RESULTIS  " -"
        CASE s.not        :  RESULTIS  " NOT"
        CASE s.abs        :  RESULTIS  " ABS"
        CASE s.rv         :  RESULTIS  " !"
        
        DEFAULT           :  cgerror( "opstr( %N )", op )
    $)
$)


