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


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


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



SECTION "CG-5"


GET "LIBHDR"
GET "bcpl.cghdr"



LET cg.switchon( switchbuff, switchsize )  BE
$(
//  Generate code for the SWITCHON directive.  The cases come to us as a
//  series of case values with associated case labels.  We sort the values,
//  and then decide what sort of code to generate depending on the spread
//  of the cases.

    LET defaultl  =  rdl()
    
    LET cases     =  switchsize / 2
    LET caseval   =  switchbuff + 0
    LET caselab   =  switchbuff + cases

    //  Take a pointer to the node representing the value being switched
    //  on, and bring the stack down.
    
    LET snode     =  arg1!a.node
    LET type      =  0
    LET value     =  0
    
    cg.stack( ssp-1 )

    //  Now read the arguments to the SWITCHON directive, and sort them
    //  in the the "caseval" and "caselab" vectors.
    
    FOR  i = 0  TO  cases-1  DO
    $(
        //  For each case entry, read the case value and case label associated
        //  with it, sorting it into its correct position in the sort buffers.
        
        LET val  =  rdn()
        LET lab  =  rdl()
        LET pos  =  i
        
        UNTIL  pos = 0  DO
        $(
            //  Search backwards in the buffers to find the correct slot for
            //  this item.
            
            IF  val > caseval!(pos - 1)  THEN  BREAK
            
            caseval!pos  :=  caseval!(pos - 1)
            caselab!pos  :=  caselab!(pos - 1)
            
            pos          :=  pos - 1
        $)
        
        //  When we drop out of that loop, we have found the correct place
        //  to put this entry, so put it there and continue.
        
        caseval!pos  :=  val
        caselab!pos  :=  lab
    $)
    
    //  We have now sorted the case values and labels.  Prepare the stack,
    //  and evaluate the value being switched on.
    
    cg.store( 0, ssp )
    
    value  :=  evaluate( snode )
    type   :=  evaltype
    
    freenode( snode )
    
    //  We can now decide which form of code generation we wish to apply.  The
    //  methods are:
    //
    //      a)  If the number of cases is small, do a linear search 
    //          immediately.
    //
    //      b)  If the spread is not greater than 256, then we can compile
    //          a table search using "CPIR".
    //
    //      c)  If a look up table would be more than half full, then this
    //          method is used.
    //
    //      d)  If the look up table would be too expensive, then a binary
    //          search method is used instead.
    
    TEST  type = t.number  THEN
    $(
        //  What is the programmer playing at?  He is switching on
        //  a number.  We can compile this without any further ado.
                
        LET found  =  FALSE
                
        FOR  i = 0  TO  cases-1  DO
                
             //  Look at the value associated with this case, and see
             //  if it is equal to the number being switched on.

             IF  value = caseval!i  THEN
             $(
                 //  Generate an unconditional jump to the case label,
                 //  and stop looking.
                         
                 cg.jump( caselab!i )
                         
                 found  :=  TRUE
                         
                 BREAK
             $)

        //  At this point, we should look to see whether the item was
        //  found, and if not, compile an unconditional jump to the
        //  default label.
                
        UNLESS  found  DO  cg.jump( defaultl )
    $)
    ELSE

    TEST  cases < 10  THEN  
    $(
        //  Small enough number of cases for us to be able to do a linear
        //  search.  This assumes the value to be in DE.

        movetor( r.de, type, value )

        linearsearch( caseval, caselab, cases, defaultl )
    $)
    ELSE
    $(
        //  Too many cases to do a linear search, so chose one of the other
        //  methods.  Whichever method we use, we need unsigned comparisons,
        //  so turn the numbers into unsigned values.

        LET highest  =  caseval!(cases - 1)
        LET lowest   =  caseval!(0)
        LET spread   =  (highest/2) - (lowest/2)
        
        FOR  i = 0  TO  cases-1  DO  caseval!i  :=  caseval!i - lowest

        //  For the CPIR case to be the most efficient, the spread must be
        //  less than 256, and the case values must be 60% sparse or
        //  more.
        
        TEST  spread < 128  &  (cases*3 < spread*4)  THEN
        $(
            //  The spread is such that a CPIR instruction can be compiled.
            //  The case values have already had the base value subtracted
            //  from them.
            
            LET r     =  0
            LET rh    =  0
            LET rl    =  0
            
            LET lab1  =  newlabel()
            LET val1  =  lookuplabel( lab1 )
            LET lab2  =  newlabel()
            LET val2  =  lookuplabel( lab2 )

            //  Now, we can subtract the lowest value from the item we are
            //  switching on.
            
            value  :=  cg.plusminus( s.minus, type, value, t.number, lowest )
            type   :=  evaltype
            
            //  The previous subtraction could well have caused overflow, but
            //  this is not relevant, since if overflow occurred, then the
            //  top byte of the register cannot be zero.
            
            r      :=  movetoanyr( type, value, TRUE )
            rh     :=  highbyte( r )
            rl     :=  lowbyte( r )
                
            code.rr.1( i.ldrr, r.a, rh )
            code.s.1( i.or, r.a )
                
            //  If the high byte is not zero, then the value can't possibly
            //  be in range, so jump to the default label.
            
            cg.branch( cond.ne, defaultl )
                
            //  Otherwise, load the low byte into the A register, and
            //  then set up the registers for a CPIR.
                
            code.rr.1( i.ldrr, r.a, rl )
                
            code.rl.3( i.ldrll, r.hl, lab1, val1 )
            code.rn.3( i.ldrnn, r.bc, cases )
            code.i.2( esc.ed, i.cpir )
                
            //  After executing the CPIR, we should jump if the 'Z' flag
            //  is not set to the default label.
                
            cg.branch( cond.ne, defaultl )
                
            //  Otherwise, BC contains the offset into the table where
            //  the label to jump to can be found.
                
            code.rl.3( i.ldrll, r.hl, lab2, val2 )
            code.ss.1( i.addhl, r.bc )
            code.ss.1( i.addhl, r.bc )
            
            //  HL now points at a location in the table where the location
            //  to be jumped to can be found.
                
            jumpihl()
                
            //  We can now generate the look up tables as pieces of data.
            //  These will be flushed on exit from the current routine.
                
            cg.data( s.datalab, lab1 )
                
            FOR  i = 0  TO  cases-1  DO  cg.data( s.itemb, caseval!i )
            
            //  Now generate the look up table of the labels.  Since the table
            //  is effectively searched in reverse order, we must put the
            //  labels in reverse order!
                
            cg.data( s.datalab, lab2 )
                
            FOR  i = cases-1  TO  0  BY -1  DO  cg.data( s.iteml, caselab!i )
        $)
        ELSE
        $(
            //  Too large a spread to use CPIR, so use one of the other
            //  methods.  Look to see what the range is, and then decide
            //  what to do.  The value "spread" is actually the spread
            //  divided by 2.
            
            //  First, subtract off the lowest number, thus giving us
            //  an unsigned offset into the lookup table.
                
            value  :=  cg.plusminus( s.minus, type, value, t.number, lowest )
            type   :=  evaltype
                
            movetor( r.de, type, value )
                
            TEST  spread < cases  THEN
            $(
                //  This is ok.  A look up table, when generated, would be
                //  more than half full, so it is deemed to be reasonable.
                //  The arithmetic done is unsigned, twos complement.  We
                //  need not worry about overflow, because to be doing this
                //  type of switchon, the spread must be small.
                
                LET lab     =  newlabel()
                LET val     =  lookuplabel( lab )
                LET offset  =  highest - lowest + 1
                LET entry   =  0
                
                //  At this point, the offset is defined to be in DE, and
                //  at this point we take over generating instructions
                //  directly.
                
                code.rn.3( i.ldrnn, r.hl, -offset )
                code.ss.1( i.addhl, r.de )
                
                cg.branch( cond.carry, defaultl )

                //  We now believe that we are within range, and hence
                //  should generate code to load the label value, and then
                //  jump.

                code.rl.3( i.ldrll, r.hl, lab, val )
                code.ss.1( i.addhl, r.de )
                code.ss.1( i.addhl, r.de )
                
                //  HL now points to the location in the table where the
                //  label address will be found.  Jump to it!
                
                jumpihl()
                
                //  We can now generate the labels themselves.
                
                cg.data( s.datalab, lab )

                FOR  i = 0  TO  offset-1  DO
                
                    //  Generate the label if possible, but the default label
                    //  if not.
                    
                    TEST  caseval!entry = i  THEN
                    $(
                        //  This is the correct entry, so generate the labe;
                        //  and step the entry pointer on.
                        
                        cg.data( s.iteml, caselab!entry )
                        
                        entry  :=  entry + 1
                    $)
                    ELSE

                        //  This is a hole in the table, which we must fill
                        //  up with the default label.
                        
                        cg.data( s.iteml, defaultl )
            $)
            ELSE

                //  Oh dear.  We can't use CPIR, and we have too big a range
                //  to use a table lookup.  This means that we should do a
                //  binary chop method.  The value being switched on is
                //  already in DE.
                
                binarychop( caseval, caselab, cases, defaultl )
        $)    
    $)
    
    //  We have now done the switchon.  Whatever happened, we must flush the
    //  register slave, and stop coding.
    
    discardslave()
    stopcoding()
$)



