// gencode-s.txt
//   public release som-v2  30 December 2004
//   public release som-v24 10 January 2007
//   for sx-code			25 Feb 2007
//   public release som v3.0 5 March 2007 (Maka-bucha day)
//   gen directly to xop[] xarg[]   15 Aug 2007

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

// 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 | c =
    case op
        icAdd:	c = a + b
        icSub:  c = a - b
        icMul:  c = a * b
        icDiv:  c = a / b
        icBand: c = a & b
        icBor:  c = a | b
        icBxor: c = a ^ b
        icEq:   c = a == b
        icNe:   c = a != b
        icLt:   c = a < b
        icLe:   c = a <= b
        icGt:   c = a > b
        icGe:   c = a >= b
        icShl:  c = a << b
        icShr:  c = a >> b
        icMod:  c = a % b
        else:   c = 0
    c

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

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

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

to genbop op e | e1 e2 ty1 ty2 =
    e1 = car e
    e2 = item2 e
    ty1 = typeX e1
    ty2 = typeX e2
    if and (ty1 == xLV) (isCommute op)
        genex e2
        outa op+OPV cdr e1
    else if and (ty1 == xLV) (isLogic op)
        genex e2
        outa (invLogic op)+OPV 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+OPV cdr e2
    else if ty2 == xLIT
        genex e1
        outa op+OPM cdr e2
    else
        genex e1
        genex e2
        outa op 0

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
to optJmp | c1 a1 c2 a2 ads =
    ads = CP - 3
    if and (XOP[ads] == icLit) (XARG[ads] == 0)
        c1 = XOP[CP-1]
        a1 = XARG[CP-1]
        c2 = XOP[CP-2]
        a2 = XARG[CP-2]
        case c2
            icNe:
                CP = ads
                outa c1 a1
            30:					// icNev
                CP = ads
                outa icGet a2
                outa c1 a1
            icEq:
                CP = ads
                outa (invJmp c1) a1
            29:					// icEqv
                CP = ads
                outa icGet a2
                outa (invJmp c1) a1

// e = (ex0 block)
to gencase e | e1 n lo hi i ads ads2 v1 v2 a =
    genex car e				// gen ex0
    outa icCase 0
    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 lo
    outa icLit hi
    outa icJmp 0			// else case
    ads = CP
    for i lo hi
        outa icJmp 0		// empty jmp table

    v1 = 0
    while e != NIL
        a = car e			// a = (num ex)
        n = cdr car a 		// n = num label
        if n > 0			// skip else (-1)
            ads2 = n-lo+ads		// entry in jmp table
            patch ads2 CP		// to jmp here
            genex item2 a
            outa icJmp v1		// jmp to eloc, backchain
            v1 = CP-1
        e = cdr e

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

// (ex .. ex )
to genlist e =
    while e != NIL
        genex car e
        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
        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
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

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 ref
        LNAME: outa icGet ref
        OPER:
            if ref == tkBREAK
                ypush CP
                ypush BMARK
                outa icJmp 0

to clean fn | ref a end =
    ref = getRef fn
    patchbreak
    a = (getLv fn) + 1
    outa icRet a
    tailCall2 fn
    end = CP-1
    setEnd fn end
    reName fn
    improv3
    improv3
    clearlis jplis
    setRetv fn (findRet fn)

    if M[mode_ads] == 2		// listing in compile mode
        showCode ref end
    if (getCount fn) == 0	// no forward call
        convert ref end
    else
        addlis ufunlis fn	// defer

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 icShr e
        tkLTLT: genbop icShl e
        tkNOT:
            genex car e
            outa icNot 0
        tkARRAY:
            genex car e
            outa icSys 14
        tkSYSCALL:				// (num ex .. ex)
            genlist cdr e
            outa icSys (cdr car e)
        tkBB:
            genlist e
        tkBE:					// (call name ex ... ex)
            idx = cdr car e		// e = (name ex .. ex)
            genlist cdr e
            a = getRef idx
            if a == 0			// forward ref
                if (sizeoflis callis) >= MAXCALL
                    error "list of calli overflow"
                addlis callis CP
                addlis reflis currentf
                setCount currentf (getCount currentf)+1
            outa icCall idx

        tkRBRACKET:				// (mac name ex...ex)
            idx = cdr car e		// e = (name ex...ex)
