// this is a Som parser (som 4.2a)
// it is intended to be a benchmark program
// it consists of som-compiler (parser only)
// all files are concatenate into one file
// as it cannot do recursive load which required immediate execution
// 8 October 2009

// it is 1500 lines of code

//load "string-s.txt"
//load "compile-h-s.txt"
//load "list-s.txt"
//load "symtab-s.txt"
//load "token-s.txt"
//load "parse-h-s.txt"
//load "stmt-s.txt"
//load "parse2.som"
//load "main-s.txt"

// load "string-s.txt"

// string-s.txt   string functions
//    som-string is an array of int
//    an int contains at most 4 char, right pad with 0
//    terminate by int 0

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

//    improve efficiency by nested-if  29 July 2008
//    fprints now move to syscall 11   20 sept 2009

// copy s1 = s2
to strcpy s1 s2 | i =
	i = 0
	while s2[i] != 0
		s1[i] = s2[i]
		i = i + 1
	s1[i] = 0

to strlen s | k =
	k = 0
	while s[k] != 0
		k = k + 1
	k

// debug per "som-string-bug.txt, 7/9/2007" 16 Mar 2008
to streq s1 s2 | i =
	i = 0
	while and (s1[i] == s2[i]) s1[i]
		i = i + 1
	s1[i] == s2[i]

// s1 is som-string (packed string)
// s1 contains only number (no sign)
to atoi s1 | a i c1 c2 c3 c4 v =
	v = 0
	i = 0
	a = s1[i]
	while a != 0
		c1 = (a >> 24) & 255
		if c1 != 0
			v = v*10 + c1 - 48
			c2 = (a >> 16) & 255
			if c2 != 0
				v = v*10 + c2 - 48
				c3 = (a >> 8) & 255
				if c3 != 0
					v = v*10 + c3 - 48
					c4 = a & 255
					if c4 != 0
						v = v*10 + c4 - 48
		i = i + 1
		a = s1[i]
	v

: prints s1 = fprints 1 s1		// prints to stdout

// pack array of char to som-string s1
// use nested if
to strpack s1 ar start len | a k i e =
	k = 0
	i = start
	e = start + len
	while i < e
		a = ar[i] << 24
		i = i + 1
		if i < e
			a = a | (ar[i] << 16)
			i = i + 1
			if i < e
				a = a | (ar[i] << 8)
				i = i + 1
				if i < e
					a = a | ar[i]
					i = i + 1
		s1[k] = a
		k = k + 1
	s1[k] = 0

// End

// load "compile-h-s.txt

// compile-h-s.txt
// header file for som-in-som project
//  public release som-v24 10 January 2007
//    Celebrating H.M.King 60 years accend to the throne.
//  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)

// sequence of loading files
//
// lib.som
// string-s.txt
// compile-h-s.txt
// list-s.txt
// symtab-s.txt
// token-s.txt
// parse-h-s.txt
// stmt-s.txt
// parse.som
// icode-s.txt
// gencode-s.txt
// macro-s.txt
// main-s.txt

enum	// marker
	0 NIL MARK BMARK
enum	// atom
	0 SP OPER NUM GNAME LNAME CNAME STRING ADS

enum	// token type
	14 tkIDEN tkNUMBER tkSTRING tkEOF tkERROR
enum	// token
	50 tkSTAR tkSLASH tkMINUS tkPLUS tkEQ tkEQEQ
	tkAND tkBAR tkCARET tkMOD tkNOT tkNE tkLT tkLE
	tkLTLT tkGT tkGE tkGTGT tkCOLON tkLPAREN tkRPAREN
	tkLBRACKET tkRBRACKET tkBB tkBE tkTO tkIF tkELSE
	tkWHILE tkFOR tkBREAK tkARRAY tkCASE tkENUM tkSYSCALL
enum	// symbol type
	6 tyFUNC tyLOCAL tyGVAR tyENUM tyKEY tyNEW tyMAC
enum	// denote gvar arg for DS relocation
	0 VSCALAR VARRAY VSTRING

//  memory model
//  M [ MAXMEM  ]		 declared in C
//  M[1..MAXSYS]  		 system area
//	CS[MAXCS]			 code segment
//       ^
//       CP
//  ystack[MAXYSTK]		 parser stack
//           ^
//          ysp
//  cell[MAXCELL]		 store list (parse-tree)
//  data segment is absolute M[]

