FIX: previous commit for issue #461 was missing the reported crash fix.

Red/System [
	Title:   "Red interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %interpreter.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 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
	}
]

#define CHECK_INFIX [
	if all [
		next < end
		TYPE_OF(next) = TYPE_WORD
	][
		value: _context/get next
		if TYPE_OF(value) = TYPE_OP [
			either next = as red-word! pc [
				if verbose > 0 [log "infix detected!"]
				infix?: yes
			][
				if TYPE_OF(pc) = TYPE_WORD [
					left: _context/get as red-word! pc
				]
				unless all [
					TYPE_OF(pc) = TYPE_WORD
					any [
						TYPE_OF(left) = TYPE_ACTION
						TYPE_OF(left) = TYPE_NATIVE
						TYPE_OF(left) = TYPE_FUNCTION
					]
					literal-first-arg? as red-native! left	;-- a literal argument is expected
				][
					if verbose > 0 [log "infix detected!"]
					infix?: yes
				]
			]
		]
	]
]

#define FETCH_ARGUMENT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
	either TYPE_OF(value) = TYPE_WORD [
		if verbose > 0 [log "evaluating argument"]
		pc: eval-expression pc end no yes
	][
		if verbose > 0 [log "fetching argument"]
		either TYPE_OF(pc) = TYPE_GET_WORD [
			copy-cell _context/get as red-word! pc stack/push*
		][
			stack/push pc
		]
		pc: pc + 1
	]
]

