// stmt-s.txt
//   public release som v3.0   5 March 2007 (Maka-bucha day)
//   public release som v3.1   19 Aug 2007 (Draft vote day)
//   public release som v4.0   2 July 2008
//   public release som v4.1   9 Aug 2008 (Birthday)

// ---- parser stack  operators -----

to ypush x =
	ysp = ysp + 1
	if ysp >= MAXYSTK
		seterror "parser stack overflow"
	ystack[ysp] = x

to ypop | x =
	if ysp <= 0
		seterror "parser stack underflow"
	x = ystack[ysp]
	ysp = ysp - 1
	x

to ytos = ystack[ysp]

// -------------------------------

to expect tk mess =
	if tok != tk seterror mess

to commit status =
	if status == 0 seterror "syntax error"

// [ idx arity -- idx ]
to setfname type | arity idx =
	arity = ypop
	idx = ytos
	if (getType idx) != tyNEW
		warning (getName idx) "redefine function"
	setType idx type
	setArity idx arity
	setLv idx Nlv

// [idx %ex -- %to]
to dofun tk | idx e a =
	e = ypop
	idx = ypop
	if verbose
		printc 43 prints getName idx nl
	a = cons (newatom GNAME idx) (list e)
	ypush cons (newatom OPER tk) a
//	dumpSym
//	dumpLocal
	clearLocal

//  [ -- %var ]
to dovar idx | type =
	type = getType idx
	if type == tyGVAR
		ypush newatom GNAME idx
	else if type == tyLOCAL
		ypush newatom LNAME (getRef idx)
	else
		seterror "dovar: expect variable"

// [lvidx %ex0 %ex0 %ex -- %for] (for lv ex0 ex0 ex)
to dofor | e idx =
	e = ypop
	e = cons ypop (list e)
	e = cons ypop e		// (ex0 ex0 ex)
	idx = ypop			// lvidx
	if (getType idx) != tyLOCAL
		seterror "index variable must be local"
	dovar idx			// [ -- %var]
	ypush cons (newatom OPER tkFOR) (cons ypop e)

// [%ex0 %ex -- %while] (while ex0 ex)
to dowhile | e =
	e = ypop
	e = cons ypop (list e)
	ypush cons (newatom OPER tkWHILE) e

// [%ex0 %ex [%ex MARK] -- %if/ifelse ]
to doif | e =
	if ytos == MARK
		e = ypop		// throw away MARK
		e = ypop
		e = cons ypop (list e)
		e = cons ypop e	// (ex0 ex ex)
		ypush cons (newatom OPER tkELSE) e
	else
		e = ypop
		e = cons ypop (list e)
		ypush cons (newatom OPER tkIF) e

// [%var %ex -- %vec]
to dovec | e v a =
	e = ypop
	v = ypop
	if isatom v
		a = newatom OPER tkLBRACKET
		ypush cons a (cons v (list e))
	else
		seterror "dovec: expect variable"

// allocate one from DS[]
: newdata = syscall {14 1}

// left variable
// if IDEN: NEW, GVAR, LOCAL then dovar mod else 0
to lval | idx type =
	if tok != tkIDEN
		0 break
	idx = tokvalue
	type = getType idx
	if type == tyNEW 	// new global, be careful !!
		setType idx tyGVAR
		setRef idx newdata
		warning getName idx "new global"
	else
		if !( (type == tyGVAR) | (type == tyLOCAL) )
			0 break
	dovar idx
	lex
	commit mod
	1

to doset | var e a = {}

// assignment, [ -- %var/%vec]
to exas =
	if lval == 1
		if tok == tkEQ
			lex		// skip =
			commit ex0
			doset
		else
			// lval has alread done
			// half of the job, term
			commit terms
		1
	else
		ex0

to doenum =
	if (getType tokvalue) == tyNEW
		setType tokvalue tyENUM
		setRef tokvalue nenum
		nenum = nenum + 1
	else
		seterror "enum: expect unique label"

// function call, parse ex0^arity
// [ -- %call]  (fun name ex .. ex)
to docall idx op | i arity e =
	arity = getArity idx
	for i 1 arity
		commit ex0
	e = NIL
	for i 1 arity
		e = cons ypop e
	e = cons (newatom GNAME idx) e
	ypush cons (newatom OPER op) e

// [ -- %num]
to donum v = ypush newatom NUM v

// already lex the next token
// ID is: var, fun-call, enum
to doiden idx =
	case getType idx
		tyNEW:				// new global, be careful
			warning getName idx "new global"
			setType idx tyGVAR
			setRef idx (array 1)
			dovar idx
			commit mod
		tyGVAR:
			dovar idx
			commit mod
		tyLOCAL:
			dovar idx
			commit mod
		tyFUNC:
			docall idx tkBE
		tyMAC:
			docall idx tkRBRACKET
//		tyFULL:
//			docall idx tkRBRACKET
		tyENUM:
			donum getRef idx

// [ %var %ex -- %set ]  (= var ex)
to doset | var e a =
	e = ypop
	var = ypop
	a = newatom OPER tkEQ
	ypush cons a (cons var (list e))

// [%ex1 bop %ex2 -- %bop] (bop ex1 ex2)
to dobop | e1 op e2 a =
	e2 = ypop
	op = ypop
	e1 = ypop
	a = newatom OPER op
	ypush cons a (cons e1 (list e2))

// [%ex -- %uop]
to douop uop | e =
	e = ypop
	ypush cons (newatom OPER uop) (list e)

// block = tkBB, simplify block size 0 and 1
to makeblock a =
	if a == NIL
		NIL 		// block size 0 {} => NIL
	else if (cdr a) == NIL
		car a 		// block size 1 {a} => a
	else
		cons (newatom OPER tkBB) a

// [MARK %e1 .. %en -- %block] (block e1 .. en)
to doblock | e a =
	a = NIL
	e = ypop
	while e != MARK
		a = cons e a
		e = ypop
	ypush makeblock a

// convert label to number [ -- %num]
to dolabel =
	if (getType tokvalue) != tyENUM
		seterror "expect label"
	donum getRef tokvalue

// [%ex0 MARK %num %ex .. %-1 %ex -- %case]
to docase | e a =
	a = NIL
	e = ypop
	while e != MARK
		e = cons ypop (list e)	// e = (num ex)
		a = cons e a
		e = ypop
	a = makeblock a
	e = cons ypop (list a)
	ypush cons (newatom OPER tkCASE) e

// [MARK %num %ex0 .. %ex0 -- %sys]
// (sys ex0 .. ex0)
to dosys | a e =
	e = NIL
	a = ypop
	while a != MARK
		e = cons a e
		a = ypop
	ypush cons (newatom OPER tkSYSCALL) e

// [ -- %string]
to dostring | s2 =
	s2 = array ((strlen tokstring) + 1)
	strcpy s2 tokstring
	ypush (newatom STRING s2)

// store tokstring to memory
to akeepStr | i =
	i = 0
	while tokstring[i] != 0
		M[newdata] = tokstring[i]
		i = i + 1
	M[newdata] = 0

// store ref of iden to memory
to akeepIden =
	if (getType tokvalue) == tyNEW
		seterror "unknown identifier"
	M[newdata] = getRef tokvalue

// End
