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


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


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



SECTION "CG-3"


GET "LIBHDR"
GET "bcpl.cghdr"


LET cg.stackop( op, t1, v1, t2, v2 )  =  VALOF
$(
//  Code generate for operators which must call monitor functions.  We must
//  put the arguments onto the stack, and then call the routine.  We then
//  leave the result on the stack, in case we are about to call another
//  monitor routine.

    IF  t1 = t.register  THEN
    $(
        //  Already in a register, so stack it immediately.

        v1  :=  stackitem( t1, v1 )
        t1  :=  t.stack
    $)

    IF  t2 = t.register  THEN
    $(
        //  Also already in a register, so stack it immediately.

        v2  :=  stackitem( t2, v2 )
        t2  :=  t.stack
    $)

    //  If either of the arguments were in registers, then thay have already
    //  been stacked.  We should now stack any other items which might
    //  themselves need registers.

    UNLESS  t1 = t.stack  DO  v1  :=  stackitem( t1, v1 )
    UNLESS  t2 = t.stack  DO  v2  :=  stackitem( t2, v2 )

    //  We should now make sure that the operands are on the stack in the
    //  right order.

    TEST  (v1 = stackp-2  &  v2 = stackp-1)  THEN

        //  This is a standard monitor function without the necessity to
        //  change the operation.

        monfunction( op, FALSE )

    ELSE

    TEST  (v2 = stackp-2  &  v1 = stackp-1)  THEN

        //  This is a monitor function, where the operation must be
        //  reversed.

        monfunction( op, TRUE )

    //  If neither of the above are true, then we have somehow got our
    //  stack in a twist.  This is an internal error, and hence we should
    //  moan.

    ELSE  cgerror( "cg.stackop( %N %N )", v1, v2 )

    //  After all that, the result is left on the stack, and so all we do is
    //  bring the stack down by one, and return the result.

    destackitem()

    evaltype  :=  t.stack

    RESULTIS  stackp-1
$)



AND stackitem( type, value )  =  VALOF
$(
//  Put the item given onto the stack.  It may already be in a register,
//  in which case we can push it immediately.  Otherwise, we must look to
//  see if we require a system call to get the item, in which case we can
//  leave it on the stack after the system call.  Otherwise, we must put
//  it in a register, and push that.

    LET r  =  lookinslave( type, value )

    IF  debugging & listing  THEN  writel( ";  Stack %N,%N  SP=%N", type, value, stackp )

    IF  r = r.none  THEN

        //  There is no mention of this item in the slave already, so we
        //  must adopt a different approach.

        TEST  systemindex( type, value )  THEN
        $(
            //  This is a value which we must call the system to get,
            //  and so we can stack the value immediately.

            stackcherished()

            RESULTIS  loadindexvalue( type, value )
        $)
        ELSE

            //  It appears as though there is nothing for it, but to move this
            //  value into a register.

            r  :=  movetoanyr( type, value, TRUE )

    //  At this point, "r" is the register containing the value we want.
    //  generate code to push the value.

    stackcherished()

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

    stackp  :=  stackp + 1

    RESULTIS  stackp-1
$)



AND destackitem()  BE  
$(
    stackp  :=  stackp - 1

    IF  debugging & listing  THEN  writel( ";  Destack  SP=%N", stackp )
$)



AND cg.monadic( op, node )  =  VALOF
$(
//  Generate code for a monadic operator.  Do any constant folding if
//  possible.

    LET v  =  evaluate( node )
    LET t  =  evaltype

    //  If the value is a constant, then we can evaluate it here and
    //  now.

    IF  t = t.number  THEN
    $(
        evaltype  :=  t

        SWITCHON  op  INTO
        $(
            CASE s.neg  :  RESULTIS  -v
            CASE s.not  :  RESULTIS  NOT v
            CASE s.abs  :  RESULTIS  ABS v

            CASE s.rv   :  ENDCASE

            DEFAULT     :  cgerror( "cg.monadic( %N )", op )
        $)
    $)

    //  If we drop through there, then there is nothing for it but to compile
    //  some code.

    SWITCHON  op  INTO
    $(
        CASE s.neg  :  RESULTIS  cg.neg( t, v )
        CASE s.not  :  RESULTIS  cg.not( t, v )
        CASE s.abs  :  RESULTIS  cg.abs( t, v )
        CASE s.rv   :  RESULTIS  cg.rv( t, v )

        DEFAULT     :  cgerror( "cg.monadic( %N )", op )
    $)
$)