interpreter: context [
	verbose: 0

	return-type: -1										;-- return type for routine calls

	log: func [msg [c-string!]][
		print "eval: "
		print-line msg
	]

	print-symbol: func [
		word [red-word!]
		/local
			sym [red-symbol!]
	][
		sym: symbol/get word/symbol
		print-line sym/cache
	]

	literal-first-arg?: func [
		native 	[red-native!]
		return: [logic!]
		/local
			fun	  	  [red-function!]
			value	  [red-value!]
			tail	  [red-value!]
			s		  [series!]
	][
		s: as series! either TYPE_OF(native) = TYPE_FUNCTION [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]
		value: s/offset
		tail:  s/tail

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD 		[return no]
				TYPE_LIT_WORD	[return yes]
				default 		[0]
			]
			value: value + 1
		]
		no
	]

	eval-option: func [
		pc		  [red-value!]
		end		  [red-value!]
		value	  [red-value!]
		tail	  [red-value!]
		word	  [red-word!]
		offset	  [int-ptr!]
		args	  [int-ptr!]
		function? [logic!]
		return:	  [red-value!]
		/local
			ref	  [red-refinement!]
			slot  [red-logic!]
			type  [integer!]
			pos	  [integer!]
			idx	  [integer!]
			pos2  [integer!]
	][
		pos:  0											;-- stack offset
		idx:  1											;-- native stack ref-array index
		args/value: 0

		while [value < tail][

			switch TYPE_OF(value) [
				TYPE_REFINEMENT [
					ref: as red-refinement! value
					either EQUAL_WORDS?(ref word) [
						slot: as red-logic! stack/arguments + pos
						slot/value: true

						value: value + 1
						pos2: pos + 1
						while [
							type: TYPE_OF(value)
							all [
								value < tail
								any [
									type = TYPE_WORD
									type = TYPE_GET_WORD
									type = TYPE_LIT_WORD
									type = TYPE_STRING
								]
							]
						][
							unless type = TYPE_STRING [
								FETCH_ARGUMENT
								if function? [
									copy-cell stack/top - 1 stack/arguments + pos2
									stack/pop 1
								]
								pos2: pos2 + 1
								args/value: args/value + 1
							]
							value: value + 1
						]
						unless function? [offset/value: idx]
						return pc
					][
						idx: idx + 1
					]
					pos: pos + 1
				]
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					pos: pos + 1
				]
				default [0]
			]

			value: value + 1
		]
		print "Error: refinement /"
		print-symbol word
		print-line " not found!"
		halt
		null
	]

	eval-function: func [
		fun  [red-function!]
		body [red-block!]
		/local
			saved
	][
		saved: fun/ctx/values
		fun/ctx/values: as node! stack/arguments
		eval body
		fun/ctx/values: saved
	]

	exec-routine: func [
		fun	 [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			count  [integer!]
			call
	][
		s: as series! fun/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: (routine/get-arity fun) - 1				;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert false]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			left   [red-value!]
			infix? [logic!]
			op	   [red-op!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op

		if verbose > 0 [
			value: stack/arguments
			print-line ["eval: op return type: " TYPE_OF(value)]
		]

		infix?: no
		next: as red-word! pc
		CHECK_INFIX
		if infix? [pc: eval-infix value pc end sub?]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		path	[red-path!]
		pos 	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			head	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			path-end  [red-value!]
			s		  [series!]
			required? [logic!]
			index	  [integer!]
			count	  [integer!]
			offset	  [integer!]
			args	  [integer!]
			size	  [integer!]
			ref-array [int-ptr!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]

		s: as series! either function? [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]

		head:  s/offset
		value: head
		tail:  s/tail

		unless null? path [
			path-end: block/rs-tail as red-block! path
			if pos + 1 = path-end [path: null]			;-- no refinement following the function
		]												;-- so, process it as a non-path call

		count:  	 0									;-- base arity (mandatory arguments only)
		index: 	 	 1
		args:		 -1
		offset:		 -1
		return-type: -1
		ref?:		 no
		required?:	 yes								;-- yes: processing mandatory args, no: optional args

		unless function? [
			size: as-integer tail - value				;@@ takes more space than really needed
			ref-array: system/stack/top - size
			system/stack/top: ref-array					;-- reserve space on native stack for refs array
		]

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					either required? [
						FETCH_ARGUMENT
						count: count + 1
					][
						if function? [none/push]
					]
				]
				TYPE_REFINEMENT [
					if required? [required?: no]		;-- no more mandatory arguments

					either function? [
						logic/push false
					][
						ref-array/index: -1
						index: index + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]

		unless routine? [
			if path <> null [
				pos: pos + 1

				while [pos < path-end][
					pc: eval-option pc end head tail as red-word! pos :offset :args function?

					unless function? [
						either args > 0 [
							ref-array/offset: count + args - 1
							count: count + args
						][
							ref-array/offset: 0
						]
					]
					pos: pos + 1
				]
			]
		]

		unless function? [
			system/stack/top: ref-array					;-- reset native stack to our custom arguments frame
			call: as function! [] native/code			;-- direct call for actions/natives
			call
		]
		pc
	]

	eval-path-element: func [
		slot     [red-value!]
		head     [red-value!]
		tail     [red-value!]
		result   [red-value!]
		alt-slot [red-value!]							;-- alternative element (computed from paren)
		set?     [logic!]
		return:  [red-value!]
		/local
			value  [red-value!]
			int	   [red-integer!]
	][
		value: case [
			TYPE_OF(slot) = TYPE_GET_WORD [_context/get as red-word! slot]
			null? alt-slot 				  [slot]
			true		   				  [alt-slot]
		]
		switch TYPE_OF(value) [
			TYPE_WORD [
				either slot = head [
					result: _context/get as red-word! value
					switch TYPE_OF(result) [
						TYPE_UNSET [
							return unset-value
						]
						TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
						TYPE_NATIVE
						TYPE_ROUTINE
						TYPE_FUNCTION [
							return result
						]
						TYPE_BLOCK 						;@@ replace with TYPE_SERIES
						TYPE_PATH
						TYPE_LIT_PATH
						TYPE_GET_PATH
						TYPE_SET_PATH
						TYPE_STRING
						TYPE_FILE [

						]
						;TYPE_OBJECT
						;TYPE_PORT [
						;
						;]
						default [
							;; TBD raise an error
						]
					]
				][
					result: either all [set? slot + 1 = tail][
						value: actions/find as red-series! result value null no no no null null no no no no
						actions/poke as red-series! value 2 stack/arguments
						stack/arguments
					][
						actions/select as red-series! result value null no no no null null no no
					]
				]
			]
			TYPE_PAREN [
				stack/mark-native words/_body			;@@ ~paren
				eval as red-block! value				;-- eval paren content
				stack/unwind
				result: eval-path-element slot head tail result stack/top - 1 set?
			]
			TYPE_INTEGER [
				int: as red-integer! value
				result: either all [set? slot + 1 = tail][
					actions/poke as red-series! result int/value stack/arguments
					stack/arguments
				][
					actions/pick as red-series! result int/value
				]
			]
			TYPE_STRING [
				--NOT_IMPLEMENTED--
			]
		]
		result
	]

	eval-path: func [
		value   [red-value!]
		pc		[red-value!]							;-- path to evaluate
		end		[red-value!]
		set?	[logic!]
		return: [red-value!]
		/local
			path   [red-path!]
			head   [red-value!]
			tail   [red-value!]
			slot   [red-value!]
			result [red-value!]
			saved  [red-value!]
	][
		if verbose > 0 [print-line "eval: path"]

		path:  as red-path! value
		head:  block/rs-head as red-block! path
		tail:  block/rs-tail as red-block! path
		slot:  head
		saved: stack/top

		if TYPE_OF(slot) <> TYPE_WORD [
			print-line "*** Error: path value must start with a word!"
			halt
		]

		result: null

		while [slot < tail][
			if verbose > 1 [print-line ["slot type: " TYPE_OF(slot)]]

			result: eval-path-element slot head tail result null set?

			switch TYPE_OF(result) [
				TYPE_UNSET [
					print-line "*** Error: word in path has no value!"
					stack/push result
					return pc
				]
				TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code result pc end yes path slot
					return pc
				]
				default [0]
			]
			slot: slot + 1
		]

		stack/top: saved
		stack/push result
		pc
	]

	eval-code: func [
		value	[red-value!]
		pc		[red-value!]
		end		[red-value!]
		sub?	[logic!]
		path	[red-path!]
		slot 	[red-value!]
		return: [red-value!]
		/local
			fun	   [red-function!]
			native [red-native!]
			s	   [series!]
			call
	][
		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				if verbose > 0 [log "pushing action/native frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot 	;-- fetch args and exec
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: action/native return type: " TYPE_OF(value)]
				]
			]
			TYPE_ROUTINE [
				if verbose > 0 [log "pushing routine frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot
				exec-routine as red-routine! value
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: routine return type: " TYPE_OF(value)]
				]
			]
			TYPE_FUNCTION [
				if verbose > 0 [log "pushing function frame"]
				stack/mark-func as red-word! pc	;@@
				pc: eval-arguments as red-native! value pc end path slot
				fun: as red-function! value
				s: as series! fun/more/value

				native: as red-native! s/offset + 2
				either zero? native/code [
					eval-function fun as red-block! s/offset
				][
					call: as function! [] native/code
					call
					0
				]
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: function return type: " TYPE_OF(value)]
				]
			]
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		prefix?	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			value  [red-value!]
			left   [red-value!]
			w	   [red-word!]
			sym	   [red-symbol!]
			op	   [red-value!]
			infix? [logic!]
	][
		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

		infix?: no
		unless prefix? [
			next: as red-word! pc + 1
			CHECK_INFIX
			if infix? [
				stack/mark-native as red-word! pc + 1
				sub?: yes								;-- force sub? for infix expressions
				op: value
			]
		]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no yes		;-- yes: push value on top of stack
				pc: eval-path value pc end yes
			]
			TYPE_GET_WORD [
				copy-cell _context/get as red-word! pc stack/push*
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				either sub? [
					w: word/push as red-word! pc		;-- nested expression: push value
				][
					w: as red-word! stack/set-last pc	;-- root expression: return value
				]
				w/header: TYPE_WORD						;-- coerce it to a word!
				pc: pc + 1
			]
			TYPE_WORD [
				if verbose > 0 [
					print "eval: '"
					print-symbol as red-word! pc
				]
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_UNSET [
						print-line "*** Error: word has no value!"
						either sub? [stack/push unset-value][stack/set-last unset-value]
					]
					TYPE_LIT_WORD [
						w: word/push as red-word! value	;-- push lit-word! on stack
						w/header: TYPE_WORD				;-- coerce it to a word!
					]
					TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: word return type: " TYPE_OF(value)]
						]
					]
				]
			]
			TYPE_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no
			]
			TYPE_LIT_PATH [
				value: stack/push pc
				value/header: TYPE_PATH
				pc: pc + 1
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]

		if infix? [
			pc: eval-infix op pc end sub?
			unless prefix? [
				either sub? [stack/unwind][stack/unwind-last]
			]
		]
		pc
	]

	eval-next: func [
		value	[red-value!]
		tail	[red-value!]
		sub?	[logic!]
		return: [red-value!]							;-- return start of next expression
	][
		stack/mark-native words/_body					;-- outer stack frame
		value: eval-expression value tail no sub?
		either sub? [stack/unwind][stack/unwind-last]
		value
	]

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			arg	  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			arg: stack/arguments
			arg/header: TYPE_UNSET
			exit
		]

		stack/mark-native words/_body					;-- outer stack frame

		while [value < tail][
			if verbose > 0 [log "root loop..."]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]

		stack/unwind-last
	]

]

