FIX: runtime errors in paren expression in Parse rules now properly reset the Parse stack.

Red/System [
	Title:   "PARSE dialect interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %parse.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

parser: context [
	verbose: 0

	series: as red-block! 0
	rules:  as red-block! 0

	#define PARSE_PUSH_POSITIONS [
		p: as positions! ALLOC_TAIL(rules)
		p/header: TYPE_POINT
		p/rule:	  (as-integer cmd - block/rs-head rule) >> 4	;-- save cmd position
		p/input:  input/head									;-- save input position
		p/sub:	  0												;-- default value for sub-rule type
	]

	#define PARSE_SET_INPUT_LENGTH(word) [
		type: TYPE_OF(input)
		word: either any [								;TBD: replace with ANY_STRING?
			type = TYPE_STRING
			type = TYPE_FILE
			type = TYPE_URL
		][
			string/rs-length? as red-string! input
		][
			block/rs-length? input
		]
	]

	#define PARSE_CHECK_INPUT_EMPTY? [
		type: TYPE_OF(input)
		end?: either any [								;TBD: replace with ANY_STRING?
			type = TYPE_STRING
			type = TYPE_FILE
			type = TYPE_URL
		][
			any [
				string/rs-tail? as red-string! input
				all [positive? part input/head >= part]
			]
		][
			block/rs-tail? input
		]
		if positive? part [end?: input/head >= part or end?]
	]

	#define PARSE_COPY_INPUT(slot) [
		min: p/input
		new: as red-series! slot
		copy-cell as red-value! input as red-value! new
		copy-cell as red-value! input base				;@@ remove once OPTION? fixed
		new/head: min
		actions/copy new as red-value! new base no null
	]

	#define PARSE_PICK_INPUT [
		value: base
		type: TYPE_OF(input)
		either any [									;TBD: replace with ANY_STRING
			type = TYPE_STRING
			type = TYPE_FILE
			type = TYPE_URL
		][
			char: as red-char! base
			char/header: TYPE_CHAR
			char/value: string/rs-abs-at as red-string! input p/input
		][
			value: block/rs-abs-at input p/input
		]
	]

	#define PARSE_TRACE(event) [
		#if red-tracing? = yes [
			if OPTION?(fun) [
				rule/head: (as-integer cmd - block/rs-head rule) >> 4
				if negative? rule/head [rule/head: 0]
				unless fire-event fun words/event match? rule input [
					return as red-value! logic/push match?
				]
			]
		]
	]

	#define PARSE_ERROR [reset fire]

	#enum states! [
		ST_PUSH_BLOCK
		ST_POP_BLOCK
		ST_PUSH_RULE
		ST_POP_RULE
		ST_CHECK_PENDING
		ST_DO_ACTION
		ST_NEXT_INPUT
		ST_NEXT_ACTION
		ST_MATCH
		ST_MATCH_RULE
		ST_FIND_ALTERN
		ST_WORD
		ST_END
		ST_EXIT
	]

	#enum rule-flags! [									;-- negative values to not collide with t/state counter
		R_NONE:		  -1
		R_TO:		  -2
		R_THRU:		  -3
		R_COPY:		  -4
		R_SET:		  -5
		R_NOT:		  -6
		R_INTO:		  -7
		R_THEN:		  -8
		R_REMOVE:	  -9
		R_INSERT:	  -10
		R_WHILE:	  -11
		R_COLLECT:	  -12
		R_KEEP:		  -13
		R_KEEP_PAREN: -14
		R_AHEAD:	  -15
	]

	triple!: alias struct! [
		header [integer!]
		min	   [integer!]
		max	   [integer!]
		state  [integer!]
	]

	positions!: alias struct! [
		header [integer!]
		rule   [integer!]
		input  [integer!]
		sub    [integer!]
	]

	#if debug? = yes [
		print-state: func [s [states!]][
			print "state: "
			print-line switch s [
				ST_PUSH_BLOCK	 ["ST_PUSH_BLOCK"]
				ST_POP_BLOCK	 ["ST_POP_BLOCK"]
				ST_PUSH_RULE	 ["ST_PUSH_RULE"]
				ST_POP_RULE	 	 ["ST_POP_RULE"]
				ST_CHECK_PENDING ["ST_CHECK_PENDING"]
				ST_DO_ACTION	 ["ST_DO_ACTION"]
				ST_NEXT_INPUT	 ["ST_NEXT_INPUT"]
				ST_NEXT_ACTION	 ["ST_NEXT_ACTION"]
				ST_MATCH		 ["ST_MATCH"]
				ST_MATCH_RULE	 ["ST_MATCH_RULE"]
				ST_FIND_ALTERN	 ["ST_FIND_ALTERN"]
				ST_WORD			 ["ST_WORD"]
				ST_END			 ["ST_END"]
				ST_EXIT			 ["ST_EXIT"]
			]
		]
	]

	advance: func [
		str		[red-string!]
		value	[red-value!]							;-- char! or string! value
		return:	[logic!]
		/local
			end? [logic!]
			type [integer!]
	][
		type: TYPE_OF(value)
		end?: either any [type = TYPE_CHAR type = TYPE_BITSET][
			string/rs-next str
		][
			assert TYPE_OF(value) = TYPE_STRING
			string/rs-skip str string/rs-length? as red-string! value
		]
		end?
	]

	find-altern: func [									;-- search for next '| symbol
		rule	[red-block!]
		pos		[red-value!]
		return: [integer!]								;-- >= 0 found, -1 not found
		/local
			head  [red-value!]
			tail  [red-value!]
			value [red-value!]
			w	  [red-word!]
	][
		s: GET_BUFFER(rule)
		head:  s/offset + ((as-integer pos - s/offset) >> 4)
		tail:  s/tail
		value: head

		while [value < tail][
			if TYPE_OF(value) = TYPE_WORD [
				w: as red-word! value
				if w/symbol = words/pipe [
					return ((as-integer value - head) >> 4)
				]
			]
			value: value + 1
		]
		-1
	]

	adjust-input-index: func [
		input	[red-series!]
		pos		[positions!]
		base    [integer!]
		offset  [integer!]
		return: [logic!]
	][
		input/head: input/head + base + offset
		pos/input: either zero? input/head [0][input/head - base]
		yes
	]

	find-token?: func [									;-- optimized fast token lookup
		rules	[red-block!]							;-- (could be optimized even further)
		input	[red-series!]
		token	[red-value!]
		comp-op	[integer!]
		part	[integer!]
		return: [logic!]
		/local
			pos*   [positions!]
			head   [red-value!]
			tail   [red-value!]
			value  [red-value!]
			char   [red-char!]
			bits   [red-bitset!]
			s	   [series!]
			p	   [byte-ptr!]
			phead  [byte-ptr!]
			ptail  [byte-ptr!]
			pbits  [byte-ptr!]
			pos    [byte-ptr!]							;-- required by BS_TEST_BIT
			p4	   [int-ptr!]
			cp	   [integer!]
			size   [integer!]
			unit   [integer!]
			type   [integer!]
			set?   [logic!]								;-- required by BS_TEST_BIT
			not?   [logic!]
			match? [logic!]
	][
		s: GET_BUFFER(rules)
		pos*: as positions! s/tail - 2
		s: GET_BUFFER(input)

		type: TYPE_OF(input)
		either any [									;TBD: replace with ANY_STRING + TYPE_BINARY
			type = TYPE_STRING
			type = TYPE_FILE
			type = TYPE_URL
			type = TYPE_BINARY
		][
			unit:  GET_UNIT(s)
			phead: (as byte-ptr! s/offset) + (input/head << (unit >> 1))
			ptail: as byte-ptr! s/tail

			if positive? part [
				p: (as byte-ptr! s/offset) + (part << (unit >> 1))
				if p < ptail [ptail: p]
			]
			p: phead

			switch TYPE_OF(token) [
				TYPE_BITSET [
					bits:  as red-bitset! token
					s:	   GET_BUFFER(bits)
					pbits: as byte-ptr! s/offset
					not?:  FLAG_NOT?(s)
					size:  s/size << 3

					until [
						cp: switch unit [
							Latin1 [as-integer p/value]
							UCS-2  [(as-integer p/2) << 8 + p/1]
							UCS-4  [p4: as int-ptr! p p4/value]
						]
						either size < cp [
							match?: not?				;-- virtual bit
						][
							BS_TEST_BIT(pbits cp match?)
						]
						if match? [
							return adjust-input-index input pos* 1 ((as-integer p - phead) >> (unit >> 1))
						]
						p: p + unit
						p = ptail
					]
				]
				TYPE_STRING
				TYPE_FILE
				TYPE_URL
				TYPE_BINARY [
					size: string/rs-length? as red-string! token
					if (string/rs-length? as red-string! input) < size [return no]

					phead: as byte-ptr! s/offset
					unit:  unit >> 1

					until [
						if zero? string/equal? as red-string! input as red-string! token comp-op yes [
							return adjust-input-index input pos* size 0
						]
						input/head: input/head + 1
						phead + (input/head + size << unit) > ptail
					]
				]
				TYPE_CHAR [
					char: as red-char! token
					cp: char/value

					switch unit [
						Latin1 [
							while [p < ptail][
								if p/value = as-byte cp [
									return adjust-input-index input pos* 1 (as-integer p - phead)
								]
								p: p + 1
							]
						]
						UCS-2 [
							while [p < ptail][
								if (as-integer p/2) << 8 + p/1 = cp [
									return adjust-input-index input pos* 1 ((as-integer p - phead) >> 1)
								]
								p: p + 2
							]
						]
						UCS-4 [
							p4: as int-ptr! p
							while [p4 < as int-ptr! ptail][
								if p4/value = cp [
									return adjust-input-index input pos* 1 ((as-integer p4 - phead) >> 2)
								]
								p4: p4 + 1
							]
						]
					]
				]
				default [
					PARSE_ERROR [TO_ERROR(script parse-rule) token]
				]
			]
		][
			head:  s/offset + input/head
			tail:  s/tail
			if positive? part [
				value: s/offset + part
				if value < tail [tail: value]
			]
			value: head

			while [value < tail][
				if actions/compare value token comp-op [
					return adjust-input-index input pos* 1 ((as-integer value - head) >> 4)
				]
				value: value + 1
			]
		]
		no
	]

	loop-bitset: func [									;-- optimized bitset matching loop
		input	[red-series!]
		bits	[red-bitset!]
		min		[integer!]
		max		[integer!]
		counter [int-ptr!]
		part	[integer!]
		return: [logic!]
		/local
			s	   [series!]
			unit   [integer!]
			p	   [byte-ptr!]
			phead  [byte-ptr!]
			ptail  [byte-ptr!]
			pbits  [byte-ptr!]
			pos    [byte-ptr!]							;-- required by BS_TEST_BIT
			p4	   [int-ptr!]
			cp	   [integer!]
			cnt	   [integer!]
			size   [integer!]
			set?   [logic!]								;-- required by BS_TEST_BIT
			not?   [logic!]
			max?   [logic!]
			match? [logic!]
	][
		s:	   GET_BUFFER(input)
		unit:  GET_UNIT(s)
		phead: (as byte-ptr! s/offset) + (input/head << (unit >> 1))
		ptail: as byte-ptr! s/tail

		if positive? part [
			p: (as byte-ptr! s/offset) + (part << (unit >> 1))
			if p < ptail [ptail: p]
		]

		p:	   phead

		s:	   GET_BUFFER(bits)
		pbits: as byte-ptr! s/offset
		not?:  FLAG_NOT?(s)
		size:  s/size << 3

		cnt: 	0
		match?: yes
		max?:	max <> R_NONE

		until [
			cp: switch unit [
				Latin1 [as-integer p/value]
				UCS-2  [(as-integer p/2) << 8 + p/1]
				UCS-4  [p4: as int-ptr! p p4/value]
			]
			either size < cp [							;-- virtual bit
				match?: not?
			][
				BS_TEST_BIT(pbits cp match?)
			]
			if match? [
				p: p + unit
				cnt: cnt + 1
			]
			any [
				not match?
				p = ptail
				all [max? cnt >= max]
			]
		]
		input/head: input/head + ((as-integer p - phead) >> (unit >> 1))
		counter/value: cnt

		either not max? [min <= cnt][all [min <= cnt cnt <= max]]
	]

	loop-token: func [									;-- fast literal matching loop
		input	[red-series!]
		token	[red-value!]
		min		[integer!]
		max		[integer!]
		counter [int-ptr!]
		comp-op	[integer!]
		part	[integer!]
		return: [logic!]
		/local
			len	   [integer!]
			cnt	   [integer!]
			type   [integer!]
			match? [logic!]
			end?   [logic!]
			s	   [series!]
	][
		PARSE_SET_INPUT_LENGTH(len)
		if any [zero? len len < min][return no]			;-- input too short

		cnt: 	0
		match?: yes
		type: 	TYPE_OF(input)

		either any [									;TBD: replace with ANY_STRING
			type = TYPE_STRING
			type = TYPE_FILE
			type = TYPE_URL
		][
			either TYPE_OF(token)= TYPE_BITSET [
				match?: loop-bitset input as red-bitset! token min max counter part
				cnt: counter/value
			][
				until [										;-- ANY-STRING input matching
					match?: string/match? as red-string! input token comp-op
					end?: any [
						all [match? advance as red-string! input token]	;-- consume matched input
						all [positive? part input/head >= part]
					]
					cnt: cnt + 1
					any [
						not match?
						end?
						all [max <> R_NONE cnt >= max]
					]
				]
			]
		][
			until [										;-- ANY-BLOCK input matching
				match?:	actions/compare block/rs-head input token comp-op	;@@ sub-optimal!!
				end?: any [
					all [match? block/rs-next input]	;-- consume matched input
					all [positive? part input/head >= part]
				]
				cnt: cnt + 1
				any [
					not match?
					end?
					all [max <> R_NONE cnt >= max]
				]
			]
		]

		either match? [
			if all [max <> R_NONE any [min > cnt cnt > max]][match?: no]
		][
			cnt: cnt - 1
			match?: either max = R_NONE [min <= cnt][all [min <= cnt cnt <= max]]
		]
		counter/value: cnt
		match?
	]

	fire-event: func [
		fun	  	[red-function!]
		event   [red-word!]
		match? 	[logic!]
		rule	[red-block!]
		input   [red-series!]
		return: [logic!]
		/local
			loop? [logic!]
	][
		stack/mark-func words/_body						;@@ find something more adequate

		stack/push as red-value! event
		logic/push match?
		stack/push as red-value! rule
		stack/push as red-value! input
		stack/push as red-value! rules
		_function/call fun global-ctx					;FIXME: hardcoded origin context

		stack/unwind
		loop?: logic/top-true?
		stack/pop 1
		loop?
	]

	save-stack: func [
		/local
			cnt [integer!]
			p	[positions!]
	][
		cnt: block/rs-length? rules
		unless zero? cnt [
			p: as positions! ALLOC_TAIL(rules)
			p/header: TYPE_POINT
			p/input:  series/head
			p/rule:   rules/head

			series/head: series/head + block/rs-length? series
			rules/head:  rules/head + cnt + 1			;-- account for the new position! slot
		]
	]

	restore-stack: func [
		/local
			s [series!]
			p [positions!]
	][
		if rules/head > 0 [
			s: GET_BUFFER(rules)
			s/tail: s/tail - 1
			p: as positions! s/tail
			series/head: p/input
			rules/head: p/rule
		]
	]

	reset: does [
		block/clear series
		block/clear rules
		restore-stack
	]

	eval: func [code [red-value!]][
		catch RED_ERROR [interpreter/eval as red-block! code no]
		if system/thrown = RED_ERROR [
			reset
			throw RED_ERROR
		]
	]

	process: func [
		input	[red-series!]
		rule	[red-block!]
		comp-op	[integer!]
		;strict? [logic!]
		part	[integer!]
		fun		[red-function!]
		return: [red-value!]
		/local
			new		 [red-series!]
			int		 [red-integer!]
			int2	 [red-integer!]
			blk		 [red-block!]
			sym*	 [red-symbol!]
			cmd		 [red-value!]
			tail	 [red-value!]
			value	 [red-value!]
			base	 [red-value!]
			char	 [red-char!]
			dt		 [red-datatype!]
			w		 [red-word!]
			t 		 [triple!]
			p		 [positions!]
			state	 [states!]
			type	 [integer!]
			sym		 [integer!]
			min		 [integer!]
			max		 [integer!]
			s		 [series!]
			cnt		 [integer!]
			offset	 [integer!]
			upper?	 [logic!]
			end?	 [logic!]
			ended?	 [logic!]
			match?	 [logic!]
			loop?	 [logic!]
			pop?	 [logic!]
			break?	 [logic!]
			rule?	 [logic!]
			collect? [logic!]
			into?	 [logic!]
	][
		match?:	  yes
		end?:	  no
		ended?:   yes
		break?:	  no
		pop?:	  no
		rule?:	  no
		collect?: no
		value:	  null
		type:	  -1
		min:	  -1
		max:	  -1
		cnt:	  0
		state:    ST_NEXT_ACTION

		save-stack
		base: stack/push*								;-- slot on stack for COPY/SET operations (until OPTION?() is fixed)
		input: as red-series! block/rs-append series as red-value! input	;-- input now points to the series stack entry

		cmd: (block/rs-head rule) - 1					;-- decrement to compensate for starting increment
		tail: block/rs-tail rule						;TBD: protect current rule block from changes

		until [
			#if debug? = yes [if verbose > 1 [print-state state]]

			switch state [
				ST_PUSH_BLOCK [
					none/make-in rules
					PARSE_PUSH_POSITIONS
					block/rs-append rules as red-value! rule
					if all [value <> null value <> rule][
						assert TYPE_OF(value) = TYPE_BLOCK
						copy-cell value as red-value! rule
					]
					cmd: (block/rs-head rule) - 1		;-- decrement to compensate for starting increment
					tail: block/rs-tail rule			;TBD: protect current rule block from changes

					PARSE_CHECK_INPUT_EMPTY?			;-- refresh end? flag
					PARSE_TRACE(_push)
					state: ST_NEXT_ACTION
				]
				ST_POP_BLOCK [
					either zero? block/rs-length? rules [
						state: ST_END
					][
						loop?: no
						ended?: cmd = tail

						s: GET_BUFFER(rules)
						copy-cell s/tail - 1 as red-value! rule
						assert TYPE_OF(rule) = TYPE_BLOCK
						p: as positions! s/tail - 2

						cmd: (block/rs-head rule) + p/rule
						tail: block/rs-tail rule
						PARSE_TRACE(_pop)
						s/tail: s/tail - 3
						value: s/tail - 1

						state: either all [
							0 < block/rs-length? rules
							TYPE_OF(value) = TYPE_INTEGER
						][
							ST_POP_RULE
						][
							either match? [ST_NEXT_ACTION][ST_FIND_ALTERN]
						]
					]
				]
				ST_PUSH_RULE [
					either any [type = R_COPY type = R_SET][
						block/rs-append rules cmd
					][
						t: as triple! ALLOC_TAIL(rules)
						t/header: TYPE_POINT
						t/min:	  min
						t/max:	  max
						t/state:  1
					]
					PARSE_PUSH_POSITIONS
					int: as red-integer! ALLOC_TAIL(rules)
					int/header: TYPE_INTEGER
					int/value: type
					if cmd < tail [cmd: cmd + 1]		;-- move after the rule prologue
					value: cmd
					PARSE_TRACE(_push)
					state: ST_MATCH_RULE
				]
				ST_POP_RULE [
					s: GET_BUFFER(rules)
					value: s/tail - 1

					either any [
						s/offset + rules/head = s/tail	;-- rules stack empty already
						TYPE_OF(value) = TYPE_BLOCK
					][
						state: either pop? [pop?: no ST_POP_BLOCK][ST_NEXT_ACTION]
					][
						pop?: yes
						p: as positions! s/tail - 2
						int: as red-integer! value
						switch int/value [
							R_WHILE
							R_NONE [					;-- iterative rules (ANY, SOME, WHILE, ...)
								t: as triple! s/tail - 3
								cnt: t/state
								;-- Find out if a new loop is required
								loop?: match?
								if all [match? t/max <> R_NONE][ ;-- if rule matched and an upper bound exists,
									loop?: cnt < t/max			 ;-- but not reached yet, loop again
								]
								if any [						 ;-- don't loop if any:
									break?						 ;-- a BREAK or REJECT command was issued
									all [						 ;-- try to avoid some infinite loops
										int/value <> R_WHILE
										input/head = p/input	 ;-- if no input was consumed (except for WHILE)
									]
									all [end? int/value = R_WHILE] ;-- don't loop on WHILE if no more input
								][
									loop?: no
									break?: no
								]
								if loop? [
									;-- Reset state for a new loop
									t/state: cnt + 1
									cmd: (block/rs-head rule) + p/rule ;-- reset rule offset
									PARSE_TRACE(_iterate)
									state: ST_NEXT_ACTION
									pop?: no
								]
								;-- Postprocess match? value
								either match? [
									if all [not loop? cnt < t/min][match?: no]	;-- minimal number of iteration not reached
								][
									if any [				;-- last loop failed case
										t/min <= (cnt - 1)	;-- number of iteration more than lower bound
										zero? t/min			;-- or lower bound is zero (ANY, OPT, WHILE)
									][
										match?: yes			;-- make the last loop return success
									]
								]
							]
							R_TO
							R_THRU [
								either match? [
									if int/value = R_TO [
										input/head: p/input	;-- move input before the last match
										end?: no
									]
								][
									type: TYPE_OF(input)
									end?: either any [	;TBD: replace with ANY_STRING?
										type = TYPE_STRING
										type = TYPE_FILE
										type = TYPE_URL
									][
										string/rs-next as red-string! input
									][
										block/rs-next input
									]
									if positive? part [end?: input/head >= part or end?]

									either end? [
										w: as red-word! (block/rs-head rule) + p/rule + 1 ;-- TO/THRU argument
										match?: all [
											TYPE_OF(w) = TYPE_WORD
											words/end = symbol/resolve w/symbol
										]
									][
										p/input: input/head	;-- refresh saved input head before new iteration
										cmd: (block/rs-head rule) + p/rule ;-- loop rule
										PARSE_TRACE(_iterate)
										state: ST_NEXT_ACTION
										pop?: no
									]
								]
							]
							R_COPY [
								if match? [
									PARSE_COPY_INPUT(p)
									_context/set as red-word! s/tail - 3 as red-value! new
								]
							]
							R_SET [
								if match? [
									PARSE_PICK_INPUT
									_context/set as red-word! p - 1 value
								]
							]
							R_KEEP
							R_KEEP_PAREN [
								if all [
									match?
									any [int/value = R_KEEP_PAREN  p/input < input/head]
								][
									blk: as red-block! stack/top - 1
									assert any [
										TYPE_OF(blk) = TYPE_WORD
										TYPE_OF(blk) = TYPE_GET_WORD
										TYPE_OF(blk) = TYPE_BLOCK
									]
									into?: TYPE_OF(blk) = TYPE_GET_WORD
									if into? [blk: as red-block! _context/get as red-word! blk]

									value: stack/top	;-- refer last value from paren expression
									if int/value = R_KEEP [
										w: as red-word! s/tail
										case [
											p/sub = R_COPY [			;-- KEEP COPY case
												value: _context/get w
											]
											p/input + 1 < input/head [	;-- KEEP with matched size > 1
												PARSE_COPY_INPUT(value)
											]
											true [
												PARSE_PICK_INPUT		;-- KEEP with matched size = 1
											]
										]
									]
									either into? [
										either any [					;@@ replace with ANY_STRING?
											TYPE_OF(blk) = TYPE_STRING
											TYPE_OF(blk) = TYPE_FILE
											TYPE_OF(blk) = TYPE_URL
										][
											string/insert as red-string! blk value null yes null no
										][
											block/insert blk value null yes null no
										]
									][
										block/rs-append blk value
									]
								]
							]
							R_REMOVE [
								if match? [
									int/value: input/head - p/input
									input/head: p/input
									assert int/value >= 0
									copy-cell as red-value! int base	;@@ remove once OPTION? fixed
									actions/remove input base
								]
							]
							R_AHEAD [
								input/head: p/input
								PARSE_CHECK_INPUT_EMPTY? ;-- refresh end? flag after backtracking
							]
							R_NOT [
								match?: not match?
							]
							R_COLLECT [
								value: stack/top - 1

								either stack/top - 2 = base [	;-- root unnamed block reached
									collect?: TYPE_OF(value) = TYPE_BLOCK
								][
									if TYPE_OF(value) = TYPE_BLOCK [
										blk: as red-block! stack/top - 2
										collect?: no

										switch TYPE_OF(blk) [
											TYPE_WORD [
												_context/set as red-word! blk value
												stack/pop 1
											]
											TYPE_GET_WORD [
												blk: as red-block! _context/get as red-word! blk
												block/insert-value blk value
											]
											default [
												assert TYPE_OF(blk) = TYPE_BLOCK
												block/rs-append blk value
												collect?: yes
											]
										]
									]
									stack/pop 1
								]
								if TYPE_OF(value) = TYPE_GET_WORD [	;-- COLLECT INTO exiting
									t: as triple! s/tail - 3
									unless t/max = -1 [
										blk: as red-block! _context/get as red-word! value
										blk/head: t/max	;-- restore saved block cursor
									]
								]
							]
							R_INTO [
								s: GET_BUFFER(series)
								s/tail: s/tail - 1
								input: as red-series! s/tail - 1
								unless ended? [match?: no]
								if match? [input/head: input/head + 1]	;-- skip parsed series

								PARSE_CHECK_INPUT_EMPTY? ;-- refresh end? flag after popping series
								s: GET_BUFFER(rules)
							]
							R_THEN [
								PARSE_TRACE(_pop)
								s/tail: s/tail - 3		;-- pop rule stack frame
								state: either match? [cmd: tail ST_NEXT_ACTION][ST_FIND_ALTERN]
								pop?: no
							]
						]
						if pop? [
							PARSE_TRACE(_pop)
							s/tail: s/tail - 3			;-- pop rule stack frame
							if s/tail > s/offset [
								p: as positions! s/tail - 2
								p/sub: int/value		;-- save rule type in parent stack frame
							]
							state: ST_CHECK_PENDING
						]
					]
					pop?: no
				]
				ST_CHECK_PENDING [
					s: GET_BUFFER(rules)
					value: s/tail - 1

					state: either any [					;-- order of conditional expressions matters!
						zero? block/rs-length? rules
						TYPE_OF(value) <> TYPE_INTEGER
					][
						either match? [ST_NEXT_ACTION][ST_FIND_ALTERN]
					][
						ST_POP_RULE
					]
				]
				ST_DO_ACTION [
					type: TYPE_OF(value)				;-- value is used in this state instead of cmd
					switch type [						;-- allows to enter the state with cmd or :cmd (if word!)
						TYPE_WORD 	[
							if all [value <> cmd TYPE_OF(cmd) = TYPE_WORD][
								PARSE_ERROR [TO_ERROR(script parse-rule) value]
							]
							state: ST_WORD
						]
						TYPE_BLOCK 	[
							state: ST_PUSH_BLOCK
						]
						TYPE_DATATYPE [
							dt: as red-datatype! value
							value: block/rs-head input
							match?: TYPE_OF(value) = dt/value
							PARSE_TRACE(_match)
							state: either match? [ST_NEXT_INPUT][ST_CHECK_PENDING]
						]
						TYPE_SET_WORD [
							_context/set as red-word! value as red-value! input
							state: ST_NEXT_ACTION
						]
						TYPE_GET_WORD [
							new: as red-series! _context/get as red-word! value
							either all [
								TYPE_OF(new) = TYPE_OF(input)
								new/node = input/node
							][
								input/head: new/head
								state: ST_NEXT_ACTION
							][
								PARSE_ERROR [TO_ERROR(script parse-invalid-ref) value]
							]
						]
						TYPE_INTEGER [
							int:  as red-integer! value
							int2: as red-integer! cmd + 1
							if all [
								int2 < tail
								TYPE_OF(int2) = TYPE_WORD
							][
								int2: as red-integer! _context/get as red-word! cmd + 1
							]
							upper?: TYPE_OF(int2) = TYPE_INTEGER
							if any [
								int2 = tail
								all [upper?	int2 + 1 = tail]
								all [upper? int/value > int2/value]
							][
								PARSE_ERROR [TO_ERROR(script parse-rule) value]
							]
							state: either all [zero? int/value not upper?][
								cmd: cmd + 1			;-- skip over sub-rule
								ST_CHECK_PENDING
							][
								min:  int/value
								max:  either upper? [cmd: cmd + 1 int2/value][min]
								type: R_NONE
								ST_PUSH_RULE
							]
						]
						TYPE_PAREN [
							offset: (as-integer cmd - block/rs-head rule) >> 4	;-- save rule position
							eval value
							stack/pop 1
							PARSE_TRACE(_paren)
							cmd: (block/rs-head rule) + offset	;-- refresh rule pointers,
							tail: block/rs-tail rule			;-- in case the block was changed
							if cmd >= tail [cmd: tail - 1]	;-- avoid a "past end" state
							state: ST_CHECK_PENDING
						]
						default [						;-- try to match a literal value
							state: ST_MATCH
						]
					]
				]
				ST_NEXT_INPUT [
					type: TYPE_OF(input)
					end?: either any [					;TBD: replace with ANY_STRING
						type = TYPE_STRING
						type = TYPE_FILE
						type = TYPE_URL
					][
						string/rs-next as red-string! input
					][
						block/rs-next input
					]
					if positive? part [end?: input/head >= part or end?]
					state: ST_CHECK_PENDING
				]
				ST_NEXT_ACTION [
					if cmd < tail [cmd: cmd + 1]

					state: either cmd = tail [
						ST_POP_BLOCK
					][
						PARSE_TRACE(_fetch)
						value: cmd
						ST_DO_ACTION
					]
				]
				ST_MATCH [
					type: TYPE_OF(input)
					either end? [
						match?: all [
							any [
								type = TYPE_STRING
								type = TYPE_FILE
								type = TYPE_URL
							]
							any [
								TYPE_OF(value) = TYPE_STRING
								TYPE_OF(value) = TYPE_FILE
								TYPE_OF(value) = TYPE_URL
							]
							zero? string/rs-length? as red-string! value
						]
					][
						end?: either any [				;TBD: replace with ANY_STRING?
							type = TYPE_STRING
							type = TYPE_FILE
							type = TYPE_URL
						][
							match?: either TYPE_OF(value) = TYPE_BITSET [
								string/match-bitset? as red-string! input as red-bitset! value
							][
								string/match? as red-string! input value comp-op
							]
							all [match? advance as red-string! input value]	;-- consume matched input
						][
							match?: actions/compare block/rs-head input value comp-op
							all [match? block/rs-next input]				;-- consume matched input
						]
						if positive? part [end?: input/head >= part or end?]
					]
					PARSE_TRACE(_match)
					state: ST_CHECK_PENDING
				]
				ST_MATCH_RULE [
					either all [value = tail][
						w: switch type [
							R_TO		 [words/_to]
							R_THRU		 [words/_thru]
							R_NOT		 [words/_not]
							R_THEN		 [words/_then]
							R_REMOVE	 [words/_remove]
							R_WHILE		 [words/_while]
							R_COLLECT	 [words/_collect]
							R_KEEP		 [words/_keep]
							R_KEEP_PAREN [words/_keep]
							R_AHEAD		 [words/_ahead]
							default		 [null]
						]
						if w <> null [PARSE_ERROR [TO_ERROR(script parse-end) w]]
						match?: yes
						state: ST_CHECK_PENDING
					][
						switch TYPE_OF(value) [
							TYPE_BLOCK	 [state: ST_PUSH_BLOCK]
							TYPE_WORD	 [state: ST_WORD rule?: all [type <> R_COLLECT type <> R_KEEP]]
							TYPE_DATATYPE
							TYPE_SET_WORD
							TYPE_GET_WORD
							TYPE_INTEGER [state: ST_DO_ACTION]
							default [
								either min = R_NONE [
									state: either any [type = R_TO type = R_THRU][
										match?: find-token? rules input value comp-op part
										PARSE_TRACE(_match)
										ST_POP_RULE
									][
										ST_DO_ACTION
									]
								][
									match?: loop-token input value min max :cnt comp-op part
									if all [not match? zero? min][match?: yes]
									PARSE_TRACE(_match)
									s: GET_BUFFER(rules)
									PARSE_TRACE(_pop)
									s/tail: s/tail - 3		;-- pop rule stack frame
									state: ST_CHECK_PENDING
								]
								PARSE_CHECK_INPUT_EMPTY?
							]
						]
					]
				]
				ST_FIND_ALTERN [
					s: GET_BUFFER(rules)				;-- backtrack input
					p: as positions! s/tail - 2
					input/head: p/input
					PARSE_CHECK_INPUT_EMPTY?			;-- refresh end? flag after backtracking

					cnt: find-altern rule cmd

					state: either cnt >= 0 [
						cmd: cmd + cnt					;-- point rule head to alternative part
						match?: yes						;-- reset match? flag
						ST_NEXT_ACTION
					][
						ST_POP_BLOCK
					]
				]
				ST_WORD [
					w: as red-word! cmd
					sym: symbol/resolve w/symbol
					#if debug? = yes [
						sym*: symbol/get sym
						if verbose > 0 [print-line ["parse: " sym*/cache]]
					]
					case [
						sym = words/pipe [				;-- |
							if cmd = tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_pipe]]
							cmd: tail
							state: ST_POP_BLOCK
						]
						sym = words/skip [				;-- SKIP
							PARSE_CHECK_INPUT_EMPTY?
							match?: not end?
							PARSE_TRACE(_match)
							state: ST_NEXT_INPUT
						]
						sym = words/any* [				;-- ANY
							if cmd + 1 = tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_any]]
							min:   0
							max:   R_NONE
							type:  R_NONE
							state: ST_PUSH_RULE
						]
						sym = words/some [				;-- SOME
							if cmd + 1 = tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_some]]
							min:   1
							max:   R_NONE
							type:  R_NONE
							state: ST_PUSH_RULE
						]
						sym = words/copy [				;-- COPY
							cmd: cmd + 1
							if any [cmd = tail TYPE_OF(cmd) <> TYPE_WORD][
								PARSE_ERROR [TO_ERROR(script parse-end) words/_copy]
							]
							min:   R_NONE
							type:  R_COPY
							state: ST_PUSH_RULE
						]
						sym = words/thru [				;-- THRU
							min:   R_NONE
							type:  R_THRU
							state: ST_PUSH_RULE
						]
						sym = words/to [				;-- TO
							min:   R_NONE
							type:  R_TO
							state: ST_PUSH_RULE
						]
						sym = words/remove [			;-- REMOVE
							min:   R_NONE
							type:  R_REMOVE
							state: ST_PUSH_RULE
						]
						sym = words/break* [			;-- BREAK
							match?: yes
							break?: yes
							cmd:	cmd + 1
							pop?:	yes
							PARSE_TRACE(_match)
							state:	ST_POP_RULE
						]
						sym = words/opt [				;-- OPT
							if cmd + 1 = tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_opt]]
							min:   0
							max:   1
							type:  R_NONE
							state: ST_PUSH_RULE
						]
						sym = words/keep [				;-- KEEP
							value: cmd + 1
							min:   R_NONE
							type:  either TYPE_OF(value) = TYPE_PAREN [R_KEEP_PAREN][R_KEEP]
							state: ST_PUSH_RULE
						]
						sym = words/fail [				;-- FAIL
							match?: no
							PARSE_TRACE(_match)
							state: ST_FIND_ALTERN
						]
						sym = words/ahead [				;-- AHEAD
							min:   R_NONE
							type:  R_AHEAD
							state: ST_PUSH_RULE
						]
						sym = words/while* [			;-- WHILE
							min:   0
							max:   R_NONE
							type:  R_WHILE
							state: ST_PUSH_RULE
						]
						sym = words/into [				;-- INTO
							if TYPE_OF(input) <> TYPE_BLOCK [
								PARSE_ERROR [TO_ERROR(script parse-series) input]
							]
							value: cmd + 1
							if value = tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_into]]

							if TYPE_OF(value) = TYPE_WORD [
								value: _context/get as red-word! value
							]
							if TYPE_OF(value) <> TYPE_BLOCK [
								PARSE_ERROR [TO_ERROR(script parse-end) words/_into]
							]
							value: block/rs-head input
							type: TYPE_OF(value)
							either ANY_SERIES?(type) [
								input: as red-series! block/rs-append series as red-value! block/rs-head input
								min:  R_NONE
								type: R_INTO
								state: ST_PUSH_RULE
							][
								match?: no
								PARSE_TRACE(_match)
								state: ST_CHECK_PENDING
							]
						]
						sym = words/insert [			;-- INSERT
							w: as red-word! cmd + 1
							max: as-integer all [
								(as red-value! w) < tail
								TYPE_OF(w) = TYPE_WORD
								words/only = symbol/resolve w/symbol
							]
							cmd: cmd + max + 1
							if cmd >= tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_insert]]

							value: cmd
							if TYPE_OF(value) = TYPE_PAREN [
								eval value
								value: stack/top - 1
								PARSE_TRACE(_paren)
							]
							actions/insert input value null max = 1 null no
							if TYPE_OF(value) = TYPE_PAREN [stack/pop 1]
							state: ST_NEXT_ACTION
						]
						sym = words/end [				;-- END
							PARSE_CHECK_INPUT_EMPTY?
							match?: end?
							PARSE_TRACE(_match)
							state: ST_CHECK_PENDING
						]
						sym = words/then [				;-- THEN
							min:   R_NONE
							type:  R_THEN
							state: ST_PUSH_RULE
						]
						sym = words/if* [				;-- IF
							cmd: cmd + 1
							if any [cmd = tail TYPE_OF(cmd) <> TYPE_PAREN][
								PARSE_ERROR [TO_ERROR(script parse-end) words/_if]
							]
							eval cmd
							match?: logic/top-true?
							stack/pop 1
							PARSE_TRACE(_match)
							state: ST_CHECK_PENDING
						]
						sym = words/not* [				;-- NOT
							min:   R_NONE
							type:  R_NOT
							state: ST_PUSH_RULE
						]
						sym = words/quote [				;-- QUOTE
							cmd: cmd + 1
							if cmd = tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_quote]]
							value: cmd
							state: ST_MATCH
						]
						sym = words/collect [			;-- COLLECT
							max: R_NONE
							into?: no
							w: as red-word! cmd + 1

							if all [
								(as red-value! w) < tail
								TYPE_OF(w) = TYPE_WORD
							][
								sym: symbol/resolve w/symbol
								into?: any [sym = words/into sym = words/after]

								if any [into? sym = words/set][
									w: w + 1
									if any [
										w >= tail
										TYPE_OF(w) <> TYPE_WORD
									][
										PARSE_ERROR [TO_ERROR(script parse-end) words/_collect]
									]
									either into? [get-word/push w][stack/push as red-value! w]
									cmd: as red-value! w
								]
							]
							either into? [
								blk: as red-block! _context/get w
								max: either sym = words/after [-1][blk/head] ;-- save block cursor
							][
								block/push* 8
							]
							min:   R_NONE
							type:  R_COLLECT
							state: ST_PUSH_RULE
						]
						sym = words/reject [			;-- REJECT
							match?: no
							break?: yes
							pop?:	yes
							PARSE_TRACE(_match)
							state:	ST_POP_RULE
						]
						sym = words/set [				;-- SET
							cmd: cmd + 1
							if any [cmd = tail TYPE_OF(cmd) <> TYPE_WORD][
								PARSE_ERROR [TO_ERROR(script parse-end) words/_set]
							]
							min:   R_NONE
							type:  R_SET
							state: ST_PUSH_RULE
						]
						sym = words/none [				;-- NONE
							match?: yes
							PARSE_TRACE(_match)
							state: ST_CHECK_PENDING
						]
						true [
							value: _context/get w
							state: either rule? [ST_MATCH_RULE][ST_DO_ACTION] ;-- enable fast loops for word argument
						]
					]
					rule?: no
				]
				ST_END [
					if match? [match?: cmd = tail]

					PARSE_SET_INPUT_LENGTH(cnt)
					if positive? part [cnt: part - input/head]
					if all [
						cnt > 0
						1 = block/rs-length? series
					][
						match?: no
					]
					PARSE_TRACE(_end)
					state: ST_EXIT
				]
			]
			state = ST_EXIT
		]

		block/clear series
		block/clear rules
		restore-stack

		either collect? [
			base + 1
		][
			as red-value! logic/push match?
		]
	]

	init: does [
		series: block/make-in root 8
		rules:  block/make-in root 100
	]
]

