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


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


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



SECTION "CG-4"


GET "LIBHDR"
GET "bcpl.cghdr"


LET cg.apply( op, stacksize )  BE
$(
//  Generate code for a routine or function application.  The value "op" is
//  an indication as to whether this is a routine or function application,
//  and "stacksize" is the size of the stack after the call.  We must put the
//  first three arguments into registers, and the rest of the items onto
//  the BCPL stack.

    LET args   =  (ssp - 1) - stacksize - savespacesize
    LET regs   =  args < 3  ->  args, 3
    
    LET tvec   =  VEC 2
    LET vvec   =  VEC 2

    //  The top item on the stack is the address of the routine to be called.
    //  We should evaluate the results in reverse order, and store them on
    //  the stack if necessary.

    LET pnode  =  arg1!a.node
    LET pt     =  0
    LET pv     =  0
    
    LET stckp  =  stacksize + savespacesize + regs

    //  Bring the stack down by one, and then scan the stack looking for any
    //  reference to the result resister.  We must unfortunately store this
    //  register, since the evaluation of the procedure address may corrupt it.

    cg.stack( ssp-1 )
    
    scanstack()

    //  We must evaluate the "pnode" to find out what sort of an animal it is.

    pv  :=  evaluate( pnode )
    pt  :=  evaltype
    
    //  Now, look to see if the address of the routine is already in
    //  a register, and if it is, we must cherish it, since we are about
    //  to swap register sets.

    IF  pt = t.register  THEN  
    $(
        LET rnode  =  block2( t.register, pv )
        
        cherish( pv, rnode )
        
        pt  :=  t.cherished
        pv  :=  rnode
    $)

    //  Now, store all those items which are below the level of the new
    //  stack frame.

    cg.store( 0, stacksize )

    //  Now, handle this arguments which must be stacked rather than passed
    //  in registers.

    cg.store( stckp, ssp )

    cg.stack( stckp )

    //  We must now take the other arguments, and put them into registers.
    //  This may require much munging around, and hence we must be careful
    //  in which order we do things.

    FOR  r = regs-1  TO  0  BY  -1  DO
    $(
        //  Pick up the relevant item on the stack, and evaluate it, keeping
        //  note of where the result was put.

        LET node     =  arg1!a.node

        LET v        =  evaluate( node )
        LET t        =  evaltype

        LET regnode  =  block2( t.register, r )

        movetor( r, t, v )
        cherish( r, regnode )

        cg.stack( ssp-1 )

        tvec!r  :=  t.cherished
        vvec!r  :=  regnode

        freenode( node )
    $)

    //  The registers now contain what they should, except they may have been
    //  cherished behind our back.  We must bring the registers back from
    //  the stack in this instance.
    
    FOR  r = 0  TO  regs-1  DO
    $(
        LET t   =  tvec!r
        LET v   =  vvec!r
        LET nt  =  v!n.type
        LET nv  =  v!n.arg1

        tvec!r  :=  nt
        vvec!r  :=  nv
        
        freeblock2( v )

        IF  nt = t.register  THEN  uncherish( nv )
    $)

    //  Now scan the table of cherished values, until no registers need
    //  destacking.
    
    $(  //  Repeat loop to scan the type and value tables until no change
        //  can be made.
        
        LET rmax     =  r.none
        LET vmax     =  0
        
        FOR  r = 0  TO  regs-1  DO
        $(
            LET t  =  tvec!r
            LET v  =  vvec!r
            
            IF  t = t.stack  THEN
            
                //  This item is still on the stack, and so should be
                //  considered, but only if it is the top item.

                UNLESS  v < vmax  DO
                $(
                    rmax  :=  r
                    vmax  :=  v
                $)
        $)
        
        IF  rmax = r.none  THEN  BREAK
        
        //  Otherwise, destack this register, and continue looking.
        
        destackregister( rmax, vmax )
        
        tvec!rmax  :=  t.register
        vvec!rmax  :=  rmax
    $)
    REPEAT  //  Until all stacked items have been destacked.
        
    //  All arguments are now set up for the big day.  We should load
    //  the procedure address, and then call the run time system to call
    //  the procedure in a BCPL environment.
    
    IF  pt = t.cherished  THEN
    $(
        //  The procedure address is cherished, and so we should restore it
        //  to its former glory.
        
        LET nt  =  pv!n.type
        LET nv  =  pv!n.arg1
        
        IF  nt = t.register  THEN  uncherish( nv )
        
        pt  :=  nt
        pv  :=  nv
    $)
    
    //  We have to decide here how to load the procedure address into HL.  It
    //  may already be in a register, in which case we must stack it.  It may
    //  be only available after a call to the run time system, in which case
    //  we should also stack it.  Otherwise it is safe to leave it after the
    //  register set switch.

    UNLESS  args = 0  DO  
    $(
        //  There are some arguments, so we must swap register sets.
        
        IF  pt = t.register  |  systemindex( pt, pv )  THEN
        $(
            //  Value is not directly loadable after a register set switch, so
            //  put it on the stack in order to preserve its value.
            
            pv  :=  stackitem( pt, pv )
            pt  :=  t.stack
        $)
        
        //  It is now safe to swap register sets, since the value is in store.

        code.i.1( i.exx )
    $)

    discardslave()

    movetor( r.hl, pt, pv )

    callmonfunction( m.apply )
    monargument( stacksize )

    freenode( pnode )

    //  On return from the procedure call, we must clear the register slave,
    //  and set the stack back to what we originally thought.  If this is a
    //  function application, then there will be a result which should be
    //  stacked.

    discardslave()

    cg.stack( stacksize )

    IF  op = s.fnap  THEN
    $(
        addslaveinfo( r.hl, t.local, ssp )

        cg.loadt( t.register, r.hl )
    $)
$)