Red/System [
	Title:   "Red interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %interpreter.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 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
	}
]

#define CHECK_INFIX [
	if all [
		next < end
		TYPE_OF(next) = TYPE_WORD
	][
		value: _context/get next
		if TYPE_OF(value) = TYPE_OP [
			if verbose > 0 [log "infix detected!"]
			infix?: yes
		]
	]
]

#define FETCH_ARGUMENT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
	either TYPE_OF(value) = TYPE_WORD [
		if verbose > 0 [log "evaluating argument"]
		pc: eval-expression pc end no yes
	][
		if verbose > 0 [log "fetching argument"]
		either TYPE_OF(pc) = TYPE_GET_WORD [
			copy-cell _context/get as red-word! pc stack/push*
		][
			stack/push pc
		]
		pc: pc + 1
	]
]

interpreter: context [
	verbose: 0

	return-type: -1										;-- return type for routine calls

	log: func [msg [c-string!]][
		print "eval: "
		print-line msg
	]

	print-symbol: func [
		word [red-word!]
		/local
			sym [red-symbol!]
	][
		sym: symbol/get word/symbol
		print-line sym/cache
	]

	eval-option: func [
		pc		  [red-value!]
		end		  [red-value!]
		value	  [red-value!]
		tail	  [red-value!]
		word	  [red-word!]
		offset	  [int-ptr!]
		args	  [int-ptr!]
		function? [logic!]
		return:	  [red-value!]
		/local
			ref	  [red-refinement!]
			slot  [red-logic!]
			type  [integer!]
			pos	  [integer!]
			idx	  [integer!]
			pos2  [integer!]
	][
		pos:  0											;-- stack offset
		idx:  1											;-- native stack ref-array index
		args/value: 0

		while [value < tail][

			switch TYPE_OF(value) [
				TYPE_REFINEMENT [
					ref: as red-refinement! value
					either EQUAL_WORDS?(ref word) [
						slot: as red-logic! stack/arguments + pos
						slot/value: true

						value: value + 1
						pos2: pos + 1
						while [
							type: TYPE_OF(value)
							all [
								value < tail
								any [
									type = TYPE_WORD
									type = TYPE_GET_WORD
									type = TYPE_LIT_WORD
									type = TYPE_STRING
								]
							]
						][
							unless type = TYPE_STRING [
								FETCH_ARGUMENT
								if function? [
									copy-cell stack/top - 1 stack/arguments + pos2
									stack/pop 1
								]
								pos2: pos2 + 1
								args/value: args/value + 1
							]
							value: value + 1
						]
						unless function? [offset/value: idx]
						return pc
					][
						idx: idx + 1
					]
					pos: pos + 1
				]
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					pos: pos + 1
				]
				default [0]
			]

			value: value + 1
		]
		print "Error: refinement /"
		print-symbol word
		print-line " not found!"
		halt
		null
	]

	eval-function: func [
		fun  [red-function!]
		body [red-block!]
		/local
			saved
	][
		saved: fun/ctx/values
		fun/ctx/values: as node! stack/arguments
		eval body
		fun/ctx/values: saved
	]

	exec-routine: func [
		fun	 [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			count  [integer!]
			call
	][
		s: as series! fun/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: (routine/get-arity fun) - 1				;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert false]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			infix? [logic!]
			op	   [red-op!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op

		if verbose > 0 [
			value: stack/arguments
			print-line ["eval: op return type: " TYPE_OF(value)]
		]

		infix?: no
		next: as red-word! pc
		CHECK_INFIX
		if infix? [pc: eval-infix value pc end sub?]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		path	[red-path!]
		pos 	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			head	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			path-end  [red-value!]
			s		  [series!]
			required? [logic!]
			index	  [integer!]
			count	  [integer!]
			offset	  [integer!]
			args	  [integer!]
			size	  [integer!]
			ref-array [int-ptr!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]

		s: as series! either function? [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]

		head:  s/offset
		value: head
		tail:  s/tail

		unless null? path [
			path-end: block/rs-tail as red-block! path
			if pos + 1 = path-end [path: null]			;-- no refinement following the function
		]												;-- so, process it as a non-path call

		count:  	 0									;-- base arity (mandatory arguments only)
		index: 	 	 1
		args:		 -1
		offset:		 -1
		return-type: -1
		ref?:		 no
		required?:	 yes								;-- yes: processing mandatory args, no: optional args

		unless function? [
			size: as-integer tail - value				;@@ takes more space than really needed
			ref-array: system/stack/top - size
			system/stack/top: ref-array					;-- reserve space on native stack for refs array
		]

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					either required? [
						FETCH_ARGUMENT
						count: count + 1
					][
						if function? [none/push]
					]
				]
				TYPE_REFINEMENT [
					if required? [required?: no]		;-- no more mandatory arguments

					either function? [
						logic/push false
					][
						ref-array/index: -1
						index: index + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]

		unless routine? [
			if path <> null [
				pos: pos + 1

				while [pos < path-end][
					pc: eval-option pc end head tail as red-word! pos :offset :args function?

					unless function? [
						either args > 0 [
							ref-array/offset: count + args - 1
							count: count + args
						][
							ref-array/offset: 0
						]
					]
					pos: pos + 1
				]
			]
		]

		unless function? [
			system/stack/top: ref-array					;-- reset native stack to our custom arguments frame
			call: as function! [] native/code			;-- direct call for actions/natives
			call
		]
		pc
	]

	eval-path-element: func [
		slot     [red-value!]
		head     [red-value!]
		tail     [red-value!]
		result   [red-value!]
		alt-slot [red-value!]							;-- alternative element (computed from paren)
		set?     [logic!]
		return:  [red-value!]
		/local
			value  [red-value!]
			int	   [red-integer!]
	][
		value: case [
			TYPE_OF(slot) = TYPE_GET_WORD [_context/get as red-word! slot]
			null? alt-slot 				  [slot]
			true		   				  [alt-slot]
		]
		switch TYPE_OF(value) [
			TYPE_WORD [
				either slot = head [
					result: _context/get as red-word! value
					switch TYPE_OF(result) [
						TYPE_UNSET [
							return unset-value
						]
						TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
						TYPE_NATIVE
						TYPE_ROUTINE
						TYPE_FUNCTION [
							return result
						]
						TYPE_BLOCK 						;@@ replace with TYPE_SERIES
						TYPE_PATH
						TYPE_LIT_PATH
						TYPE_GET_PATH
						TYPE_SET_PATH
						TYPE_STRING
						TYPE_FILE [

						]
						;TYPE_OBJECT
						;TYPE_PORT [
						;
						;]
						default [
							;; TBD raise an error
						]
					]
				][
					result: either all [set? slot + 1 = tail][
						value: actions/find as red-series! result value null no no no null null no no no no
						actions/poke as red-series! value 2 stack/arguments
						stack/arguments
					][
						actions/select as red-series! result value null no no no null null no no
					]
				]
			]
			TYPE_PAREN [
				stack/mark-native words/_body			;@@ ~paren
				eval as red-block! value				;-- eval paren content
				stack/unwind
				result: eval-path-element slot head tail result stack/top - 1 set?
			]
			TYPE_INTEGER [
				int: as red-integer! value
				result: either all [set? slot + 1 = tail][
					actions/poke as red-series! result int/value stack/arguments
					stack/arguments
				][
					actions/pick as red-series! result int/value
				]
			]
			TYPE_STRING [
				--NOT_IMPLEMENTED--
			]
		]
		result
	]

	eval-path: func [
		value   [red-value!]
		pc		[red-value!]							;-- path to evaluate
		end		[red-value!]
		set?	[logic!]
		return: [red-value!]
		/local
			path   [red-path!]
			head   [red-value!]
			tail   [red-value!]
			slot   [red-value!]
			result [red-value!]
			saved  [red-value!]
	][
		if verbose > 0 [print-line "eval: path"]

		path:  as red-path! value
		head:  block/rs-head as red-block! path
		tail:  block/rs-tail as red-block! path
		slot:  head
		saved: stack/top

		if TYPE_OF(slot) <> TYPE_WORD [
			print-line "*** Error: path value must start with a word!"
			halt
		]

		result: null

		while [slot < tail][
			if verbose > 1 [print-line ["slot type: " TYPE_OF(slot)]]

			result: eval-path-element slot head tail result null set?

			switch TYPE_OF(result) [
				TYPE_UNSET [
					print-line "*** Error: word in path has no value!"
					stack/push result
					return pc
				]
				TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code result pc end yes path slot
					return pc
				]
				default [0]
			]
			slot: slot + 1
		]

		stack/top: saved
		stack/push result
		pc
	]

	eval-code: func [
		value	[red-value!]
		pc		[red-value!]
		end		[red-value!]
		sub?	[logic!]
		path	[red-path!]
		slot 	[red-value!]
		return: [red-value!]
		/local
			fun	   [red-function!]
			native [red-native!]
			s	   [series!]
			call
	][
		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				if verbose > 0 [log "pushing action/native frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot 	;-- fetch args and exec
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: action/native return type: " TYPE_OF(value)]
				]
			]
			TYPE_ROUTINE [
				if verbose > 0 [log "pushing routine frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot
				exec-routine as red-routine! value
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: routine return type: " TYPE_OF(value)]
				]
			]
			TYPE_FUNCTION [
				if verbose > 0 [log "pushing function frame"]
				stack/mark-func as red-word! pc	;@@
				pc: eval-arguments as red-native! value pc end path slot
				fun: as red-function! value
				s: as series! fun/more/value

				native: as red-native! s/offset + 2
				either zero? native/code [
					eval-function fun as red-block! s/offset
				][
					call: as function! [] native/code
					call
					0
				]
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: function return type: " TYPE_OF(value)]
				]
			]
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		prefix?	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			value  [red-value!]
			w	   [red-word!]
			sym	   [red-symbol!]
			op	   [red-value!]
			infix? [logic!]
	][
		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

		infix?: no
		unless prefix? [
			next: as red-word! pc + 1
			CHECK_INFIX
			if infix? [
				stack/mark-native as red-word! pc + 1
				sub?: yes								;-- force sub? for infix expressions
				op: value
			]
		]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no yes		;-- yes: push value on top of stack
				pc: eval-path value pc end yes
			]
			TYPE_GET_WORD [
				copy-cell _context/get as red-word! pc stack/push*
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				either sub? [
					w: word/push as red-word! pc		;-- nested expression: push value
				][
					w: as red-word! stack/set-last pc	;-- root expression: return value
				]
				w/header: TYPE_WORD						;-- coerce it to a word!
				pc: pc + 1
			]
			TYPE_WORD [
				if verbose > 0 [
					print "eval: '"
					print-symbol as red-word! pc
				]
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_UNSET [
						print-line "*** Error: word has no value!"
						either sub? [stack/push unset-value][stack/set-last unset-value]
					]
					TYPE_LIT_WORD [
						w: word/push as red-word! value	;-- push lit-word! on stack
						w/header: TYPE_WORD				;-- coerce it to a word!
					]
					TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: word return type: " TYPE_OF(value)]
						]
					]
				]
			]
			TYPE_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no
			]
			TYPE_LIT_PATH [
				value: stack/push pc
				value/header: TYPE_PATH
				pc: pc + 1
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]

		if infix? [
			pc: eval-infix op pc end sub?
			unless prefix? [
				either sub? [stack/unwind][stack/unwind-last]
			]
		]
		pc
	]

	eval-next: func [
		value	[red-value!]
		tail	[red-value!]
		sub?	[logic!]
		return: [red-value!]							;-- return start of next expression
	][
		stack/mark-native words/_body					;-- outer stack frame
		value: eval-expression value tail no sub?
		either sub? [stack/unwind][stack/unwind-last]
		value
	]

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			arg	  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			arg: stack/arguments
			arg/header: TYPE_UNSET
			exit
		]

		stack/mark-native words/_body					;-- outer stack frame

		while [value < tail][
			if verbose > 0 [log "root loop..."]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]

		stack/unwind-last
	]

]