Red/System [
	Title:   "PARSE dialect interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %parse.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

parser: context [
	verbose: 0

	series: as red-block! 0
	rules:  as red-block! 0

	#define PARSE_PUSH_POSITIONS [
		p: as positions! ALLOC_TAIL(rules)
		p/header: TYPE_POINT
		p/rule:	  (as-integer cmd - block/rs-head rule) >> 4	;-- save cmd position
		p/input:  input/head									;-- save input position
		p/sub:	  0												;-- default value for sub-rule type
	]

	#define PARSE_SET_INPUT_LENGTH(word) [
		type: TYPE_OF(input)
		word: either any [								;TBD: replace with ANY_STRING?
			type = TYPE_STRING
			type = TYPE_FILE
			type = TYPE_URL
		][
			string/rs-length? as red-string! input
		][
			block/rs-length? input
		]
	]

	#define PARSE_CHECK_INPUT_EMPTY? [
		type: TYPE_OF(input)
		end?: either any [								;TBD: replace with ANY_STRING?
			type = TYPE_STRING
			type = TYPE_FILE
			type = TYPE_URL
		][
			any [
				string/rs-tail? as red-string! input
				all [positive? part input/head >= part]
			]
		][
			block/rs-tail? input
		]
		if positive? part [end?: input/head >= part or end?]
	]

	#define PARSE_COPY_INPUT(slot) [
		min: p/input
		new: as red-series! slot
		copy-cell as red-value! input as red-value! new
		copy-cell as red-value! input base				;@@ remove once OPTION? fixed
		new/head: min
		actions/copy new as red-value! new base no null
	]

	#define PARSE_PICK_INPUT [
		value: base
		type: TYPE_OF(input)
		either any [									;TBD: replace with ANY_STRING
			type = TYPE_STRING
			type = TYPE_FILE
			type = TYPE_URL
		][
			char: as red-char! base
			char/header: TYPE_CHAR
			char/value: string/rs-abs-at as red-string! input p/input
		][
			value: block/rs-abs-at input p/input
		]
	]

	#define PARSE_TRACE(event) [
		#if red-tracing? = yes [
			if OPTION?(fun) [
				rule/head: (as-integer cmd - block/rs-head rule) >> 4
				if negative? rule/head [rule/head: 0]
				unless fire-event fun words/event match? rule input [
					return as red-value! logic/push match?
				]
			]
		]
	]

	#define PARSE_ERROR [reset fire]

	#enum states! [
		ST_PUSH_BLOCK
		ST_POP_BLOCK
		ST_PUSH_RULE
		ST_POP_RULE
		ST_CHECK_PENDING
		ST_DO_ACTION
		ST_NEXT_INPUT
		ST_NEXT_ACTION
		ST_MATCH
		ST_MATCH_RULE
		ST_FIND_ALTERN
		ST_WORD
		ST_END
		ST_EXIT
	]

	#enum rule-flags! [									;-- negative values to not collide with t/state counter
		R_NONE:		  -1
		R_TO:		  -2
		R_THRU:		  -3
		R_COPY:		  -4
		R_SET:		  -5
		R_NOT:		  -6
		R_INTO:		  -7
		R_THEN:		  -8
		R_REMOVE:	  -9
		R_INSERT:	  -10
		R_WHILE:	  -11
		R_COLLECT:	  -12
		R_KEEP:		  -13
		R_KEEP_PAREN: -14
		R_AHEAD:	  -15
	]

	triple!: alias struct! [
		header [integer!]
		min	   [integer!]
		max	   [integer!]
		state  [integer!]
	]

	positions!: alias struct! [
		header [integer!]
		rule   [integer!]
		input  [integer!]
		sub    [integer!]
	]

	#if debug? = yes [
		print-state: func [s [states!]][
			print "state: "
			print-line switch s [
				ST_PUSH_BLOCK	 ["ST_PUSH_BLOCK"]
				ST_POP_BLOCK	 ["ST_POP_BLOCK"]
				ST_PUSH_RULE	 ["ST_PUSH_RULE"]
				ST_POP_RULE	 	 ["ST_POP_RULE"]
				ST_CHECK_PENDING ["ST_CHECK_PENDING"]
				ST_DO_ACTION	 ["ST_DO_ACTION"]
				ST_NEXT_INPUT	 ["ST_NEXT_INPUT"]
				ST_NEXT_ACTION	 ["ST_NEXT_ACTION"]
				ST_MATCH		 ["ST_MATCH"]
				ST_MATCH_RULE	 ["ST_MATCH_RULE"]
				ST_FIND_ALTERN	 ["ST_FIND_ALTERN"]
				ST_WORD			 ["ST_WORD"]
				ST_END			 ["ST_END"]
				ST_EXIT			 ["ST_EXIT"]
			]
		]
	]

	advance: func [
		str		[red-string!]
		value	[red-value!]							;-- char! or string! value
		return:	[logic!]
		/local
			end? [logic!]
			type [integer!]
	][
		type: TYPE_OF(value)
		end?: either any [type = TYPE_CHAR type = TYPE_BITSET][
			string/rs-next str
		][
			assert TYPE_OF(value) = TYPE_STRING
			string/rs-skip str string/rs-length? as red-string! value
		]
		end?
	]

	find-altern: func [									;-- search for next '| symbol
		rule	[red-block!]
		pos		[red-value!]
		return: [integer!]								;-- >= 0 found, -1 not found
		/local
			head  [red-value!]
			tail  [red-value!]
			value [red-value!]
			w	  [red-word!]
	][
		s: GET_BUFFER(rule)
		head:  s/offset + ((as-integer pos - s/offset) >> 4)
		tail:  s/tail
		value: head

		while [value < tail][
			if TYPE_OF(value) = TYPE_WORD [
				w: as red-word! value
				if w/symbol = words/pipe [
					return ((as-integer value - head) >> 4)
				]
			]
			value: value + 1
		]
		-1
	]

	adjust-input-index: func [
		input	[red-series!]
		pos		[positions!]
		base    [integer!]
		offset  [integer!]
		return: [logic!]
	][
		input/head: input/head + base + offset
		pos/input: either zero? input/head [0][input/head - base]
		yes
	]

	find-token?: func [									;-- optimized fast token lookup
		rules	[red-block!]							;-- (could be optimized even further)
		input	[red-series!]
		token	[red-value!]
		comp-op	[integer!]
		part	[integer!]
		return: [logic!]
		/local
			pos*   [positions!]
			head   [red-value!]
			tail   [red-value!]
			value  [red-value!]
			char   [red-char!]
			bits   [red-bitset!]
			s	   [series!]
			p	   [byte-ptr!]
			phead  [byte-ptr!]
			ptail  [byte-ptr!]
			pbits  [byte-ptr!]
			pos    [byte-ptr!]							;-- required by BS_TEST_BIT
			p4	   [int-ptr!]
			cp	   [integer!]
			size   [integer!]
			unit   [integer!]
			type   [integer!]
			set?   [logic!]								;-- required by BS_TEST_BIT
			not?   [logic!]
			match? [logic!]
	][
		s: GET_BUFFER(rules)
		pos*: as positions! s/tail - 2
		s: GET_BUFFER(input)

		type: TYPE_OF(input)
		either any [									;TBD: replace with ANY_STRING + TYPE_BINARY
			type = TYPE_STRING
			type = TYPE_FILE
			type = TYPE_URL
			type = TYPE_BINARY
		][
			unit:  GET_UNIT(s)
			phead: (as byte-ptr! s/offset) + (input/head << (unit >> 1))
			ptail: as byte-ptr! s/tail

			if positive? part [
				p: (as byte-ptr! s/offset) + (part << (unit >> 1))
				if p < ptail [ptail: p]
			]
			p: phead

			switch TYPE_OF(token) [
				TYPE_BITSET [
					bits:  as red-bitset! token
					s:	   GET_BUFFER(bits)
					pbits: as byte-ptr! s/offset
					not?:  FLAG_NOT?(s)
					size:  s/size << 3

					until [
						cp: switch unit [
							Latin1 [as-integer p/value]
							UCS-2  [(as-integer p/2) << 8 + p/1]
							UCS-4  [p4: as int-ptr! p p4/value]
						]
						either size < cp [
							match?: not?				;-- virtual bit
						][
							BS_TEST_BIT(pbits cp match?)
						]
						if match? [
							return adjust-input-index input pos* 1 ((as-integer p - phead) >> (unit >> 1))
						]
						p: p + unit
						p = ptail
					]
				]
				TYPE_STRING
				TYPE_FILE
				TYPE_URL
				TYPE_BINARY [
					size: string/rs-length? as red-string! token
					if (string/rs-length? as red-string! input) < size [return no]

					phead: as byte-ptr! s/offset
					unit:  unit >> 1

					until [
						if zero? string/equal? as red-string! input as red-string! token comp-op yes [
							return adjust-input-index input pos* size 0
						]
						input/head: input/head + 1
						phead + (input/head + size << unit) > ptail
					]
				]
				TYPE_CHAR [
					char: as red-char! token
					cp: char/value

					switch unit [
						Latin1 [
							while [p < ptail][
								if p/value = as-byte cp [
									return adjust-input-index input pos* 1 (as-integer p - phead)
								]
								p: p + 1
							]
						]
						UCS-2 [
							while [p < ptail][
								if (as-integer p/2) << 8 + p/1 = cp [
									return adjust-input-index input pos* 1 ((as-integer p - phead) >> 1)
								]
								p: p + 2
							]
						]
						UCS-4 [
							p4: as int-ptr! p
							while [p4 < as int-ptr! ptail][
								if p4/value = cp [
									return adjust-input-index input pos* 1 ((as-integer p4 - phead) >> 2)
								]
								p4: p4 + 1
							]
						]
					]
				]
				default [
					PARSE_ERROR [TO_ERROR(script parse-rule) token]
				]
			]
		][
			head:  s/offset + input/head
			tail:  s/tail
			if positive? part [
				value: s/offset + part
				if value < tail [tail: value]
			]
			value: head

			while [value < tail][
				if actions/compare value token comp-op [
					return adjust-input-index input pos* 1 ((as-integer value - head) >> 4)
				]
				value: value + 1
			]
		]
		no
	]

	loop-bitset: func [									;-- optimized bitset matching loop
		input	[red-series!]
		bits	[red-bitset!]
		min		[integer!]
		max		[integer!]
		counter [int-ptr!]
		part	[integer!]
		return: [logic!]
		/local
			s	   [series!]
			unit   [integer!]
			p	   [byte-ptr!]
			phead  [byte-ptr!]
			ptail  [byte-ptr!]
			pbits  [byte-ptr!]
			pos    [byte-ptr!]							;-- required by BS_TEST_BIT
			p4	   [int-ptr!]
			cp	   [integer!]
			cnt	   [integer!]
			size   [integer!]
			set?   [logic!]								;-- required by BS_TEST_BIT
			not?   [logic!]
			max?   [logic!]
			match? [logic!]
	][
		s:	   GET_BUFFER(input)
		unit:  GET_UNIT(s)
		phead: (as byte-ptr! s/offset) + (input/head << (unit >> 1))
		ptail: as byte-ptr! s/tail

		if positive? part [
			p: (as byte-ptr! s/offset) + (part << (unit >> 1))
			if p < ptail [ptail: p]
		]

		p:	   phead

		s:	   GET_BUFFER(bits)
		pbits: as byte-ptr! s/offset
		not?:  FLAG_NOT?(s)
		size:  s/size << 3

		cnt: 	0
		match?: yes
		max?:	max <> R_NONE

		until [
			cp: switch unit [
				Latin1 [as-integer p/value]
				UCS-2  [(as-integer p/2) << 8 + p/1]
				UCS-4  [p4: as int-ptr! p p4/value]
			]
			either size < cp [							;-- virtual bit
				match?: not?
			][
				BS_TEST_BIT(pbits cp match?)
			]
			if match? [
				p: p + unit
				cnt: cnt + 1
			]
			any [
				not match?
				p = ptail
				all [max? cnt >= max]
			]
		]
		input/head: input/head + ((as-integer p - phead) >> (unit >> 1))
		counter/value: cnt

		either not max? [min <= cnt][all [min <= cnt cnt <= max]]
	]

	loop-token: func [									;-- fast literal matching loop
		input	[red-series!]
		token	[red-value!]
		min		[integer!]
		max		[integer!]
		counter [int-ptr!]
		comp-op	[integer!]
		part	[integer!]
		return: [logic!]
		/local
			len	   [integer!]
			cnt	   [integer!]
			type   [integer!]
			match? [logic!]
			end?   [logic!]
			s	   [series!]
	][
		PARSE_SET_INPUT_LENGTH(len)
		if any [zero? len len < min][return no]			;-- input too short

		cnt: 	0
		match?: yes
		type: 	TYPE_OF(input)

		either any [									;TBD: replace with ANY_STRING
			type = TYPE_STRING
			type = TYPE_FILE
			type = TYPE_URL
		][
			either TYPE_OF(token)= TYPE_BITSET [
				match?: loop-bitset input as red-bitset! token min max counter part
				cnt: counter/value
			][
				until [										;-- ANY-STRING input matching
					match?: string/match? as red-string! input token comp-op
					end?: any [
						all [match? advance as red-string! input token]	;-- consume matched input
						all [positive? part input/head >= part]
					]
					cnt: cnt + 1
					any [
						not match?
						end?
						all [max <> R_NONE cnt >= max]
					]
				]
			]
		][
			until [										;-- ANY-BLOCK input matching
				match?:	actions/compare block/rs-head input token comp-op	;@@ sub-optimal!!
				end?: any [
					all [match? block/rs-next input]	;-- consume matched input
					all [positive? part input/head >= part]
				]
				cnt: cnt + 1
				any [
					not match?
					end?
					all [max <> R_NONE cnt >= max]
				]
			]
		]

		either match? [
			if all [max <> R_NONE any [min > cnt cnt > max]][match?: no]
		][
			cnt: cnt - 1
			match?: either max = R_NONE [min <= cnt][all [min <= cnt cnt <= max]]
		]
		counter/value: cnt
		match?
	]

	fire-event: func [
		fun	  	[red-function!]
		event   [red-word!]
		match? 	[logic!]
		rule	[red-block!]
		input   [red-series!]
		return: [logic!]
		/local
			loop? [logic!]
	][
		stack/mark-func words/_body						;@@ find something more adequate

		stack/push as red-value! event
		logic/push match?
		stack/push as red-value! rule
		stack/push as red-value! input
		stack/push as red-value! rules
		_function/call fun global-ctx					;FIXME: hardcoded origin context

		stack/unwind
		loop?: logic/top-true?
		stack/pop 1
		loop?
	]

	save-stack: func [
		/local
			cnt [integer!]
			p	[positions!]
	][
		cnt: block/rs-length? rules
		unless zero? cnt [
			p: as positions! ALLOC_TAIL(rules)
			p/header: TYPE_POINT
			p/input:  series/head
			p/rule:   rules/head

			series/head: series/head + block/rs-length? series
			rules/head:  rules/head + cnt + 1			;-- account for the new position! slot
		]
	]

	restore-stack: func [
		/local
			s [series!]
			p [positions!]
	][
		if rules/head > 0 [
			s: GET_BUFFER(rules)
			s/tail: s/tail - 1
			p: as positions! s/tail
			series/head: p/input
			rules/head: p/rule
		]
	]

	reset: does [
		block/clear series
		block/clear rules
		restore-stack
	]

	process: func [
		input	[red-series!]
		rule	[red-block!]
		comp-op	[integer!]
		;strict? [logic!]
		part	[integer!]
		fun		[red-function!]
		return: [red-value!]
		/local
			new		 [red-series!]
			int		 [red-integer!]
			int2	 [red-integer!]
			blk		 [red-block!]
			sym*	 [red-symbol!]
			cmd		 [red-value!]
			tail	 [red-value!]
			value	 [red-value!]
			base	 [red-value!]
			char	 [red-char!]
			dt		 [red-datatype!]
			w		 [red-word!]
			t 		 [triple!]
			p		 [positions!]
			state	 [states!]
			type	 [integer!]
			sym		 [integer!]
			min		 [integer!]
			max		 [integer!]
			s		 [series!]
			cnt		 [integer!]
			offset	 [integer!]
			upper?	 [logic!]
			end?	 [logic!]
			ended?	 [logic!]
			match?	 [logic!]
			loop?	 [logic!]
			pop?	 [logic!]
			break?	 [logic!]
			rule?	 [logic!]
			collect? [logic!]
			into?	 [logic!]
	][
		match?:	  yes
		end?:	  no
		ended?:   yes
		break?:	  no
		pop?:	  no
		rule?:	  no
		collect?: no
		value:	  null
		type:	  -1
		min:	  -1
		max:	  -1
		cnt:	  0
		state:    ST_NEXT_ACTION

		save-stack
		base: stack/push*								;-- slot on stack for COPY/SET operations (until OPTION?() is fixed)
		input: as red-series! block/rs-append series as red-value! input	;-- input now points to the series stack entry

		cmd: (block/rs-head rule) - 1					;-- decrement to compensate for starting increment
		tail: block/rs-tail rule						;TBD: protect current rule block from changes

		until [
			#if debug? = yes [if verbose > 1 [print-state state]]

			switch state [
				ST_PUSH_BLOCK [
					none/make-in rules
					PARSE_PUSH_POSITIONS
					block/rs-append rules as red-value! rule
					if all [value <> null value <> rule][
						assert TYPE_OF(value) = TYPE_BLOCK
						copy-cell value as red-value! rule
					]
					cmd: (block/rs-head rule) - 1		;-- decrement to compensate for starting increment
					tail: block/rs-tail rule			;TBD: protect current rule block from changes

					PARSE_CHECK_INPUT_EMPTY?			;-- refresh end? flag
					PARSE_TRACE(_push)
					state: ST_NEXT_ACTION
				]
				ST_POP_BLOCK [
					either zero? block/rs-length? rules [
						state: ST_END
					][
						loop?: no
						ended?: cmd = tail

						s: GET_BUFFER(rules)
						copy-cell s/tail - 1 as red-value! rule
						assert TYPE_OF(rule) = TYPE_BLOCK
						p: as positions! s/tail - 2

						cmd: (block/rs-head rule) + p/rule
						tail: block/rs-tail rule
						PARSE_TRACE(_pop)
						s/tail: s/tail - 3
						value: s/tail - 1

						state: either all [
							0 < block/rs-length? rules
							TYPE_OF(value) = TYPE_INTEGER
						][
							ST_POP_RULE
						][
							either match? [ST_NEXT_ACTION][ST_FIND_ALTERN]
						]
					]
				]
				ST_PUSH_RULE [
					either any [type = R_COPY type = R_SET][
						block/rs-append rules cmd
					][
						t: as triple! ALLOC_TAIL(rules)
						t/header: TYPE_POINT
						t/min:	  min
						t/max:	  max
						t/state:  1
					]
					PARSE_PUSH_POSITIONS
					int: as red-integer! ALLOC_TAIL(rules)
					int/header: TYPE_INTEGER
					int/value: type
					if cmd < tail [cmd: cmd + 1]		;-- move after the rule prologue
					value: cmd
					PARSE_TRACE(_push)
					state: ST_MATCH_RULE
				]
				ST_POP_RULE [
					s: GET_BUFFER(rules)
					value: s/tail - 1

					either any [
						s/offset + rules/head = s/tail	;-- rules stack empty already
						TYPE_OF(value) = TYPE_BLOCK
					][
						state: either pop? [pop?: no ST_POP_BLOCK][ST_NEXT_ACTION]
					][
						pop?: yes
						p: as positions! s/tail - 2
						int: as red-integer! value
						switch int/value [
							R_WHILE
							R_NONE [					;-- iterative rules (ANY, SOME, WHILE, ...)
								t: as triple! s/tail - 3
								cnt: t/state
								;-- Find out if a new loop is required
								loop?: match?
								if all [match? t/max <> R_NONE][ ;-- if rule matched and an upper bound exists,
									loop?: cnt < t/max			 ;-- but not reached yet, loop again
								]
								if any [						 ;-- don't loop if any:
									break?						 ;-- a BREAK or REJECT command was issued
									all [						 ;-- try to avoid some infinite loops
										int/value <> R_WHILE
										input/head = p/input	 ;-- if no input was consumed (except for WHILE)
									]
									all [end? int/value = R_WHILE] ;-- don't loop on WHILE if no more input
								][
									loop?: no
									break?: no
								]
								if loop? [
									;-- Reset state for a new loop
									t/state: cnt + 1
									cmd: (block/rs-head rule) + p/rule ;-- reset rule offset
									PARSE_TRACE(_iterate)
									state: ST_NEXT_ACTION
									pop?: no
								]
								;-- Postprocess match? value
								either match? [
									if all [not loop? cnt < t/min][match?: no]	;-- minimal number of iteration not reached
								][
									if any [				;-- last loop failed case
										t/min <= (cnt - 1)	;-- number of iteration more than lower bound
										zero? t/min			;-- or lower bound is zero (ANY, OPT, WHILE)
									][
										match?: yes			;-- make the last loop return success
									]
								]
							]
							R_TO
							R_THRU [
								either match? [
									if int/value = R_TO [
										input/head: p/input	;-- move input before the last match
										end?: no
									]
								][
									type: TYPE_OF(input)
									end?: either any [	;TBD: replace with ANY_STRING?
										type = TYPE_STRING
										type = TYPE_FILE
										type = TYPE_URL
									][
										string/rs-next as red-string! input
									][
										block/rs-next input
									]
									if positive? part [end?: input/head >= part or end?]

									either end? [
										w: as red-word! (block/rs-head rule) + p/rule + 1 ;-- TO/THRU argument
										match?: all [
											TYPE_OF(w) = TYPE_WORD
											words/end = symbol/resolve w/symbol
										]
									][
										p/input: input/head	;-- refresh saved input head before new iteration
										cmd: (block/rs-head rule) + p/rule ;-- loop rule
										PARSE_TRACE(_iterate)
										state: ST_NEXT_ACTION
										pop?: no
									]
								]
							]
							R_COPY [
								if match? [
									PARSE_COPY_INPUT(p)
									_context/set as red-word! s/tail - 3 as red-value! new
								]
							]
							R_SET [
								if match? [
									PARSE_PICK_INPUT
									_context/set as red-word! p - 1 value
								]
							]
							R_KEEP
							R_KEEP_PAREN [
								if all [
									match?
									any [int/value = R_KEEP_PAREN  p/input < input/head]
								][
									blk: as red-block! stack/top - 1
									assert any [
										TYPE_OF(blk) = TYPE_WORD
										TYPE_OF(blk) = TYPE_GET_WORD
										TYPE_OF(blk) = TYPE_BLOCK
									]
									into?: TYPE_OF(blk) = TYPE_GET_WORD
									if into? [blk: as red-block! _context/get as red-word! blk]

									value: stack/top	;-- refer last value from paren expression
									if int/value = R_KEEP [
										w: as red-word! s/tail
										case [
											p/sub = R_COPY [			;-- KEEP COPY case
												value: _context/get w
											]
											p/input + 1 < input/head [	;-- KEEP with matched size > 1
												PARSE_COPY_INPUT(value)
											]
											true [
												PARSE_PICK_INPUT		;-- KEEP with matched size = 1
											]
										]
									]
									either into? [
										either any [					;@@ replace with ANY_STRING?
											TYPE_OF(blk) = TYPE_STRING
											TYPE_OF(blk) = TYPE_FILE
											TYPE_OF(blk) = TYPE_URL
										][
											string/insert as red-string! blk value null yes null no
										][
											block/insert blk value null yes null no
										]
									][
										block/rs-append blk value
									]
								]
							]
							R_REMOVE [
								if match? [
									int/value: input/head - p/input
									input/head: p/input
									assert int/value >= 0
									copy-cell as red-value! int base	;@@ remove once OPTION? fixed
									actions/remove input base
								]
							]
							R_AHEAD [
								input/head: p/input
								PARSE_CHECK_INPUT_EMPTY? ;-- refresh end? flag after backtracking
							]
							R_NOT [
								match?: not match?
							]
							R_COLLECT [
								value: stack/top - 1

								either stack/top - 2 = base [	;-- root unnamed block reached
									collect?: TYPE_OF(value) = TYPE_BLOCK
								][
									if TYPE_OF(value) = TYPE_BLOCK [
										blk: as red-block! stack/top - 2
										collect?: no

										switch TYPE_OF(blk) [
											TYPE_WORD [
												_context/set as red-word! blk value
												stack/pop 1
											]
											TYPE_GET_WORD [
												blk: as red-block! _context/get as red-word! blk
												block/insert-value blk value
											]
											default [
												assert TYPE_OF(blk) = TYPE_BLOCK
												block/rs-append blk value
												collect?: yes
											]
										]
									]
									stack/pop 1
								]
								if TYPE_OF(value) = TYPE_GET_WORD [	;-- COLLECT INTO exiting
									t: as triple! s/tail - 3
									unless t/max = -1 [
										blk: as red-block! _context/get as red-word! value
										blk/head: t/max	;-- restore saved block cursor
									]
								]
							]
							R_INTO [
								s: GET_BUFFER(series)
								s/tail: s/tail - 1
								input: as red-series! s/tail - 1
								unless ended? [match?: no]
								if match? [input/head: input/head + 1]	;-- skip parsed series

								PARSE_CHECK_INPUT_EMPTY? ;-- refresh end? flag after popping series
								s: GET_BUFFER(rules)
							]
							R_THEN [
								PARSE_TRACE(_pop)
								s/tail: s/tail - 3		;-- pop rule stack frame
								state: either match? [cmd: tail ST_NEXT_ACTION][ST_FIND_ALTERN]
								pop?: no
							]
						]
						if pop? [
							PARSE_TRACE(_pop)
							s/tail: s/tail - 3			;-- pop rule stack frame
							if s/tail > s/offset [
								p: as positions! s/tail - 2
								p/sub: int/value		;-- save rule type in parent stack frame
							]
							state: ST_CHECK_PENDING
						]
					]
					pop?: no
				]
				ST_CHECK_PENDING [
					s: GET_BUFFER(rules)
					value: s/tail - 1

					state: either any [					;-- order of conditional expressions matters!
						zero? block/rs-length? rules
						TYPE_OF(value) <> TYPE_INTEGER
					][
						either match? [ST_NEXT_ACTION][ST_FIND_ALTERN]
					][
						ST_POP_RULE
					]
				]
				ST_DO_ACTION [
					type: TYPE_OF(value)				;-- value is used in this state instead of cmd
					switch type [						;-- allows to enter the state with cmd or :cmd (if word!)
						TYPE_WORD 	[
							if all [value <> cmd TYPE_OF(cmd) = TYPE_WORD][
								PARSE_ERROR [TO_ERROR(script parse-rule) value]
							]
							state: ST_WORD
						]
						TYPE_BLOCK 	[
							state: ST_PUSH_BLOCK
						]
						TYPE_DATATYPE [
							dt: as red-datatype! value
							value: block/rs-head input
							match?: TYPE_OF(value) = dt/value
							PARSE_TRACE(_match)
							state: either match? [ST_NEXT_INPUT][ST_CHECK_PENDING]
						]
						TYPE_SET_WORD [
							_context/set as red-word! value as red-value! input
							state: ST_NEXT_ACTION
						]
						TYPE_GET_WORD [
							new: as red-series! _context/get as red-word! value
							either all [
								TYPE_OF(new) = TYPE_OF(input)
								new/node = input/node
							][
								input/head: new/head
								state: ST_NEXT_ACTION
							][
								PARSE_ERROR [TO_ERROR(script parse-invalid-ref) value]
							]
						]
						TYPE_INTEGER [
							int:  as red-integer! value
							int2: as red-integer! cmd + 1
							if all [
								int2 < tail
								TYPE_OF(int2) = TYPE_WORD
							][
								int2: as red-integer! _context/get as red-word! cmd + 1
							]
							upper?: TYPE_OF(int2) = TYPE_INTEGER
							if any [
								int2 = tail
								all [upper?	int2 + 1 = tail]
								all [upper? int/value > int2/value]
							][
								PARSE_ERROR [TO_ERROR(script parse-rule) value]
							]
							state: either all [zero? int/value not upper?][
								cmd: cmd + 1			;-- skip over sub-rule
								ST_CHECK_PENDING
							][
								min:  int/value
								max:  either upper? [cmd: cmd + 1 int2/value][min]
								type: R_NONE
								ST_PUSH_RULE
							]
						]
						TYPE_PAREN [
							offset: (as-integer cmd - block/rs-head rule) >> 4	;-- save rule position
							interpreter/eval as red-block! value no
							stack/pop 1
							PARSE_TRACE(_paren)
							cmd: (block/rs-head rule) + offset	;-- refresh rule pointers,
							tail: block/rs-tail rule			;-- in case the block was changed
							if cmd >= tail [cmd: tail - 1]	;-- avoid a "past end" state
							state: ST_CHECK_PENDING
						]
						default [						;-- try to match a literal value
							state: ST_MATCH
						]
					]
				]
				ST_NEXT_INPUT [
					type: TYPE_OF(input)
					end?: either any [					;TBD: replace with ANY_STRING
						type = TYPE_STRING
						type = TYPE_FILE
						type = TYPE_URL
					][
						string/rs-next as red-string! input
					][
						block/rs-next input
					]
					if positive? part [end?: input/head >= part or end?]
					state: ST_CHECK_PENDING
				]
				ST_NEXT_ACTION [
					if cmd < tail [cmd: cmd + 1]

					state: either cmd = tail [
						ST_POP_BLOCK
					][
						PARSE_TRACE(_fetch)
						value: cmd
						ST_DO_ACTION
					]
				]
				ST_MATCH [
					type: TYPE_OF(input)
					either end? [
						match?: all [
							any [
								type = TYPE_STRING
								type = TYPE_FILE
								type = TYPE_URL
							]
							any [
								TYPE_OF(value) = TYPE_STRING
								TYPE_OF(value) = TYPE_FILE
								TYPE_OF(value) = TYPE_URL
							]
							zero? string/rs-length? as red-string! value
						]
					][
						end?: either any [				;TBD: replace with ANY_STRING?
							type = TYPE_STRING
							type = TYPE_FILE
							type = TYPE_URL
						][
							match?: either TYPE_OF(value) = TYPE_BITSET [
								string/match-bitset? as red-string! input as red-bitset! value
							][
								string/match? as red-string! input value comp-op
							]
							all [match? advance as red-string! input value]	;-- consume matched input
						][
							match?: actions/compare block/rs-head input value comp-op
							all [match? block/rs-next input]				;-- consume matched input
						]
						if positive? part [end?: input/head >= part or end?]
					]
					PARSE_TRACE(_match)
					state: ST_CHECK_PENDING
				]
				ST_MATCH_RULE [
					either all [value = tail][
						w: switch type [
							R_TO		 [words/_to]
							R_THRU		 [words/_thru]
							R_NOT		 [words/_not]
							R_THEN		 [words/_then]
							R_REMOVE	 [words/_remove]
							R_WHILE		 [words/_while]
							R_COLLECT	 [words/_collect]
							R_KEEP		 [words/_keep]
							R_KEEP_PAREN [words/_keep]
							R_AHEAD		 [words/_ahead]
							default		 [null]
						]
						if w <> null [PARSE_ERROR [TO_ERROR(script parse-end) w]]
						match?: yes
						state: ST_CHECK_PENDING
					][
						switch TYPE_OF(value) [
							TYPE_BLOCK	 [state: ST_PUSH_BLOCK]
							TYPE_WORD	 [state: ST_WORD rule?: all [type <> R_COLLECT type <> R_KEEP]]
							TYPE_DATATYPE
							TYPE_SET_WORD
							TYPE_GET_WORD
							TYPE_INTEGER [state: ST_DO_ACTION]
							default [
								either min = R_NONE [
									state: either any [type = R_TO type = R_THRU][
										match?: find-token? rules input value comp-op part
										PARSE_TRACE(_match)
										ST_POP_RULE
									][
										ST_DO_ACTION
									]
								][
									match?: loop-token input value min max :cnt comp-op part
									if all [not match? zero? min][match?: yes]
									PARSE_TRACE(_match)
									s: GET_BUFFER(rules)
									PARSE_TRACE(_pop)
									s/tail: s/tail - 3		;-- pop rule stack frame
									state: ST_CHECK_PENDING
								]
								PARSE_CHECK_INPUT_EMPTY?
							]
						]
					]
				]
				ST_FIND_ALTERN [
					s: GET_BUFFER(rules)				;-- backtrack input
					p: as positions! s/tail - 2
					input/head: p/input
					PARSE_CHECK_INPUT_EMPTY?			;-- refresh end? flag after backtracking

					cnt: find-altern rule cmd

					state: either cnt >= 0 [
						cmd: cmd + cnt					;-- point rule head to alternative part
						match?: yes						;-- reset match? flag
						ST_NEXT_ACTION
					][
						ST_POP_BLOCK
					]
				]
				ST_WORD [
					w: as red-word! cmd
					sym: symbol/resolve w/symbol
					#if debug? = yes [
						sym*: symbol/get sym
						if verbose > 0 [print-line ["parse: " sym*/cache]]
					]
					case [
						sym = words/pipe [				;-- |
							if cmd = tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_pipe]]
							cmd: tail
							state: ST_POP_BLOCK
						]
						sym = words/skip [				;-- SKIP
							PARSE_CHECK_INPUT_EMPTY?
							match?: not end?
							PARSE_TRACE(_match)
							state: ST_NEXT_INPUT
						]
						sym = words/any* [				;-- ANY
							if cmd + 1 = tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_any]]
							min:   0
							max:   R_NONE
							type:  R_NONE
							state: ST_PUSH_RULE
						]
						sym = words/some [				;-- SOME
							if cmd + 1 = tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_some]]
							min:   1
							max:   R_NONE
							type:  R_NONE
							state: ST_PUSH_RULE
						]
						sym = words/copy [				;-- COPY
							cmd: cmd + 1
							if any [cmd = tail TYPE_OF(cmd) <> TYPE_WORD][
								PARSE_ERROR [TO_ERROR(script parse-end) words/_copy]
							]
							min:   R_NONE
							type:  R_COPY
							state: ST_PUSH_RULE
						]
						sym = words/thru [				;-- THRU
							min:   R_NONE
							type:  R_THRU
							state: ST_PUSH_RULE
						]
						sym = words/to [				;-- TO
							min:   R_NONE
							type:  R_TO
							state: ST_PUSH_RULE
						]
						sym = words/remove [			;-- REMOVE
							min:   R_NONE
							type:  R_REMOVE
							state: ST_PUSH_RULE
						]
						sym = words/break* [			;-- BREAK
							match?: yes
							break?: yes
							cmd:	cmd + 1
							pop?:	yes
							PARSE_TRACE(_match)
							state:	ST_POP_RULE
						]
						sym = words/opt [				;-- OPT
							if cmd + 1 = tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_opt]]
							min:   0
							max:   1
							type:  R_NONE
							state: ST_PUSH_RULE
						]
						sym = words/keep [				;-- KEEP
							value: cmd + 1
							min:   R_NONE
							type:  either TYPE_OF(value) = TYPE_PAREN [R_KEEP_PAREN][R_KEEP]
							state: ST_PUSH_RULE
						]
						sym = words/fail [				;-- FAIL
							match?: no
							PARSE_TRACE(_match)
							state: ST_FIND_ALTERN
						]
						sym = words/ahead [				;-- AHEAD
							min:   R_NONE
							type:  R_AHEAD
							state: ST_PUSH_RULE
						]
						sym = words/while* [			;-- WHILE
							min:   0
							max:   R_NONE
							type:  R_WHILE
							state: ST_PUSH_RULE
						]
						sym = words/into [				;-- INTO
							if TYPE_OF(input) <> TYPE_BLOCK [
								PARSE_ERROR [TO_ERROR(script parse-series) input]
							]
							value: cmd + 1
							if value = tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_into]]

							if TYPE_OF(value) = TYPE_WORD [
								value: _context/get as red-word! value
							]
							if TYPE_OF(value) <> TYPE_BLOCK [
								PARSE_ERROR [TO_ERROR(script parse-end) words/_into]
							]
							value: block/rs-head input
							type: TYPE_OF(value)
							either ANY_SERIES?(type) [
								input: as red-series! block/rs-append series as red-value! block/rs-head input
								min:  R_NONE
								type: R_INTO
								state: ST_PUSH_RULE
							][
								match?: no
								PARSE_TRACE(_match)
								state: ST_CHECK_PENDING
							]
						]
						sym = words/insert [			;-- INSERT
							w: as red-word! cmd + 1
							max: as-integer all [
								(as red-value! w) < tail
								TYPE_OF(w) = TYPE_WORD
								words/only = symbol/resolve w/symbol
							]
							cmd: cmd + max + 1
							if cmd >= tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_insert]]

							value: cmd
							if TYPE_OF(value) = TYPE_PAREN [
								interpreter/eval as red-block! value no
								value: stack/top - 1
								PARSE_TRACE(_paren)
							]
							actions/insert input value null max = 1 null no
							if TYPE_OF(value) = TYPE_PAREN [stack/pop 1]
							state: ST_NEXT_ACTION
						]
						sym = words/end [				;-- END
							PARSE_CHECK_INPUT_EMPTY?
							match?: end?
							PARSE_TRACE(_match)
							state: ST_CHECK_PENDING
						]
						sym = words/then [				;-- THEN
							min:   R_NONE
							type:  R_THEN
							state: ST_PUSH_RULE
						]
						sym = words/if* [				;-- IF
							cmd: cmd + 1
							if any [cmd = tail TYPE_OF(cmd) <> TYPE_PAREN][
								PARSE_ERROR [TO_ERROR(script parse-end) words/_if]
							]
							interpreter/eval as red-block! cmd no
							match?: logic/top-true?
							stack/pop 1
							PARSE_TRACE(_match)
							state: ST_CHECK_PENDING
						]
						sym = words/not* [				;-- NOT
							min:   R_NONE
							type:  R_NOT
							state: ST_PUSH_RULE
						]
						sym = words/quote [				;-- QUOTE
							cmd: cmd + 1
							if cmd = tail [PARSE_ERROR [TO_ERROR(script parse-end) words/_quote]]
							value: cmd
							state: ST_MATCH
						]
						sym = words/collect [			;-- COLLECT
							max: R_NONE
							into?: no
							w: as red-word! cmd + 1

							if all [
								(as red-value! w) < tail
								TYPE_OF(w) = TYPE_WORD
							][
								sym: symbol/resolve w/symbol
								into?: any [sym = words/into sym = words/after]

								if any [into? sym = words/set][
									w: w + 1
									if any [
										w >= tail
										TYPE_OF(w) <> TYPE_WORD
									][
										PARSE_ERROR [TO_ERROR(script parse-end) words/_collect]
									]
									either into? [get-word/push w][stack/push as red-value! w]
									cmd: as red-value! w
								]
							]
							either into? [
								blk: as red-block! _context/get w
								max: either sym = words/after [-1][blk/head] ;-- save block cursor
							][
								block/push* 8
							]
							min:   R_NONE
							type:  R_COLLECT
							state: ST_PUSH_RULE
						]
						sym = words/reject [			;-- REJECT
							match?: no
							break?: yes
							pop?:	yes
							PARSE_TRACE(_match)
							state:	ST_POP_RULE
						]
						sym = words/set [				;-- SET
							cmd: cmd + 1
							if any [cmd = tail TYPE_OF(cmd) <> TYPE_WORD][
								PARSE_ERROR [TO_ERROR(script parse-end) words/_set]
							]
							min:   R_NONE
							type:  R_SET
							state: ST_PUSH_RULE
						]
						sym = words/none [				;-- NONE
							match?: yes
							PARSE_TRACE(_match)
							state: ST_CHECK_PENDING
						]
						true [
							value: _context/get w
							state: either rule? [ST_MATCH_RULE][ST_DO_ACTION] ;-- enable fast loops for word argument
						]
					]
					rule?: no
				]
				ST_END [
					if match? [match?: cmd = tail]

					PARSE_SET_INPUT_LENGTH(cnt)
					if positive? part [cnt: part - input/head]
					if all [
						cnt > 0
						1 = block/rs-length? series
					][
						match?: no
					]
					PARSE_TRACE(_end)
					state: ST_EXIT
				]
			]
			state = ST_EXIT
		]

		block/clear series
		block/clear rules
		restore-stack

		either collect? [
			base + 1
		][
			as red-value! logic/push match?
		]
	]

	init: does [
		series: block/make-in root 8
		rules:  block/make-in root 100
	]
]