AND cg.neg( type, value )  =  VALOF
$(
//  Generate code for the "negate" function.  Since we are working on a
//  twos complement machine, this is the same as a NOT, followed by an
//  increment.

    LET v  =  cg.not( type, value )
    LET t  =  evaltype

    LET r  =  movetoanyr( t, v, TRUE )

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

    unsetslave( r )

    evaltype  :=  t.register

    RESULTIS  r
$)



AND cg.not( type, value )  =  VALOF
$(
//  Code generate for a logical "NOT" operation.

    LET r   =  movetoanyr( type, value, FALSE )
    LET rh  =  highbyte( r )
    LET rl  =  lowbyte( r )

    code.rr.1( i.ldrr, r.a, rh )
    code.i.1( i.cpl )
    code.rr.1( i.ldrr, rh, r.a )

    code.rr.1( i.ldrr, r.a, rl )
    code.i.1( i.cpl )
    code.rr.1( i.ldrr, rl, r.a )

    unsetslave( r )

    evaltype  :=  t.register

    RESULTIS  r
$)



AND cg.abs( type, value )  =  VALOF
$(
//  Code generate for the ABS operator.  This involves a call to the operating
//  system, and hence we must put the argument onto the stack.

    UNLESS  type = t.stack  DO  value  :=  stackitem( type, value )

    //  At this point, the item is on the stack, but we must do an internal
    //  check to make sure that it is in the right place.

    UNLESS  value = stackp-1  DO  cgerror( "cg.abs( %N )", value )

    monfunction( s.abs, FALSE )

    //  The result is on the stack, so return this as the value.

    evaltype  :=  t.stack

    RESULTIS  value
$)



AND cg.rv( type, value )  =  VALOF
$(
//  Code generate for the "!" operator.  This means moving the value into
//  HL, making it a machine pointer, and then indirecting on it.

    movetor( r.hl, type, value )

    //  The operand is now in the HL register.  Before we can indirect on
    //  it, we must make it a byte address.

    code.ss.1( i.addhl, r.hl )

    //  We can now load the indirect value into 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 )

    unsetslave( r.hl )

    evaltype  :=  t.register

    RESULTIS  r.hl
$)



