// 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
//   public release som v4.1   9 Aug 2008   (Birthday)
//  public release som v5.0   5 Dec 2009    (Long live the King)

// e :=  exp, asg, cntl
// cntl := if, while, for, block, break
// asg  :=  lhs = exp
// exp  := op, call, vec, lv, gv, num, sys
// lhs  := lv, gv, vec
// special :=  def, macrodef, macro

// what value genex return?
//  exp :=  op/temp, call/retval, vec/temp, sys/retval
//          lv, gv, num
//  asg :=  nil
//  cntl :=  the value of the last e generated
//  where temp is the intermediate register (not lv,gv,retval)

to isTemp v =
    and (v > nlocal) (v < RETVAL)

// 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 =
    if isTemp v
        vsp = vsp + 1
        vrec[vsp] = v

to lastOp = CS[lastCP] & 255
to lastArg = CS[lastCP] >> 8

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

to isLocal e = (car e) == LNAME
to isGlobal e = (car e) == GNAME
to isNum e = (car e) == NUM
to isCall e = and (islist e) (atomeq (car e) OPER tkBE)
to isMacro e = and (islist e) (atomeq (car e) OPER tkRBRACKET)

to evalBop op a b =		// strength reduction
    case op
        tAdd:  a + b
        tSub:  a - b
        tMul:  a * b
        tDiv:  a / b
        tAnd:  a & b
        tOr:   a | b
        tXor:  a ^ b
        tEq:   a == b
        tNe:   a != b
        tLt:   a < b
        tLe:   a <= b
        tGt:   a > b
        tGe:   a >= b
        tMod:  a % b
        tShl:  a << b
        tShr:  a >> b
        else:  0