AND scanstack()  BE
$(
//  Scan the stack, looking for elements which reference the result register.
//  When found, this item should be stored.

    LET found  =  FALSE
    LET arg    =  arg1
    
    UNTIL  arg = NIL  DO
    $(
        LET node  =  arg!a.node
        LET link  =  arg!a.link
        LET bool  =  scanforregister( node )
        
        IF  found & bool  THEN  cgerror( "scanstack( 2regs )" )
        
        found  :=  found | bool
        arg    :=  link
    $)
$)

    

AND cg.finish()  BE
$(
//  Generate code for the FINISH statement.  This is simple, since it is
//  just a call into the run time system.

    callmonfunction( m.finish )
    
    stopcoding()
$)



AND cg.global( n )  BE
$(
//  Generate code for the end of a section.  The value "n" is the number
//  of entries in the global table.

    incode  :=  TRUE

    IF  n = 0  THEN  cgwarning( "Code is unreachable" )

    bcplalign()

    code.n.2( 0 )

    FOR  i = 1  TO  n  DO
    $(
        LET gn  =  rdg()
        LET gl  =  rdl()
        LET nl  =  namelist

        code.n.2( gn*bytesperz80word )
        code.l.2( gl, lookuplabel( gl ) )

        //  Look in the name list for this entry.  When we have found it,
        //  update the entry so that it reflects the "global" status.
        
        UNTIL  nl = NIL  DO
        $(
            IF  nl!nl.type = t.local  &  nl!nl.value = gl  THEN
            $(
                nl!nl.type   :=  t.global
                nl!nl.value  :=  gn
                
                BREAK
            $)
            
            nl  :=  nl!nl.link
        $)
    $)

    code.n.2( maxgn*bytesperz80word )

    stopcoding()
$)