AND cg.byteop( op, t1, v1, t2, v2 )  =  VALOF
$(
//  Code generate for a "getbyte" or "putbyte" operation.  This involves
//  making a machine representation of the first operand, adding in the
//  second operand, and then indirecting on the result.

    LET noadd  =  FALSE

    IF  t1 = t.number  &  t2 = t.number  THEN
    $(
        //  This is a simple case.  We can evaluate the address immediately.
        
        v1     :=  (v1 * bytesperz80word)  +  v2
        v2     :=  0
        
        noadd  :=  TRUE
    $)

    IF  t1 = t.number  &  v1 = 0  THEN
    $(
        //  This is also very simple, since we know that the address is now
        //  (t2,v2).
        
        t1     :=  t2
        v1     :=  v2
        
        t2     :=  t.number
        v2     :=  0
        
        noadd  :=  TRUE
    $)

    //  We really do have to compile the addition.  We have to deal with
    //  all the complicated cases where the arguments are all mixed up.

    IF  t1 = t.register  THEN
    $(
        //  Better cherish the register, just to make sure it doesn't get
        //  clobbered by the following load.
            
        LET rnode  =  block2( t1, v1 )
        
        cherish( v1, rnode )

        t1  :=  t.cherished
        v1  :=  rnode
    $)

    UNLESS  (t1 = t.stack  &  t2 = t.stack  &  (v1 > v2))  |  t2 = t.number  DO
    $(
        LET r  =  movetoanybutr( r.hl, t2, v2, TRUE )
        
        t2  :=  t.register
        v2  :=  r
    $)

    //  Now, restore the status of the first argument, and move it into HL.
    
    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 )
    $)

    TEST  noadd  THEN

        //  This is a simple case, since we have already calculated the address
        //  and hence we need not do the addition.
             
        movetor( r.hl, t1, v1 )
            
    ELSE
    $(
        //  More complicated.  We have to calculate the address by
        //  addition.

        movetor( r.hl, t1, v1 )

        code.ss.1( i.addhl, r.hl )

        unsetslave( r.hl )
    $)
    
    //  Now generate code to add the two numbers together, and then indirect
    //  on the result.
    
    v1  :=  cg.plusminus( s.plus, t.register, r.hl, t2, v2 )
    t1  :=  evaltype

    movetor( r.hl, t1, v1 )

    //  We must now decide whether we are generating for a "getbyte" or a
    //  "putbyte" operation.

    IF  op = s.putbyte  THEN
    $(
        //  Since the address we want is in HL, we had better cherish the
        //  register PDQ, since we don't want it to be overwritten.

        LET node1  =  arg1!a.node
        LET node2  =  block2( t.register, r.hl )

        cherish( r.hl, node2 )

        //  We are now in a state to evaluate the value which we wish to
        //  store in this location.

        cg.stack( ssp-1 )

        v1  :=  evaluate( node1 )
        t1  :=  evaltype

        t2  :=  node2!n.type
        v2  :=  node2!n.arg1
        
        IF  t2 = t.register  THEN  uncherish( v2 )

        freenode( node1 )
        freeblock2( node2 )

        //  We have now evaluated both the address and the value.  Move the
        //  address back into HL (if it had been moved), and then decide on
        //  how we intend to store the value.

        UNLESS  (t1 = t.stack  &  t2 = t.stack  &  (v1 < v2))  |  t1 = t.number  DO
        $(
            LET r  =  movetoanybutr( r.hl, t1, v1, TRUE )
            
            t1  :=  t.register
            v1  :=  r
        $)

        //  It is now safe to bring the indirection address back into HL from
        //  wherever it was hiding.

        movetor( r.hl, t2, v2 )

        TEST  t1 = t.number  THEN
        $(
            //  If we are storing a number, then there is no point in wasting
            //  another register.  We just store the byte as data.

            LET byte  =  v1  &  #XFF

            code.rn.2( i.ldrn, r.ihl, byte )
        $)
        ELSE
        $(
            //  Otherwise, we must load the data into a register, and then
            //  store it.

            LET r  =  movetoanybutr( r.hl, t1, v1, TRUE )

            code.rr.1( i.ldrr, r.ihl, lowbyte( r ) )
            
            unsetslave( r )
        $)

        unsetslave( r.hl )

        RESULTIS  NIL
    $)

    //  Otherwise, we assume that we are dealing with a "getbyte" operation,
    //  and so we can get on with it.

    code.rr.1( i.ldrr, r.l, r.ihl )
    code.s.1( i.xor, r.a )
    code.rr.1( i.ldrr, r.h, r.a )

    unsetslave( r.hl )

    evaltype  :=  t.register

    RESULTIS  r.hl
$)