FIX: issue #414 (Interpreter corrupts argument passing)

Red/System [
	Title:   "Red interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %interpreter.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 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
	}
]

#define EVAL_CHECK_INPUT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
]

#define EVAL_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "evaluating argument"]
	pc: eval-expression pc end no yes					;-- eval argument
	count: count + 1
]

#define EVAL_FETCH_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "fetching argument"]
	stack/push pc
	pc: pc + 1
	count: count + 1
]

interpreter: context [
	verbose: 0

	ref-array: as int-ptr! allocate 64 * size? integer!	;-- for natives/actions refinements handling
	offset: 0											;-- refinements counter for last call
	count:  0											;-- arguments counter for last call
	return-type: -1										;-- return type for routine calls

	log: func [msg [c-string!]][
		print "eval: "
		print-line msg
	]

	exec: func [
		native	  [red-native!]							;-- works for action! too
		/local
			index [integer!]
			call
	][
		call: as function! [] native/code
		index: 0
		if positive? offset [
			until [
				system/words/push ref-array/index
				index: index + 1
				offset: offset - 1
				zero? offset
			]
		]
		call
	]

	exec-routine: func [
		routine [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			call
	][
		s: as series! routine/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: count - 1								;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert true]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			op	  [red-op!]
			call-op
	][
		if verbose > 0 [log "infix detected!"]

		stack/mark-native as red-word! pc + 1
		eval-expression pc end yes	yes
		pc: pc + 2										;-- skip both left operand and operator
		pc: eval-expression pc end no yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op
		either sub? [stack/unwind][stack/unwind-last]

		if verbose > 0 [
			value: stack/arguments
			print-line ["eval: op return type: " TYPE_OF(value)]
		]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			s		  [series!]
			ref?	  [logic!]
	][
		function?: TYPE_OF(native) = TYPE_FUNCTION
		routine?:  TYPE_OF(native) = TYPE_ROUTINE

		s: as series! either any [function? routine?][
			fun: as red-function! native
			fun/spec/node/value
		][
			native/spec/value
		]
		value: s/offset
		tail:  s/tail

		count:  	 0
		offset: 	 0
		return-type: -1
		ref?:		 no

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD [
					either zero? offset [
						EVAL_ARGUMENT
					][
						either ref? [
							either any [function? routine?][
								none/push
							][
								ref-array/offset: count
								EVAL_ARGUMENT
							]
						][
							either any [function? routine?][
								none/push
							][
								ref-array/offset: -1
							]
						]
						offset: offset + 1
					]
				]
				TYPE_LIT_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_GET_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_REFINEMENT [
					ref?: no							;@@ set it correctly once path supported
					either any [function? routine?][
						;TBD: check here if refinement is used
						logic/push false
						offset: 1
					][
						ref-array/offset: -1
						offset: offset + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
					return pc
				]
				default [0]
			]
			value: value + 1
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		infix	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next  [red-word!]
			value [red-value!]
			fun	  [red-function!]
			w	  [red-word!]
			s	  [series!]
	][
		next: as red-word! pc + 1

		if all [
			not infix
			TYPE_OF(next) = TYPE_WORD
		][
			value: _context/get next
			if TYPE_OF(value) = TYPE_OP [
				return eval-infix value pc end sub?
			]
		]

		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc no
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				--NOT_IMPLEMENTED--
			]
			TYPE_GET_WORD [
				word/get as red-word! pc
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				w: word/push as red-word! pc			;-- push lit-word! on stack
				w/header: TYPE_WORD						;-- set correct value type on stack
				pc: pc + 1
			]
			TYPE_WORD [
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_ACTION
					TYPE_NATIVE [
						if verbose > 0 [log "pushing action/native frame"]
						stack/mark-native as red-word! pc
						pc: eval-arguments as red-native! value pc end
						exec as red-native! value
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: action/native return type: " TYPE_OF(value)]
						]
					]
					TYPE_ROUTINE [
						if verbose > 0 [log "pushing routine frame"]
						stack/mark-native as red-word! pc
						pc: eval-arguments as red-native! value pc end
						exec-routine as red-routine! value
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: routine return type: " TYPE_OF(value)]
						]
					]
					TYPE_FUNCTION [
						if verbose > 0 [log "pushing function frame"]
						stack/mark-func as red-word! pc	;@@
						pc: eval-arguments as red-native! value pc end
						fun: as red-function! value
						s: as series! fun/more/value
						;eval as red-block! s/offset	;@@ eval body version (add an option for that)
						exec as red-native! s/offset + 2
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: function return type: " TYPE_OF(value)]
						]
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: word return type: " TYPE_OF(value)]
						]
					]
				]
			]
			TYPE_PATH [
				--NOT_IMPLEMENTED--
			]
			TYPE_LIT_PATH [
				--NOT_IMPLEMENTED--
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]
		pc
	]

	eval-next: func [
		value	[red-value!]
		tail	[red-value!]
		return: [red-value!]							;-- return start of next expression
	][
		stack/mark-native words/_body					;-- outer stack frame
		value: eval-expression value tail no no
		stack/unwind-last
		value
	]

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			stack/set-last unset-value
			exit
		]

		stack/mark-native words/_body					;-- outer stack frame

		while [value < tail][
			if verbose > 0 [log "root loop..."]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]

		stack/unwind-last
	]

]

