// gencode-s.txt
//   for sx-code			25 Feb 2007
//   public release som v3.0 5 March 2007 (Maka-bucha day)
//   public release som v4.0 2 July 2008

bop_type = array	// 0..20
  xUD
  xCM xUD xCM xUD xCM xCM xCM xUD xCM xCM
  xLG xLG xLG xLG xUD xUD xSH xSH xUD xUD

: isCommute op = bop_type[op] == xCM
: isLogic op = bop_type[op] == xLG
: isShift op = bop_type[op] == xSH

// return a free local, use vrec[] as stack
to newv | v =
    if vsp == 0
        v = (getLv currentf) + 1
        setLv currentf v
    else
        v = vrec[vsp]
        vsp = vsp - 1
    v

to freev v =
    vsp = vsp + 1
    vrec[vsp] = v

to lastOp = CS[lastCP]
to lastArg = CS[lastCP+1]

to atomeq e type value =
    and ((car e) == type) ((cdr e) == value)

to isLocal e = (car e) == LNAME
to isGlobal e = (car e) == GNAME

// check e = (lv (+/- lv 1))
to isinc e | a ref op =
    a = car e
    if (car a) != LNAME
        0 break
    ref = cdr a
    e = item2 e		// e = (+ lv 1)
    op = car e
    if ! ((atomeq op OPER tkPLUS) | (atomeq op OPER tkMINUS))
        0 break
    a = item2 e
    if ! (atomeq a LNAME ref)
        0 break
    if ! (atomeq (item3 e) NUM 1)
        0 break
    1

to evalBop op a b =
    case op
        icAdd:	a + b
        icSub:  a - b
        icMul:  a * b
        icDiv:  a / b
        icBand: a & b
        icBor:  a | b
        icBxor: a ^ b
        icEq:   a == b
        icNe:   a != b
        icLt:   a < b
        icLe:   a <= b
        icGt:   a > b
        icGe:   a >= b
        icMod:  a % b
        icShli: a << b
        icShri: a >> b
        else:   0

to invLogic op =
    case op
        icLt: icGt
        icLe: icGe
        icGt: icLt
        icGe: icLe
        else: 0

// type of expression
to typeX e =
    if isatom e
        case car e
            LNAME: xLV
            GNAME: xGV
            NUM:   xLIT
            else:  xEX
    else
        xEX

to genex x | a e e1 ads ads2 v1 v2 idx = {}

to genbop op e | e1 e2 ty1 ty2 t =
    e1 = car e
    e2 = item2 e
    ty1 = typeX e1
    ty2 = typeX e2
    if and (ty1 == xLV) (isCommute op)
        genex e2
        outa op cdr e1
    else if and (ty1 == xLV) (isLogic op)
        genex e2
        outa (invLogic op) cdr e1
    else if and (ty1 == xLIT) (ty2 == xLIT)
        // still cannot do recursively
        outa icLit (evalBop op (cdr e1) (cdr e2))
    else if ty2 == xLV
        genex e1
        outa op cdr e2
    else if and (ty2 == xLIT) (op == icAdd)
        genex e1
        outa icAddi cdr e2
    else if and (ty2 == xLIT) (op == icSub)
        genex e1
        outa icSubi cdr e2
    else if isShift op
        // ty2 must be xLIT
        genex e1
        outa op cdr e2
    else
        t = newv
        genex e2
        outa icPut t
        genex e1
        outa op t
        freev t

to invJmp op =
    if op == icJt icJf else icJt

// optimise jump with x!=0, x==0
// x!=0,jf => x,jf
// x==0,jf => x,jt
// x!=0,jt => x,jt
// x==0,jt => x,jf
// !,jt => jf
// !,jf => jt
to optJmp op d | c =
    c = lastOp
    if and (c == icNe) (isLit0 CP-4)
        CP = CP-4
        outa icGet lastArg
        outa op d
    else if and (c == icEq) (isLit0 CP-4)
        CP = CP-4
        outa icGet lastArg
        outa (invJmp op) d
    else if (c == icNot)
        CP = lastCP
        outa (invJmp op) d
    else
        outa op d	// normal

