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


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


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



SECTION "CG-1"


GET "LIBHDR"
GET "bcpl.cghdr"


LET start()  BE
$(
//  Main routine of the BCPL code generator.  All the routines in this section
//  should be common to all BCPL code generators, and hence need not be
//  implemented again.

    LET args  =  "FROM/A,TO/A,LIST/K,MAP/K,DEBUG/S"
    LET argv  =  VEC 50

    sysout  :=  output()

    UNLESS  rdargs( args, argv, 50 )  DO
    $(
        cgwarning( "Bad arguments for string *"%S*"*N", args )

        stop( 20 )
    $)

    fromfile    :=  argv!0
    tofile      :=  argv!1
    listfile    :=  argv!2
    mapfile     :=  argv!3
    debugging   :=  argv!4

    fromstream  :=  findinput( fromfile )
    tostream    :=  findoutput( tofile )

    IF  fromstream = 0  |  tostream = 0  THEN
    $(
        TEST  fromstream = 0
            THEN  cgwarning( "Cannot open input file *"%S*"*N", fromfile )
            ELSE  endstream( fromstream )

        TEST  tostream = 0
            THEN  cgwarning( "Cannot open output file *"%S*"*N", tofile )
            ELSE  endstream( tostream )

        stop( 20 )
    $)

    TEST  listfile = 0  THEN  liststream  :=  0
    ELSE
    $(
        liststream  :=  findoutput( listfile )

        IF  liststream = 0  THEN
            cgwarning( "Cannot open listing file *"%S*"", listfile )
    $)

    //  If there is no output stream for the listing, then reset the "listing"
    //  flag, so we don't waste any time attempting to generate one.

    listing  :=  (liststream \= 0)

    //  Now open the map stream, of there is one.

    TEST  mapfile = 0  THEN  mapstream  :=  0
    ELSE
    $(
        mapstream  :=  findoutput( mapfile )

        IF  mapstream = 0  THEN
            cgwarning( "Cannot open mapping file *"%S*"", mapfile )
    $)

    //  Set the mapping flag if we have a map stream.

    mapping  :=  (mapstream \= 0)

    //  Say hello to the outside world.

    writes( "Z80CG  Version 1.15*N*N" )

    //  We can now select the streams, and away we go!

    selectinput( fromstream )
    selectoutput( tostream )

    freelist2     :=  NIL
    freelist3     :=  NIL

    namelist      :=  NIL

    totalstorage  :=  0
    totalused     :=  0

    cg.initstore( 2500 )

    maxlabel      :=  1000
    labeladdr     :=  getstore( maxlabel )
    labelrefs     :=  getstore( maxlabel )

    //  Initialise the buffer which will hold pointers to the compiled code.

    memchunks     :=  getstore( maxchunks )

    FOR  i = 0  TO  maxchunks-1  DO  memchunks!i  :=  NIL

    //  The following tables define the restart functions which are available.
    //  The vector "rstfuncs" is set to the functions which it is desirable to
    //  call directly.  The vector "rstinsts" is a list of the instructions
    //  which correspond to the functions, and "rstcount" is the number of
    //  free restart instructions for the current operating system.

    rstfuncs      :=  TABLE  0,        m.apply,   m.fixup,   m.loadix,
                             m.loadiy, m.storeix, m.storeiy, m.loadlvix

    rstinsts      :=  TABLE  i.rst38,  0,         0,         0,
                             0,        0,         0,         0

    rstcount      :=  0

    cg.initdata()
    cg.initstack( savespacesize )

    rinfo         :=  getstore( r.bc )
    rchnode       :=  getstore( r.bc )
    rchseq        :=  getstore( r.bc )

    currentloc    :=  0
    programbase   :=  0

    readocode()

    moduleend()

    endread()
    endwrite()

    IF  listing  THEN
    $(
        selectoutput( liststream )

        endwrite()
    $)

    IF  mapping  THEN
    $(
        selectoutput( mapstream )

        writef( "*NProgram size:  %N bytes*N", currentloc )

        endwrite()
    $)

    cg.uninitstore()

    selectoutput( sysout )

    writef( "%N bytes of code generated.*N*
            *%N out of %N words of workspace used.*N",
            currentloc, totalused, totalstorage )
$)