enum
	20000 MAXCS		// size of code segment
enum
	1000 MACSIZE	// size of macro
enum
	2000 MAXYSTK	// size of parser stack
enum
	200  MAXCALL	// size of call forward list
enum
	100  MAXLV		// size of lv table

//  system area  1 .. MAXSYS-1

//  1..80 tokstring
//  101  mode
//  102  tokvalue
//  103  tokcol
//  104  line

enum
	101 mode_ads

to initSom | a =
	M = 0				// base of M, alias with C M[]
	CP = 6  			// code pointer
//	CS = array MAXCS
	ystack = array MAXYSTK  // parser stack
	ysp = 0
	currentf = 0		// current fn idx
	nenum = 0			// enum number
	verbose = 1			// control compiler message
	cmode = 0			// compile mode, 0 def, 1 im, 2 rep
	callis = array MAXCALL	// list of call forward
	CPX = MAXCS-MACSIZE	// immediate & macro code area
	exsym = array 500 	// export symbol
	nxsym = 0
//	line = 0
	M[104] = 0			// line
	FI = 0				// input file
	FO = 1				// output file
	vrec = array MAXLV
	vsp = 0				// vrec sp
//	jplis = array 1000	// ads of icJmp
//	relis = array (MAXCS/4) // reloc list
	lastCP = 0

: line = M[104]
: setline n = M[104] = n

: fspace = fprintc FO 32
: fnl = fprintc FO 10

// when no line number is available (gencode, eval, etc.)
to error x =
	prints "error: " prints x nl
	exit

// error during parsing
to seterror s =
	prints "line " print line space
	prints s nl
	exit

to warning nm mess =
	if verbose
		prints "Warning: "
		if nm != 0
			prints nm space
		prints mess nl

// End

// load "list-s.txt"

// list-s.txt    list processing
//   implement list.c  for som-som project  14 Jan 2004
//   P. Chongstitvatana

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

enum
	10 CELLPTR			// min pointer to acell
enum
	100000 MAXCELL

to init_list =
	cell = array MAXCELL
	freecell = CELLPTR
	endcell = MAXCELL - 2

: setcar a value =
	cell[a] = value

: setcdr a value =
	cell[a+1] = value

//: car a = if a == NIL a else cell[a]
//: cdr a = if a == NIL a else cell[a+1]
: car a = cell[a]
: cdr a = cell[a+1]
to item2 x = car cdr x
to item3 x = car cdr cdr x

to newcell | a =
	a = freecell
	freecell = freecell + 2
	if freecell >= endcell
		seterror "out of memory cell"
	else
		setcar a NIL
		setcdr a NIL
	a

to islist x = (car x) >= CELLPTR
to isatom x = (car x) < CELLPTR

to newatom type value | a =
	a = newcell
	setcar a type
	setcdr a value
	a

to list a | b =
	b = newcell
	setcar b a
	b

to cons a l | b =
	b = newcell
	setcdr b l
	setcar b a
	b

to append lst x | a b =
	if x != NIL
		a = lst
		b = cdr a
		while b != NIL
			a = b
			b = cdr a
		setcdr a (list x)
	lst


// can cons2 be used instead of cons ?  31 Mar 2004

// cons2 x, y = {NIL, atom, list}
to cons2 x y | z =
	if x == NIL
		y break
	if y == NIL
		list x break
	// it is the same whether x is atom of list
	// a new cell is required to build a dot-pair
	// only y must be inspected, if it is not a list
	// a new dot-pair to make y a list is needed
	if isatom y
		z = newatom y NIL
	else
		z = y
	newatom x z

// clone a copy of list t
to copylist t =
	if t == NIL
		NIL
		break
	if isatom t
		newatom (car t) (cdr t)
	else
		cons2 (copylist car t) (copylist cdr t)

to countcell | k =
	k = (MAXCELL - freecell) / 2
	prints "+freecell = " print k nl

// data structure of type lis
// is an one-dimension vector with element 0 storing its size
// total space of vector is size+1

to addlis lis x | n =
	n = lis[0] + 1
	lis[n] = x
	lis[0] = n

: clearlis lis = lis[0] = 0
: sizeoflis lis = lis[0]

to countlis lis | i n =
	n = 0
	for i 1 (sizeoflis lis)
		if lis[i] != 0
			n = n + 1
	n

// end

// load "symtab-s.txt"