// e = (ex0 block)
to gencase e | e1 n lo hi i ads v1 v2 =
    e1 = car e
    if isLocal e1
        v1 = cdr e1
    else
        genex e1			// gen ex0
        v1 = newv
        outa icPut v1
    e = cdr item2 e			// block => (ex..ex)

    // get case label range
    n = cdr car car e		// e = (num ex), n = num.ref
    lo = n
    hi = n
    e1 = e
    while e1 != NIL
        n = cdr car car e1
        if n < 0 break
        if n < lo lo = n
        if n > hi hi = n
        e1 = cdr e1

    outa icLit hi
    out3 icCase lo v1
    outa icJmp 0		// else
    ads = CP
    for i lo hi
        outa icJmp 0	// empty jmp vector
    v1 = 0
    while e != NIL
        e1 = car e		// e1 = (num ex)
        n = cdr car e1 	// n = num label
        if n > 0				// skip else (-1)
            v2 = 2*(n-lo)+ads
            patch v2 CP 		// entry in jmp vector
            genex item2 e1
            outa icJmp v1		// jmp to eloc, backchain
            v1 = lastCP
        e = cdr e

    patch ads-2 CP		// here is exelse
    for i lo hi
        v2 = 2*(i-lo)+ads
        if CS[v2+1] == 0
            patch v2 CP	// patch empty entry to here
    if n == #f			// gen else case -1
        genex item2 e1
    // here is eloc
    // update backchain jmp to eloc
    while v1 != 0
        v2 = CS[v1+1]
        patch v1 CP
        v1 = v2

// (ex .. ex )
to genlist e =
    while e != NIL
        genex car e
        e = cdr e

// parameter list (ex .. ex )
to genpar e | a =
    while (cdr e) != NIL
        a = car e
        if isLocal a
            outa icPush (cdr a)
        else
            genex a
            outa icPusha 0
        e = cdr e
    genex (car e)

// if there is any break, patch jump to CP
to patchbreak | ads a =
    if ytos == MARK		// no break
        a = ypop
        break
    while ytos == BMARK
        a = ypop		// throw away BMARK
        ads = ypop
        patch ads CP
    if ytos != MARK
        error "patch break: no matching mark"
    a = ypop			// throw away MARK

// update symbol table for static array and string
// ref is a global
// update data segment without eval im
to updatesym ref e | a =
    a = car e
    if isatom e
        if a == STRING
            setArity ref VSTRING
        else if a == ADS
            setArity ref VARRAY
    else if isatom a			// e = (array ..)
        if atomeq a OPER tkARRAY
            setArity ref VARRAY
    M[getRef ref] = cdr e

to genatom x | ref =
    ref = cdr x
    case car x				// type
        STRING: outa icAds ref
        ADS: outa icAds ref
        NUM: outa icLit ref
        GNAME: outa icLd (getRef ref)
        LNAME: outa icGet ref
        OPER:
            if ref == tkBREAK
                ypush CP
                ypush BMARK
                outa icJmp 0

to clean fn | ref lv i =
    ref = getRef fn
    lv = getLv fn
    // check tail call
    if and (lastOp == icCall) (lastArg == ref)
        CS[lastCP] = icCallt
    patchbreak
    outa icRet lv
    // update fun header
    patch ref enc2 (getArity fn) lv
    vsp = 0
    clearlis jplis
    for i ref CP-1
        if op_str[CS[i]*4] == mJ
            addlis jplis i
        i = i + 1
    improv
    improv

to subst e1 e2 = {}			// define in macro-s.txt