AND readocode()  BE
$(
//  Main loop of the code generator.  Read in OCODE statements one by one,
//  and parse them.  This main loop SHOULD be repeated...

    LET op  =  initsection( rdop() )
    LET o   =  output()

    IF  op = s.end  THEN  RETURN

    $(  //  Now, enter the main loop, generating code for the sections.
        //  The OCODE statement "GLOBAL" terminates a section.

        parseocode( op )

        IF  op = s.global  THEN  BREAK

        op  :=  rdop()
    $)
    REPEAT

    uninitsection()

    selectoutput( sysout )
    newline()
    selectoutput( o )
$)
REPEAT



AND initsection( op )  =  op = s.end  ->  op,  VALOF
$(
//  Initialise all the variables for a section.

    FOR  r = r.hl  TO  r.bc  DO
    $(
        rinfo!r    :=  NIL
        rchnode!r  :=  NIL
        rchseq!r   :=  0
    $)

    FOR  l = 0  TO  maxlabel  DO
    $(
        labeladdr!l  :=  NIL
        labelrefs!l  :=  NIL
    $)

    cglabel     :=  maxlabel
    procdepth   :=  0
    maxgn       :=  0
    maxln       :=  0
    chseq       :=  0
    stackp      :=  0
    lengthlab   :=  maxlabel

    TEST   op = s.section
        THEN  op  :=  cg.section()
        ELSE  moduledef( "NoName" )

    WHILE  op = s.needs  DO  op  :=  cg.needs()

    incode  :=  TRUE

    IF  listing  THEN  writel( "    REL" )

    code.n.1( 'B' )
    code.n.1( 'C' )
    code.n.1( 'P' )
    code.n.1( 'L' )

    code.l.2( lengthlab, 0 )

    incode  :=  FALSE


    RESULTIS  op
$)



AND cg.section()  =  VALOF
$(
    LET length  =  rdn()
    LET o       =  output()
    LET buffer  =  VEC 256/bytesperword

    FOR  i = 1  TO  length   DO  buffer % i   :=  rdn()

    buffer % 0   :=  length

    IF  listing  THEN  writel( "%S  TITLE  *"SECTION %S*"", buffer, buffer )

    IF  mapping  THEN
    $(
        selectoutput( mapstream )
        writef( "Section *"%S*"    ", buffer )
        selectoutput( o )
    $)

    moduledef( buffer )

    selectoutput( sysout )
    writef( "SECTION *"%S*"*N", buffer )
    selectoutput( o )

    RESULTIS  rdop()
$)



AND cg.needs()  =  VALOF
$(
    LET length  =  rdn()
    LET o       =  output()
    LET buffer  =  VEC 256/bytesperword

    FOR  i = 1  TO  length  DO  buffer % i  :=  rdch()

    buffer % 0  :=  length

    IF  listing  THEN  writel( "    NEEDS *"%S*"", buffer )

    selectoutput( sysout )
    writef( "NEEDS *"%S*"*N", buffer )
    selectoutput( o )

    RESULTIS  rdop()
$)



AND uninitsection()  BE
$(
//  Generate the closing sequence.  This means writing out the code generated,
//  and dealing with all the relocation information.

    LET length  =  currentloc - programbase
    LET lenh    =  (length >> 8)  &  #XFF
    LET lenl    =  (length)       &  #XFF

    update( programbase+4, lenl )
    update( programbase+5, lenh )

    IF  listing  THEN
    $(
        writel( "L%N:  EQU  %N", lengthlab, length )

        writel( "    END" )
    $)

    IF  mapping  THEN  printmap( length )

    moduledata( length )

    modulereloc()

    programbase  :=  currentloc
$)



AND moduledef( name )  BE
$(
//  Generate the module definition name.

    LET csum    =  #X05 + #X01
    LET length  =  name % 0

    wrch( '$' )

    FOR  i = 1  TO  6  DO
    $(
        LET ch  =  i > length  ->  '*S',  name % i

        csum  :=  csum  +  ch

        wrch( ch )
    $)

    writef( "0501%X2*N", -csum )
$)



