1.1 --- a/genesis/ometa/ometa-interpreter.church	Sun Mar 27 13:51:45 2011 +0200
     1.2 +++ b/genesis/ometa/ometa-interpreter.church	Sun Mar 27 18:19:10 2011 +0200
     1.3 @@ -8,19 +8,9 @@
     1.4  		variables
     1.5  		action-closures
     1.6  
     1.7 -get-variable-position rule-variables var
     1.8 -	position (intern var) (reverse rule-variables)
     1.9 -
    1.10 -get-variable-position-new rule-variables sym
    1.11 +get-variable-position rule-variables sym
    1.12  	(position sym rule-variables)
    1.13  
    1.14 -global ometa-church-parser = nil
    1.15 -
    1.16 -ometa-parse-array-with-interpreter array
    1.17 -	if (null? ometa-church-parser)
    1.18 -		ometa-church-parser = new 'new-church-parser :church-grammar-file-name "genesis/church/church.g"
    1.19 -	parse-array ometa-church-parser array
    1.20 -
    1.21  replace-variables-with-positions variables form quoting
    1.22  	if (null? form)
    1.23  		form
    1.24 @@ -54,11 +44,442 @@
    1.25  						else
    1.26  							`[quote ,form]
    1.27  					else
    1.28 -						pos = get-variable-position-new variables form
    1.29 +						pos = get-variable-position variables form
    1.30  						if (null? pos)
    1.31  							error "var not found " (list form variables)
    1.32  						`[_ometa_get_variable ,pos]
    1.33  
    1.34  
    1.35 +class ometa-interpreter
    1.36 +	with-slots
    1.37 +		data-stack
    1.38 +		rules
    1.39 +		rules-map
    1.40 +		memo
    1.41 +		actions
    1.42 +	init
    1.43 +		self.memo = new 'native-dictionary
    1.44 +		create self.memo 10000
    1.45 +		self.actions = nil
    1.46 +	reset-memo
    1.47 +		self.memo = new 'native-dictionary
    1.48 +		create self.memo 10000		
    1.49 +	rewrite-instruction rule form
    1.50 +;		print "rewrite-instruction 3"
    1.51 +;		print form
    1.52 +		case (first form)
    1.53 +			and
    1.54 +				new-forms =  [(rewrite-instruction self rule x) for x in (cdr form)]
    1.55 +				`[and |,(remove nil new-forms)]
    1.56 +			or
    1.57 +				new-forms =  [(rewrite-instruction self rule x) for x in (cdr form)]
    1.58 +				`[or |,(remove nil new-forms)]
    1.59 +			set
    1.60 +;				print "set"
    1.61 +;				print form
    1.62 +;				print rule.variables
    1.63 +				rhs = third form
    1.64 +				variable-position = get-variable-position rule.variables (intern (second form))
    1.65 +				`[set ,variable-position ,(rewrite-instruction self rule rhs)]
    1.66 +			app
    1.67 +				rule-name = second form
    1.68 +				if (and (string? rule-name) (string-equal? rule-name "token"))
    1.69 +					return-from rewrite-instruction	`[app-token ,rule-name ,(coerce rule-name 'array)]
    1.70 +				if (eq? rule-name 'token)
    1.71 +					str = (third form)
    1.72 +					`[app-token ,str ,(coerce str 'array)]
    1.73 +				else
    1.74 +					if (eq? rule-name 'exactly)
    1.75 +						args = cddr form
    1.76 +						str = third form
    1.77 +						if (cons? str)
    1.78 +							str = second str
    1.79 +						`[match-char ,(char-at str 0)]
    1.80 +					else
    1.81 +;						print form
    1.82 +						if (== (length form) 3)
    1.83 +							if (and (cons? (third form)) (eq? (first (third form)) 'string))
    1.84 +								`[app-with-string ,(intern (second form)) ,(second (third form))]
    1.85 +							else
    1.86 +								if (or (null? (third form)) (or (null? (third form)) (eq? 'nil (third form)) (string-equal? (third form) "nil")))
    1.87 +									if (symbol? (second form))
    1.88 +										`[app-with-nil ,(second form)]
    1.89 +									else
    1.90 +										`[app-with-nil ,(intern (second form))]
    1.91 +								else
    1.92 +									`[app-with-argument ,(second form) ,(get-variable-position rule.variables (intern (third form)))]
    1.93 +						else
    1.94 +							if (string? (second form))
    1.95 +								`[app ,(intern (second form))]
    1.96 +							else
    1.97 +								form
    1.98 +			act
    1.99 +;				print "*** rewrite act"
   1.100 +;				print rule.variables
   1.101 +;				print form
   1.102 +;				print (coerce (second form) 'array)
   1.103 +				forms = (parse-sexps-from-array (coerce (second form) 'array))
   1.104 +				if (null? forms)
   1.105 +					error "bad sexp" form
   1.106 +				act-form = first forms
   1.107 +				res = `[act ,(replace-variables-with-positions rule.variables act-form nil)]
   1.108 +				res
   1.109 +			many
   1.110 +				`[many ,(rewrite-instruction self rule (second form))]
   1.111 +			many1
   1.112 +				`[many1 ,(rewrite-instruction self rule (second form))]
   1.113 +			not
   1.114 +				`[not ,(rewrite-instruction self rule (second form))]
   1.115 +			lookahead
   1.116 +				`[not [not ,(rewrite-instruction self rule (second form))]]
   1.117 +			loadarg
   1.118 +				`[loadarg]
   1.119 +			else
   1.120 +				error "unhandled form" form
   1.121 +	parse rule-name stream frame-pointer stack-pointer
   1.122 +			memo = self.memo
   1.123 +			inputpos = stream.input-position
   1.124 +			found = has? memo rule-name
   1.125 +			mark stream
   1.126 +;			print "** parse"
   1.127 +;			print rule-name
   1.128 +			if found
   1.129 +				lookup = get memo rule-name nil
   1.130 +				lookup2 = get lookup inputpos nil
   1.131 +				if (null? lookup2)
   1.132 +					result = (actual-parse self rule-name stream  frame-pointer stack-pointer)
   1.133 +					put lookup inputpos (list result stream.input-position)
   1.134 +;					print "put result 1"
   1.135 +;					print (list result stream.input-position)
   1.136 +					pop-mark stream
   1.137 +					result
   1.138 +				else
   1.139 +					if (not (eq? (car lookup2) o-fail))
   1.140 +;						print "got memo "
   1.141 +;						print lookup2
   1.142 +						reset-to stream (second lookup2)
   1.143 +					else
   1.144 +						reset-to-mark stream
   1.145 +					pop-mark stream
   1.146 +					car lookup2
   1.147 +			else
   1.148 +				result = (actual-parse self rule-name stream frame-pointer stack-pointer)
   1.149 +				d = new 'native-dictionary
   1.150 +				create d 100
   1.151 +				put d inputpos (list result stream.input-position)
   1.152 +				put memo rule-name d
   1.153 +;				print "put result 2"
   1.154 +;				print rule-name
   1.155 +;				print result
   1.156 +				pop-mark stream
   1.157 +				result			
   1.158 +	actual-parse rule-name stream frame-pointer stack-pointer
   1.159 +		lookup = get self.rules-map rule-name nil
   1.160 +		if (null? lookup)
   1.161 +;			out "** primitive parse "
   1.162 +;			print rule-name
   1.163 +			prim-result = apply rule-name self stream
   1.164 +;			print prim-result
   1.165 +;			print (remaining stream)
   1.166 +			prim-result
   1.167 +		else
   1.168 +			r = lookup
   1.169 +			frame-pointer = stack-pointer
   1.170 +			stack-pointer = + (+ stack-pointer (length r.variables)) 1
   1.171 +			loop
   1.172 +				for i from frame-pointer to stack-pointer
   1.173 +				do
   1.174 +					self.data-stack[i] = nil
   1.175  
   1.176 +			result = interpret self r.instructions stream frame-pointer stack-pointer
   1.177 +;			print result
   1.178 +;			print (remaining stream)
   1.179 +			result
   1.180 +	parse-with-arg rule-name stream frame-pointer stack-pointer arg
   1.181 +;		print "** parse with arg"
   1.182 +;		print rule-name
   1.183 +;		print arg
   1.184 +		lookup = get self.rules-map rule-name nil
   1.185 +		if (null? lookup)
   1.186 +			apply rule-name self stream arg
   1.187 +		else
   1.188 +			r = lookup
   1.189 +			frame-pointer = stack-pointer
   1.190 +			stack-pointer = + (+ stack-pointer (length r.variables)) 1
   1.191 +			loop
   1.192 +				for i from frame-pointer to stack-pointer
   1.193 +				do
   1.194 +					self.data-stack[i] = nil
   1.195  
   1.196 +			self.data-stack[ frame-pointer ] = arg
   1.197 +			interpret self r.instructions stream frame-pointer stack-pointer
   1.198 +	seq stream arg
   1.199 +		if (o-fail? arg)
   1.200 +			return-from seq o-fail
   1.201 +;		print "in seq"
   1.202 +;		print arg
   1.203 +		mark stream
   1.204 +		loop
   1.205 +			for x in arg
   1.206 +			do
   1.207 +				str = x
   1.208 +;				print "seq str"
   1.209 +;				print str
   1.210 +;				print "next"
   1.211 +				if (string? str)
   1.212 +					print "is string"
   1.213 +					error "not string" str
   1.214 +				else
   1.215 +					if (at-end? stream)
   1.216 +						reset-to-mark stream
   1.217 +						pop-mark stream
   1.218 +						return-from seq o-fail
   1.219 +					c = read-next stream
   1.220 +					if (not (eq? c str))
   1.221 +						reset-to-mark stream
   1.222 +						pop-mark stream
   1.223 +						return-from seq o-fail
   1.224 +
   1.225 +		pop-mark stream
   1.226 +;		print "in seq ret"
   1.227 +		arg
   1.228 +	anything stream
   1.229 +		if (at-end? stream)
   1.230 +			o-fail
   1.231 +		else
   1.232 +			read-next stream
   1.233 +	cnewline stream
   1.234 +		if (at-end? stream)
   1.235 +			o-fail
   1.236 +		else
   1.237 +			c = peek stream
   1.238 +;			assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
   1.239 +			x = nil
   1.240 +			inline (set! |x| (|church-make-character| 10))
   1.241 +			if (eq? c x)
   1.242 +				read-next stream
   1.243 +			else
   1.244 +				unpeek stream
   1.245 +				o-fail
   1.246 +	stringquote stream
   1.247 +		if (at-end? stream)
   1.248 +			o-fail
   1.249 +		else
   1.250 +			c = peek stream
   1.251 +;			assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
   1.252 +			x = nil
   1.253 +			inline (set! |x| (|church-make-character| 34))
   1.254 +			if (eq? c x)
   1.255 +				read-next stream
   1.256 +			else
   1.257 +				unpeek stream
   1.258 +				o-fail
   1.259 +	digit stream
   1.260 +		if (>= (remaining-byte-count stream) 1)
   1.261 +			c = peek stream
   1.262 +;			assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
   1.263 +			if (and (char? c) (digit? c))
   1.264 +				read-next stream
   1.265 +				c
   1.266 +			else
   1.267 +				unpeek stream
   1.268 +				o-fail
   1.269 +		else
   1.270 +			o-fail
   1.271 +	letter stream
   1.272 +		if (>= (remaining-byte-count stream) 1)
   1.273 +			c = peek stream
   1.274 +;			assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
   1.275 +			if (and (char? c) (letter? c))
   1.276 +				read-next stream
   1.277 +			else
   1.278 +				unpeek stream
   1.279 +				o-fail
   1.280 +		else
   1.281 +			o-fail
   1.282 +	interpret-action form frame-pointer stack-pointer quoting
   1.283 +;		print "interpret-action"
   1.284 +;		print form
   1.285 +;		print frame-pointer
   1.286 +		typecase form
   1.287 +			cons
   1.288 +				if (eq? (first form) 'quote)
   1.289 +					second form
   1.290 +				else
   1.291 +					if (eq? (first form) '_ometa_get_variable)
   1.292 +;						print "getting variable"
   1.293 +;						print (second form)
   1.294 +;						print self.data-stack[frame-pointer]
   1.295 +						self.data-stack[+ frame-pointer (second form)]
   1.296 +					else
   1.297 +						collector = nil
   1.298 +						loop
   1.299 +							for x in form
   1.300 +							do
   1.301 +								if (and (cons? x) (eq? (first x) '_ometa_get_variable_splice))
   1.302 +									mylist = self.data-stack[+ frame-pointer (second x)]
   1.303 +									collector = append! (reverse! mylist) collector
   1.304 +								else
   1.305 +									push (interpret-action self x frame-pointer stack-pointer quoting) collector
   1.306 +
   1.307 +;						print collector
   1.308 +						reverse! collector
   1.309 +			else
   1.310 +				error "bad type in interpret-action" form
   1.311 +	interpret ins stream frame-pointer stack-pointer
   1.312 +;						out "<-------- "
   1.313 +;						if (not (at-end? stream))
   1.314 +;							print (remaining stream) 
   1.315 +;						print ins
   1.316 +;						print stream.input-position
   1.317 +;					print "stack-pointer"
   1.318 +;					print stack-pointer
   1.319 +;					print ">"
   1.320 +;					loop
   1.321 +;						for i from 0 to frame-pointer
   1.322 +;						do
   1.323 +;							print self.data-stack[i]
   1.324 +;
   1.325 +;					print ">>"
   1.326 +;					loop
   1.327 +;						for i from frame-pointer to stack-pointer
   1.328 +;						do
   1.329 +;							print self.data-stack[i]
   1.330 +;
   1.331 +					case (first ins)
   1.332 +						app (parse self (second ins) stream frame-pointer stack-pointer)
   1.333 +						and
   1.334 +							args = rest ins
   1.335 +							if (null? args)
   1.336 +								true
   1.337 +							else
   1.338 +								mark stream
   1.339 +								answer = nil
   1.340 +								loop
   1.341 +									for x in args
   1.342 +									do (answer = interpret self x stream frame-pointer stack-pointer)
   1.343 +									when (o-fail? answer)
   1.344 +									do
   1.345 +										reset-to-mark stream
   1.346 +										pop-mark stream
   1.347 +										return-from interpret o-fail
   1.348 +
   1.349 +								pop-mark stream
   1.350 +								answer
   1.351 +						or
   1.352 +							mark stream
   1.353 +							args = rest ins
   1.354 +							if (null? args)
   1.355 +								error "bad or" ins
   1.356 +							loop
   1.357 +								for x in args
   1.358 +								do
   1.359 +									reset-to-mark stream
   1.360 +									answer = interpret self x stream frame-pointer stack-pointer
   1.361 +									if (not (o-fail? answer))
   1.362 +										pop-mark stream
   1.363 +										return-from interpret answer
   1.364 +
   1.365 +							pop-mark stream
   1.366 +							o-fail
   1.367 +						many
   1.368 +							answer = nil
   1.369 +							loop
   1.370 +								do
   1.371 +									mark stream
   1.372 +									v = interpret self (second ins) stream frame-pointer stack-pointer
   1.373 +									if (o-fail? v)
   1.374 +										reset-to-mark stream
   1.375 +										pop-mark stream
   1.376 +										return-from interpret (reverse! answer)
   1.377 +									push v answer
   1.378 +									pop-mark stream
   1.379 +
   1.380 +						many1
   1.381 +							x = second ins
   1.382 +							v = interpret self x stream frame-pointer stack-pointer
   1.383 +							if (o-fail? v)
   1.384 +								o-fail
   1.385 +							else
   1.386 +								answer = list v
   1.387 +								loop
   1.388 +									do
   1.389 +										mark stream
   1.390 +										v = interpret self x stream frame-pointer stack-pointer
   1.391 +										if (o-fail? v)
   1.392 +											reset-to-mark stream
   1.393 +											pop-mark stream
   1.394 +											return-from interpret (reverse! answer)
   1.395 +										push v answer
   1.396 +										pop-mark stream
   1.397 +
   1.398 +						act
   1.399 +;							print "act"
   1.400 +;							print ins
   1.401 +							v = interpret-action self (second ins) frame-pointer stack-pointer nil
   1.402 +;							print "interpret-action "
   1.403 +;							print v
   1.404 +							v
   1.405 +						set
   1.406 +							index = second ins
   1.407 +							x = third ins
   1.408 +							v = interpret self x stream frame-pointer stack-pointer
   1.409 +							self.data-stack[+ frame-pointer index] = v
   1.410 +							v
   1.411 +						not
   1.412 +							mark stream
   1.413 +							if (o-fail? (interpret self (second ins) stream frame-pointer stack-pointer))
   1.414 +								pop-mark stream
   1.415 +								true
   1.416 +							else
   1.417 +								reset-to-mark stream
   1.418 +								pop-mark stream
   1.419 +								o-fail
   1.420 +						app-token
   1.421 +							str = second ins
   1.422 +							char-array = third ins
   1.423 +							len = length char-array
   1.424 +							if (>= (remaining-byte-count stream) len)
   1.425 +								input-position = stream.input-position
   1.426 +								native1 = char-array.native-array
   1.427 +								native2 = stream.input-array.native-array
   1.428 +								result = 0
   1.429 +								inline (set! result (tf (call-c memcmp native1 (+ native2 (* (uf input-position) CHURCH_WORD_SIZE)) (* (uf len) CHURCH_WORD_SIZE))))
   1.430 +								if (== result 0)
   1.431 +									read-ahead stream len 
   1.432 +;									print "app-token returning"
   1.433 +;									print str
   1.434 +									str
   1.435 +								else
   1.436 +									;print "app-token failed"
   1.437 +									;print (remaining stream)
   1.438 +									o-fail
   1.439 +							else
   1.440 +								o-fail
   1.441 +						match-char
   1.442 +							if (>= (remaining-byte-count stream) 1)
   1.443 +								arg = second ins
   1.444 +								c = peek stream
   1.445 +;								assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
   1.446 +								if (eq? c arg)
   1.447 +									read-next stream
   1.448 +								else
   1.449 +									unpeek stream
   1.450 +									o-fail
   1.451 +							else
   1.452 +								o-fail
   1.453 +						app-with-nil
   1.454 +							parse-with-arg self (second ins) stream frame-pointer stack-pointer nil
   1.455 +						app-with-argument
   1.456 +							parse-with-arg self (second ins) stream frame-pointer stack-pointer self.data-stack[ + frame-pointer (third ins)]
   1.457 +						app-with-string
   1.458 +							parse-with-arg self (second ins) stream frame-pointer stack-pointer (third ins)
   1.459 +						loadarg
   1.460 +							self.data-stack[frame-pointer]
   1.461 +						else
   1.462 +							error "invalid ins" ins
   1.463 +
   1.464 +
   1.465 +
   1.466 +
   1.467 +