// gencode-s.txt
//   public release som-v2  30 December 2004
//   public release som-v24 10 January 2007

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

to genex x | 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

// e = (ex0 block)
to gencase e | e1 n lo hi i ads ads2 v1 v2 a =
	genex car e				// gen ex0
	outs icCase
	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-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 ads+hi-lo
		v2 = CS[i] >> 8
		if v2 == 0	patch i CP-i
	patch ads-1 CP-(ads-1)		// 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 = CS[v1] >> 8
		patch v1 CP-v1
		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-ads
	if ytos != MARK
		error "patch break: no matching mark"
	a = ypop			// throw away MARK

// e = fun body
to genfun idx e | ref =
	if e == NIL break
	currentf = idx
	ref = CP
	setRef idx ref
	outa icFun 0		// update later
	ypush MARK
	genex e
	patchbreak			// clean
	outa icRet (getLv idx) + 1
	tailCall2 CP-1
	// update fun header to any change of lv
	patch ref ((getLv idx)-(getArity idx)+1)
	reName idx
//	improve2 ref
//	improve2 ref

// macro must not be recursive?
to genmac idx e | ads i =
	if e == NIL break
	currentf = idx
	setRef idx e			// ref parse tree
	ads = CP
	CP = CPX
	ypush MARK
	genex e
	patchbreak
	outs icEnd
//	tailCall2 CP-1
	// check if any assign local, full macro
	for i CPX CP-1
		if (CS[i] & 255) == icPut
			setType idx tyFULL
			setRef idx CPX	// ref code
			break
	CPX = CP				// update CPX
	CP = ads				// restore CP


// 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 getRef ref
		LNAME: outa icGet ref
		OPER:
			if ref == tkBREAK
				ypush CP
				ypush BMARK
				outa icJmp 0
			else
				error "genatom: unknown operator"

to domacro idx e = {}

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: 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
				if Ncall >= MAXCALLI
					error "list of calli overflow"
				callis[Ncall] = CP
				Ncall = Ncall + 1
				outa icCalli idx
			else
				outa icCall a
		tkRBRACKET:				// (mac name ex...ex)
			idx = cdr car e		// e = (name ex...ex)
			domacro idx cdr e
		tkTO:					// (to name ex)
			idx = cdr car e		// e = (name ex)
			genfun idx item2 e
		tkCOLON:				// define macro
			idx = cdr car e
			genmac idx item2 e
		tkEQ:					// (= var/vec ex)
			a = car e			// var/vec
			ads = cdr a
			e1 = item2 e
			if isinc e			// e = (lv (+ lv 1))
				if atomeq (car e1) OPER tkPLUS
					outa icInc ads
				else
					outa icDec ads
			else if isatom a	// var
				genex e1		// RHS
				case car a		// type
					GNAME:
						outa icSt getRef ads
						if cmode == 1 updatesym ads e1
					LNAME:
						outa icPut ads
					else:
						error "genex: unknown atom type"
			else
				genvec ads		// 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 which is already defined to Call
to patchCalli | i a d =
	for i 0 Ncall-1
		a = callis[i]
		if a != 0
			d = CS[a] >> 8
			if (getRef d) != 0
				putcode a icCall getRef d
				callis[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 icCall getRef idx
	outs icEnd
	CP = d		// restore CP

//to showimm start end | i =
//	FO = 1
//	for i start end
//		print i space
//		prCode i nl

// execute immediate line, use CS[CPX] area
// CPX in increasing, do not reuse this area
// as runimm may be nested
to runimm e | d ads i =
	if e == NIL break
//	prlist e
	cmode = 1
	d = CP
	CP = CPX
	ads = CP	// begining of imm code
	genex e		// e can be a block
	outs icEnd
	patchCalli
//	showimm ads CP-1
	CPX = CP	// update CPX
	CP = d		// restore CP
	eval ads

// End