AND binarychop( caseval, caselab, cases, defaultl )  BE
$(
//  First, we should split the cases into two halves, and then decide in
//  which half this particular item belongs.

    TEST  cases < 10  THEN  linearsearch( caseval, caselab, cases, defaultl )
    ELSE
    $(    
        LET midpoint   =  cases/2
        LET midvalue   =  caseval!midpoint
        LET midlabel   =  caselab!midpoint
        LET lesslabel  =  newlabel()
    
        movetor( r.hl, t.number, midvalue )
    
        code.s.1( i.or, r.a )
        code.ss.2( esc.ed, i.sbchl, r.de )
        
        cg.branch( cond.eq,      midlabel )
        cg.branch( cond.nocarry, lesslabel )
        
        //  If we drop though here, then the value is greater than the
        //  mid point, so binary chop that bit.
        
        binarychop( caseval+midpoint+1, caselab+midpoint+1, cases-midpoint-1, defaultl )
        
        //  We should now set the label which corresponds to the lower
        //  half of the table.
        
        cg.setlabel( s.lab, lesslabel )
        
        binarychop( caseval, caselab, midpoint, defaultl )
    $)
$)



AND linearsearch( caseval, caselab, cases, defaultl )  BE
$(
//  Compile a linear search of the case table given.  This is done by a
//  monitor function.

    callmonfunction( m.linsearch )
    monargument( cases )
    
    FOR  i = 0  TO  cases-1  DO
    $(
        LET value  =  caseval!i
        LET label  =  caselab!i

        code.n.2( value )
        code.l.2( label, lookuplabel( label ) )
    $)
    
    //  At the end of the table, we generate the address of the defaule label
    //  which we jump to if the search fails.
    
    code.l.2( defaultl, lookuplabel( defaultl ) )
$)