FIX: [Windows] output an extra newline in console

Red [
	Title:	"Red console"
	Author: ["Nenad Rakocevic" "Kaj de Vos"]
	File: 	%console.red
	Tabs: 	4
	Rights: "Copyright (C) 2012-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				ReadConsole: 	 "ReadConsoleW" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
		line-buffer-size: 15 * 1024
		line-buffer: allocate line-buffer-size * 2 + 1
	][
		#switch OS [
			MacOSX [
				#define ReadLine-library "libreadline.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
				rl-bind-key: "rl_bind_key" [
					key				[integer!]
					command			[integer!]
					return:			[integer!]
				]
				rl-insert:	 "rl_insert" [
					count			[integer!]
					key				[integer!]
					return:			[integer!]
				]
			]
			#if OS <> 'MacOSX [
				History-library cdecl [
					add-history: "add_history" [  ; Add line to the history.
						line		[c-string!]
					]
				]
			]
		]

		rl-insert-wrapper: func [
			[cdecl]
			count   [integer!]
			key	    [integer!]
			return: [integer!]
		][
			rl-insert count key
		]
	]
]

wprint: func [str [string!]][prin str]

ask: routine [
	prompt [string!]
	/local
		len ret str buffer line pos
][
	#either OS = 'Windows [
		#call [wprint prompt]
		len: 0
		ret: ReadConsole stdin line-buffer line-buffer-size :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		pos: (len * 2) - 3								;-- position at lower 8bits of CR character
		line-buffer/pos: null-byte						;-- overwrite CR with NUL
		str: string/load as-c-string line-buffer len - 1 UTF-16LE
	][
		line: read-line unicode/to-utf8 prompt
		if line = null [halt]  ; EOF

		 #if OS <> 'MacOSX [add-history line]

		str: string/load line  1 + length? line UTF-8
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

input: func [][
	ask ""
]

Red [
	Title:	"Red console"
	Author: ["Nenad Rakocevic" "Kaj de Vos"]
	File: 	%console.red
	Tabs: 	4
	Rights: "Copyright (C) 2012-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				ReadConsole: 	 "ReadConsoleW" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
		line-buffer-size: 15 * 1024
		line-buffer: allocate line-buffer-size * 2 + 1
	][
		#switch OS [
			MacOSX [
				#define ReadLine-library "libreadline.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
				rl-bind-key: "rl_bind_key" [
					key				[integer!]
					command			[integer!]
					return:			[integer!]
				]
				rl-insert:	 "rl_insert" [
					count			[integer!]
					key				[integer!]
					return:			[integer!]
				]
			]
			#if OS <> 'MacOSX [
				History-library cdecl [
					add-history: "add_history" [  ; Add line to the history.
						line		[c-string!]
					]
				]
			]
		]

		rl-insert-wrapper: func [
			[cdecl]
			count   [integer!]
			key	    [integer!]
			return: [integer!]
		][
			rl-insert count key
		]
	]
]