Red/System [
	Title:   "Red interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %interpreter.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 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
	}
]

#define EVAL_CHECK_INPUT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
]

#define EVAL_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "evaluating argument"]
	pc: eval-expression pc end no yes					;-- eval argument
	count: count + 1
]

#define EVAL_FETCH_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "fetching argument"]
	stack/push pc
	pc: pc + 1
	count: count + 1
]

interpreter: context [
	verbose: 0

	ref-array: as int-ptr! allocate 64 * size? integer!	;-- for natives/actions refinements handling
	offset: 0											;-- refinements counter for last call
	count:  0											;-- arguments counter for last call
	return-type: -1										;-- return type for routine calls

	log: func [msg [c-string!]][
		print "eval: "
		print-line msg
	]

	exec: func [
		native	  [red-native!]							;-- works for action! too
		/local
			index [integer!]
			call
	][
		call: as function! [] native/code
		index: 0
		if positive? offset [
			until [
				system/words/push ref-array/index
				index: index + 1
				offset: offset - 1
				zero? offset
			]
		]
		call
	]

	exec-routine: func [
		routine [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			call
	][
		s: as series! routine/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: count - 1								;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert true]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			op	  [red-op!]
			call-op
	][
		if verbose > 0 [log "infix detected!"]

		stack/mark-native as red-word! pc + 1
		eval-expression pc end yes	yes
		pc: pc + 2										;-- skip both left operand and operator
		pc: eval-expression pc end no yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op
		either sub? [stack/unwind][stack/unwind-last]

		if verbose > 0 [
			value: stack/arguments
			print-line ["eval: op return type: " TYPE_OF(value)]
		]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			s		  [series!]
			ref?	  [logic!]
	][
		function?: TYPE_OF(native) = TYPE_FUNCTION
		routine?:  TYPE_OF(native) = TYPE_ROUTINE

		s: as series! either any [function? routine?][
			fun: as red-function! native
			fun/spec/node/value
		][
			native/spec/value
		]
		value: s/offset
		tail:  s/tail

		count:  	 0
		offset: 	 0
		return-type: -1
		ref?:		 no

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD [
					either zero? offset [
						EVAL_ARGUMENT
					][
						either ref? [
							either any [function? routine?][
								none/push
							][
								ref-array/offset: count
								EVAL_ARGUMENT
							]
						][
							ref-array/offset: -1
						]
						offset: offset + 1
					]
				]
				TYPE_LIT_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_GET_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_REFINEMENT [
					ref?: no							;@@ set it correctly once path supported
					either any [function? routine?][
						;TBD: check here if refinement is used
						logic/push false
						offset: 1
					][
						ref-array/offset: -1
						offset: offset + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
					return pc
				]
				default [0]
			]
			value: value + 1
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		infix	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next  [red-word!]
			value [red-value!]
			fun	  [red-function!]
			w	  [red-word!]
			s	  [series!]
	][
		next: as red-word! pc + 1

		if all [
			not infix
			TYPE_OF(next) = TYPE_WORD
		][
			value: _context/get next
			if TYPE_OF(value) = TYPE_OP [
				return eval-infix value pc end sub?
			]
		]

		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc no
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				--NOT_IMPLEMENTED--
			]
			TYPE_GET_WORD [
				word/get as red-word! pc
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				w: word/push as red-word! pc			;-- push lit-word! on stack
				w/header: TYPE_WORD						;-- set correct value type on stack
				pc: pc + 1
			]
			TYPE_WORD [
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_ACTION
					TYPE_NATIVE [
						if verbose > 0 [log "pushing action/native frame"]
						stack/mark-native as red-word! pc
						pc: eval-arguments as red-native! value pc end
						exec as red-native! value
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: action/native return type: " TYPE_OF(value)]
						]
					]
					TYPE_ROUTINE [
						if verbose > 0 [log "pushing routine frame"]
						stack/mark-native as red-word! pc
						pc: eval-arguments as red-native! value pc end
						exec-routine as red-routine! value
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: routine return type: " TYPE_OF(value)]
						]
					]
					TYPE_FUNCTION [
						if verbose > 0 [log "pushing function frame"]
						stack/mark-func as red-word! pc	;@@
						pc: eval-arguments as red-native! value pc end
						fun: as red-function! value
						s: as series! fun/more/value
						;eval as red-block! s/offset	;@@ eval body version (add an option for that)
						exec as red-native! s/offset + 2
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: function return type: " TYPE_OF(value)]
						]
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: word return type: " TYPE_OF(value)]
						]
					]
				]
			]
			TYPE_PATH [
				--NOT_IMPLEMENTED--
			]
			TYPE_LIT_PATH [
				--NOT_IMPLEMENTED--
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]
		pc
	]

	eval-next: func [
		value	[red-value!]
		tail	[red-value!]
		return: [red-value!]							;-- return start of next expression
	][
		stack/mark-native words/_body					;-- outer stack frame
		value: eval-expression value tail no no
		stack/unwind-last
		value
	]

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			stack/set-last unset-value
			exit
		]

		stack/mark-native words/_body					;-- outer stack frame

		while [value < tail][
			if verbose > 0 [log "root loop..."]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]

		stack/unwind-last
	]

]