// make it a small constant or becomes a gv
to genNum n | v =
    if and (n >= #f6) (n <= 300) // -10..300 M390..M700
        v = 400 + n
    else
        v = newdata
        M[v] = n			// become a global var
    v

to genex x = {}

to genbop op e | e1 e2 v v1 v2 =
    e1 = car e
    e2 = item2 e
    if and (isNum e1) (isNum e2)
        v = genNum evalBop op (cdr e1) (cdr e2)
    else
        v1 = genex e1
        v2 = genex e2
        freev v1
        freev v2
        v = newv
        outc op v v1 v2
    v

to outJmp d =
    addlis jplis CP
    outc tJmp d 0 0

// inv condjmp: index by Eq, Ne, Lt, Le, Gt, Ge
// index by condJmp[op-9] and condJmp[op-9+6]
condJmp = array
    tJne tJeq tJge tJgt tJle tJlt  // Jf
    tJeq tJne tJlt tJle tJgt tJge   // Jt

to optJmp op d e | c v =
    v = genex e
    c = lastOp
    if and (! isatom e) (isLogic c) 	// combine jmp
        addlis jplis lastCP
        if op == tJf
            patch lastCP (enc2 d condJmp[c-9])   // jf, inv
        else
            patch lastCP (enc2 d condJmp[c-9+6]) // jt
    else
        addlis jplis CP
        outc op d v 0						 	// normal
    freev v

// if v is singleton, must mov it to RETVAL
// if op has dest and dest is temp, diffuse RETVAL
to final v | a =
    if and (v != nil) (v != RETVAL)
        a = lastArg
        if and (lastOp <= tStx) (isTemp a)
            patchArg lastCP RETVAL
            freev a
        else
            outc tMov RETVAL v 0
            freev v
        v = RETVAL
    v

// e = (ex0 block)
to gencase e | e1 n lo hi i ads v1 v2 v end =
    v1 = genex car e		// cond
    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 = cdr e
    while e1 != NIL
        n = cdr car car e1
        if n < 0 break
        else if n < lo lo = n
        else if n > hi hi = n
        e1 = cdr e1

    outc tCase v1 lo hi
    freev v1
    ads = CP
    end = ads + hi - lo
    for i ads end
        CS[i] = 0				// empty jmp vector
    CP = end + 1
    outJmp 0					// <1> else case
    v1 = 0						// end of backchain
    while e != NIL
        e1 = car e				// e1 = (num ex)
        n = cdr car e1 			// n = num label
        if n > 0				// skip else (-1)
            patch (n-lo)+ads CP-ads+3 // entry in jmp vector
            v = final (genex item2 e1)
            outJmp v1			// jmp to eloc, backchain
            v1 = lastCP
        e = cdr e
    patchArg end+1 CP				// <1> here is exelse
    for i ads end
        if CS[i] == 0
            patch i CP-ads+3	// patch empty entry to here
    if n == #f					// gen else case -1
        v = final (genex item2 e1)
    // here is eloc, update backchain jmp here
    while v1 != 0
        v2 = argAt v1
        patchArg v1 CP
        v1 = v2
    v

// parameter list (ex .. ex ), no return
to genpar e | v =
    while e != NIL		// (cdr e) != NIL
        v = genex car e
        outc tPush v 0 0
        freev v
        e = cdr 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
        patchArg 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
to updatesym ref e | a =
    a = car e
    if isatom e					// e = ADS/STRING
        if or (a == STRING) (a == ADS)
            setArity ref VARRAY
    else if isatom a			// e = (array ..)
        if atomeq a OPER tkARRAY
            setArity ref VARRAY

to genAds ref | v =
    v = genNum ref
    addlis relis v			// must reloc later
    v

to genatom x | ref v =
    ref = cdr x
    case car x				// type
        STRING: genAds ref
        ADS: genAds ref
        NUM: genNum ref
        GNAME: getRef ref
        LNAME: ref
        else:  0

to genput v e | v1 =
    v1 = genex e
    if and (v1 < RETVAL) (! isatom e)  // is local and not atom
        patchArg lastCP v
    else
        outc tMov v v1 0
    freev v1

to relocjmp | i ads a =
    for i 1 (sizeoflis jplis)
        ads = jplis[i]
        if ads != 0
            a = argAt ads
            patchArg ads a-ads

to genfun idx e | ref lv i v =
    nlocal = getLv idx	// set range of temp
    clearlis jplis
    ref = CP
    setRef idx ref
    outc tFun (getArity idx) 0 0
    ypush MARK
    v = genex e			// body
    patchbreak
    vsp = 0				// clear vrec[] stack
    // check tail call
    if and (lastOp == tCall) (CS[lastCP+2] == ref)
        patch lastCP (enc2 lastArg tCallt)
    lv = getLv idx
    patch ref+1 lv		// update fun header
    outc tRet v lv 0

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

// x is a list ( oper ... )
to genex x | a e e1 ads ads2 v1 idx v =
    if isatom x
        genatom x		// return v
        break
    // x is a list
    a = car x
    e = cdr x
    if (car a) != OPER
        error "genex: expect operator"
    case cdr a
        tkPLUS: v = genbop tAdd e
        tkMINUS: v = genbop tSub e
        tkSTAR: v = genbop tMul e
        tkSLASH: v = genbop tDiv e
        tkAND: v = genbop tAnd e
        tkBAR: v = genbop tOr e
        tkCARET: v = genbop tXor e
        tkEQEQ: v = genbop tEq e
        tkNE: v = genbop tNe e
        tkLT: v = genbop tLt e
        tkLE: v = genbop tLe e
        tkGE: v = genbop tGe e
        tkGT: v = genbop tGt e
        tkMOD: v = genbop tMod e
        tkGTGT: v = genbop tShr e
        tkLTLT: v = genbop tShl e
        tkNOT:
            v = genex car e
            outc tNot v v 0
        tkARRAY:
            v1 = genex car e
            outc tSys 14 v1 0
            freev v1
            v = RETVAL
        tkSYSCALL:				// (num ex .. ex)
            // hard code, at most 2 params
            v1 = genex item2 e
            v = genex item3 e
            outc tSys (cdr car e) v1 v
            freev v1
            freev v
            v = RETVAL
        tkBB:					// block
            while e != NIL
                v = final genex car e
                e = cdr e
        tkBE:					// (call name ex ... ex)
            idx = cdr car e		// e = (name ex .. ex)
            e = cdr e
            v1 = nil
            v = nil
            if e != NIL				// gen param pass
                v1 = genex car e	// 1st param
                e = cdr e
                // if it is rv and next param is call
                // must mov rv to another reg
                // still cannot handle macro well   21 Oct 2009
                if and (v1 == RETVAL) (e != NIL)
                    e1 = car e		// get op
                    if or (isCall e1) (isMacro e1)
                        a = v1
                        v1 = newv
                        outc tMov v1 a 0
                if e != NIL
                    v = genex car e	// 2nd param
                    e = cdr e
                    if e != NIL
                        genpar e	// the rest
            a = getRef idx
            if a == 0			// forward ref
                if (sizeoflis callis) >= MAXCALL
                    error "list of calli overflow"
                addlis callis CP
                outc tCall v1 v idx
            else
                outc tCall v1 v a
            freev v1
            freev v
            v = RETVAL

        tkRBRACKET:				// (mac name ex...ex)
            idx = cdr car e		// e = (name ex...ex)
            v = 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
                genfun idx e
                improv
                improv
                relocjmp
            currentf = 0
            v = nil
        tkCOLON:				// define macro
            idx = cdr car e		// e = (name ex)
//			currentf = idx
            setRef idx item2 e
            v = nil
        tkEQ:					// e = (var/vec ex)
            a = car e			// var/vec
            e1 = item2 e		// ex
            if isatom a			// scalar lv/gv
                if and (isGlobal a) (currentf == 0)
                    updatesym (cdr a) e1
                v = genatom a
                genput v e1
            else					// vec, a = (vec nm ex)
                e = cdr a			// e LHS, (nm ex)
                v1 = genatom car e  // nm, base
                idx = genex item2 e	// idx
                v = genex e1		// RHS
                outc tStx v v1 idx
                freev idx
                freev v
            v = nil

        tkLBRACKET:					// vec RHS e = (nm ex)
            v1 = genatom car e		// nm, base
            idx = genex item2 e		// ex, index
            v = newv
            outc tLdx v v1 idx
            freev idx

        tkIF:							// (if e1 e)
            optJmp tJf 0 (car e)		// e = (e1 e)
            ads = lastCP
            v = final (genex item2 e)
            patchArg ads CP
        tkELSE:							// (ifelse e1 et ef)
            optJmp tJf 0 (car e)		// e = (e1 et ef)
            ads = lastCP
            v = final (genex item2 e)	// et
            outJmp 0
            patchArg ads CP
            ads = lastCP
            v = final (genex item3 e)	// ef
            patchArg ads CP
        tkWHILE:						// (while e1 e)
            ypush MARK
            ads = CP
            outJmp 0					// branch to cond
            v = final (genex item2 e)	// body
            ads2 = CP
            optJmp tJt ads+3 (car e)	// cond,jmp to body
            patchArg ads ads2
            patchbreak
        tkFOR:							// (for lv ex0 ex0 ex)
            ypush MARK					// e = (lv ex0 ex0 ex)
            idx = genatom car e
            e = cdr e					// e = (ex0 ex0 ex)
            // make (- init 1)
            a = cons (car e) (list (newatom NUM 1))
            a = cons (newatom OPER tkMINUS) a
            genput idx a
            v1 = genex item2 e 			// end
            ads = CP
            outJmp 0					// jmp to test
            v = final (genex item3 e)	// body
            patchArg ads CP				// test
            outc tEfor ads+3-CP idx v1
            freev v1
            patchbreak
        tkCASE:
            v = gencase e
        tkBREAK:
            ypush CP
            ypush BMARK
            outJmp 0
            v = nil
        else: error "from genex: syntax error"
    v

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

// and gen call to "main" if it is defined
to genfinal | idx d =
    patchCalli
    d = CP
    CP = 3
    idx = install "main"
    if (getType idx) != tyNEW
        outc tCall 0 0 (getRef idx)
    outc tSys 13 0 0
    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 v =
    if (cdr e) == NIL break		// empty
    patchCalli
    currentf = 0		// force im mode
//	setLv currentf 0	// not sure
    d = CP
    CP = CPX
    ads = CP			// begining of imm code
    v = genex e			// e can be a block
    outc tSys 13 0 0  	// End
    CPX = CP			// update CPX
    CP = d				// restore CP
    eval ads

// End