//			domacro idx cdr e
            genex subst (getRef idx) (cdr e)  // macro subst
        tkTO:					// (to name ex)
            idx = cdr car e		// e = (name ex)
            currentf = idx
            v1 = getLv idx
            e = item2 e			// e = body (block ex ex ..)
            if e != NIL
                for a 1 v1
                    vrec[a] = a
                setRef idx CP
                outa icFun idx
                ypush MARK
                genex e
                clean idx
        tkCOLON:				// define macro
            idx = cdr car e		// e = (name ex)
            currentf = idx
            e = item2 e
            setRef idx e
        tkEQ:					// (= 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 isatom a	// var
                genex e1		// RHS
                if (car a) == LNAME	// type
                    outa icPut v1
                else				// GNAME
                    outa icSt v1
                    if cmode == 1 updatesym v1 e1
            else				// vec, a = (vec nm ex)
                e = cdr a		// e LHS, e1 RHS
                genex item2 e	// idx
                genex e1		// RHS val
                e = car e		// nm
                if (car e) == LNAME	// type of nm
                    outa icStx cdr e
                else 			// GNAME
                    outa icSty cdr e

        tkLBRACKET:				// vec RHS
            genex item2 e		// ex, e = (nm ex)
            e = car e			// nm
            if (car e) == LNAME	// type of nm
                outa icLdx cdr e
            else				// GNAME
                outa icLdy cdr e
        tkIF:					// (if e1 e)
            genex car e			// e = (e1 e)
            outa icJf 0
            optJmp
            ads = CP-1
            genex item2 e
            patch ads CP
        tkELSE:					// (ifelse e1 et ef)
            genex car e			// e = (e1 et ef)
            outa icJf 0
            optJmp
            ads = CP-1
            genex item2 e
            outa icJmp 0
            patch ads CP
            ads = CP-1
            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
            outa icJt 0
            optJmp
            patch CP-1 ads+1	// jmp to body
            patch ads ads2
            patchbreak
        tkFOR:					// (for lv ex0 ex0 ex)
            ypush MARK			// e = (lv ex0 ex0 ex)
            v1 = cdr car e
            v2 = vrec[v1]		// find adj v1
            if v2 == v1			// no pair
                v2 = (getLv currentf) + 1
                setLv currentf v2 // update symtab
                vrec[v1] = v2
                vrec[v2] = 0	// is a pair
            e = cdr e			// e = (ex0 ex0 ex)
            e1 = cons (car e) (list newatom NUM 1)
            e1 = cons (newatom OPER tkMINUS) e1
            genex e1			// initial
            outa icPut v1
            genex item2 e		// end
            outa icPut v2
            ads = CP
            outa icJmp 0		// jmp to test
            genex item3 e		// body of for
            patch ads CP		// test
            outa icEfor v1
            outa icJt ads+1
            patchbreak
        tkCASE:
            gencase e
        else: error "genex: unknown operator"

// update count of Call which is already defined
// check unconverted list
to patchCalli | i a d idx =
    for i 1 (sizeoflis callis)
        a = callis[i]
        if a != 0
            d = XARG[a]
            if (getRef d) != 0
                idx = reflis[i]
                setCount idx (getCount idx)-1
                callis[i] = 0		// delete entry

    for i 1 (sizeoflis ufunlis)
        a = ufunlis[i]
        if a != 0
            if (getCount a) <= 0
                convert (getRef a) (getEnd a)
                ufunlis[i] = 0		// delete entry

// just clean up calli
// and gen call to "main" if it is defined
to genfinal | idx d =
    patchCalli
    d = CP
    CP = 1
    idx = install "main"
    if (getType idx) != tyNEW
        outa icCall0 (getRef idx)
    outa icEnd 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 i =
    if e == NIL break
//	prlist e
    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 icEnd 0
//	showCode ads CP-1
    convert ads CP-1
    CPX = CP	// update CPX
    CP = d		// restore CP
    eval ads

// End