AND jumpihl()  BE
$(
//  Generate code to jump to the label contained in the location pointed to by
//  HL.

    code.rr.1( i.ldrr, r.a, r.ihl )
    code.ss.1( i.inc, r.hl )
    code.rr.1( i.ldrr, r.h, r.ihl )
    code.rr.1( i.ldrr, r.l, r.a )
    
    code.i.1( i.jpihl )
$)



AND storeregister( r, t, v )  BE
$(
//  Generate code to store the register "r" at the location given by "t,v".

    TEST  t = t.local  |  t = t.global  THEN  storeindex( r, t, v )  ELSE
    TEST  t = t.label                   THEN  storestatic( r, v )    ELSE

          cgerror( "storeregister( %N )", t )
$)



AND storeindex( r, t, v )  BE
$(
//  Store the register "r" in location "t,v".  We must look to see if this is
//  out of range of the index registers, and if it is, store it by calling
//  the monitor.

    TEST  systemindex( t, v )  THEN
    $(
        //  The location is out of range of the normal store instruction,
        //  so push the register onto the stack, and call the monitor
        //  function to do the job.
        
        code.ss.1( i.push, r )
        
        monstorefunction( t )
        monargument( v-128 )
    $)
    ELSE  storeixiy( r, t, v )
$)



AND storeixiy( r, t, v )  BE
$(
//  Store register "r" at offset "v" on the stack or in the global vector.

    LET esc     =  t = t.local  ->  esc.dd, esc.fd
    LET offset  =  (v * bytesperz80word) - 128
    
    LET rh      =  highbyte( r )
    LET rl      =  lowbyte( r )
    
    code.ir.3( esc, i.ldir, rl, offset+0 )
    code.ir.3( esc, i.ldir, rh, offset+1 )
$)