wprint: func [str [string!]][print str]

ask: routine [
	prompt [string!]
	/local
		len ret str buffer line pos
][
	#either OS = 'Windows [
		#call [wprint prompt]
		len: 0
		ret: ReadConsole stdin line-buffer line-buffer-size :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		pos: (len * 2) - 3								;-- position at lower 8bits of CR character
		line-buffer/pos: null-byte						;-- overwrite CR with NUL
		str: string/load as-c-string line-buffer len - 1 UTF-16LE
	][
		line: read-line unicode/to-utf8 prompt
		if line = null [halt]  ; EOF

		 #if OS <> 'MacOSX [add-history line]

		str: string/load line  1 + length? line UTF-8
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

input: func [][
	ask ""
]


FIX: regression in HELP on path values.

FIX: regression in HELP on path values.

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

help: function [
	"Display helping information about words and other values"
	'word [any-type!] "Word you are looking for"
	/local word type info w attributes block ref
][
	tab: tab4: "    "
	tab8: "        "

	case [
		unset? :word [									;-- HELP with no arguments
			print {Use HELP or ? to see built-in info:

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other useful functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
    about - display version number and build date
    q or quit - leave the Red console
}
			exit
		]
		all [word? :word datatype? get :word] [			;-- HELP <datatype!>
			type: get :word
			found?: no
			foreach w system/words [
				if type = type? get w [
					found?: yes
					case [
						any [function? get w native? get w action? get w op? get w routine? get w][
							prin [tab w]
							spec: spec-of get w

							either any [
								string? desc: spec/1
								string? desc: spec/2	;-- attributes block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
			unless found? [print "No value of that type found in global space."]
			exit
		]
		string? :word [
			foreach w system/words [
				if any [function? get w native? get w action? get w op? get w routine? get w][
					spec: spec-of get w
					if any [find form w word find form spec word] [
						prin [tab w]

						either any [
							string? desc: spec/1
							string? desc: spec/2		;-- attributes block case
						][
							print ["^-=> " desc]
						][
							prin lf
						]
					]
				]
			]
			exit
		]
		not any [word? :word path? :word][				;-- all others except word!
			type: type? :word
			print [mold :word "is" a-an form type type]
			exit
		]
	]

	func-name: :word

	argument-rule: [
		set word [word! | lit-word! | get-word!]
		(prin [tab mold :word])
		opt [set type block!  (prin [#" " mold type])]
		opt [set info string! (prin [" =>" append form info dot])]
		(prin lf)
	]

	case [
		unset? get/any :word [
			print ["Word" :word "is not defined"]
		]
		all [
			any [word? func-name path? func-name]
			fun: get func-name
			any [action? :fun function? :fun native? :fun op? :fun routine? :fun]
		][
			prin ["^/USAGE:^/" tab ]

			parse spec-of :fun [
				start: [									;-- 1st pass
					any [block! | string! ]
					opt [set w [word! | lit-word! | get-word!] (either op? :fun [prin [mold w func-name]][prin [func-name mold w]])]
					any [
						/local to end
						| set w [word! | lit-word! | get-word!] (prin [" " w])
						| set w refinement! (prin [" " mold w])
						| skip
					]
				]

				:start										;-- 2nd pass
				opt [set attributes block! (prin ["^/^/ATTRIBUTES:^/" tab mold attributes])]
				opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot lf tab func-name "is of type:" mold type? :fun])]

				(print "^/ARGUMENTS:")
				any [argument-rule]; (prin lf)]

				(print "^/REFINEMENTS:")
				any [
					/local [
						to ahead set-word! 'return set block block!
						(print ["^/RETURN:^/" mold block])
						| to end
					]
					| [
						set ref refinement! (prin [tab mold ref])
						opt [set info string! (prin [" =>" append form info dot])]
						(tab: tab8 prin lf)
						any [argument-rule]
						(tab: tab4)
					]
				]
			]
		]
		all [any [word? word path? word] object? get word][
			prin #"`"
			prin form word
			print "` is an object! of value:"

			foreach w words-of get word [
				value: get/any in get word w

				desc: case [
					object? :value  [words-of value]
					find [op! action! native! function! routine!] type?/word :value [
						spec: spec-of :value
						if string? spec/1 [spec: spec/1]
						spec
					]
					'else [:value]
				]

				desc: either string? desc [copy/part desc 47][mold/part/flat desc 47]

				if 47 = length? desc [					;-- optimized for width = 78
					clear skip tail desc -3
					append desc "..."
				]
				print [
					tab
					pad form/part w 16 16
					pad mold type? get/any w 9
					desc
				]
			]
		]
		'else [
			value: get :word
			print [
				word "is a"
				mold type? :value
				"of value:"
				mold either path? :value [get :value][:value]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

a-an: function [s [string!]][
	pick ["an" "a"] make logic! find "aeiou" s/1
]

what: function [
	"Lists all functions, or words of a given type"
][
	foreach w system/words [
		if any [function? get w native? get w action? get w op? get w routine? get w][
			prin pad form w 15
			spec: spec-of get w

			either any [
				string? desc: spec/1
				string? desc: spec/2					;-- attributes block case
			][
				print [#":" desc]
			][
				prin lf
			]
		]
	]
	exit												;-- return unset value
]

source: function [
	"Print the source of a function"
	'func-name [any-word!] "The name of the function"
][
	print either function? get func-name [
		[append mold func-name #":" mold get func-name]
	][
		type: mold type? get func-name
		["Sorry," func-name "is" a-an type "so no source is available"]
	]
]

about: function [
	"Print Red version information"
][
	print ["Red" system/version #"-" system/build]
]

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

help: function [
	"Display helping information about words and other values"
	'word [any-type!] "Word you are looking for"
	/local word type info w attributes block ref
][
	tab: tab4: "    "
	tab8: "        "

	case [
		unset? :word [									;-- HELP with no arguments
			print {Use HELP or ? to see built-in info:

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other useful functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
    about - display version number and build date
    q or quit - leave the Red console
}
			exit
		]
		all [word? :word datatype? get :word] [			;-- HELP <datatype!>
			type: get :word
			found?: no
			foreach w system/words [
				if type = type? get w [
					found?: yes
					case [
						any [function? get w native? get w action? get w op? get w routine? get w][
							prin [tab w]
							spec: spec-of get w

							either any [
								string? desc: spec/1
								string? desc: spec/2	;-- attributes block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
			unless found? [print "No value of that type found in global space."]
			exit
		]
		string? :word [
			foreach w system/words [
				if any [function? get w native? get w action? get w op? get w routine? get w][
					spec: spec-of get w
					if any [find form w word find form spec word] [
						prin [tab w]

						either any [
							string? desc: spec/1
							string? desc: spec/2		;-- attributes block case
						][
							print ["^-=> " desc]
						][
							prin lf
						]
					]
				]
			]
			exit
		]
		not word? :word [								;-- all others except word!
			type: type? :word
			print [mold :word "is" a-an form type type]
			exit
		]
	]

	func-name: :word

	argument-rule: [
		set word [word! | lit-word! | get-word!]
		(prin [tab mold :word])
		opt [set type block!  (prin [#" " mold type])]
		opt [set info string! (prin [" =>" append form info dot])]
		(prin lf)
	]

	case [
		unset? get/any :word [
			print ["Word" :word "is not defined"]
		]
		all [
			any [word? func-name path? func-name]
			fun: get func-name
			any [action? :fun function? :fun native? :fun op? :fun routine? :fun]
		][
			prin ["^/USAGE:^/" tab ]

			parse spec-of :fun [
				start: [									;-- 1st pass
					any [block! | string! ]
					opt [set w [word! | lit-word! | get-word!] (either op? :fun [prin [mold w func-name]][prin [func-name mold w]])]
					any [
						/local to end
						| set w [word! | lit-word! | get-word!] (prin [" " w])
						| set w refinement! (prin [" " mold w])
						| skip
					]
				]

				:start										;-- 2nd pass
				opt [set attributes block! (prin ["^/^/ATTRIBUTES:^/" tab mold attributes])]
				opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot lf tab func-name "is of type:" mold type? :fun])]

				(print "^/ARGUMENTS:")
				any [argument-rule]; (prin lf)]

				(print "^/REFINEMENTS:")
				any [
					/local [
						to ahead set-word! 'return set block block!
						(print ["^/RETURN:^/" mold block])
						| to end
					]
					| [
						set ref refinement! (prin [tab mold ref])
						opt [set info string! (prin [" =>" append form info dot])]
						(tab: tab8 prin lf)
						any [argument-rule]
						(tab: tab4)
					]
				]
			]
		]
		all [any [word? word path? word] object? get word][
			prin #"`"
			prin form word
			print "` is an object! of value:"

			foreach w words-of get word [
				value: get/any in get word w

				desc: case [
					object? :value  [words-of value]
					find [op! action! native! function! routine!] type?/word :value [
						spec: spec-of :value
						if string? spec/1 [spec: spec/1]
						spec
					]
					'else [:value]
				]

				desc: either string? desc [copy/part desc 47][mold/part/flat desc 47]

				if 47 = length? desc [					;-- optimized for width = 78
					clear skip tail desc -3
					append desc "..."
				]
				print [
					tab
					pad form/part w 16 16
					pad mold type? get/any w 9
					desc
				]
			]
		]
		'else [
			value: get :word
			print [
				word "is a"
				mold type? :value
				"of value:"
				mold either path? :value [get :value][:value]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

a-an: function [s [string!]][
	pick ["an" "a"] make logic! find "aeiou" s/1
]

what: function [
	"Lists all functions, or words of a given type"
][
	foreach w system/words [
		if any [function? get w native? get w action? get w op? get w routine? get w][
			prin pad form w 15
			spec: spec-of get w

			either any [
				string? desc: spec/1
				string? desc: spec/2					;-- attributes block case
			][
				print [#":" desc]
			][
				prin lf
			]
		]
	]
	exit												;-- return unset value
]

source: function [
	"Print the source of a function"
	'func-name [any-word!] "The name of the function"
][
	print either function? get func-name [
		[append mold func-name #":" mold get func-name]
	][
		type: mold type? get func-name
		["Sorry," func-name "is" a-an type "so no source is available"]
	]
]

about: function [
	"Print Red version information"
][
	print ["Red" system/version #"-" system/build]
]


Fix: UTF-8 length now include terminal zero

Red [
	Title:  "Red call binding"
	Author: "Bruno Anselme"
	EMail:  "be.red@free.fr"
	File:   %call.red
	Rights: "Copyright (c) 2014-2015 Bruno Anselme"
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
	Needs: {
		Red/System >= 0.4.1
		%call.reds
	}
]

#system-global [ #include %call.reds ]

; Routines definitions
redsys-call: routine [ "Set IO buffers if needed, execute call"
	cmd        [string!]  "Command"
	waitend    [logic!]   "Wait for end of child process"
	console    [logic!]   "Runs command with I/O redirected to console"
	shell      [logic!]   "Forces command to be run from shell"
	redirin    [logic!]   "Input redirection"
	in-str     [string!]  "Input data"
	redirout   [logic!]   "Output redirection"
	redirerr   [logic!]   "Error redirection"
	return:    [integer!]
	/local
	inp out err s
][
	either redirin [
		inp: declare p-buffer!
		inp/buffer: string/rs-head in-str
		s: GET_BUFFER(in-str)
		inp/count:  GET_UNIT(s) * string/rs-length? in-str
		#if OS = 'Windows [ system-call/to-ascii inp ]
	][
		inp: null
	]
	either redirout [
		out:  declare p-buffer!
		out/buffer: null
		out/count:  0
	][
		out: null
	]
	either redirerr [
		err:  declare p-buffer!
		err/buffer: null
		err/count:  0
	][
		err: null
	]
	system-call/call (as-c-string string/rs-head cmd) waitend console shell inp out err
]

get-out: routine [ "Returns redirected stdout"
	/local
		sout   [red-string!]
		str    [c-string!]
		result [integer!]
][
	with system-call [
		#either OS = 'Windows [
			result: IS_TEXT_UNICODE_UNICODE_MASK
			is-text-unicode outputs/out/buffer outputs/out/count :result
			either result = 0 [
				to-ascii outputs/out
				sout: string/load as-c-string outputs/out/buffer (outputs/out/count) UTF-8
			][
				sout: string/load as-c-string outputs/out/buffer (outputs/out/count / 2) UTF-16LE
			]
		][
			sout: string/load as-c-string outputs/out/buffer (outputs/out/count) UTF-8
		]
		free outputs/out/buffer
		SET_RETURN(sout)
	]
]

get-err: routine [ "Returns redirected stderr"
	/local
		serr	[red-string!]
		result	[integer!]
][
	with system-call [
		#either OS = 'Windows [
			result: IS_TEXT_UNICODE_UNICODE_MASK
			is-text-unicode outputs/err/buffer outputs/err/count :result
			either result = 0 [
				to-ascii outputs/err
				serr: string/load as-c-string outputs/err/buffer (outputs/err/count) UTF-8
			][
				serr: string/load as-c-string outputs/err/buffer (outputs/err/count / 2) UTF-16LE
			]
		][
			serr: string/load as-c-string outputs/err/buffer (outputs/err/count) UTF-8
		]
		free outputs/err/buffer
		SET_RETURN(serr)
	]
]

print-to-stderr: routine [ "Call to low level print to stderr"
	mesg	[string!]
][
	system-call/print-error [ as-c-string string/rs-head mesg ]
]

print-error: func [
	mesg			[string! block!]	"A shell command, an executable file or a block"
][
	if block? mesg [ mesg: form mesg ]
	print-to-stderr mesg
]

call: func [ "Executes a shell command to run another process."
	cmd			[string! block!]	"A shell command, an executable file or a block"
	/wait							"Runs command and waits for exit"
	/console						"Runs command with I/O redirected to console"
	/shell							"Forces command to be run from shell"
	/input	in	[string! block!]	"Redirects in to stdin"
	/output	out	[string! block!]	"Redirects stdout to out"
	/error	err	[string! block!]	"Redirects stderr to err"
	return:		[integer!]			"0 if success, -1 if error, or a process ID"
	/local
		pid		[integer!]
		str		[string!]
		do-in do-out do-err
][
	pid: 0
	if block? cmd [ cmd: form cmd ]
	either input  [
		if block? in [ in: form in ]
		str: in
	][
		str: ""
	]
	pid: redsys-call cmd wait console shell input str output error
	if output [
		str: get-out
		parse str [ while [ ahead crlf remove cr | skip ] ]
		out: head insert out str
	]
	if error [
		str: get-err
		parse str [ while [ ahead crlf remove cr | skip ] ]
		err: head insert err str
	]
	pid
]

Red [
	Title:  "Red call binding"
	Author: "Bruno Anselme"
	EMail:  "be.red@free.fr"
	File:   %call.red
	Rights: "Copyright (c) 2014-2015 Bruno Anselme"
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
	Needs: {
		Red/System >= 0.4.1
		%call.reds
	}
]

#system-global [ #include %call.reds ]

; Routines definitions
redsys-call: routine [ "Set IO buffers if needed, execute call"
	cmd        [string!]  "Command"
	waitend    [logic!]   "Wait for end of child process"
	console    [logic!]   "Runs command with I/O redirected to console"
	shell      [logic!]   "Forces command to be run from shell"
	redirin    [logic!]   "Input redirection"
	in-str     [string!]  "Input data"
	redirout   [logic!]   "Output redirection"
	redirerr   [logic!]   "Error redirection"
	return:    [integer!]
	/local
	inp out err s
][
	either redirin [
		inp: declare p-buffer!
		inp/buffer: string/rs-head in-str
		s: GET_BUFFER(in-str)
		inp/count:  GET_UNIT(s) * string/rs-length? in-str
		#if OS = 'Windows [ system-call/to-ascii inp ]
	][
		inp: null
	]
	either redirout [
		out:  declare p-buffer!
		out/buffer: null
		out/count:  0
	][
		out: null
	]
	either redirerr [
		err:  declare p-buffer!
		err/buffer: null
		err/count:  0
	][
		err: null
	]
	system-call/call (as-c-string string/rs-head cmd) waitend console shell inp out err
]

get-out: routine [ "Returns redirected stdout"
	/local
		sout   [red-string!]
		str    [c-string!]
		result [integer!]
][
	with system-call [
		#either OS = 'Windows [
			result: IS_TEXT_UNICODE_UNICODE_MASK
			is-text-unicode outputs/out/buffer outputs/out/count :result
			either result = 0 [
				to-ascii outputs/out
				sout: string/load as-c-string outputs/out/buffer (1 + outputs/out/count) UTF-8
			][
				sout: string/load as-c-string outputs/out/buffer (1 + (outputs/out/count / 2)) UTF-16LE
			]
		][
			sout: string/load as-c-string outputs/out/buffer (1 + outputs/out/count) UTF-8
		]
		free outputs/out/buffer
		SET_RETURN(sout)
	]
]

get-err: routine [ "Returns redirected stderr"
	/local
		serr	[red-string!]
		result	[integer!]
][
	with system-call [
		#either OS = 'Windows [
			result: IS_TEXT_UNICODE_UNICODE_MASK
			is-text-unicode outputs/err/buffer outputs/err/count :result
			either result = 0 [
				to-ascii outputs/err
				serr: string/load as-c-string outputs/err/buffer (1 + outputs/err/count) UTF-8
			][
				serr: string/load as-c-string outputs/err/buffer (1 + (outputs/err/count / 2)) UTF-16LE
			]
		][
			serr: string/load as-c-string outputs/err/buffer (1 + outputs/err/count) UTF-8
		]
		free outputs/err/buffer
		SET_RETURN(serr)
	]
]

print-to-stderr: routine [ "Call to low level print to stderr"
	mesg	[string!]
][
	system-call/print-error [ as-c-string string/rs-head mesg ]
]

print-error: func [
	mesg			[string! block!]	"A shell command, an executable file or a block"
][
	if block? mesg [ mesg: form mesg ]
	print-to-stderr mesg
]

call: func [ "Executes a shell command to run another process."
	cmd			[string! block!]	"A shell command, an executable file or a block"
	/wait							"Runs command and waits for exit"
	/console						"Runs command with I/O redirected to console"
	/shell							"Forces command to be run from shell"
	/input	in	[string! block!]	"Redirects in to stdin"
	/output	out	[string! block!]	"Redirects stdout to out"
	/error	err	[string! block!]	"Redirects stderr to err"
	return:		[integer!]			"0 if success, -1 if error, or a process ID"
	/local
		pid		[integer!]
		str		[string!]
		do-in do-out do-err
][
	pid: 0
	if block? cmd [ cmd: form cmd ]
	either input  [
		if block? in [ in: form in ]
		str: in
	][
		str: ""
	]
	pid: redsys-call cmd wait console shell input str output error
	if output [
		str: get-out
		parse str [ while [ ahead crlf remove cr | skip ] ]
		out: head insert out str
	]
	if error [
		str: get-err
		parse str [ while [ ahead crlf remove cr | skip ] ]
		err: head insert err str
	]
	pid
]