// symtab-s.txt

//	  for som v2.3    21 Jan 2006
//	  one hash table + local shadow buffer
//	  search and insert O(1), no linear search for local

// interface:
//    install str	  -- search and insert string in symtab
//                    -- return index to table
//    enterLocal idx  -- enter local, shadow gvar if exist
//					  -- error if duplicate
//	  clearLocal	  -- clear local table
//    init_symtab

//    alloc iden string from a fixed array "nmstr"
//    to separate compiler/user allocation	12 June 2006
//
//    Celebrating H.M.King 60 years accend to the throne.

//    separate symtab to htab and symtab 	24 Aug 2007

enum
    2003 htabsize	  // a prime number
enum
    1000 tablesize
enum
    5000 namesize

// sym-entry is   (name,type,ref,arity,lv)
// local sym use: (name,type,ref,gv,lv)

enum
    5 elesize

// access functions by index

: getName a = symtab[a]
: getType a = symtab[a+1]
: getRef a = symtab[a+2]
: getArity a = symtab[a+3]
: getLv a = symtab[a+4]

: setName a nm = symtab[a] = nm
: setType a v = symtab[a+1] = v
: setRef a v = symtab[a+2] = v
: setArity a v = symtab[a+3] = v
: setLv a v = symtab[a+4] = v

to init_symtab | i k =
    htab = array htabsize
    symtab = array (tablesize*elesize)
    nmstr = array namesize	// identifier string
    Namep = 0				// pointer to nmstr
    freeSym = 0				// pointer to symtab
    lvlis = array MAXLV		// list of lv
    clearlis lvlis
    Nlv = 0

// hast string to v  0..tablesize-1
to hash s1 | i v a =
    i = 0
    v = 0
    a = s1[i]
    while a != 0
        v = v + a	// add all int
        i = i + 1
        a = s1[i]
    if (v < 0) v = 0 - v
    v % htabsize

// alloc space for string from nmstr[]
to makename nm | s =
    s = Namep
    Namep = Namep + (strlen nm) + 1
    if Namep >= namesize
        seterror "string space in symbol table is full"
    s = nmstr + s	// pointer to name string
    strcpy s nm
    s

// alloc a space in symtab
to newSym nm ty | k =
    freeSym = freeSym + elesize
    if freeSym >= (tablesize*elesize)
        seterror "symbol table full (symtab)"
    k = freeSym
    setName k nm
    setType k ty
    k

// hash with linear probe
//   if new, insert name, return index
//   i 0..tablesize-1, k point to symtab
to install nm | key i k =
    key = hash nm
    i = key
    while 1
        k = htab[i]
        if k == 0				// new, insert name
            k = newSym (makename nm) tyNEW
            htab[i] = k
            setLv k i			// back pointer to htab
            break
        if streq (getName k) nm	// found
            break
        i = (i+1) % htabsize
        if i == key		// wrap around, impossible
            seterror "symbol table full (htab)"
    k	// return index to symtab

to enterLocal idx | k h =
    Nlv = Nlv + 1
    case getType idx
        tyNEW:
            setType idx tyLOCAL
            setRef idx Nlv
            setArity idx 0		// not shadow
        tyGVAR:					// shadow
            h = getLv idx 		// pointer to htab
            k = newSym (getName idx) tyLOCAL
            setRef k Nlv
            setArity k idx		// point to gv
            htab[h] = k			// htab point here
            idx = k
        else:
            seterror "invalid local (enter)" // duplicate
    addlis lvlis idx

to clearLocal | idx i k =
    for i 1 (sizeoflis lvlis)
        k = lvlis[i]
        setType k tyNEW			// null it
        idx = getArity k
        if idx != 0				// shadow gv
            htab[getLv idx] = idx	// htab to gv
    clearlis lvlis
    Nlv = 0

// list index of export symbol (tyFUNC, tyGVAR)
// return num of sym
to getExportSym ar | k ty n =
    n = 0
    k = elesize
    while k <= freeSym
        ty = getType k
        if (ty == tyFUNC) | (ty == tyGVAR)
            ar[n] = k
            n = n + 1
        k = k + elesize
    n

// exsym = array 200
// nxsym = 0	 num of export sym

// must getExportSym first
//to findName type ref | i a k =
//	a = 0
//	for i 0 nxsym-1
//		k = exsym[i]
//		if ((getType k) == type) & ((getRef k) == ref)
//			a = getName k
//			break
//	a