AND storestatic( r, l )  BE
$(
//  Generate code to store register "r" into static label "l".  The instruction
//  which we generate depends on whether the register is in fact HL.

    LET labeladdr  =  lookuplabel( l )

    TEST  r = r.hl  THEN

        code.li.3( i.ldlhl, l, labeladdr )

    ELSE

        code.lr.4( esc.ed, i.ldlr, r, l, labeladdr )
$)



AND addslaveinfo( r, t, v )  BE
$(
//  Add the information about the item "t,v" to the register slave entry
//  for register "r".  We only do this if "t,v" itself is not a register.

    UNLESS  t = t.register  DO
    $(
        LET node  =  block3( rinfo!r, t, v )
        
        rinfo!r  :=  node
    $)
$)



AND cg.unslavelocal()  BE
$(
//  Scan the register slave, and discard any slave entries which represent
//  items above the current stack high water mark.

    FOR  r = r.hl  TO  r.bc  DO
    $(
        LET list  =  scanlocals( rinfo!r )
        
        unsetslave( r )
        
        rinfo!r  :=  list
    $)
$)



AND cg.unslavestorage()  BE
$(
//  Scan the register slave, and discard any slave entries which represent
//  items in main storage.

    FOR  r = r.hl  TO  r.bc  DO
    $(
        LET list  =  scanstorage( rinfo!r )
        
        unsetslave( r )
        
        rinfo!r  :=  list
    $)
$)



AND scanlocals( list )  =  list = NIL  ->  NIL,  VALOF
$(
//  Make a copy of the list "list" omitting any items which are outside
//  the current stack frame.

    LET l  =  list!l.link
    LET t  =  list!l.type
    LET v  =  list!l.value

    TEST  t = t.local  &  v >= ssp  
        THEN  RESULTIS  scanlocals( l )
        ELSE  RESULTIS  block3( scanlocals( l ), t, v )
$)



AND scanstorage( list )  =  list = NIL  ->  NIL,  VALOF
$(
//  Make a copy of the list "list" omitting any items which are in storage.

    LET l  =  list!l.link
    LET t  =  list!l.type
    LET v  =  list!l.value

    TEST  t = t.local  |  t = t.global  |  t = t.label
        THEN  RESULTIS  scanlocals( l )
        ELSE  RESULTIS  block3( scanlocals( l ), t, v )
$)



AND unsetslave( r )  BE
$(
//  Clear all the slave information for register "r".  This means throwing
//  away all the information we had so carefully stored about it!  Ho, humm.

    LET list  =  rinfo!r
    
    UNTIL  list = NIL  DO
    $(
        LET node  =  list
        
        list  :=  list!l.link
        
        freeblock3( node )
    $)

    rinfo!r  :=  NIL
$)



AND cherish( r, node )  BE
$(
//  Mark the register "r" to say that it contains interesting information.
//  The "cherished" field of the register data structure should be set to
//  point to the node "node", so that should the register be required, the
//  upper levels can be notified of this fact.

    UNLESS  rchnode!r = NIL  DO  cgerror( "cherish( %N )", r )

    IF  debugging & listing  THEN  writel( ";  Cherish R%N", r )

    chseq      :=  chseq + 1

    rchnode!r  :=  node
    rchseq!r   :=  chseq
$)



AND uncherish( r )  BE
$(
//  Unset the "cherished" state of the register "r".

    IF  rchnode!r = NIL  THEN  cgerror( "uncherish( %N )", r )

    IF  debugging & listing  THEN  writel( ";  Uncherish R%N", r )

    rchnode!r  :=  NIL
    rchseq!r   :=  0
$)



