extern o-fail

class ometa-rule
	with-slots
		name
		instructions
		original-instructions
		variables
		action-closures

get-variable-position rule-variables sym
	(position sym rule-variables)

replace-variables-with-positions variables form quoting
	if (null? form)
		form
	else
		typecase form
			cons
				cond
					(and quoting (eq? (first form) 'unquote))
						pos = position (second form) variables
						`[_ometa_get_variable ,pos]
					(and quoting (eq? (first form) 'unquote-splice))
						pos = position (second form) variables
						`[_ometa_get_variable_splice ,pos]
					(eq? (first form) 'quote)
						,(replace-variables-with-positions variables (second form) true)
					(eq? (first form) 'quasiquote)
						loop
							for f in (second form)
							collect (replace-variables-with-positions variables f true)
					true
						loop
							for f in form
							collect (replace-variables-with-positions variables f quoting)
			else
				if (string? form)
					form
				else
					if quoting
						if (and (cons? form) (eq? (first form) 'quote))
							form
						else
							`[quote ,form]
					else
						pos = get-variable-position variables form
						if (null? pos)
							error "var not found " (list form variables)
						`[_ometa_get_variable ,pos]


class ometa-interpreter
	with-slots
		data-stack
		rules
		rules-map
		memo
		actions
	init
		self.memo = new 'native-dictionary
		create self.memo 10000
		self.actions = nil
	reset-memo
		self.memo = new 'native-dictionary
		create self.memo 10000		
	rewrite-instruction rule form
;		print "rewrite-instruction 3"
;		print form
		case (first form)
			and
				new-forms =  [(rewrite-instruction self rule x) for x in (cdr form)]
				`[and |,(remove nil new-forms)]
			or
				new-forms =  [(rewrite-instruction self rule x) for x in (cdr form)]
				`[or |,(remove nil new-forms)]
			set
;				print "set"
;				print form
;				print rule.variables
				rhs = third form
				variable-position = get-variable-position rule.variables (intern (second form))
				`[set ,variable-position ,(rewrite-instruction self rule rhs)]
			app
				rule-name = second form
				if (and (string? rule-name) (string-equal? rule-name "token"))
					return-from rewrite-instruction	`[app-token ,rule-name ,(coerce rule-name 'array)]
				if (eq? rule-name 'token)
					str = (third form)
					`[app-token ,str ,(coerce str 'array)]
				else
					if (eq? rule-name 'exactly)
						args = cddr form
						str = third form
						if (cons? str)
							str = second str
						`[match-char ,(char-at str 0)]
					else
;						print form
						if (== (length form) 3)
							if (and (cons? (third form)) (eq? (first (third form)) 'string))
								`[app-with-string ,(intern (second form)) ,(second (third form))]
							else
								if (or (null? (third form)) (or (null? (third form)) (eq? 'nil (third form)) (string-equal? (third form) "nil")))
									if (symbol? (second form))
										`[app-with-nil ,(second form)]
									else
										`[app-with-nil ,(intern (second form))]
								else
									`[app-with-argument ,(second form) ,(get-variable-position rule.variables (intern (third form)))]
						else
							if (string? (second form))
								`[app ,(intern (second form))]
							else
								form
			act
;				print "*** rewrite act"
;				print rule.variables
;				print form
;				print (coerce (second form) 'array)
				forms = (parse-sexps-from-array (coerce (second form) 'array))
				if (null? forms)
					error "bad sexp" form
				act-form = first forms
				res = `[act ,(replace-variables-with-positions rule.variables act-form nil)]
				res
			many
				`[many ,(rewrite-instruction self rule (second form))]
			many1
				`[many1 ,(rewrite-instruction self rule (second form))]
			not
				`[not ,(rewrite-instruction self rule (second form))]
			lookahead
				`[not [not ,(rewrite-instruction self rule (second form))]]
			loadarg
				`[loadarg]
			else
				error "unhandled form" form
	parse rule-name stream frame-pointer stack-pointer
			memo = self.memo
			inputpos = stream.input-position
			found = has? memo rule-name
			mark stream
;			print "** parse"
;			print rule-name
			if found
				lookup = get memo rule-name nil
				lookup2 = get lookup inputpos nil
				if (null? lookup2)
					result = (actual-parse self rule-name stream  frame-pointer stack-pointer)
					put lookup inputpos (list result stream.input-position)
;					print "put result 1"
;					print (list result stream.input-position)
					pop-mark stream
					result
				else
					if (not (eq? (car lookup2) o-fail))
;						print "got memo "
;						print lookup2
						reset-to stream (second lookup2)
					else
						reset-to-mark stream
					pop-mark stream
					car lookup2
			else
				result = (actual-parse self rule-name stream frame-pointer stack-pointer)
				d = new 'native-dictionary
				create d 100
				put d inputpos (list result stream.input-position)
				put memo rule-name d
;				print "put result 2"
;				print rule-name
;				print result
				pop-mark stream
				result			
	actual-parse rule-name stream frame-pointer stack-pointer
		lookup = get self.rules-map rule-name nil
		if (null? lookup)
;			out "** primitive parse "
;			print rule-name
			prim-result = apply rule-name self stream
;			print prim-result
;			print (remaining stream)
			prim-result
		else
			r = lookup
			frame-pointer = stack-pointer
			stack-pointer = + (+ stack-pointer (length r.variables)) 1
			loop
				for i from frame-pointer to stack-pointer
				do
					self.data-stack[i] = nil

			result = interpret self r.instructions stream frame-pointer stack-pointer
;			print result
;			print (remaining stream)
			result
	parse-with-arg rule-name stream frame-pointer stack-pointer arg
;		print "** parse with arg"
;		print rule-name
;		print arg
		lookup = get self.rules-map rule-name nil
		if (null? lookup)
			apply rule-name self stream arg
		else
			r = lookup
			frame-pointer = stack-pointer
			stack-pointer = + (+ stack-pointer (length r.variables)) 1
			loop
				for i from frame-pointer to stack-pointer
				do
					self.data-stack[i] = nil

			self.data-stack[ frame-pointer ] = arg
			interpret self r.instructions stream frame-pointer stack-pointer
	seq stream arg
		if (o-fail? arg)
			return-from seq o-fail
;		print "in seq"
;		print arg
		mark stream
		loop
			for x in arg
			do
				str = x
;				print "seq str"
;				print str
;				print "next"
				if (string? str)
					print "is string"
					error "not string" str
				else
					if (at-end? stream)
						reset-to-mark stream
						pop-mark stream
						return-from seq o-fail
					c = read-next stream
					if (not (eq? c str))
						reset-to-mark stream
						pop-mark stream
						return-from seq o-fail

		pop-mark stream
;		print "in seq ret"
		arg
	anything stream
		if (at-end? stream)
			o-fail
		else
			read-next stream
	cnewline stream
		if (at-end? stream)
			o-fail
		else
			c = peek stream
;			assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
			x = nil
			inline (set! |x| (|church-make-character| 10))
			if (eq? c x)
				read-next stream
			else
				unpeek stream
				o-fail
	stringquote stream
		if (at-end? stream)
			o-fail
		else
			c = peek stream
;			assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
			x = nil
			inline (set! |x| (|church-make-character| 34))
			if (eq? c x)
				read-next stream
			else
				unpeek stream
				o-fail
	digit stream
		if (>= (remaining-byte-count stream) 1)
			c = peek stream
;			assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
			if (and (char? c) (digit? c))
				read-next stream
				c
			else
				unpeek stream
				o-fail
		else
			o-fail
	letter stream
		if (>= (remaining-byte-count stream) 1)
			c = peek stream
;			assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
			if (and (char? c) (letter? c))
				read-next stream
			else
				unpeek stream
				o-fail
		else
			o-fail
	interpret-action form frame-pointer stack-pointer quoting
;		print "interpret-action"
;		print form
;		print frame-pointer
		typecase form
			cons
				if (eq? (first form) 'quote)
					second form
				else
					if (eq? (first form) '_ometa_get_variable)
;						print "getting variable"
;						print (second form)
;						print self.data-stack[frame-pointer]
						self.data-stack[+ frame-pointer (second form)]
					else
						collector = nil
						loop
							for x in form
							do
								if (and (cons? x) (eq? (first x) '_ometa_get_variable_splice))
									mylist = self.data-stack[+ frame-pointer (second x)]
									collector = append! (reverse! mylist) collector
								else
									push (interpret-action self x frame-pointer stack-pointer quoting) collector

;						print collector
						reverse! collector
			else
				error "bad type in interpret-action" form
	interpret ins stream frame-pointer stack-pointer
;						out "<-------- "
;						if (not (at-end? stream))
;							print (remaining stream) 
;						print ins
;						print stream.input-position
;					print "stack-pointer"
;					print stack-pointer
;					print ">"
;					loop
;						for i from 0 to frame-pointer
;						do
;							print self.data-stack[i]
;
;					print ">>"
;					loop
;						for i from frame-pointer to stack-pointer
;						do
;							print self.data-stack[i]
;
					case (first ins)
						app (parse self (second ins) stream frame-pointer stack-pointer)
						and
							args = rest ins
							if (null? args)
								true
							else
								mark stream
								answer = nil
								loop
									for x in args
									do (answer = interpret self x stream frame-pointer stack-pointer)
									when (o-fail? answer)
									do
										reset-to-mark stream
										pop-mark stream
										return-from interpret o-fail

								pop-mark stream
								answer
						or
							mark stream
							args = rest ins
							if (null? args)
								error "bad or" ins
							loop
								for x in args
								do
									reset-to-mark stream
									answer = interpret self x stream frame-pointer stack-pointer
									if (not (o-fail? answer))
										pop-mark stream
										return-from interpret answer

							pop-mark stream
							o-fail
						many
							answer = nil
							loop
								do
									mark stream
									v = interpret self (second ins) stream frame-pointer stack-pointer
									if (o-fail? v)
										reset-to-mark stream
										pop-mark stream
										return-from interpret (reverse! answer)
									push v answer
									pop-mark stream

						many1
							x = second ins
							v = interpret self x stream frame-pointer stack-pointer
							if (o-fail? v)
								o-fail
							else
								answer = list v
								loop
									do
										mark stream
										v = interpret self x stream frame-pointer stack-pointer
										if (o-fail? v)
											reset-to-mark stream
											pop-mark stream
											return-from interpret (reverse! answer)
										push v answer
										pop-mark stream

						act
;							print "act"
;							print ins
							v = interpret-action self (second ins) frame-pointer stack-pointer nil
;							print "interpret-action "
;							print v
							v
						set
							index = second ins
							x = third ins
							v = interpret self x stream frame-pointer stack-pointer
							self.data-stack[+ frame-pointer index] = v
							v
						not
							mark stream
							if (o-fail? (interpret self (second ins) stream frame-pointer stack-pointer))
								pop-mark stream
								true
							else
								reset-to-mark stream
								pop-mark stream
								o-fail
						app-token
							str = second ins
							char-array = third ins
							len = length char-array
							if (>= (remaining-byte-count stream) len)
								input-position = stream.input-position
								native1 = char-array.native-array
								native2 = stream.input-array.native-array
								result = 0
								inline (set! result (tf (call-c memcmp native1 (+ native2 (* (uf input-position) CHURCH_WORD_SIZE)) (* (uf len) CHURCH_WORD_SIZE))))
								if (== result 0)
									read-ahead stream len 
;									print "app-token returning"
;									print str
									str
								else
									;print "app-token failed"
									;print (remaining stream)
									o-fail
							else
								o-fail
						match-char
							if (>= (remaining-byte-count stream) 1)
								arg = second ins
								c = peek stream
;								assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
								if (eq? c arg)
									read-next stream
								else
									unpeek stream
									o-fail
							else
								o-fail
						app-with-nil
							parse-with-arg self (second ins) stream frame-pointer stack-pointer nil
						app-with-argument
							parse-with-arg self (second ins) stream frame-pointer stack-pointer self.data-stack[ + frame-pointer (third ins)]
						app-with-string
							parse-with-arg self (second ins) stream frame-pointer stack-pointer (third ins)
						loadarg
							self.data-stack[frame-pointer]
						else
							error "invalid ins" ins