// nmstr[] has unique symbols (494 for this compiler)
//to dumpName | s n =
//	n = 0
//	s = nmstr
//	while s < (nmstr + Namep)
//		prints s space
//		s = s + (strlen s) + 1
//		n = n + 1
//	nl print n nl

// update value of gvar
to dumpSym | i k type ref =
    fprint FO nxsym fnl
    for i 0 nxsym-1
        k = exsym[i]
        type = getType k
        ref = getRef k
//		if type == tyGVAR
//			setLv k M[ref]
        fprints FO getName k fspace
        fprint FO type fspace
        fprint FO ref fspace
        fprint FO getArity k fspace
        fprint FO getLv k fnl

// End

// load "token-s.txt"

// token-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)
//	 public release som v4.2   9 Sept 2009 (triple 9, 9/9/2009)

enum
	80 maxcol				// max depth of nested indent

//  250..299 tokstring
//  101  mode
//  102  tokvalue
//  103  tokcol
//  104  line

: tokvalue = M[102]
: tokcol = M[103]
: settokvalue x = M[102] = x

to initlex =
//	inbuf = array 1000		// input line buffer
	tok = 0					// current token
//	tokvalue = 0			// token value
//	tokstring = array 256	// token string
	tokstring = 250			// M[1..80]
	// column stack for block indentation
//	tokcol = 0				// current token column
	colstk = array maxcol	// column stack
	colsp = 0

to pushcol col =
	if colsp >= maxcol
		seterror "lex error col stack overflow"
	else
		colsp = colsp + 1
		colstk[colsp] = col

to popcol =
	if colsp <= 0
		seterror "lex error col stack underflow"
	else
		colsp = colsp - 1

to startlex =
//	CLEN = 0				// current token length
//	TP = 0					// current token pointer
//	line = 0				// current line number
	setline 0
	lexstate = 1			// state of lex
	oldtok = 0				// old token
	colsp = 0				// col stack pointer
	pushcol 0

to prtoken tk | a = {}

to lex2 =
	tok = syslex FI
	if tok == tkIDEN
//		tokvalue = install tokstring
		settokvalue (install tokstring)
		if (getType tokvalue) == tyKEY // key word
			tok = getRef tokvalue

// lexstate N=1, F=2, B=3
// state description   condition  action    next
//   N  normal  lex     oldline   out tok     N
//   N                  nl & ==   out tok     N
//   N                  nl & >    out { push  F
//   N                  nl & <    out } pop   B
//   F  forward         -         out oldtok  N
//   B  backward        ==        out oldtok  N
//   B                  <         out } pop   B
//   transition occurs on call lex
//   eof is a special case

to lex | oldline =
	case lexstate
		1:	// normal
			oldline = line
//			lex1					// at token-old-s.txt
			lex2
//			printc 34 prtoken tok printc 34 space
			oldtok = tok
			if tok == tkEOF			// out BE til match
				if colstk[colsp] != 0
					tok = tkBE
					popcol
				break
			if line != oldline		// newline
				if tokcol > colstk[colsp]
					tok = tkBB
					pushcol tokcol
					lexstate = 2	// F
				else if tokcol < colstk[colsp]
					tok = tkBE
					popcol
					lexstate = 3	// B
				// tokcol == colstk, just return tok
		2:	// forward
			tok = oldtok
			lexstate = 1			// N
		3:	// backward
			if tokcol >= colstk[colsp]
				tok = oldtok
				lexstate = 1		// N
			else // if tokcol < colstk[colsp]
				tok = tkBE
				popcol

// original prtoken (in som-v2) is 251 words
// this version using tok_str is 41 words

// print string of token, len 3 each
tok_str = array
	"*" 0 "/" 0 "-" 0 "+" 0 "=" 0 "==" 0 "&" 0 "|" 0
	"^" 0 "%" 0 "!" 0 "!=" 0 "<" 0 "<=" 0 "<<" 0 ">" 0
	">=" 0 ">>" 0 ":" 0 "(" 0 ")" 0 "[" 0 "]" 0 "{" 0
	"}" 0 "to" 0 "if" 0 "else" 0 "while" "for" 0 "break" "array"
	"case" 0 "enum" 0 "syscall"