AND stackcherished()  BE
$(
//  Stack all items which are cherished.  We must stack them in the order
//  in which they were cherished.

    FOR  i = 1  TO  chseq  DO
    $(
        LET r  =  chseqr( i )
        
        //  If the value "r" is "r.none", then this cherished slot has been
        //  used, and discarded.  Ignore it.
        
        UNLESS  r = r.none  DO  storecherished( r )
    $)

    //  At this point, all the cherished registers have been stacked, and
    //  so we can reset the "cherish sequence".
    
    chseq  :=  0
$)



AND chseqr( seq )  =  VALOF
$(
//  Return the identity of the register which has "cherish sequence" "seq".

    FOR  r = r.hl  TO  r.bc  DO
         IF  rchseq!r = seq  THEN
             RESULTIS  r

    //  Otherwise, this slot is now unused, and we can return an error value.

    RESULTIS  r.none
$)
            


AND findfreer( r )  =  VALOF
$(
//  Return a pointer to a free register.  We return the first one which is
//  uncherished and undefined, and if that fails, return the first one which
//  is uncherished.

    LET notc  =  VEC r.bc
    LET notr  =  VEC r.bc
    LET notd  =  VEC r.bc

    FOR  rr = r.hl  TO  r.bc  DO
    $(
        //  Find out all we can about the registers.  The three important
        //  pieces of information are:
        //
        //      a)  Is the register cherished?
        //      b)  Is the register referenced?
        //      c)  Is the register defined?
        
        notc!rr  :=  notcherished( rr )
        notr!rr  :=  notreferenced( rr )
        notd!rr  :=  notdefined( rr )
    $)

    FOR  rr = r.hl  TO  r.bc  DO
         UNLESS  rr = r  DO
             IF  notc!rr  &  notr!rr  &  notd!rr  THEN
                 RESULTIS  rr

    FOR  rr = r.hl  TO  r.bc  DO
         UNLESS  rr = r  DO
             IF  notc!rr  &  notr!rr  THEN
                 RESULTIS  rr

    FOR  rr = r.hl  TO  r.bc  DO
         UNLESS  rr = r  DO
             IF  notc!rr  THEN
                 RESULTIS  rr

    RESULTIS  r.none
$)



AND freecherished( r )  =  VALOF
$(
//  Return a pointer to a register (previously cherished) which has been
//  successfully freed.

    FOR  i = 1  TO  chseq  DO
    $(
        LET rr  =  chseqr( i )
        
        UNLESS  rr = r.none  DO
        $(
            storecherished( rr )

            //  Unless this register has been explicitly precluded, we should
            //  return it immediately.
        
            UNLESS  rr = r  DO  RESULTIS  rr
        $)
    $)

    //  We should never drop out of that loop, but if we do, print out an
    //  error message.
    
    cgerror( "freecherished( %N )", r )
$)



AND storecherished( r )  BE
$(
//  We need the register "r", and it has been cherished.  We should therefore
//  put it onto the stack, and mark the cherished node as now containing a
//  stacked item.

    LET node  =  rchnode!r
    
    IF  node = NIL  THEN  cgerror( "storecherished( %N )", r )

    code.ss.1( i.push, r )
    
    node!n.type  :=  t.stack
    node!n.arg1  :=  stackp

    stackp       :=  stackp + 1

    uncherish( r )
$)



AND notcherished( r )  =  (rchnode!r = NIL)



AND notdefined( r )    =  (rinfo!r = NIL)



AND notreferenced( r )  =  VALOF
$(
//  Scan the simulated stack, returning a boolean to say whether this register
//  is referenced or not.

    LET arg  =  arg1

    UNTIL  arg = NIL  DO
    $(
        LET node   =  arg!a.node
        
        IF  isreferenced( node, r )  THEN  RESULTIS  FALSE
        
        arg  :=  arg!a.link
    $)

    RESULTIS  TRUE
$)