AND cg.comparejump( label, op, node1, node2 )  BE
$(
//  Generate code for a "compare" followed by a "jump" instruction.  We can
//  look to see if this can be optimised.  If "node2" is NIL, this means that
//  a second operand of zero is assumed.

    TEST  node2 = NIL  THEN
    $(
        //  We must evaluate the node represented by "node1" and then set the
        //  condition codes on the result.  

        LET v  =  evaluate( node1 )
        LET t  =  evaltype
        
        //  If the value is numeric, then we know know whether we should jump
        //  or not.
        
        TEST  t = t.number  THEN

            //  Look at the value and decide whether an unconditional branch
            //  should be compiled.
            
            IF  (op = s.eq  &  v = 0)  |  (op = s.ne  &  v \= 0)  THEN

                //  The condition matches, and so an unconditional branch
                //  should be compiled.
                
                cg.jump( label )
                
        ELSE
        $(
            //  Not quite so easy.  This value should be moved into a register,
            //  and then tested for equality with zero.
            
            LET r   =  movetoanyr( t, v, TRUE )
            LET rh  =  highbyte( r )
            LET rl  =  lowbyte( r )
            
            //  If the original node indicates that an indirection had to be
            //  made, then the result will already be in HL, and the low byte
            //  will already be in "A".
            
            UNLESS  node1!n.type = s.rv  DO  code.rr.1( i.ldrr, r.a, rl )

            code.s.1( i.or, rh )
            
            cg.branch( condition( op ), label )
        $)
    $)
    ELSE
    $(
        //  This is not quite so easy.  We should evaluate the condition
        //  by subtraction, and then decide what to do.  First, we should
        //  get rid of the two conditions which we cannot handle.
            
        LET t       =  0
        LET v       =  0
        LET t1      =  0
        LET v1      =  0
        LET t2      =  0
        LET v2      =  0
        LET noload  =  0

        IF  op = s.gr  |  op = s.le  THEN
        $(
            LET n  =  node1
                
            node1  :=  node2
            node2  :=  n
                
            op     :=  reverse( op )
        $)
        
        //  Look to see whether this is an indirection, followed by a
        //  comparison with zero.  If this is the case, then we can ignore
        //  one of the loads later on.
        
        IF  node1!n.type = s.rv  &  (node2!n.type = t.number  &  node2!n.arg1 = 0)  THEN
        
            //  This is exactly what we want.  The first operand is an
            //  indirection, and the second operand is zero.  Set the
            //  "noload" flag, so we can save ourselves work later.
            
            noload  :=  TRUE
            
        //  We now know that we have a condition which we can turn into
        //  a conditional branch.

        IF  node2!n.type = t.register  THEN
        $(
            //  The second argument is already in a register, so cherish it to
            //  stop it being clobbered by the evaluation of the first argument.
        
            LET r      =  node2!n.arg1
            LET rnode  =  block2( t.register, r )
            
            node2!n.type  :=  t.cherished
            node2!n.arg1  :=  rnode
            
            cherish( r, rnode )
        $)
    
        //  Now, evaluate the first argument, and see what sort of a revelation
        //  this brings.
    
        v1  :=  evaluate( node1 )
        t1  :=  evaltype
    
        //  Look at the data type of the first operand, and if it is a register
        //  then we must take special precautions to stop the register being
        //  destroyed.
    
        IF  t1 = t.register  THEN
        $(
            LET node  =  block2( t1, v1 )
    
            cherish( v1, node )
    
            t1  :=  t.cherished
            v1  :=  node
        $)
    
        //  Now evaluate the second argument.  We know that the first one will be
        //  safe, since it will be cherished if it is a register.
    
        v2  :=  evaluate( node2 )
        t2  :=  evaltype
    
        //  Having evaluated both operands, we can remove their cherished status
    
        IF  t1 = t.cherished  THEN
        $(
            LET node  =  v1
    
            t1  :=  node!n.type
            v1  :=  node!n.arg1
    
            IF  t1 = t.register  THEN  uncherish( v1 )
    
            freeblock2( node )
        $)
    
        IF  t2 = t.cherished  THEN
        $(
            LET node  =  v2
    
            t2  :=  node!n.type
            v2  :=  node!n.arg1
    
            IF  t2 = t.register  THEN  uncherish( v2 )
    
            freeblock2( node )
        $)

        //  Now, clear the "compare.cc" flag, and execute the subtraction
        //  which is going to compile the comparison.
        
        compare.cc  :=  FALSE

        v           :=  cg.plusminus( s.minus, t1, v1, t2, v2 )
        t           :=  evaltype
            
        //  We can now look to see if the result is a number.  If it is
        //  then we can compile (or not) an unconditional branch.
            
        TEST  t = t.number  THEN

            //  The result is numeric, and so if the value corresponds to
            //  the jumping condition, we can compile an unconditional
            //  jump.
                
            IF  (op = s.eq  &  v = 0)  |  (op = s.ne  &  v \= 0)  |
                (op = s.ls  &  v < 0)  |  (op = s.ge  &  v >= 0)  THEN
                    
                //  The condition is met, so compile the unconditional
                //  jump.
                    
                cg.jump( label )

        ELSE
        $(
            //  If the value is not a number, then we would expect it to
            //  be in a register.  If not, then there has been some sort
            //  of optimisation, which we must unoptimise!
                
            LET cc  =  0

            UNLESS  t = t.register  DO  
            $(
                v  :=  movetoanyr( t, v, TRUE )
                t  :=  t.register
            $)
                
            UNLESS  compare.cc  DO
            $(
                //  The condition codes have not been set unfortunately,
                //  but no matter, since we can set the condition codes
                //  now.
                    
                LET rh  =  highbyte( v )
                LET rl  =  lowbyte( v )
                
                //  At this point, it is worth checking for the common case
                //  of  (rv <cond> 0).  If this is the case, then the value
                //  will already by in HL, and A is already set up to contain
                //  L.
                
                TEST  op = s.eq  |  op = s.ne  THEN

                    //  This involves the OR of both halves of the register.
                    //  If the "noload" flag is set, then we have no need to
                    //  load the low byte of the register.

                    UNLESS  noload  DO  code.rr.1( i.ldrr, r.a, rl )

                ELSE

                    //  We must just OR the high byte of the register with
                    //  itself.
                    
                    code.rr.1( i.ldrr, r.a, rh )

                code.s.1( i.or, rh )
            $)

            //  It is worth putting some effort here into optimising the
            //  following:
            //
            //       xxxx
            //       Jx   L1
            //       JUMP L2
            //   L1: xxxx
            
            cc  :=  op
            
            op  :=  rdop()
            
            WHILE  op = s.stack  DO
            $(
                cg.stack( rdn() )
                
                op  :=  rdop()
            $)
            
            TEST  op = s.jump  THEN
            $(
                LET l1  =  rdl()
                
                //  Now read the next ocode statement, and decide whether
                //  we can optimise the jump.
                
                op  :=  rdop()
                
                WHILE  op = s.stack  DO
                $(
                    cg.stack( rdn() )
                
                    op  :=  rdop()
                $)
                
                TEST  op = s.lab  THEN
                $(
                    LET l2  =  rdl()
                    
                    //  We are now in the situation where we can do the
                    //  optimisation.  It may all have been for nothing,
                    //  but now is the moment of truth.
                    
                    TEST  l2 = label  THEN
                    $(
                        cg.branch( condition( notcond( cc ) ), l1 )
                        cg.setlabel( s.lab, l2 )
                    $)
                    ELSE
                    $(
                        //  Oh dear.  We have done all this lookahead, and
                        //  it is to no avail.
                        
                        cg.branch( condition( cc ), label )
                        cg.jump( l1 )
                        cg.setlabel( s.lab, l2 )
                    $)
                $)
                ELSE
                $(
                    //  This wasn't the OCODE we were expecting, so do
                    //  something about it.
                    
                    cg.branch( condition( cc ), label )
                    cg.jump( l1 )
                    
                    parseocode( op )
                $)
            $)
            ELSE
            $(
                //  We hardly got anywhere with the optimisation.  Oh well, 
                //  better luck next time!
                
                cg.branch( condition( cc ), label )
                
                parseocode( op )
            $)
        $)
    $)
$)