AND moduledata( length )  BE
$(
//  Generate the module data definitions.

    FOR  address = 0  TO  length-1  BY  bytesperchunk  DO
    $(
        LET chunk   =  address/bytesperchunk
        LET buffer  =  memchunks!chunk
        LET base    =  programbase + address
        LET size    =  length - address

        IF  size > bytesperchunk  THEN  size  :=  bytesperchunk

        FOR  offset  =  0  TO  size-1  BY  32  DO
        $(
            LET bytes  =  size - offset
            LET addr   =  base + offset
            LET addrh  =  (addr >> 8)  &  #XFF
            LET addrl  =  (addr)       &  #XFF
            LET csum   =  addrh + addrl

            IF  bytes > 32  THEN  bytes  :=  32

            csum  :=  csum + bytes

            writef( ":%X2%X400", bytes, addr )

            FOR  i = 0  TO  bytes-1  DO
            $(
                LET byte  =  buffer % (offset + i)

                writehex( byte, 2 )

                csum  :=  csum + byte
            $)

            writef( "%X2*N", -csum )
        $)
    $)
$)



AND modulereloc()  BE
$(
//  Generate the relocation information from the "label reference" lists.

    LET list     =  NIL
    LET ptr      =  @list
    LET entries  =  0

    //  First, change the series of lists into one long one, keeping note of
    //  the number of entries.

    FOR  i = 0  TO  lengthlab-1  DO
    $(
        LET llist  =  labelrefs!i

        UNLESS  llist = NIL  DO
        $(
            ptr!r.link  :=  llist

            UNTIL  ptr!r.link = NIL  DO
            $(
                ptr      :=  ptr!r.link
                entries  :=  entries + 1
            $)
        $)
    $)

    FOR  entry = 0  TO  entries-1  BY  16  DO
    $(
        LET size  =  entries - entry
        LET csum  =  #X04

        IF  size > 16  THEN  size  :=  16

        csum  :=  csum + size

        writef( "$%X2000004", size )

        FOR  i = 0  TO  size-1  DO
        $(
            LET link   =  list!r.link
            LET addr   =  list!r.addr
            LET addrh  =  (addr >> 8)  &  #XFF
            LET addrl  =  (addr)       &  #XFF

            writehex( addr, 4 )

            csum  :=  csum + addrh + addrl

            freeblock2( list )

            list  :=  link
        $)

        writef( "%X2*N", -csum )
    $)

    freeblock2( labelrefs!lengthlab )
$)



AND moduleend()  BE
$(
//  Generate a module end record.

    LET csum  =  #XFF + #XFF + #X01

    writef( ":00FFFF01%X2*N", -csum )
$)



AND printmap( length )  BE
$(
    LET o       =  output()
    LET lcount  =  0

    selectoutput( mapstream )

    writef( "%X4 - %X4  (%N bytes)*N*N*N", programbase, currentloc, length )

    writes( "Procedures:*N*N" )

    UNTIL  namelist = NIL  DO
    $(
        LET link   =  namelist!nl.link
        LET name   =  namelist!nl.name
        LET addr   =  namelist!nl.addr
        LET type   =  namelist!nl.type
        LET value  =  namelist!nl.value

        writef( "%X4  -  ", addr )
        writestring( name, 20 )

        TEST  type = t.global
            THEN  writef( "global %N", value )
            ELSE  writes( "local" )

        newline()

        namelist  :=  link
    $)

    writef( "*NHighest global referenced:  %N*N*N*N", maxgn )

    writes( "Labels:*N" )

    FOR  i = 0  TO  maxlabel-1  DO
    $(
        LET addr  =  labeladdr!i

        UNLESS  addr = NIL  DO
        $(
            IF  lcount = 0  THEN  newline()

            wrch( 'L' )
            writenumber( i, 4 )

            writef( " %X4   ", addr )

            lcount  :=  (lcount + 1)  REM  6
        $)
    $)

    writes( "*N*N*N" )

    writef( "Label allocation:*N*N*
            *    OCODE:           %I4  -  %I4*N*
            *    Code Generator:  %I4  -  %I4*N*N*N", 1,       maxln,
                                                      cglabel, maxlabel-1 )

    selectoutput( o )
$)