to prtoken tk | a =
	if tk > tkSYSCALL
		seterror "unknown token"
	if tk >= tkSTAR
		a = tk - tkSTAR		// a 0..34
		prints tok_str+(a*3)
		break
	case tk
		tkIDEN: prints tokstring
		tkNUMBER: print tokvalue
		tkSTRING:
			printc 34 prints tokstring printc 34
		tkEOF: prints "eof"

// print atom
to pratom type ref =
	case type
		SP:
			prints "NIL"
		OPER:
			prtoken ref
		ADS:
			printc 36 print ref	// $
		NUM:
			print ref
		GNAME:
			prints getName ref
		LNAME:
			printc 35 print ref // #
		CNAME:
			prints "classname"
		STRING:
			printc 34 prints ref printc 34

// print list
to prlist a =
	if a == NIL break
	if isatom a
		pratom (car a) (cdr a)
		space
	else
		printc 40   // "("
		while a != NIL
			prlist car a
			a = cdr a
		printc 41   // ")"

to enterKey nm ref | a =
	a = install nm
	setType a tyKEY
	setRef a ref

to initkeysym =
	init_symtab
	enterKey "to" tkTO
	enterKey "if" tkIF
	enterKey "else" tkELSE
	enterKey "while" tkWHILE
	enterKey "for" tkFOR
	enterKey "break" tkBREAK
	enterKey "array" tkARRAY
	enterKey "case" tkCASE
	enterKey "enum" tkENUM
	enterKey "syscall" tkSYSCALL

// end

// load "parse-h-s.txt"

to top = {}
to fundef = {}
to macro = {}
to args = {}
to local = {}
to ex = {}
to exs = {}
to ex1 = {}
to exelse = {}
to elist = {}
to elist2 = {}
to caselist = {}
to label = {}
to ex0 = {}
to terms = {}
to term = {}
to aspec = {}
to alist = {}
to aitem = {}
to tuple = {}
to tuples = {}
to mod = {}
to bop = {}

// load "stmt-s.txt"

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

// load "parse2.som"

// parser Som-som generated from parse-grammar.txt 22 Sept 2009
// global: Nlv, tok, tokvalue, nenum

to top = {
case tok {
tkTO: {
lex
commit fundef
1 break }
tkCOLON: {
lex
commit macro
1 break }
else: {
if ex {
1 break }
}
}
0
}

to fundef = {
if tok == tkIDEN {
ypush tokvalue
lex
commit args
setfname tyFUNC
expect tkEQ "missing tkEQ"
lex
commit ex
dofun tkTO
1 break }
0
}

to macro = {
if tok == tkIDEN {
ypush tokvalue
lex
commit args
setfname tyMAC
expect tkEQ "missing tkEQ"
lex
commit ex
dofun tkCOLON
1 break }
0
}

to args = {
while tok == tkIDEN {
enterLocal tokvalue
lex
}
if tok == tkBAR {
ypush Nlv
lex
commit local
1 break }
ypush Nlv
1
}

to local = {
while tok == tkIDEN {
enterLocal tokvalue
lex
}
1
}

to ex = {
if tok == tkBB {
ypush MARK
lex
commit exs
expect tkBE "missing tkBE"
doblock
lex
1 break }
if ex1 {
1 break }
0
}

to exs = {
while ex1 {
}
1
}

to ex1 = {
case tok {
tkIF: {
lex
commit ex0
commit ex
commit exelse
doif
1 break }
tkWHILE: {
lex
commit ex0
commit ex
dowhile
1 break }
tkFOR: {
lex
expect tkIDEN "missing tkIDEN"
ypush tokvalue
lex
commit ex0
commit ex0
commit ex
dofor
1 break }
tkCASE: {
lex
commit ex0
expect tkBB "missing tkBB"
ypush MARK
lex
commit caselist
expect tkBE "missing tkBE"
docase
lex
1 break }
tkENUM: {
lex
expect tkBB "missing tkBB"
lex
commit elist
expect tkBE "missing tkBE"
ypush NIL
lex
1 break }
tkBREAK: {
ypush newatom OPER tkBREAK
lex
1 break }
else: {
if exas {
1 break }
}
}
0
}

to exelse = {
if tok == tkELSE {
lex
commit ex
ypush MARK
1 break }
1
}

to elist = {
if tok == tkNUMBER {
nenum = tokvalue
lex
commit elist2
1 break }
if elist2 {
1 break }
0
}