AND cg.branch( condition, label )  BE
$(
//  Generate a conditional branch instruction, depending on the condition
//  code given.

    LET labeladdr  =  lookuplabel( label )
    LET cc         =  z80cc( condition )

    IF  labeladdr \= NIL  &  relpossible( cc )  THEN
    $(
        //  This label has been set (backward jump), and hence we may be
        //  able to generate a "JR" instruction.
        
        LET offset  =  labeladdr - (currentloc + 2)
        
        UNLESS  offset < -128  DO
        $(
            //  Cooer.  This is a backward jump, and is in fact in range.
            
            cg.reljump( cc, label, offset )
            
            RETURN
        $)
    $)

    //  If we drop through that, then this means that this is an long branch
    //  and so we must generate absolute code.
    
    cg.absjump( cc, label, labeladdr )
$)



AND relpossible( cc )  =  cc = cc.none  |  cc = cc.z   |  cc = cc.nz  |
                          cc = cc.c     |  cc = cc.nc




AND cg.reljump( cc, label, offset )  BE
$(
//  Generate code for a relative jump operation.  The condition code for
//  the jump is "cc".

    LET inst  =  cc = cc.none  ->  i.jr,
                 cc = cc.z     ->  i.jrz,
                 cc = cc.nz    ->  i.jrnz,  
                 cc = cc.c     ->  i.jrc,
                 cc = cc.nc    ->  i.jrnc,  cgerror( "cg.reljump( %N )", cc )

    code.il.2( inst, label, offset & #XFF )
$)



AND cg.absjump( cc, label, location )  BE
$(
//  Generate code for an absolute jump.  The location given is either NIL,
//  implying that this label hasn't been set yet.

    LET inst  =  cc = cc.none  ->  i.jp,
                 cc = cc.z     ->  i.jpz,
                 cc = cc.nz    ->  i.jpnz,
                 cc = cc.p     ->  i.jpp,
                 cc = cc.m     ->  i.jpm,  
                 cc = cc.c     ->  i.jpc,
                 cc = cc.nc    ->  i.jpnc,  cgerror( "cg.absjump( %N )", cc )

    code.il.3( inst, label, location )
$)



AND z80cc( condition )  =  condition = cond.always  ->  cc.none,
                           condition = cond.carry   ->  cc.c,
                           condition = cond.nocarry ->  cc.nc,
                           condition = cond.eq      ->  cc.z,
                           condition = cond.ne      ->  cc.nz,
                           condition = cond.ls      ->  cc.m,
                           condition = cond.ge      ->  cc.p,  
                           
                           //  The following are not strictly correct, but
                           //  we should have them here, because certain
                           //  optimisations require them.
                           
                           condition = cond.gr      ->  cc.p,
                           condition = cond.le      ->  cc.m,
                           
                                                        cgerror( "z80cc( %N )", condition )

        
        
AND systemindex( t, v )  =  VALOF
$(
//  Return TRUE if this value can only be loaded by calling the monitor.

    TEST  (t = t.lv.local  |  t = t.lv.global)  THEN
          RESULTIS  TRUE

    ELSE

    TEST  (t = t.local  |  t = t.global)  &  outofrange( v )  THEN
          RESULTIS  TRUE

    ELSE  RESULTIS  FALSE
$)



AND outofrange( v )  =  NOT  (0 <= v <= 127)



AND loadindexvalue( t, v )  =  VALOF
$(
//  Generate code to call the monitor function to load the value given onto
//  the stack.  If the item being handled is "local" or "global", then
//  we must subtract off the number which are already addressable.

    IF  t = t.local  |  t = t.global  THEN  v  :=  v - 128

    monloadfunction( t )
    monargument( v )

    stackp  :=  stackp + 1

    RESULTIS  stackp-1
$)



AND highbyte( r )     =  r = r.hl  ->  r.h,
                         r = r.de  ->  r.d,
                         r = r.bc  ->  r.b,  cgerror( "highbyte( %N )", r )



AND lowbyte( r )   =  r = r.hl  ->  r.l,
                      r = r.de  ->  r.e,
                      r = r.bc  ->  r.c,  cgerror( "lowbyte( %N )", r )




AND movetor( r, t, v )  BE
$(
//  Generate code to move the value "t,v" into register "r".  What we do
//  depends very much on the value we need to move in.

    LET s  =  lookinslave( t, v )

    //  We must check to make sure that this register is not in fact
    //  cherished, and if it is, store its value away.

    UNLESS  notcherished( r )  DO
    $(
        LET seq  =  rchseq!r
        
        FOR  i = 1  TO  seq  DO
        $(
            LET rr  =  chseqr( i )
            
            UNLESS  rr = r.none  DO  storecherished( rr )
        $)
    $)

    //  Look to see if the item we wish to move is actually in a
    //  register, and if it is, save ourselves the trouble of doing any
    //  more.
    
    UNLESS  s = r.none  DO
    $(
        //  The value we want is in the slave.  All we need to do is to
        //  copy the information across.

        UNLESS  s = r  DO
        $(
            //  We must compile some code to move the value from register
            //  "s" to register "r".
            
            LET sh  =  highbyte( s )
            LET rh  =  highbyte( r )
            LET sl  =  lowbyte( s )
            LET rl  =  lowbyte( r )
            
            code.rr.1( i.ldrr, rl, sl )
            code.rr.1( i.ldrr, rh, sh )
            
            unsetslave( r )
            copyslave( s, r )
        $)
        
        RETURN
    $)

    //  Ok.  The value was not in the slave, and so we had better do
    //  something about this.

    SWITCHON  t  INTO
    $(
        CASE t.local      :
        CASE t.global     :  TEST  systemindex( t, v )  
                                 THEN  destackregister( r, loadindexvalue( t, v ) )
                                 ELSE  loadixiy( r, t, v )
                             ENDCASE


        CASE t.lv.local   :
        CASE t.lv.global  :  destackregister( r, loadindexvalue( t, v ) )
                             ENDCASE


        CASE t.label      :  loadstatic( r, v )
                             ENDCASE


        CASE t.lv.label   :  loadlvstatic( r, v )
                             ENDCASE


        CASE t.number     :  loadnumber( r, v )
                             ENDCASE


        CASE t.stack      :  destackregister( r, v )
                             ENDCASE
                             
                             
        CASE t.cherished  :  movetor( r, v!n.type, v!n.arg1 )
                             ENDCASE


        DEFAULT           :  cgerror( "movetor( %N, %N )", t, v )
    $)

    //  When we drop out of there, the item has been moved into the register,
    //  and so we should update the slave to reflect this.
    
    unsetslave( r )
    
    UNLESS  t = t.register  |  t = t.stack  DO  addslaveinfo( r, t, v )
$)



AND loadixiy( r, t, v )  BE
$(
//  Load the item at offset "v" on the stack or in the global vector into
//  register "r".

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



AND loadnumber( r, n )  BE  code.rn.3( i.ldrnn, r, n )



AND loadstatic( r, l )  BE
$(
//  Generate code to load a label from a static location.  The size of the
//  instruction depends on whether the register is HL or not.

    LET labeladdr  =  lookuplabel( l )
    
    TEST  r = r.hl  THEN

        //  This is a 3 byte instruction, which should be used in preference
        //  to the more general 4 byte version.

        code.il.3( i.ldhll, l, labeladdr )

    ELSE

        //  This is unfortunately a 4 byte instruction, but what the hell - it's
        //  still shorter than loading from the stack.
        
        code.rl.4( esc.ed, i.ldrl, r, l, labeladdr )
$)



AND loadlvstatic( r, l )  BE
$(
//  Load the BCPL address of a static location into the register "r".  We can
//  load the machine address immedietaly, but we must shift it to the right
//  in order to get the BCPL address.

    LET labeladdr  =  lookuplabel( l )
    
    LET rh         =  highbyte( r )
    LET rl         =  lowbyte( r )

    code.rl.3( i.ldrll, r, l, labeladdr )

    //  Now, generate the code to shift the value right.
    
    code.r.2( esc.cb, i.srl, rh )
    code.r.2( esc.cb, i.rr, rl )
$)



AND destackregister( r, n )  BE
$(
//  Generate code to destack the item on the stack into a register.  We must
//  make sure that the item is actually on the top of the stack.

    UNLESS  n = stackp-1  DO  cgerror( "destackregister( %N )", n )

    code.ss.1( i.pop, r )

    destackitem()
$)

    

AND movetoanyr( t, v, readonly )  =  movetoanybutr( r.none, t, v, readonly )



AND movetoanybutr( r, t, v, readonly )  =  VALOF
$(
//  General routine to attempt to move the value "t,v" into any register
//  but "r".  The value "readonly" is a flag saying whether exclusive
//  access is required for this register.

    LET slaver  =  searchslave( r, t, v )
    LET freer   =  0

    //  If we have found this item in the register slave, and we only want
    //  the register "read only", then we can return the item without
    //  further ado.
    
    IF  slaver \= r.none  &  (readonly  |  notcherished( slaver ))  THEN  
    
        RESULTIS  slaver

    //  Otherwise, we must move the value into a register and return that
    //  register.  If there are free registers, then return a free register,
    //  otherwise we must make one free and then use it.  Otherwise, use the
    //  one that was least recently cherished.
    
    freer  :=  findfreer( r )

    IF  freer = r.none  THEN

        //  There are no free registers around, and so we must stack the 
        //  oldest cherished register.
        
        freer  :=  freecherished( r )

    //  We now have a free register into which we can put the value, so call
    //  the next level to do just that.
         
    movetor( freer, t, v )

    //  When we drop out of there, the value "freer" is the register in
    //  which the item is held.
    
    RESULTIS  freer
$)



AND lookinslave( t, v )  =  searchslave( r.none, t, v )



AND searchslave( r, t, v )  =  VALOF
$(
//  Search the register slave for the value "t,v", excluding register "r".
//  We return the name of the register containing the value we want, or
//  "r.none" if the item is not in the slave.

    IF  t = t.register  THEN
        UNLESS  v = r  DO
            RESULTIS  v

    FOR  rr = r.hl  TO  r.bc  DO
    
        //  First, check to see if this register is allowed, and if it is,
        //  search further to see if there is a relevant entry.
        
        UNLESS  rr = r  DO
        
            //  Search the list of items associated with this register in the
            //  slave, and if the item is in there, return it.

            IF  isinlist( rinfo!rr, t, v )  THEN  
            
                //  We can return the name of this register as the result of
                //  the procedure.

                RESULTIS  rr

    //  If we drop out of that loop without returning, then the value we want
    //  is not in the slave, and hence we should return nothing.
    
    RESULTIS  r.none
$)



AND copyslave( r1, r2 )  BE
$(
//  Copy the slave information from register r1 to register r2.

    unsetslave( r2 )

    rinfo!r2  :=  copyof( rinfo!r1 )
$)



AND copyof( item )  =  

    //  Return a copy of the list given.  The list will be short, so we can
    //  do the copy recursively.

    item = NIL  ->  NIL,   
                    block3( copyof( item!l.link ), item!l.type, item!l.value )



AND isinlist( list, t, v )  =

    //  Return a boolean saying whether there is an entry for "t,v" in the
    //  list "list".  The list will be short, so we can search it recursively.

    (list = NIL)                            ->  FALSE,
    (list!l.type = t  &  list!l.value = v)  ->  TRUE,
                                                isinlist( list!l.link, t, v )