AND writestring( string, width )  BE
$(
//  Write out a string in a fixed width, padding with spaces.

    writes( string )

    FOR  i = string % 0  TO  width-1  DO  wrch( '*S' )
$)



AND writenumber( number, width )  BE
$(
//  Write out a number in a fixed width, padding with spaces.

    writen( number )

    FOR  i = numberofdigits( number )  TO  width-1  DO  wrch( '*S' )
$)



AND numberofdigits( n )  =  n < 10  ->  1, numberofdigits( n/10 ) + 1



AND parseocode( op )  BE
$(
//  Parse a single OCODE statement.

    IF  testflags( #B0001 )  THEN  cgerror( "BREAK" )
    IF  testflags( #B1000 )  THEN  cgwarning( "%N bytes of code compiled", currentloc  )

    IF  debugging & listing  THEN  writel( ";  OP:%N,  SSP:%N,  STACKP:%N", op, ssp, stackp )

    SWITCHON  op  INTO
    $(
        CASE s.lp       :  cg.loadt( t.local, rdn() )       ;  ENDCASE
        CASE s.lg       :  cg.loadt( t.global, rdg() )      ;  ENDCASE
        CASE s.ln       :  cg.loadt( t.number, rdn() )      ;  ENDCASE
        CASE s.ll       :  cg.loadt( t.label, rdl() )       ;  ENDCASE

        CASE s.llp      :  cg.loadt( t.lv.local, rdn() )    ;  ENDCASE
        CASE s.llg      :  cg.loadt( t.lv.global, rdg() )   ;  ENDCASE
        CASE s.lll      :  cg.loadt( t.lv.label, rdl() )    ;  ENDCASE

        CASE s.true     :  cg.loadt( t.number, TRUE )       ;  ENDCASE
        CASE s.false    :  cg.loadt( t.number, FALSE )      ;  ENDCASE

        CASE s.query    :  cg.loadt( t.local, ssp )         ;  ENDCASE

        CASE s.lstr     :  cg.loadstring( rdn() )           ;  ENDCASE

        CASE s.sp       :  cg.storet( t.local, rdn() )      ;  ENDCASE
        CASE s.sg       :  cg.storet( t.global, rdg() )     ;  ENDCASE
        CASE s.sl       :  cg.storet( t.label, rdl() )      ;  ENDCASE

        CASE s.stind    :  cg.stind()                       ;  ENDCASE
        CASE s.putbyte  :  cg.putbyte()                     ;  ENDCASE

        CASE s.jump     :  cg.jump( rdl() )                 ;  ENDCASE

        CASE s.jf       :
        CASE s.jt       :  cg.condjump( op, rdl() )         ;  ENDCASE

        CASE s.endfor   :  cg.endfor( rdl() )               ;  ENDCASE

        CASE s.goto     :  cg.goto()                        ;  ENDCASE

        CASE s.blab     :
        CASE s.lab      :  cg.setlabel( op, rdl() )         ;  ENDCASE

        CASE s.save     :  cg.save( rdn() )                 ;  ENDCASE
        CASE s.stack    :  cg.stack( rdn() )                ;  ENDCASE
        CASE s.store    :  cg.store( 0, ssp )               ;  ENDCASE

        CASE s.entry    :  cg.entry( rdn() )                ;  ENDCASE

        CASE s.fnap     :
        CASE s.rtap     :  cg.apply( op, rdn() )            ;  ENDCASE

        CASE s.fnrn     :
        CASE s.rtrn     :  cg.return( op )                  ;  ENDCASE

        CASE s.endproc  :  cg.endproc( rdn() )
                           cg.flushdata()                   ;  ENDCASE

        CASE s.res      :  cg.res( rdl() )                  ;  ENDCASE
        CASE s.rstack   :  cg.rstack( rdn() )               ;  ENDCASE
        CASE s.finish   :  cg.finish()                      ;  ENDCASE

        CASE s.switchon :  aptovec( cg.switchon, rdn()*2 )  ;  ENDCASE

        CASE s.global   :  cg.global( rdn() )               ;  ENDCASE

        CASE s.datalab  :
        CASE s.iteml    :  cg.data( op, rdl() )             ;  ENDCASE

        CASE s.itemn    :  cg.data( op, rdn() )             ;  ENDCASE


        CASE s.getbyte  :  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       :

                           cg.dyadicop( op )
                           ENDCASE


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

                           cg.monadicop( op )
                           ENDCASE


        CASE s.end      :  RETURN


        CASE s.debug    :  printdebuginfo()
                           ENDCASE


        DEFAULT         :  cgerror( "readocode( %N )", op )
    $)
$)



AND cg.initstack()  BE
$(
//  Initialise the slaved stack at start of day.  The size of the stack is
//  the "save space" reserved by the compiler.

    ssp   :=  savespacesize - 2

    arg2  :=  NIL
    arg1  :=  NIL

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



AND cg.stack( newssp )  BE
$(
//  Set the size of the slave stack to be the value given.

    LET down  =  newssp < ssp
    LET diff  =  0

    //  First, bring the stack down until we are less than or equal to the
    //  correct position.

    UNTIL  ssp <= newssp  DO  cg.unloadt()

    //  After doing that, we should then (if necessary) bring the stack
    //  up to its required amount.

    diff  :=  newssp - ssp

    TEST  diff < 2  THEN
          FOR  i = 1  TO  diff  DO  cg.loadt( t.local, ssp )

    ELSE
    $(
        //  Initialise a new portion of stack frame.

        ssp  :=  newssp - 2

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

    //  Given that the stack frame size has changed, we had better modify our
    //  register slave (if any) to reflect this change.

    IF  down  THEN  cg.unslavelocal()
$)



AND cg.loadt( type, value )  BE
$(
//  Load an item with the type and value given onto the stack.  Remembered
//  with the item itself is its original place on the stack.  This is so that
//  we can save it safely, even which the stack position has changed.

    LET item  =  block3( arg1, ssp, block3( type, value, ssp ) )

    arg2  :=  arg1
    arg1  :=  item
    ssp   :=  ssp + 1
$)



AND cg.unloadt()  BE
$(
//  Unload the top item from the stack, and throw it away.

    freeblock3( arg1 )

    arg1  :=  arg2
    arg2  :=  arg2!a.link

    ssp   :=  arg1!a.ssp + 1
$)



AND cg.loadstring( length )  BE
$(
//  Load a pointer to a string onto the stack.  We do not compile code for
//  this yet, but just buffer the string up.

    LET label   =  newlabel()

    cg.data( s.datalab, label )
    cg.data( s.itemb, length )

    FOR  i = 1  TO  length  DO  cg.data( s.itemb, rdn() )

    cg.loadt( t.lv.label, label )
$)



AND cg.dyadicop( op )  BE
$(
//  Code generate for a dyadic operator.  This means taking the top two
//  items on the stack, and operating on them, and storing the result back
//  on the stack.

    LET node  =  block3( op, arg2!a.node, arg1!a.node )

    cg.stack( ssp-1 )

    arg1!a.node  :=  node
$)



AND cg.monadicop( op )  BE
$(
//  Code generate for a monadic operator.  Take the top item on the stack,
//  and operate on it, storing the result back on the stack.

    LET node  =  block2( op, arg1!a.node )

    arg1!a.node  :=  node
$)



AND cg.store( ssp.f, ssp.t )  BE
$(
//  Store those items on the stack between SSP locations "ssp.f" and "ssp.t".

    LET arg  =  arg1

    IF  debugging & listing  THEN  writel( ";  CGStore %N:%N", ssp.f, ssp.t )

    UNTIL  arg = NIL  DO
    $(
        //  Make sure that this item is within the range given, and if it is,
        //  store it on the stack.

        LET s  =  arg!a.ssp

        IF  ssp.f <= s < ssp.t  THEN
        $(
            //  Look to see if the item here is in fact what should be here,
            //  and if not, evaluate it, and store it.

            LET node  =  arg!a.node
            LET type  =  node!n.type
            LET a1    =  node!n.arg1

            UNLESS  type = t.local  &  a1 = s  DO
            $(
                cg.storeitem( node, t.local, s )

                arg!a.node  :=  block3( t.local, s, s )
            $)
        $)

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



AND cg.storet( type, value )  BE
$(
//  Take the top item on the stack, and store it in the location given by
//  "type" and "value".

    LET node  =  arg1!a.node

    cg.storeitem( node, type, value )

    cg.stack( ssp-1 )
$)



AND cg.endfor( label )  BE
$(
//  Code generate for the end of a FOR loop.  This is logically equivalent
//  to:
//
//      LE
//      JT  L<label>

    LET node1  =  arg1!a.node
    LET node2  =  arg2!a.node

    cg.stack( ssp-2 )

    cg.comparejump( label, s.le, node2, node1 )

    freenode( node1 )
    freenode( node2 )
$)



AND cg.jump( label )  BE
$(
//  Code generate for an unconditional jump.  This means that we should
//  make sure that all items are stored.

    cg.store( 0, ssp )

    cg.branch( cond.always, label )
$)



AND cg.condjump( jumptype, label )  BE
$(
//  Generate code for a conditional jump.  The jump type is one of JT or
//  JF, depending on the condition.  We can usually optimise this as the
//  previous operation is a comparison.

    LET node  =  arg1!a.node
    LET type  =  node!n.type

    cg.stack( ssp-1 )

    cg.store( 0, ssp )

    TEST  conditional( type )  THEN
    $(
        //  This is something of the form  "IF x <cond> y THEN", and the
        //  condition can be optimised.

        IF  jumptype = s.jf  THEN  type  :=  notcond( type )

        cg.comparejump( label, type, node!n.arg1, node!n.arg2 )
    $)
    ELSE
    $(
        //  Here, we are testing a single value, and jumping on either TRUE
        //  or FALSE.  We can optimise this, since we know that FALSE is
        //  always zero.

        type  :=  jumptype = s.jf  ->  s.eq, s.ne

        cg.comparejump( label, type, node, NIL )
    $)

    freenode( node )
$)



AND symmetric( op )    =  op = s.plus  |  op = s.logand  |  op = s.logor  |
                          op = s.eqv   |  op = s.neqv    |  op = s.mult   |

                          conditional( op )



AND conditional( op )  =  op = s.eq    |  op = s.ne      |  op = s.ls     |
                          op = s.gr    |  op = s.le      |  op = s.ge



AND reverse( op )  =      op = s.plus    ->  s.plus,
                          op = s.logand  ->  s.logand,
                          op = s.logor   ->  s.logor,
                          op = s.eqv     ->  s.eqv,
                          op = s.neqv    ->  s.neqv,
                          op = s.mult    ->  s.mult,
                          op = s.eq      ->  s.eq,
                          op = s.ne      ->  s.ne,
                          op = s.ls      ->  s.gr,
                          op = s.gr      ->  s.ls,
                          op = s.le      ->  s.ge,
                          op = s.ge      ->  s.le,

                                             cgerror( "reverse( %N )", op )



AND notcond( op )  =      op = s.eq      ->  s.ne,
                          op = s.ne      ->  s.eq,
                          op = s.ls      ->  s.ge,
                          op = s.gr      ->  s.le,
                          op = s.le      ->  s.gr,
                          op = s.ge      ->  s.ls,

                                             cgerror( "notcond( %N )", op )



AND condition( op )  =    op = s.eq  ->      cond.eq,
                          op = s.ne  ->      cond.ne,
                          op = s.ls  ->      cond.ls,
                          op = s.gr  ->      cond.gr,
                          op = s.le  ->      cond.le,
                          op = s.ge  ->      cond.ge,

                                             cgerror( "condition( %N )", op )



AND cg.data( type, value )  BE
$(
//  Queue up an item of data onto the data queue.  The queue is flushed at
//  convenient moments, for example between the code of procedures.

    LET data  =  block3( NIL, type, value )

    datae!d.link  :=  data
    datae         :=  data
$)



AND cg.flushdata()  BE
$(
//  Flush the static data which we have carefully buffered up.

    LET data  =  datap

    UNTIL  data = NIL  DO
    $(
        LET link   =  data!d.link
        LET type   =  data!d.type
        LET value  =  data!d.value

        cg.constant( type, value )

        freeblock3( data )

        data  :=  link
    $)

    //  When we drop out of that loop, we should set the data pointers back
    //  to their initial values.

    cg.initdata()
$)



AND cg.initdata()  BE
$(
//  Initialise the chain associated with the data buffer.

    datap  :=  NIL
    datae  :=  @datap
$)



AND block2( a, b )  =  VALOF
$(
//  Return a store element of 2 words.  First, look in the chain of free
//  blocks, and if that proves useless, then allocate a new piece of
//  storage.

    LET block  =  0

    TEST  freelist2 = NIL  THEN  block  :=  getstore( 1 )

    ELSE
    $(
        block      :=  freelist2
        freelist2  :=  block!b.link
    $)

    block!0  :=  a
    block!1  :=  b

    RESULTIS  block
$)



AND block3( a, b, c )  =  VALOF
$(
//  Return a store element of 3 words.  First, look in the chain of free
//  blocks, and if that proves useless, then allocate a new piece of
//  storage.

    LET block  =  0

    TEST  freelist3 = NIL  THEN  block  :=  getstore( 2 )

    ELSE
    $(
        block      :=  freelist3
        freelist3  :=  block!b.link
    $)

    block!0  :=  a
    block!1  :=  b
    block!2  :=  c

    RESULTIS  block
$)



AND freeblock2( block )  BE
$(
//  Release a block of size 2 so that it can be re-used.

    block!b.link  :=  freelist2
    freelist2     :=  block
$)



AND freeblock3( block )  BE
$(
//  Release a block of size 3 so that it can be reused.

    block!b.link  :=  freelist3
    freelist3     :=  block
$)



AND cg.initstore( chunksize )  BE
$(
//  Initialise the storage package, defining the size of chunks which will
//  be grabbed from the standard storage manager.

    storage.chunksize  :=  chunksize
    storage.root       :=  0
    storage.high       :=  0
    storage.low        :=  0
$)



AND getstore( upb )  =  VALOF
$(
//  Analagous to "getvec"  -  allocate a vector whose word upperbound
//  is "upb" from the heap.  If there is not enough room in the current
//  chunk, then allocate a new chunk.

    LET size   =  upb + 1
    LET chunk  =  0

    IF  size > storage.chunksize  THEN  abort( error.toolarge )

    IF  (storage.high - storage.low)  <  size  THEN
    $(
        //  Not enough room left in the current chunk, so allocate a
        //  new chunk, and try again.

        LET chunksize  =  storage.chunksize + 1
        LET newchunk   =  getvec( chunksize )

        IF  newchunk = 0  THEN  abort( error.nospace )

        newchunk!0    :=  storage.root
        storage.root  :=  newchunk
        storage.low   :=  newchunk + 1
        storage.high  :=  storage.low + chunksize

        totalstorage  :=  totalstorage + chunksize + 1
    $)

    chunk        :=  storage.low
    storage.low  :=  storage.low + size

    totalused    :=  totalused + size

    RESULTIS  chunk
$)



AND cg.uninitstore()  BE
$(
//  Free all the storage in use by the storage package.  The base of the
//  storage chain is pointed to by "storage.root".

    UNTIL  storage.root = 0  DO
    $(
        LET next  =  storage.root!0

        freevec( storage.root )

        storage.root  :=  next
    $)
$)



AND freenode( node )  BE
$(
//  Free the storage associated with the node.  The size of the storage
//  used by the node depends on its type.

    LET type  =  node!n.type

    SWITCHON  type  INTO
    $(
        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      :  CASE t.cherished  :

                             freeblock3( node )
                             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    :

                             freenode( node!n.arg1 )
                             freenode( node!n.arg2 )
                             freeblock3( node )
                             ENDCASE


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

                             freenode( node!n.arg1 )
                             freeblock2( node )
                             ENDCASE


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


