// 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)

bop_type = array	// 0..16
  xUD
  xCM xUD xCM xUD xCM xCM xCM xUD xCM xCM
  xLG xLG xLG xLG xUD xUD

bop_im = array		// 0..16
  0
  icAddi icSubi 0 0 icBandi icBori 0 0 icEqi 0
  icLti  icLei  0 0 icShli icShri

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

to hasIm op =
	if op < 17  bop_im[op] else  0

// 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
		icShl:  a << b
		icShr:  a >> b
		else:   0

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

to invLogicIm op =
	case op
		icNe: icEqi
		icGt: icLei
		icGe: icLti
		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 genbopi op e1 c | opi t =
	opi = hasIm op
	if opi != 0
		genex e1
		outa opi c
	else if isLogic op
		genex e1
		opi = invLogicIm op
		outa opi c
		outa icNot 0
	else
		t = newv
		outa icLit c
		outa icPut t
		genex e1
		outa op t
		freev t

to genbop op e | e1 e2 ty1 ty2 t =
	e1 = car e
	e2 = item2 e
	ty1 = typeX e1
	ty2 = typeX e2
	if ty2 == xLV
		genex e1
		outa op cdr e2
	else if and (isCommute op) (ty1 == xLV)
		genex e2
		outa op cdr e1
	else if ty2 == xLIT
		if ty1 == xLIT  // still cannot do recursively
			outa icLit (evalBop op (cdr e1) (cdr e2))
		else
			genbopi op e1 (cdr e2)
	else if and (isCommute op) (ty1 == xLIT)
		genbopi op e2 (cdr e1)
	else
		genex e2
		t = newv
		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 and (c == icEqi) (lastArg == 0)
		CP = lastCP
		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
	genex e1
	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 icCase lo
	outa icLit hi
	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 icPush 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

// add ads (CP) to reloc list
to genglobal op arg =
	addlis relis CP
	outa op arg

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

to clean fn | ref lv i a =
	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
		a = CS[i]
		if op_str[a*4] == mJ
			addlis jplis i
		else if a == icCase	// skip jmp table (hi-lo+1)*2+6
			i = i + 2*(CS[i+3]-CS[i+1]) + 6
		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 icShr e
		tkLTLT: genbop icShl 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
				genglobal 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
					v2 = cdr idx
					if isLocal v1
						out3 icStx (cdr v1) v2
					else
						genglobal icSty (enc2 (getRef cdr v1) v2)
				else
					genex idx	// idx
					v2 = newv
					outa icPut v2
					genex e1	// RHS
					if isLocal v1
						out3 icStx (cdr v1) v2
					else
						genglobal icSty (enc2 (getRef cdr v1) v2)
					freev v2

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

		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

