// 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)
//   som v5  starts            7 Oct 2009
//   som v5.1  starts          12 Dec 2010
//   public release som v5.1   24 Dec 2010 (Christmas)

// 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] & 63
to lastArg = CS[lastCP] >> 6

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 = {}

// always use sequence: op a c b (arg as appear in field)

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
		outb op v1 v v2
	v

to outJmp d =
	addlis jplis CP
	outi 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 opzJmp op d e | c v j a =
	v = genex e
	c = lastOp
	if and (! isatom e) (isLogic c) // combine jmp
		if op == tJf
			j = condJmp[c-9]		// jf, inv
		else
			j = condJmp[c-9+6]		// jt
		a = dispAt lastCP			// src1 of logic
		patch lastCP (enc3 j d a)
	else
		outc op d v 0				// normal
	addlis jplis lastCP
	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 = destAt lastCP
		if and (lastOp <= tStx) (isTemp a)
			patchC lastCP RETVAL
			freev a
		else
			out2 tMov RETVAL v
			freev v
		v = RETVAL
	v

// get case label range, return (lo,hi)
to lohi e | n lo hi =
	n = cdr car car e		// e = (num ex), n = num.ref
	lo = n
	hi = n
	e = cdr e
	while e != NIL
		n = cdr car car e
		if n < 0 break
		else if n < lo lo = n
		else if n > hi hi = n
		e = cdr e
	newatom lo hi

// e = (ex0 block)
to gencase e | e1 n lo hi i ads v1 v end =
	v1 = genex car e		// cond
	e = cdr item2 e			// block => (ex..ex)
	n = lohi e
	lo = car n
	hi = cdr n
	// all disp in jmp table are relative to this
	outc tCase lo v1 hi
	ads = lastCP
	freev v1
	end = ads+2 + even(hi-lo+2) // size hi-lo+1 +else
	CS[ads+2] = end-ads			// jmp end
	for i ads+3 end-1
		CS[i] = 0				// empty jmp vector
	CP = end
	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+3 CP-ads // entry in jmp vector
			v = final (genex item2 e1)
			outJmp v1			// jmp to eloc, backchain
			v1 = lastCP
		e = cdr e

	// this opt is too risky as it undo lastCP with lot of consequences
//	if n != #f 					// if no exelse
//		removeLastlis jplis		// remove last jmp to exit
//		CP = CP - 2

	patchA end CP				// <1> here is exelse
	for i ads+3 end-1
		if CS[i] == 0
			patch i CP-ads		// 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
		n = dispAt v1
		patchA v1 CP
		v1 = n
	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
		patchA 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
	// is local and not atom, and less than 10 bits
	if and and (v1 < RETVAL) (! isatom e) (v <= #03ff)
		patchC lastCP v
	else
		out2 tMov v v1
	freev v1

to relocjmp | i ads =
	for i 1 (sizeoflis jplis)
		ads = jplis[i]
		if ads != 0
			patchA ads (dispAt ads)-ads

to genfun idx e | ref lv v =
	nlocal = getLv idx	// set range of temp
	clearlis jplis
	ref = CP
	setRef idx ref
	outi 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+1] == ref)
		patch lastCP (enc2 tCallt lastArg)
	lv = getLv idx
	patchC ref 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 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
			outb tNot v v 0
		tkARRAY:
			v = genex car e
			outc tSys 0 14 v
			freev v
			v = RETVAL
		tkSYSCALL:				// (num ex .. ex)
			// hard code, at most 2 params
			v1 = genex item2 e
			v = genex item3 e
			outc tSys v (cdr car e) v1
			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
						out2 tMov v1 a
				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 idx v v1
				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
			outb tLdx idx v v1
			freev idx
		tkIF:							// (if e1 e)
			opzJmp tJf 0 (car e)		// e = (e1 e)
			ads = lastCP
			v = final (genex item2 e)
			patchA ads CP
		tkELSE:							// (ifelse e1 et ef)
			opzJmp tJf 0 (car e)		// e = (e1 et ef)
			ads = lastCP
			v = final (genex item2 e)	// et
			outJmp 0
			patchA ads CP
			ads = lastCP
			v = final (genex item3 e)	// ef
			patchA ads CP
		tkWHILE:						// (while e1 e)
			ypush MARK
			ads = CP
			outJmp 0					// branch to cond
			v = final (genex item2 e)	// body
			patchA ads CP
			opzJmp tJt ads+2 (car e)	// cond,jmp to body
			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)
			genput idx (car e)
			v1 = genex item2 e 			// end
			outc tJgt 0 idx v1
			ads = lastCP
			addlis jplis ads
			v = final (genex item3 e)	// body
			outc tEfor ads+2-CP idx v1
			patchA ads CP
			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+1]
			if d != 0
				patch a+1 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
		outi tCall 0 0 (getRef idx)
	outi tSys 0 13 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 a1 =
	if (cdr e) == NIL break		// empty
	patchCalli
//	cmode = 1
	currentf = 0		// force im mode
//	setLv currentf 0	// not sure
	d = CP
	CP = CPX
//	a1 = CP
	ads = CP			// begining of imm code
	v = genex e			// e can be a block
	outi tSys 0 13 0  	// End
	CPX = CP			// update CPX
	CP = d				// restore CP
//	showCode a1 a1+20
	eval ads

// End