TESTS: added Red Find/only tests

TESTS: added Red Find/only tests

Red [
	Title:   "Red find test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %find-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

#include  %../../../../quick-test/quick-test.red

~~~start-file~~~ "find"

===start-group=== "find"
	--test-- "find-1"
	--assert [1 2 3 4] = find [1 2 3 4] 1
	--test-- "find-2"
	--assert [2 3 4] = find [1 2 3 4] 2
	--test-- "find-3"
	--assert [4] = find [1 2 3 4] 4
	--test-- "find-4"
	--assert none = find [1 2 3 4] 0
	--test-- "find-5"
	--assert none = find [1 2 3 4] 5
	--test-- "find-6"
	--assert none = find [1 2 3 4] "1"
	--test-- "find-7"
	--assert "12345" = find "12345" #"1"
	--test-- "find-8"
	--assert "12345" = find "12345" 1
	--test-- "find-9"
	--assert "12345" = find "12345" "1"
	--test-- "find-10"
	--assert "12345" = find "12345" "12"
	--test-- "find-11"
	--assert "2345" = find "12345" #"2"
	--test-- "find-12"
	--assert "5" = find "12345" #"5"
	--test-- "find-13"
	--assert none = find "12345" #"0"
	--test-- "find-14"
	--assert none = find "12345" #"6"
	--test-- "find-15"
	--assert [2 3] = find [1 2 3] [2 3]
	--test-- "find-16"
	--assert none = find [1 2 3] [3 2]
	--test-- "find-17"
	--assert [2 3] = find [1 2 2 3] [2 3]
	--test-- "find-18"
	--assert none = find [1 2] [2 3]
	--test-- "find-19"
	--assert "é" = find "abcdeé" "é"
	--test-- "find-20"
	--assert "eé" = find "abcdeé" "eé"
	--test-- "find-21"
	--assert none = find "abcdeé" "ée"
	--test-- "find-22"
	--assert "✐" = "abcde✐" "✐"            ;; code point 10000 (decimal)
	--test-- "find-23"
	--assert none = "abcde✐" "ed✐"
	--test-- "find-24"
	--assert "^(010000)" = find "abcde^(010000)" "^(010000)"
===end-group===

===start-group=== "find/part"
	--test-- "find/part-1"
	--assert none = find/part "1234" "1" 0
	--test-- "find/part-2"
	--assert "1234" = find/part "1234" "1" 1
	--test-- "find/part-3"
	--assert "234" = find/part "1234" "2" 2
	--test-- "find/part-4"
	--assert "234" = find/part "1234" "2" 4
	--test-- "find/part-5"
	--assert "234" = find/part "1234" "2" 5
	--test-- "find/part-6"
	--assert none = find/part "1234" "3" 2
	--test-- "find/part-7"
	--assert none = find/part [1 2 3 4] 1 0
	--test-- "find/part-8"
	--assert [1 2 3 4] = find/part [1 2 3 4] 1 1
	--test-- "find/part-9"
	--assert [2 3 4] = find/part [1 2 3 4] 2 2
	--test-- "find/part-10"
	--assert [2 3 4] = find/part [1 2 3 4] [2 3] 4
	--test-- "find/part-11"
	--assert none = find/part [1 2 3 4] [2 3] 2
	--test-- "find/part-12"
	--assert none = find/part [1 2 3 4] 3 2
===end-group===

===start-group=== "find/only"
	--test-- "find/only-1"
	--assert [[2 3] 4] = find/only [1 [2 3] 4] [2 3]
	--test-- "find/only-2"
	--assert none = find/only [1 2 3 4] [2 3]
===end-group===

~~~end-file~~~

Red [
	Title:   "Red find test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %find-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

#include  %../../../../quick-test/quick-test.red

~~~start-file~~~ "find"

===start-group=== "find"
	--test-- "find-1"
	--assert [1 2 3 4] = find [1 2 3 4] 1
	--test-- "find-2"
	--assert [2 3 4] = find [1 2 3 4] 2
	--test-- "find-3"
	--assert [4] = find [1 2 3 4] 4
	--test-- "find-4"
	--assert none = find [1 2 3 4] 0
	--test-- "find-5"
	--assert none = find [1 2 3 4] 5
	--test-- "find-6"
	--assert none = find [1 2 3 4] "1"
	--test-- "find-7"
	--assert "12345" = find "12345" #"1"
	--test-- "find-8"
	--assert "12345" = find "12345" 1
	--test-- "find-9"
	--assert "12345" = find "12345" "1"
	--test-- "find-10"
	--assert "12345" = find "12345" "12"
	--test-- "find-11"
	--assert "2345" = find "12345" #"2"
	--test-- "find-12"
	--assert "5" = find "12345" #"5"
	--test-- "find-13"
	--assert none = find "12345" #"0"
	--test-- "find-14"
	--assert none = find "12345" #"6"
	--test-- "find-15"
	--assert [2 3] = find [1 2 3] [2 3]
	--test-- "find-16"
	--assert none = find [1 2 3] [3 2]
	--test-- "find-17"
	--assert [2 3] = find [1 2 2 3] [2 3]
	--test-- "find-18"
	--assert none = find [1 2] [2 3]
	--test-- "find-19"
	--assert "é" = find "abcdeé" "é"
	--test-- "find-20"
	--assert "eé" = find "abcdeé" "eé"
	--test-- "find-21"
	--assert none = find "abcdeé" "ée"
	--test-- "find-22"
	--assert "✐" = "abcde✐" "✐"            ;; code point 10000 (decimal)
	--test-- "find-23"
	--assert none = "abcde✐" "ed✐"
	--test-- "find-24"
	--assert "^(010000)" = find "abcde^(010000)" "^(010000)"
===end-group===

===start-group=== "find/part"
	--test-- "find/part-1"
	--assert none = find/part "1234" "1" 0
	--test-- "find/part-2"
	--assert "1234" = find/part "1234" "1" 1
	--test-- "find/part-3"
	--assert "234" = find/part "1234" "2" 2
	--test-- "find/part-4"
	--assert "234" = find/part "1234" "2" 4
	--test-- "find/part-5"
	--assert "234" = find/part "1234" "2" 5
===end-group===

~~~end-file~~~


FIX: small comment fix

FIX: small comment fix

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

#define OS_DIR_SEP 47						;-- #"/"

#import [									;-- mandatory C bindings
	LIBC-file cdecl [
		sigaction: "sigaction" [
			signum	[integer!]
			action	[sigaction!]
			oldact	[sigaction!]
			return: [integer!]
		]
		sigemptyset: "sigemptyset" [
			mask	[integer!]
			return: [integer!]
		]
	]
]

stdin:  0
stdout: 1
stderr: 2

#if use-natives? = yes [
	prin: func [s [c-string!] return: [integer!]][
		write stdout s length? s
	]
]