AND cg.stindop( t1, v1, t2, v2 )  =  VALOF
$(
//  Code generate for the STIND operation.  We have used the "dyadic" op
//  routines to evaluate the arguments.  We should now calculate the
//  machine address of the first operand, and then store the second operand
//  in that location.

    IF  t1 = t.register  THEN
    $(
        //  Better cherish the register, just to make sure it doesn't get
        //  clobbered by the following load.
        
        LET rnode  =  block2( t1, v1 )
        
        cherish( v1, rnode )

        t1  :=  t.cherished
        v1  :=  rnode
    $)

    UNLESS  (t1 = t.stack  &  t2 = t.stack  &  (v1 > v2))  |  t2 = t.number  DO
    $(
        LET r  =  movetoanybutr( r.hl, t2, v2, TRUE )
        
        t2  :=  t.register
        v2  :=  r
    $)

    //  Now, restore the status of the first argument, and move it into HL.
    
    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 )
    $)

    movetor( r.hl, t1, v1 )

    code.ss.1( i.addhl, r.hl )

    unsetslave( r.hl )

    //  Now, look at the second operand, and decide what to do.  If it is
    //  a number, then we store the number immediately.  Otherwise, we
    //  put the value into a register, and then store the register.

    TEST  t2 = t.number  THEN
    $(
        LET hb  =  (v2 >> 8)  &  #XFF
        LET lb  =  (v2)       &  #XFF

        code.rn.2( i.ldrn, r.ihl, lb )
        code.ss.1( i.inc, r.hl )
        code.rn.2( i.ldrn, r.ihl, hb )
    $)
    ELSE
    $(
        //  We must load the second value into a register, and then store
        //  that register.

        LET r   =  movetoanybutr( r.hl, t2, v2, TRUE )
        LET rh  =  highbyte( r )
        LET rl  =  lowbyte( r )

        code.rr.1( i.ldrr, r.ihl, rl )
        code.ss.1( i.inc, r.hl )
        code.rr.1( i.ldrr, r.ihl, rh )
    $)

//******  UNSAFE
//******  cg.unslavestorage()
//******  UNSAFE

    RESULTIS  NIL
$)



AND cg.goto()  BE
$(
//  Generate code for a GOTO statement.  The top item on the stack represents
//  an address to jump to.

    LET node  =  arg1!a.node
    LET v     =  0
    LET t     =  0

    cg.stack( ssp-1 )
    cg.store( 0, ssp )

    //  Having got the stack into a sanitary state, we can evaluate the node
    //  expression, and put the resulting value either into HL, or on the
    //  stack.  We can then generate either a JP (HL) or a RET instruction.

    v  :=  evaluate( node )
    t  :=  evaltype

    UNLESS  t = t.stack  DO

        //  The item is not on the stack, so look to see where it is.  If we
        //  must access the value via the stack, then there is no point in
        //  destacking the item.

        TEST  systemindex( t, v )  THEN
        $(
            v  :=  loadindexvalue( t, v )
            t  :=  t.stack
        $)
        ELSE
        $(
            movetor( r.hl, t, v )

            v  :=  r.hl
            t  :=  t.register
        $)

    //  We should now generate either a JP (HL) or a RET instruction,
    //  depending on where the value is.

    TEST  t = t.stack  THEN
    $(
        code.i.1( i.ret )

        destackitem()
    $)
    ELSE  code.i.1( i.jpihl )

    //  Having done all that, we can leave the realm of compiled code,
    //  discarding all the registers etc.

    freenode( node )

    stopcoding()
$)



AND cg.setlabel( type, label )  BE
$(
//  Set a label.  On finding a label, we can assume that code is reachable
//  again, and hence we can start coding.  The type is "blab" or "lab",
//  the difference being irrelevant to us.

    startcoding()

    cg.store( 0, ssp )
    discardslave()

    setlabel( label )
    setlabelrefs( label )
$)



AND cg.entry( n )  BE
$(
//  Code generate an entry point to a procedure.  The value passed to us is the
//  length of the name of the procedure.

    LET label  =  rdl()
    LET o      =  output()
    LET s      =  getstore( n/bytesperword )

    procdepth  :=  procdepth + 1
    
    startcoding()

    bcplalign()

    FOR  i = 1  TO  n  DO  s % i  :=  rdn()

    s % 0  :=  n

    addname( s, label )

    IF  listing  THEN  writel( ";  Entry to *"%S*"", s )

    selectoutput( sysout )
    writef( "%X4:  *"%S*"*N", currentloc, s )
    selectoutput( o )

    cg.setlabel( s.lab, label )
$)



