// gencode-s.txt
//   public release som-v2  30 December 2004

to atomeq e type value =
	((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

// 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-ads
	if ytos != MARK
		error "patch break: no matching mark"
	a = ypop			// throw away MARK

// call only when fn is not empty
to clean fn | ref a =
	ref = getRef fn
	patchbreak
	a = (getLv fn) + 1
	outa icRet a
	tailCall2 CP-1
	// update fun head, new lv from for
	a = (getLv fn) - (getArity fn) + 1
	putcode ref icFun a
	// post processing
	reName fn
	improve2 ref
	improve2 ref

to genex l | a e e1 ads ads2 v1 v2 idx type ref = {}

to genbop op l =
	genex car l
	genex item2 l
	outs op

to genuop op l =
	genex car l
	outs op

//  gen vec ads: (name ex) => ld/get, ex, ldx
to genvec e | nm type ref =
	nm = car e
	type = car nm
	ref = cdr nm
	case type
		GNAME: outa icLd getRef ref
		LNAME: outa icGet ref
	genex item2 e

// return patch-address, e = (e1 e)
to genif e | ads =
	genex car e
	outa icJf 0
	ads = CP - 1
	genex item2 e
	ads

// get Lo Hi from caselist
// Lo Hi are globals
to getcaselist e | n e2 =
	Lo = 0
	Hi = 0
	if e == NIL break
	e = cdr e
	e2 = car e				// a = (num ex)
	n = cdr car e2			// n = num.ref
	Lo = n
	Hi = n
	while e != NIL
		e2 = car e
		n = cdr car e2
		if n < 0 break		// else case
		if n < Lo Lo = n
		if n > Hi Hi = n
		e = cdr e

// e = (ex0 block)
to gencase e | ads ads2 i v1 v2 a type ref =
	genex car e				// gen ex0
	outs icCase
	e = item2 e				// block
	getcaselist e			// set Lo Hi globals
	outa icLit Lo
	outa icLit Hi
	ads = CP
	outa icJmp 0			// else case
	for i Lo Hi
		outa icJmp 0		// empty jmp table
	v1 = 0
	e = cdr e				// e = (ex .. ex)
	while e != NIL
		a = car e			// a = (num ex)
		ref = cdr car a 	// ref = num label
		if ref > 0			// skip else (ref -1)
			ads2 = ref-Lo+ads+1	// entry in jmp table
			patch ads2 CP-ads2	// 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+1 ads+1+Hi-Lo
		v2 = CS[i] >> 8
		if v2 == 0 patch i CP-i
	patch ads CP-ads			// jmp to else
	if ref == (0-1)				// gen else case
		genex item2 a
	// here is eloc
	// update backchain jmp to eloc
	while v1 != 0
		v2 = CS[v1] >> 8
		patch v1 CP-v1
		v1 = v2
	patch v1 CP-v1				// the first one

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

to genex x | a e e1 ads ads2 v1 v2 idx type ref =
	if x == NIL break
	if isatom x
		type = car x
		ref = cdr x
		case type
			STRING: outa icLit 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
				else
					error "genex: unknown atomic operator"
	else
		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: genuop icNot e
			tkARRAY: genuop icArray e
			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
					outa icCalli idx
				else
					outa icCall a
			tkTO:					// (to name ex)
				idx = cdr car e		// e = (name ex)
				currentf = idx
				e = item2 e
				if e != NIL
					setRef idx CP
					outa icFun 0	// update at clean
					ypush MARK
					genex e
					clean idx
			tkEQ:					// (= var/vec ex)
				a = car e			// var/vec
				e1 = item2 e
				if isinc e			// e = (lv (+ lv 1))
					ref = cdr a 	// lvar ref
					if atomeq (car e1) OPER tkPLUS
						outa icInc ref
					else
						outa icDec ref
				else
					if isatom a			// var
						genex e1		// RHS
						type = car a
						ref = cdr a
						case type
							GNAME: outa icSt getRef ref
							LNAME: outa icPut ref
							else: error "genex: unknown atom type"
					else
						genvec cdr a	// get address LHS
						genex e1		// RHS
						outs icStx
			tkLBRACKET:				// vec RHS
				genvec e
				outs icLdx
			tkIF:					// (if e1 e)
				ads = genif e		// e = (e1 e)
				patch ads CP-ads
			tkELSE:					// (ifelse e1 et ef)
				ads = genif e		// e = (e1 et ef)
				outa icJmp 0
				patch ads CP-ads
				ads = CP - 1
				genex item3 e
				patch ads CP-ads
			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 ads+1-CP	// jmp to body
				patch ads ads2-ads
				patchbreak
			tkFOR:					// (for lv ex0 ex0 ex)
				ypush MARK			// e = (lv ex0 ex0 ex)
				v2 = (getLv currentf) + 1
				setLv currentf v2	// update header when clean
				v1 = cdr car e
				e = cdr e			// e = (ex0 ex0 ex)
				genex car e			// 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
				outa icInc v1
				patch ads CP-ads	// test
				outa icGet v1
				outa icGet v2
				outs icLe
				outa icJt ads+1-CP
				patchbreak
			tkCASE:
				gencase e
			else: error "genex: unknown operator"

// change Calli to Call from CS[a]..CS[b]
to patchCalli a b | i c d =
	for i a b
		c = CS[i] & 255
		d = CS[i] >> 8
		if c == icCalli
			putcode i icCall (getRef d)

// End