;====== Catching runtime errors ======

;; sources:
;;		http://www.kernel.org/doc/man-pages/online/pages/man2/sigaction.2.html

#include %POSIX-signals.reds

posix-startup-ctx: context [

	UCTX_DEFINITION

	***-on-signal: func [
		[cdecl]
		signal	[integer!]
		info	[siginfo!]
		ctx		[_ucontext!]
		/local code error
	][
		error: 99								;-- default unknown error
		code: info/code

		error: switch signal [
			SIGILL [
				switch code [
					ILL_ILLOPC [17]				;-- illegal opcode
					ILL_ILLOPN [23]				;-- illegal operand
					ILL_ILLADR [24]				;-- illegal addressing mode
					ILL_ILLTRP [25]				;-- illegal trap
					ILL_PRVOPC [15]				;-- privileged opcode
					ILL_PRVREG [31]				;-- privileged register
					ILL_COPROC [26]				;-- coprocessor error
					ILL_BADSTK [19]				;-- internal stack error
					default    [99]
				]
			]
			SIGBUS [
				switch code [
					BUS_ADRALN    [2]			;-- invalid address alignment
					BUS_ADRERR   [27]			;-- non-existant physical address
					BUS_OBJERR   [28]			;-- object specific hardware error
					BUS_MCERR_AR [29]			;-- hardware memory error consumed (action required)
					BUS_MCERR_AO [30]			;-- hardware memory error consumed (action optional)
					default      [34]
				]
			]
			SIGFPE [
				switch code [
					FPE_INTDIV [13]				;-- integer divide by zero
					FPE_INTOVF [14]				;-- integer overflow
					FPE_FLTDIV  [7]				;-- floating point divide by zero
					FPE_FLTOVF [10]				;-- floating point overflow
					FPE_FLTUND [12]				;-- floating point underflow
					FPE_FLTRES  [8]				;-- floating point inexact result
					FPE_FLTINV  [9]				;-- floating point invalid operation
					FPE_FLTSUB  [5]				;-- subscript out of range
					default    [33]
				]
			]
			SIGSEGV [
				switch code [
					SEGV_MAPERR  [1]			;-- address not mapped to object
					SEGV_ACCERR [16]			;-- invalid permissions for mapped object
					default     [32]
				]
			]
		]

		***-on-quit error UCTX_INSTRUCTION(ctx)
	]

	init: does [
		__sigaction-options: declare sigaction!

		__sigaction-options/sigaction: 	as-integer :***-on-signal
		__sigaction-options/flags: 		SA_SIGINFO ;or SA_RESTART

		sigaction SIGILL  __sigaction-options as sigaction! 0
		sigaction SIGBUS  __sigaction-options as sigaction! 0
		sigaction SIGFPE  __sigaction-options as sigaction! 0
		sigaction SIGSEGV __sigaction-options as sigaction! 0
	]
]