AND cg.save( n )  BE
$(
//  Code generate for a SAVE statement.  This occurs only after entry to a
//  procedure, and gives an indication of how many arguments are expected.
//  All the linkage set up is done by one of three system routines depending
//  on how many arguments there are.

    LET args  =  n - savespacesize
    LET regs  =  args > 3  ->  3, args

    LET monf  =  args = 0  ->  m.setlink0,
                 args = 1  ->  m.setlink1,
                 args = 2  ->  m.setlink2,
                               m.setlink3

    //  Bring the stack down to a reasonable position, and then load the
    //  register arguments onto the stack.

    cg.stack( savespacesize )

    callmonfunction( monf )

    //  Stack the registers, and other local variables...

    FOR  i = 0  TO  regs-1  DO
    $(
        //  Add the register slave information, and then load the register
        //  concerned onto the simulated stack.
        
        LET r  =  i    //  See MANIFEST declarations

        addslaveinfo( r, t.local, ssp )

        cg.loadt( t.local, ssp )
    $)

    //  We should now load the relevant number of local variables onto the
    //  stack, and we are ready for the body of the procedure.

    FOR  i = regs  TO  args-1  DO  cg.loadt( t.local, ssp )
$)



AND cg.return( op )  BE
$(
//  Code generate for the RETURN operation.  The return link is on the BCPL
//  stack, and there may or may not be a result to be passed back.

    IF  op = s.fnrn  THEN
    $(
        //  We must return a result.  The result is currently in "arg1", and
        //  it should be evaluated and placed in HL before returning.

        LET node  =  arg1!a.node
        LET v     =  evaluate( node )
        LET t     =  evaltype

        cg.stack( ssp-1 )

        movetor( r.hl, t, v )

        freenode( node )
    $)

    //  We must now return.  The code after this is unreachable, so stop
    //  compiling code.

    callmonfunction( m.return )

    stopcoding()
$)



AND cg.endproc( n )  BE
$(
//  End of a procedure.  This means that we should stop coding, and decrement
//  the procedure depth value.

    UNLESS  n = 0  DO  cgerror( "cg.endproc( %N )", n )
 
    IF  listing  THEN  writel( ";  End of procedure" )

    stopcoding()

    procdepth  :=  procdepth - 1
$)



AND cg.res( label )  BE
$(
//  Code generate for a RESULTIS statement.  The value to be evaluated is
//  currently in ARG1, with the label to be jumped to in "label".  We can
//  usually optimise this, since OCODE of the following form is common:
//
//      RES Ln   LAB Ln
//  or  RES Ln   STACK n  LAB Ln

    LET op    =  0
    LET node  =  arg1!a.node
    LET v     =  0
    LET t     =  0

    //  First, move the evaluated argument into HL, and then bring the stack
    //  down by one.

    cg.store( 0, ssp-1 )

    v  :=  evaluate( node )
    t  :=  evaltype

    movetor( r.hl, t, v )

    cg.stack( ssp-1 )

    freenode( node )

    //  Now, look ahead in the ocode, for the corresponding LAB statement.

    op  :=  rdop()

    WHILE  op = s.stack  DO
    $(
        cg.stack( rdn() )

        op  :=  rdop()
    $)

    //  Now, look to see if we have to set a label.  If not, we had better
    //  undo the damage done, and generate the jump instruction after
    //  all.

    TEST  op = s.lab  THEN
    $(
        //  This is a LAB statement, but is it the right one ?

        LET l  =  rdl()

        UNLESS  l = label  DO

            //  This is a label, but not the one we were expecting.  We should
            //  generate a jump for the RES, and then set the new label.

            cg.branch( cond.always, label )

        cg.setlabel( s.lab, l )
    $)
    ELSE
    $(
        //  We are even further up the creek, since this isn't even a LAB
        //  instruction.  Generate the JUMP, and then parse the OCODE
        //  statement.

        cg.branch( cond.always, label )

        stopcoding()

        parseocode( op )
    $)
$)



AND cg.rstack( n )  BE
$(
//  Generate code for the RSTACK instruction.  This is called immediately after
//  a RES instruction, and hence we know that the result to be stacked is
//  in HL.

    cg.stack( n )

    discardslave()
    addslaveinfo( r.hl, t.local, ssp )

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