AND isreferenced( node, r )  =  VALOF
$(
//  Scan the data structure associated with the node given, and search for
//  references to the register "r".

    LET type  =  node!n.type

    SWITCHON  type  INTO
    $(
        CASE t.register   :  //  This is a register node, and so we should
                             //  set it up as being cherished.

                             RESULTIS  node!n.arg1 = r


        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.stack      :  
        CASE t.cherished  :  

                             RESULTIS  FALSE


        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    :

                             RESULTIS  isreferenced( node!n.arg1, r )  |
                                       isreferenced( node!n.arg2, r )


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

                             RESULTIS  isreferenced( node!n.arg1, r )


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



AND monfunction( op, alt )  BE
$(
//  Generate a monitor call for the monitor function represented by "op".
//  If the "alt" flag is set, then use the alternative form of the function.

    LET monf  =  op = s.mult    ->  m.multiply,
                 op = s.div     ->  m.divide,
                 op = s.rem     ->  m.rem,
                 op = s.lshift  ->  m.lshift,
                 op = s.rshift  ->  m.rshift,
                 op = s.eq      ->  m.eq,
                 op = s.ne      ->  m.ne,
                 op = s.ls      ->  m.ls,
                 op = s.gr      ->  m.gr,
                 op = s.le      ->  m.le,
                 op = s.ge      ->  m.ge,
                 op = s.abs     ->  m.abs,
                                    cgerror( "monfunction( %N )", op )

    //  Now generate the call to the monitor, using the alternative form
    //  of the function if necessary.
    
    callmonfunction( alt  ->  alternative( monf ), monf )
$)



AND monloadfunction( type )  BE
$(
//  Use the monitor to load an out of range value onto the stack.  The
//  value "type" is the type of item to be loaded.

    LET monf  =  type = t.local      ->  m.loadix,
                 type = t.global     ->  m.loadiy,
                 type = t.lv.local   ->  m.loadlvix,
                 type = t.lv.global  ->  m.loadlviy,

                                         cgerror( "monloadfunction( %N )", type )

    //  Look to see if the "short" flag is set, and if so, get the alternative
    //  form of the function.
    
    callmonfunction( monf )
$)



AND monstorefunction( type )  BE
$(
//  Generate a monitor store instruction.

    LET monf  =  type = t.local   ->  m.storeix,
                 type = t.global  ->  m.storeiy,
                                      cgerror( "monstorefunction( %N )", type )

    //  Now call the function, using the alternative form if necessary.
    
    callmonfunction( monf )
$)



AND monargument( value )  BE
$(
//  Define an argument to the monitor.  The size of the item we store 
//  depends on its value.  It is assumed that "value" is positive.

    LET low7   =  (value)       &  #B0000000001111111
    LET high8  =  (value << 1)  &  #B1111111100000000

    TEST  high8 = 0  THEN  code.n.1( low7 )
    ELSE
    $(
        code.n.1( low7 + #B10000000 )
        code.n.1( high8 >> 8 )
    $)
$)



AND callmonfunction( monf )  BE
$(
//  Generate code to call a monitor function.  This means generating a
//  RST instruction.  Which one we generate depends on the type of
//  monitor function.

    LET inst  =  rstinsts!0
    LET def   =  TRUE

    FOR  i = 1  TO  rstcount  DO
    $(
        //  Look at the relevant entry in the restart table, and decide whether
        //  this is a direct restart.  Otherwise, make it a default one with
        //  argument.

        IF  monf = rstfuncs!i  THEN
        $(
            //  This matches, so set the instructions up.
            
            inst  :=  rstinsts!i
            def   :=  FALSE
        $)
    $)

    code.im.1( inst, (def -> m.default, monf) )

    IF  def  THEN  code.m.1( monf )
$)



AND alternative( monf )  =  monf = m.multiply  ->  m.multiply,
                            monf = m.divide    ->  m.rdivide,
                            monf = m.rem       ->  m.rrem,
                            monf = m.lshift    ->  m.rlshift,
                            monf = m.rshift    ->  m.rrshift,
                            monf = m.eq        ->  m.eq,
                            monf = m.ne        ->  m.ne,
                            monf = m.ls        ->  m.gr,
                            monf = m.gr        ->  m.ls,
                            monf = m.le        ->  m.ge,
                            monf = m.ge        ->  m.le,
                            monf = m.abs       ->  m.abs,
                                                   cgerror( "alternative( %N )", monf )



AND discardslave()  BE
$(
    //  Ignore the slaving information in the register slave.
    
    FOR  r = r.hl  TO  r.bc  DO  unsetslave( r )

    chseq  :=  0
$)



AND addname( name, label )  BE
$(
//  Add the name of a BCPL routine to the name data structure.

    LET node  =  getstore( nl.size )
    LET ptr   =  @namelist

    node!nl.link   :=  NIL
    node!nl.name   :=  name
    node!nl.addr   :=  currentloc
    node!nl.type   :=  t.local
    node!nl.value  :=  label

    UNTIL  ptr!nl.link = NIL  DO  ptr  :=  ptr!nl.link

    ptr!nl.link    :=  node
$)



AND bcplalign()  BE

    //  Align the code onto a BCPL word boundary.
    
    IF  odd( currentloc )  THEN  code.i.1( i.nop )



AND odd( value )  =  (value & 1)  \=  0



AND setlabelrefs( label )  BE
$(
    //  Update the label references for label "label".  This means scanning
    //  down the list of label references updating the buffered code for
    //  each label reference.  Since the list may be long, we should not
    //  use recursion.

    LET refs  =  labelrefs!label
    LET addr  =  labeladdr!label

    UNTIL  refs = NIL  DO
    $(
        setlabelref( refs!r.addr, addr )
        
        refs  :=  refs!r.link
    $)
$)



AND setlabelref( location, value )  BE
$(
    //  Set a reference to a label with value "value" at location "location".

    update( location+0, (value)      & #XFF )
    update( location+1, (value >> 8) & #XFF )
$)



AND lookuplabel( label )  =  VALOF
$(
//  Look up the value of label "label".

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

    RESULTIS  labeladdr!label
$)



AND startcoding()  BE

//  Start coding, so long as we are within a procedure.

    incode  :=  (procdepth > 0)



AND stopcoding()  BE
$(
//  Stop generating code.  We should store all the items onto the stack,
//  and flush the register slave.

    discardslave()

    incode  :=  FALSE
$)



AND cg.constant( type, value )  BE
$(
//  Code generate a constant.  What we do depends on the type of the constant.
//  We must always generate code at this point.

    LET oldic  =  incode

    incode  :=  TRUE

    SWITCHON  type  INTO
    $(
        CASE s.itemb    :  code.n.1( value )
                           ENDCASE

        CASE s.itemn    :  code.n.2( value )
                           ENDCASE

        CASE s.iteml    :  code.l.2( value, lookuplabel( value ) )
                           ENDCASE

        CASE s.datalab  :  bcplalign()
                           setlabel( value )
                           setlabelrefs( value )
                           ENDCASE


        DEFAULT         :  cgerror( "cg.constant( %N )", type )
    $)

    incode  :=  oldic
$)



AND newlabel()  =  VALOF
$(
//  Return the value of a new code generator generated label.  We must check
//  that the one we are about to generate is not in the range generated by
//  the translator.

    cglabel  :=  cglabel - 1

    UNLESS  maxln < cglabel < maxlabel  DO  cgerror( "newlabel( %N )", cglabel )

    RESULTIS  cglabel
$)



AND rdop()  =  rdn()



AND rdl()  =  VALOF
$(
//  Read a new label number from the input stream.

    LET l  =  rdn()

    IF  l > maxln  THEN  maxln  :=  l

    RESULTIS  l
$)



AND rdg()  =  VALOF
$(
//  Read a new global number from the input stream.

    LET g  =  rdn()

    IF  g > maxgn  THEN  maxgn  :=  g

    RESULTIS  g
$)



AND rdn()  =  readn()



AND cgerror( format, arg1, arg2, arg3 )  BE
$(
//  Print out an error message, and stop.

    cgwarning( format, arg1, arg2, arg3 )

    abort( 9999 )

    printdebuginfo()

    selectinput( fromstream )   ;  endread()
    selectoutput( tostream )    ;  endwrite()

    IF  listing  THEN
    $(
        selectoutput( liststream )
        
        endwrite()
    $)

    IF  mapping  THEN
    $(
        selectoutput( mapstream )
        
        endwrite()
    $)

    cg.uninitstore()

    selectoutput( sysout )

    writes( "*NCode Generation Abandoned.*N" )

    stop( 20 )
$)



AND cgwarning( format, arg1, arg2, arg3 )  BE
$(
//  Print out an error message.

    LET o  =  output()

    selectoutput( sysout )

    writes( "*N****** Z80CG:  " )
    writef( format, arg1, arg2, arg3 )
    newline()

    selectoutput( o )
$)