#if OS <> 'MacOSX [								;-- OS X has it's own start code
	#switch type [
		dll [
			***-dll-entry-point: func [
				[cdecl]
			][
				***-main
				posix-startup-ctx/init
				on-load
			]
		]
		exe [
			posix-startup-ctx/init
		]
	]
]

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

#define OS_DIR_SEP 47						;-- #"\"

#import [									;-- mandatory C bindings
	LIBC-file cdecl [
		sigaction: "sigaction" [
			signum	[integer!]
			action	[sigaction!]
			oldact	[sigaction!]
			return: [integer!]
		]
		sigemptyset: "sigemptyset" [
			mask	[integer!]
			return: [integer!]
		]
	]
]

stdin:  0
stdout: 1
stderr: 2

#if use-natives? = yes [
	prin: func [s [c-string!] return: [integer!]][
		write stdout s length? s
	]
]

;====== Catching runtime errors ======

;; sources:
;;		http://www.kernel.org/doc/man-pages/online/pages/man2/sigaction.2.html

#include %POSIX-signals.reds

posix-startup-ctx: context [

	UCTX_DEFINITION

	***-on-signal: func [
		[cdecl]
		signal	[integer!]
		info	[siginfo!]
		ctx		[_ucontext!]
		/local code error
	][
		error: 99								;-- default unknown error
		code: info/code

		error: switch signal [
			SIGILL [
				switch code [
					ILL_ILLOPC [17]				;-- illegal opcode
					ILL_ILLOPN [23]				;-- illegal operand
					ILL_ILLADR [24]				;-- illegal addressing mode
					ILL_ILLTRP [25]				;-- illegal trap
					ILL_PRVOPC [15]				;-- privileged opcode
					ILL_PRVREG [31]				;-- privileged register
					ILL_COPROC [26]				;-- coprocessor error
					ILL_BADSTK [19]				;-- internal stack error
					default    [99]
				]
			]
			SIGBUS [
				switch code [
					BUS_ADRALN    [2]			;-- invalid address alignment
					BUS_ADRERR   [27]			;-- non-existant physical address
					BUS_OBJERR   [28]			;-- object specific hardware error
					BUS_MCERR_AR [29]			;-- hardware memory error consumed (action required)
					BUS_MCERR_AO [30]			;-- hardware memory error consumed (action optional)
					default      [34]
				]
			]
			SIGFPE [
				switch code [
					FPE_INTDIV [13]				;-- integer divide by zero
					FPE_INTOVF [14]				;-- integer overflow
					FPE_FLTDIV  [7]				;-- floating point divide by zero
					FPE_FLTOVF [10]				;-- floating point overflow
					FPE_FLTUND [12]				;-- floating point underflow
					FPE_FLTRES  [8]				;-- floating point inexact result
					FPE_FLTINV  [9]				;-- floating point invalid operation
					FPE_FLTSUB  [5]				;-- subscript out of range
					default    [33]
				]
			]
			SIGSEGV [
				switch code [
					SEGV_MAPERR  [1]			;-- address not mapped to object
					SEGV_ACCERR [16]			;-- invalid permissions for mapped object
					default     [32]
				]
			]
		]

		***-on-quit error UCTX_INSTRUCTION(ctx)
	]

	init: does [
		__sigaction-options: declare sigaction!

		__sigaction-options/sigaction: 	as-integer :***-on-signal
		__sigaction-options/flags: 		SA_SIGINFO ;or SA_RESTART

		sigaction SIGILL  __sigaction-options as sigaction! 0
		sigaction SIGBUS  __sigaction-options as sigaction! 0
		sigaction SIGFPE  __sigaction-options as sigaction! 0
		sigaction SIGSEGV __sigaction-options as sigaction! 0
	]
]

#if OS <> 'MacOSX [								;-- OS X has it's own start code
	#switch type [
		dll [
			***-dll-entry-point: func [
				[cdecl]
			][
				***-main
				posix-startup-ctx/init
				on-load
			]
		]
		exe [
			posix-startup-ctx/init
		]
	]
]