to genex x | a e e1 ads ads2 v1 v2 idx =
    if x == NIL break
    if isatom x
        genatom x
        break
    // x is list
    a = car x
    e = cdr x
    if (car a) != OPER
        error "genex: expect operator"
    case cdr a
        tkPLUS: genbop icAdd e
        tkMINUS: genbop icSub e
        tkSTAR: genbop icMul e
        tkSLASH: genbop icDiv e
        tkAND: genbop icBand e
        tkBAR: genbop icBor e
        tkCARET: genbop icBxor e
        tkEQEQ: genbop icEq e
        tkNE: genbop icNe e
        tkLT: genbop icLt e
        tkLE: genbop icLe e
        tkGE: genbop icGe e
        tkGT: genbop icGt e
        tkMOD: genbop icMod e
        tkGTGT: genbop icShri e
        tkLTLT: genbop icShli e
        tkNOT:
            genex car e
            outa icNot 0
        tkARRAY:
            genpar e
            outa icSys 14
        tkSYSCALL:				// (num ex .. ex)
            genpar cdr e
            outa icSys (cdr car e)
        tkBB:
            genlist e
        tkBE:					// (call name ex ... ex)
            idx = cdr car e		// e = (name ex .. ex)
            genpar cdr e
            a = getRef idx
            if a == 0			// forward ref
                if (sizeoflis callis) >= MAXCALL
                    error "list of calli overflow"
                addlis callis CP
                outa icCall idx
            else
                outa icCall a

        tkRBRACKET:				// (mac name ex...ex)
            idx = cdr car e		// e = (name ex...ex)
            genex subst (getRef idx) (cdr e)  // macro subst
        tkTO:					// (to name ex)
            idx = cdr car e		// e = (name ex)
            currentf = idx
            e = item2 e			// e = body (block ex ex ..)
            if e != NIL
                setRef idx CP
                outa icFun 0
                ypush MARK
                genex e
                clean idx
        tkCOLON:				// define macro
            idx = cdr car e		// e = (name ex)
            currentf = idx
            setRef idx item2 e
        tkEQ:					// e = (var/vec ex)
            a = car e			// var/vec
            v1 = cdr a
            e1 = item2 e		// ex
            if isinc e			// e = (lv (+ lv 1))
                if atomeq (car e1) OPER tkPLUS
                    outa icInc v1
                else
                    outa icDec v1
            else if isLocal a
                genex e1		// RHS
                outa icPut v1
            else if isGlobal a
                genex e1		// RHS
                outa icSt getRef v1
                if cmode == 1 updatesym v1 e1

            else				// vec, a = (vec nm ex)
                e = cdr a		// e LHS, (nm ex)
                idx = item2 e	// idx
                v1 = car e		// nm
                if isLocal idx
                    genex e1	// RHS
                    if isLocal v1
                        out3 icStx (cdr v1) (cdr idx)
                    else
                        out3 icSty (getRef cdr v1) (cdr idx)
                else
                    genex idx	// idx
                    v2 = newv
                    outa icPut v2
                    genex e1	// RHS
                    freev v2
                    if isLocal v1
                        out3 icStx (cdr v1) v2
                    else
                        out3 icSty (getRef cdr v1) v2

        tkLBRACKET:				// vec RHS e = (nm ex)
            idx = item2 e		// ex, index
            e = car e			// nm, base
            if isLocal idx
                if isLocal e
                    out3 icLdx (cdr e) (cdr idx)
                else
                    out3 icLdy (getRef cdr e) (cdr idx)
            else
                genex idx		// index
                v2 = newv
                outa icPut v2
                freev v2
                if isLocal e
                    out3 icLdx (cdr e) v2
                else
                    out3 icLdy (getRef cdr e) v2

        tkIF:					// (if e1 e)
            genex car e			// e = (e1 e)
            optJmp icJf 0
            ads = lastCP
            genex item2 e
            patch ads CP
        tkELSE:					// (ifelse e1 et ef)
            genex car e			// e = (e1 et ef)
            optJmp icJf 0
            ads = lastCP
            genex item2 e
            outa icJmp 0
            patch ads CP
            ads = lastCP
            genex item3 e
            patch ads CP
        tkWHILE:				// (while e1 e)
            ypush MARK
            ads = CP
            outa icJmp 0		// branch to cond
            genex item2 e		// body of while
            ads2 = CP
            genex car e			// cond
            optJmp icJt ads+2	// jmp to body
            patch ads ads2
            patchbreak
        tkFOR:					// (for lv ex0 ex0 ex)
            ypush MARK			// e = (lv ex0 ex0 ex)
            v1 = cdr car e
            e = cdr e			// e = (ex0 ex0 ex)
            v2 = newv			// v1 pair
            genex item2 e		// end
            outa icPut v2
            genex car e			// initial
            outa icPut v1
            ads = CP
            outa icJmp 0		// jmp to test
            genex item3 e		// body of for
            outa icInc v1
            patch ads CP		// test
            out3 icJle ads+2 v2
            freev v2
            patchbreak
        tkCASE:
            gencase e
        else: error "genex: unknown operator"

// update forward call if defined
to patchCalli | i a d =
    for i 1 (sizeoflis callis)
        a = callis[i]
        if a != 0
            d = getRef (argAt a)
            if d != 0
                patch a d
                callis[i] = 0		// delete entry

// and gen call to "main" if it is defined
to genfinal | idx d =
    patchCalli
    d = CP
    CP = 2
    idx = install "main"
    if (getType idx) != tyNEW
        outa icCall (getRef idx)
    outa icSys 13
    CP = d		// restore CP

// execute immediate line, use CS[CPX] area
// CPX is increasing, do not reuse this area
// as runimm may be nested
to runimm e | d ads i =
    if (cdr e) == NIL break		// empty
    patchCalli
    cmode = 1
    d = CP
    CP = CPX
    ads = CP	// begining of imm code
    genex e		// e can be a block
    outa icSys 13  // End
    CPX = CP	// update CPX
    CP = d		// restore CP
    eval ads

// End