to elist2 = {
while tok == tkIDEN {
doenum
lex
}
1
}

to caselist = {
while label {
expect tkCOLON "missing tkCOLON"
lex
commit ex
}
if tok == tkELSE {
donum #ff
lex
expect tkCOLON "missing tkCOLON"
lex
commit ex
1 break }
1
}

to label = {
if tok == tkNUMBER {
donum tokvalue
lex
1 break }
if tok == tkIDEN {
dolabel
lex
1 break }
0
}

to ex0 = {
if term {
commit terms
1 break }
0
}

to terms = {
while bop {
commit term
dobop
}
1
}

to term | a  = {
case tok {
tkNUMBER: {
donum tokvalue
lex
1 break }
tkSTRING: {
dostring
lex
1 break }
tkIDEN: {
a = tokvalue
lex
doiden a
1 break }
tkNOT: {
lex
commit ex0
douop tkNOT
1 break }
tkARRAY: {
lex
commit aspec
1 break }
tkSYSCALL: {
lex
commit tuple
dosys
1 break }
tkLPAREN: {
lex
commit ex0
expect tkRPAREN "missing tkRPAREN"
lex
1 break }
}
0
}

to aspec | a  = {
if tok == tkBB {
a = array 0
lex
commit alist
expect tkBE "missing tkBE"
ypush newatom ADS a
lex
1 break }
if ex0 {
douop tkARRAY
1 break }
0
}

to alist = {
while aitem {
}
1
}

to aitem = {
case tok {
tkNUMBER: {
M[newdata] = tokvalue
lex
1 break }
tkSTRING: {
akeepStr
lex
1 break }
tkIDEN: {
akeepIden
lex
1 break }
}
0
}

to tuple = {
if tok == tkBB {
lex
expect tkNUMBER "missing tkNUMBER"
ypush MARK donum tokvalue
lex
commit tuples
expect tkBE "missing tkBE"
lex
1 break }
0
}

to tuples = {
while ex0 {
}
1
}

to mod = {
if tok == tkLBRACKET {
lex
commit ex0
expect tkRBRACKET "missing tkRBRACKET"
dovec
lex
1 break }
1
}

to bop = {
case tok {
tkPLUS: {
ypush tok
lex
1 break }
tkMINUS: {
ypush tok
lex
1 break }
tkSTAR: {
ypush tok
lex
1 break }
tkSLASH: {
ypush tok
lex
1 break }
tkAND: {
ypush tok
lex
1 break }
tkBAR: {
ypush tok
lex
1 break }
tkCARET: {
ypush tok
lex
1 break }
tkEQEQ: {
ypush tok
lex
1 break }
tkNE: {
ypush tok
lex
1 break }
tkLT: {
ypush tok
lex
1 break }
tkLE: {
ypush tok
lex
1 break }
tkGE: {
ypush tok
lex
1 break }
tkGT: {
ypush tok
lex
1 break }
tkMOD: {
ypush tok
lex
1 break }
tkGTGT: {
ypush tok
lex
1 break }
tkLTLT: {
ypush tok
lex
1 break }
}
0
}

// load "main-s.txt"

// main-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)
//   public release som v4.2    9 Sept 2009 (triple 9, 9/9/2009)

//  system area  1 .. MAXSYS-1
//   1..80   tokstring-som
//   101     mode ads
//   110..149 "inputfile"  som-string
//   150..199 "input.lst"  som-string
//   200..249 "input.obj"  som-string

enum
	110 src_file
enum
	150 lst_file
enum
	200 obj_file

to parse | f e tk =
	setcdr im NIL		// clear im
	startlex
	lex
	while tok != tkEOF
		tk = tok
		f = top			// parse, throw away flag
		e = ypop
		if (tk == tkTO) | (tk == tkCOLON)
			def = append def e
//			genex e
		else
			im = append im e

to init_all =
	initSom
	init_list
	def = list newatom OPER tkBB
	im = list newatom OPER tkBB
	initkeysym
	hSym = array hSymsize
	initlex
//	clearlis relis

to loadfile fn =
	if verbose
		prints "load " prints fn nl
	FI = fopen fn 0
	cmode = 0
	parse
	fclose FI
//	runimm im

to main =
	init_all
	userDS = array 0		// start of user ds
	verbose = 0
	loadfile "lib2.som"
	loadfile "parser.txt"	// parse only
	if verbose
		prlist def

// End


