FIX: issue #776 (Infix operators creation from functions can't use local variables)

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
	]
	switch TYPE_OF(value) [
		TYPE_WORD [
			if verbose > 0 [log "evaluating argument"]
			pc: eval-expression pc end no yes
		]
		TYPE_GET_WORD [
			if verbose > 0 [log "fetching argument as-is"]
			stack/push pc
			pc: pc + 1
		]
		default [
			if verbose > 0 [log "fetching argument"]
			switch TYPE_OF(pc) [
				TYPE_GET_WORD [
					copy-cell _context/get as red-word! pc stack/push*
				]
				TYPE_PAREN [
					either TYPE_OF(value) = TYPE_LIT_WORD [
						stack/mark-native as red-word! pc	;@@ ~paren
						eval as red-block! pc yes
						stack/unwind
					][
						stack/push pc
					]
				]
				default [
					stack/push pc
				]
			]
			pc: pc + 1
		]
	]
]

interpreter: context [
	verbose: 0

	return-type: -1										;-- return type for routine calls
	in-func?:	 0										;@@ make it thread-safe?

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

	set-locals: func [
		fun [red-function!]
		/local
			tail  [red-value!]
			value [red-value!]
			s	  [series!]
			set?  [logic!]
	][
		s: as series! fun/spec/value
		value: s/offset
		tail:  s/tail
		set?:  no

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					if set? [none/push]
				]
				TYPE_REFINEMENT [
					unless set? [set?: yes]
					logic/push false
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]
	]

	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 [
		[catch]
		fun  [red-function!]
		body [red-block!]
		/local
			ctx	  [red-context!]
			saved [node!]
	][
		in-func?: in-func? + 1
		ctx: GET_CTX(fun)
		saved: ctx/values
		ctx/values: as node! stack/arguments
		eval body yes
		ctx/values: saved
		in-func?: in-func? - 1
	]

	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!]
			fun	   [red-function!]
			infix? [logic!]
			op	   [red-op!]
			s	   [series!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value

		either op/header and body-flag <> 0 [
			node: as node! op/code
			s: as series! node/value
			fun: as red-function! s/offset + 3
			either TYPE_OF(fun) = TYPE_ROUTINE [
				exec-routine as red-routine! fun
			][
				set-locals fun
				eval-function fun as red-block! s/offset
			]
		][
			call-op: as function! [] op/code
			call-op
			0											;-- @@ to make compiler happy!
		]

		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!]
			w		  [red-word!]
			blk		  [red-block!]
			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!]
			ret-set?  [logic!]
			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
		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? [
						blk: as red-block! value + 1
						either all [
							pc >= end
							TYPE_OF(value) = TYPE_LIT_WORD
							value + 1 < tail
							TYPE_OF(blk) = TYPE_BLOCK
							symbol/is-any-type? as red-word! block/pick blk 1 null	;-- check for [any-type!] spec
						][
							unset/push
						][
							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 [
					w: as red-word! value
					unless words/return* = symbol/resolve w/symbol [
						print "*** Error: invalid function definition: "
						print-symbol w
						print-line ":"
					]
					if routine? [
						ret-set?: yes
						value: block/pick (as red-block! value + 1) 1 null
						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 ret-set? [return-type: -1]				;-- set the default correctly in case of nested calls

		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: 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!]
			item   [red-value!]
			parent [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
		item:   head + 1
		saved:  stack/top

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

		parent: _context/get as red-word! head

		switch TYPE_OF(parent) [
			TYPE_ACTION								;@@ replace with TYPE_ANY_FUNCTION
			TYPE_NATIVE
			TYPE_ROUTINE
			TYPE_FUNCTION [
				pc: eval-code parent pc end yes path item - 1
				return pc
			]
			default [0]
		]

		while [item < tail][
			#if debug? = yes [if verbose > 0 [print-line ["eval: path parent: " TYPE_OF(parent)]]]

			value: either any [
				TYPE_OF(item) = TYPE_GET_WORD
				all [
					parent = head
					TYPE_OF(item) = TYPE_WORD
					TYPE_OF(parent) <> TYPE_OBJECT
				]
			][
				_context/get as red-word! item
			][
				item
			]
			switch TYPE_OF(value) [
				TYPE_UNSET [
					print-line "*** Error: word in path has no value!"
					stack/push parent
					return pc
				]
				TYPE_PAREN [
					stack/mark-native words/_body		;@@ ~paren
					eval as red-block! value yes		;-- eval paren content
					stack/unwind
					value: stack/top - 1
				]
				default [0]								;-- pass-thru
			]
			#if debug? = yes [if verbose > 0 [print-line ["eval: path item: " TYPE_OF(value)]]]

			parent: actions/eval-path parent value all [set? item + 1 = tail]

			switch TYPE_OF(parent) [
				TYPE_ACTION								;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code parent pc end yes path item
					return pc
				]
				default [0]
			]

			item: item + 1
		]

		stack/top: saved
		stack/push parent
		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
			name   [red-word!]
	][
		name: as red-word! pc - 1
		if TYPE_OF(name) <> TYPE_WORD [name: words/_anon]

		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				if verbose > 0 [log "pushing action/native frame"]
				stack/mark-native name
				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 name
				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 name
				pc: eval-arguments as red-native! value pc end path slot
				_function/call as red-function! value
				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!]
			op	   [red-value!]
			sym	   [integer!]
			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 yes
				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
					print lf
				]
				value: _context/get as red-word! pc

				if positive? in-func? [
					w: as red-word! pc
					sym: w/symbol
					case [
						sym = words/exit* [
							copy-cell unset-value stack/arguments
							stack/unroll-last stack/FLAG_FUNCTION
							throw THROWN_EXIT
						]
						sym = words/return* [
							pc: pc + 1
							either pc >= end [
								copy-cell unset-value stack/arguments
							][
								pc: eval-expression pc end no yes
							]
							stack/unroll-last stack/FLAG_FUNCTION
							throw THROWN_RETURN
						]
						true [0]
					]
				]
				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 [
						word/push as red-word! value	;-- push lit-word! on stack
					]
					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!]
		chain? [logic!]									;-- chain it with previous stack frame
		/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-eval 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]
		]
		either chain? [stack/unwind-last][stack/unwind]
	]

]

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
	]
	switch TYPE_OF(value) [
		TYPE_WORD [
			if verbose > 0 [log "evaluating argument"]
			pc: eval-expression pc end no yes
		]
		TYPE_GET_WORD [
			if verbose > 0 [log "fetching argument as-is"]
			stack/push pc
			pc: pc + 1
		]
		default [
			if verbose > 0 [log "fetching argument"]
			switch TYPE_OF(pc) [
				TYPE_GET_WORD [
					copy-cell _context/get as red-word! pc stack/push*
				]
				TYPE_PAREN [
					either TYPE_OF(value) = TYPE_LIT_WORD [
						stack/mark-native as red-word! pc	;@@ ~paren
						eval as red-block! pc yes
						stack/unwind
					][
						stack/push pc
					]
				]
				default [
					stack/push pc
				]
			]
			pc: pc + 1
		]
	]
]

interpreter: context [
	verbose: 0

	return-type: -1										;-- return type for routine calls
	in-func?:	 0										;@@ make it thread-safe?

	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 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 [
		[catch]
		fun  [red-function!]
		body [red-block!]
		/local
			ctx	  [red-context!]
			saved [node!]
	][
		in-func?: in-func? + 1
		ctx: GET_CTX(fun)
		saved: ctx/values
		ctx/values: as node! stack/arguments
		eval body yes
		ctx/values: saved
		in-func?: in-func? - 1
	]

	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!]
			fun	   [red-value!]
			infix? [logic!]
			op	   [red-op!]
			s	   [series!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value

		either op/header and body-flag <> 0 [
			node: as node! op/code
			s: as series! node/value
			fun: s/offset + 3
			either TYPE_OF(fun) = TYPE_ROUTINE [
				exec-routine as red-routine! fun
			][
				eval-function as red-function! fun as red-block! s/offset
			]
		][
			call-op: as function! [] op/code
			call-op
			0											;-- @@ to make compiler happy!
		]

		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!]
			w		  [red-word!]
			blk		  [red-block!]
			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!]
			ret-set?  [logic!]
			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
		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? [
						blk: as red-block! value + 1
						either all [
							pc >= end
							TYPE_OF(value) = TYPE_LIT_WORD
							value + 1 < tail
							TYPE_OF(blk) = TYPE_BLOCK
							symbol/is-any-type? as red-word! block/pick blk 1 null	;-- check for [any-type!] spec
						][
							unset/push
						][
							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 [
					w: as red-word! value
					unless words/return* = symbol/resolve w/symbol [
						print "*** Error: invalid function definition: "
						print-symbol w
						print-line ":"
					]
					if routine? [
						ret-set?: yes
						value: block/pick (as red-block! value + 1) 1 null
						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 ret-set? [return-type: -1]				;-- set the default correctly in case of nested calls

		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: 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!]
			item   [red-value!]
			parent [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
		item:   head + 1
		saved:  stack/top

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

		parent: _context/get as red-word! head

		switch TYPE_OF(parent) [
			TYPE_ACTION								;@@ replace with TYPE_ANY_FUNCTION
			TYPE_NATIVE
			TYPE_ROUTINE
			TYPE_FUNCTION [
				pc: eval-code parent pc end yes path item - 1
				return pc
			]
			default [0]
		]

		while [item < tail][
			#if debug? = yes [if verbose > 0 [print-line ["eval: path parent: " TYPE_OF(parent)]]]

			value: either any [
				TYPE_OF(item) = TYPE_GET_WORD
				all [
					parent = head
					TYPE_OF(item) = TYPE_WORD
					TYPE_OF(parent) <> TYPE_OBJECT
				]
			][
				_context/get as red-word! item
			][
				item
			]
			switch TYPE_OF(value) [
				TYPE_UNSET [
					print-line "*** Error: word in path has no value!"
					stack/push parent
					return pc
				]
				TYPE_PAREN [
					stack/mark-native words/_body		;@@ ~paren
					eval as red-block! value yes		;-- eval paren content
					stack/unwind
					value: stack/top - 1
				]
				default [0]								;-- pass-thru
			]
			#if debug? = yes [if verbose > 0 [print-line ["eval: path item: " TYPE_OF(value)]]]

			parent: actions/eval-path parent value all [set? item + 1 = tail]

			switch TYPE_OF(parent) [
				TYPE_ACTION								;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code parent pc end yes path item
					return pc
				]
				default [0]
			]

			item: item + 1
		]

		stack/top: saved
		stack/push parent
		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
			name   [red-word!]
	][
		name: as red-word! pc - 1
		if TYPE_OF(name) <> TYPE_WORD [name: words/_anon]

		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				if verbose > 0 [log "pushing action/native frame"]
				stack/mark-native name
				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 name
				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 name
				pc: eval-arguments as red-native! value pc end path slot
				_function/call as red-function! value
				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!]
			op	   [red-value!]
			sym	   [integer!]
			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 yes
				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
					print lf
				]
				value: _context/get as red-word! pc

				if positive? in-func? [
					w: as red-word! pc
					sym: w/symbol
					case [
						sym = words/exit* [
							copy-cell unset-value stack/arguments
							stack/unroll-last stack/FLAG_FUNCTION
							throw THROWN_EXIT
						]
						sym = words/return* [
							pc: pc + 1
							either pc >= end [
								copy-cell unset-value stack/arguments
							][
								pc: eval-expression pc end no yes
							]
							stack/unroll-last stack/FLAG_FUNCTION
							throw THROWN_RETURN
						]
						true [0]
					]
				]
				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 [
						word/push as red-word! value	;-- push lit-word! on stack
					]
					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!]
		chain? [logic!]									;-- chain it with previous stack frame
		/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-eval 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]
		]
		either chain? [stack/unwind-last][stack/unwind]
	]

]


TESTS: update run-all-inter.red to include object-test.red

Red []
	#include %../quick-test/quick-test.red
	***start-run*** "Testing Red Interpreter"
	#include %source/units/auto-tests/interpreter-binding-test.red
  	#include %source/units/auto-tests/interpreter-case-test.red
  	#include %source/units/auto-tests/interpreter-conditional-test.red
  	#include %source/units/auto-tests/interpreter-evaluation-test.red
  	#include %source/units/auto-tests/interpreter-find-test.red
  	#include %source/units/auto-tests/interpreter-function-test.red
  	#include %source/units/auto-tests/interpreter-load-test.red
  	#include %source/units/auto-tests/interpreter-logic-test.red
  	#include %source/units/auto-tests/interpreter-loop-test.red
  	#include %source/units/auto-tests/interpreter-select-test.red
  	#include %source/units/auto-tests/interpreter-serialization-test.red
  	#include %source/units/auto-tests/interpreter-series-test.red
  	#include %source/units/auto-tests/interpreter-type-test.red
  	#include %source/units/auto-tests/interpreter-switch-test.red
  	#include %source/units/auto-tests/interpreter-append-test.red
  	#include %source/units/auto-tests/interpreter-insert-test.red
  	#include %source/units/auto-tests/interpreter-system-test.red
  	#include %source/units/auto-tests/interp-parse-test.red
  	#include %source/units/auto-tests/interp-bitset-test.red
  	#include %source/units/auto-tests/interp-equal-auto-test.red
  	#include %source/units/auto-tests/interp-greater-auto-test.red
  	#include %source/units/auto-tests/interp-inf-equal-auto-test.red
  	#include %source/units/auto-tests/interp-strict-equal-test.red
  	#include %source/units/auto-tests/interp-inf-greater-auto-test.red
  	#include %source/units/auto-tests/interp-inf-lesser-auto-test.red
  	#include %source/units/auto-tests/interp-inf-lesser-equal-auto-test.red
  	#include %source/units/auto-tests/interp-inf-not-equal-auto-test.red
  	#include %source/units/auto-tests/interp-integer-auto-test.red
  	#include %source/units/auto-tests/interp-float-auto-test.red
  	#include %source/units/auto-tests/interp-lesser-auto-test.red
  	#include %source/units/auto-tests/interp-lesser-equal-auto-test.red
  	#include %source/units/auto-tests/interp-not-equal-auto-test.red
  	#include %source/units/auto-tests/interp-integer-test.red
  	#include %source/units/auto-tests/interp-float-test.red
  	#include %source/units/auto-tests/interp-char-test.red
  	#include %source/units/auto-tests/interp-object-test.red
  	#include %source/units/auto-tests/interp-same-test.red
  	***end-run***

Red []
	#include %../quick-test/quick-test.red
	***start-run*** "Testing Red Interpreter"
	#include %source/units/auto-tests/interpreter-binding-test.red
  	#include %source/units/auto-tests/interpreter-case-test.red
  	#include %source/units/auto-tests/interpreter-conditional-test.red
  	#include %source/units/auto-tests/interpreter-evaluation-test.red
  	#include %source/units/auto-tests/interpreter-find-test.red
  	#include %source/units/auto-tests/interpreter-function-test.red
  	#include %source/units/auto-tests/interpreter-load-test.red
  	#include %source/units/auto-tests/interpreter-logic-test.red
  	#include %source/units/auto-tests/interpreter-loop-test.red
  	#include %source/units/auto-tests/interpreter-select-test.red
  	#include %source/units/auto-tests/interpreter-serialization-test.red
  	#include %source/units/auto-tests/interpreter-series-test.red
  	#include %source/units/auto-tests/interpreter-type-test.red
  	#include %source/units/auto-tests/interpreter-switch-test.red
  	#include %source/units/auto-tests/interpreter-append-test.red
  	#include %source/units/auto-tests/interpreter-insert-test.red
  	#include %source/units/auto-tests/interpreter-system-test.red
  	#include %source/units/auto-tests/interp-parse-test.red
  	#include %source/units/auto-tests/interp-bitset-test.red
  	#include %source/units/auto-tests/interp-equal-auto-test.red
  	#include %source/units/auto-tests/interp-greater-auto-test.red
  	#include %source/units/auto-tests/interp-inf-equal-auto-test.red
  	#include %source/units/auto-tests/interp-strict-equal-test.red
  	#include %source/units/auto-tests/interp-inf-greater-auto-test.red
  	#include %source/units/auto-tests/interp-inf-lesser-auto-test.red
  	#include %source/units/auto-tests/interp-inf-lesser-equal-auto-test.red
  	#include %source/units/auto-tests/interp-inf-not-equal-auto-test.red
  	#include %source/units/auto-tests/interp-integer-auto-test.red
  	#include %source/units/auto-tests/interp-float-auto-test.red
  	#include %source/units/auto-tests/interp-lesser-auto-test.red
  	#include %source/units/auto-tests/interp-lesser-equal-auto-test.red
  	#include %source/units/auto-tests/interp-not-equal-auto-test.red
  	#include %source/units/auto-tests/interp-integer-test.red
  	#include %source/units/auto-tests/interp-float-test.red
  	#include %source/units/auto-tests/interp-char-test.red
  	#include %source/units/auto-tests/interp-same-test.red
  	***end-run***


FEAT: runtime error catching now fully supported for ARM.

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

sigaction!: alias struct! [
	handler		[integer!]					;-- Warning: compiled as union on most UNIX
	mask0		[integer!]					;-- glibc/Hurd insane inheritage...
	mask1		[integer!]
	mask2		[integer!]
	mask3		[integer!]
	mask4		[integer!]
	mask5		[integer!]
	mask6		[integer!]
	mask7		[integer!]
	mask8		[integer!]
	mask9		[integer!]
	mask10		[integer!]
	mask11		[integer!]
	mask12		[integer!]
	mask13		[integer!]
	mask14		[integer!]
	mask15		[integer!]
	mask16		[integer!]
	mask17		[integer!]
	mask18		[integer!]
	mask19		[integer!]
	mask20		[integer!]
	mask21		[integer!]
	mask22		[integer!]
	mask23		[integer!]
	mask24		[integer!]
	mask25		[integer!]
	mask26		[integer!]
	mask27		[integer!]
	mask28		[integer!]
	mask29		[integer!]
	mask30		[integer!]
	mask31		[integer!]
	flags		[integer!]
]

siginfo!: alias struct! [
	signal		[integer!]
	error		[integer!]
	code		[integer!]
	address		[integer!]					;-- this field is a C union, dependent on signal
]

#import [									;-- mandatory C bindings
	LIBC-file cdecl [
		sigaction: "sigaction" [
			signum	[integer!]
			action	[sigaction!]
			oldact	[sigaction!]
			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
;; 		http://fxr.watson.org/fxr/source/include/asm-generic/siginfo.h?v=linux-2.6;im=excerpts#L161

#define	SIGILL		 4						;-- Illegal instruction
#define SIGBUS		 7						;-- Bus access error
#define	SIGFPE		 8						;-- Floating point error
#define	SIGSEGV		11						;-- Segmentation violation

#switch target [
	IA-32 [
		_ucontext!: alias struct! [
			flags 		[integer!]
			link		[_ucontext!]
			ss_sp		[byte-ptr!]					;-- stack_t struct inlined
			ss_flags	[integer!]
			ss_size		[integer!]
			gs			[integer!]					;-- sigcontext struct inlined
			fs			[integer!]
			es			[integer!]
			ds			[integer!]
			edi			[integer!]
			esi			[integer!]
			ebp			[integer!]
			esp			[integer!]
			ebx			[integer!]
			edx			[integer!]
			ecx			[integer!]
			eax			[integer!]
			trapno		[integer!]
			err			[integer!]
			eip			[integer!]
			cs			[integer!]
			eflags		[integer!]
			esp_at_sig	[integer!]
			ss			[integer!]
			fpstate		[int-ptr!]
			oldmask		[integer!]
			cr2			[integer!]
			;sigmask	[...]						;-- 128 byte array ignored
		]
	]
	ARM [
		_ucontext!: alias struct! [
			flags 		[integer!]
			link		[_ucontext!]
			ss_sp		[byte-ptr!]					;-- stack_t struct inlined
			ss_flags	[integer!]
			ss_size		[integer!]
			trap_no		[integer!]
			error_code	[integer!]
			oldmask		[integer!]
			arm_r0		[integer!]
			arm_r1		[integer!]
			arm_r2		[integer!]
			arm_r3		[integer!]
			arm_r4		[integer!]
			arm_r5		[integer!]
			arm_r6		[integer!]
			arm_r7		[integer!]
			arm_r8		[integer!]
			arm_r9		[integer!]
			arm_r10		[integer!]
			arm_fp		[integer!]
			arm_ip		[integer!]
			arm_sp		[integer!]
			arm_lr		[integer!]
			arm_pc		[integer!]
			arm_cpsr	[integer!]
			fault_address [integer!]
			;sigmask	[...]						;-- 128 byte array ignored
		]
	]
]

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

	if signal = SIGILL [
		if code = 1 [error: 17]				;-- illegal opcode
		if code = 2 [error: 23]				;-- illegal operand
		if code = 3 [error: 24]				;-- illegal addressing mode
		if code = 4 [error: 25]				;-- illegal trap
		if code = 5 [error: 15]				;-- privileged opcode
		if code = 6 [error: 31]				;-- privileged register
		if code = 7 [error: 26]				;-- coprocessor error
		if code = 8 [error: 19]				;-- internal stack error
	]
	if signal = SIGBUS [
		if code = 1 [error:  2]				;-- invalid address alignment
		if code = 2 [error: 27]				;-- non-existant physical address
		if code = 3 [error: 28]				;-- object specific hardware error
		if code = 4 [error: 29]				;-- hardware memory error consumed (action required)
		if code = 5 [error: 30]				;-- hardware memory error consumed (action optional)
	]
	if signal = SIGFPE [
		if code = 1 [error: 13]				;-- integer divide by zero
		if code = 2 [error: 14]				;-- integer overflow
		if code = 3 [error:  7]				;-- floating point divide by zero
		if code = 4 [error: 10]				;-- floating point overflow
		if code = 5 [error: 12]				;-- floating point underflow
		if code = 6 [error:  8]				;-- floating point inexact result
		if code = 7 [error:  9]				;-- floating point invalid operation
		if code = 8 [error:  5]				;-- subscript out of range
	]
	if signal = SIGSEGV [
		if code = 1 [error:  1]				;-- address not mapped to object
		if code = 2 [error: 16]				;-- invalid permissions for mapped object
	]

	#switch target [
		IA-32 [***-on-quit error ctx/eip]
		ARM	  [***-on-quit error ctx/arm_pc]
	]
]

__sigaction-options: declare sigaction!

__sigaction-options/handler: 	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

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

sigaction!: alias struct! [
	handler		[integer!]					;-- Warning: compiled as union on most UNIX
	mask0		[integer!]					;-- glibc/Hurd insane inheritage...
	mask1		[integer!]
	mask2		[integer!]
	mask3		[integer!]
	mask4		[integer!]
	mask5		[integer!]
	mask6		[integer!]
	mask7		[integer!]
	mask8		[integer!]
	mask9		[integer!]
	mask10		[integer!]
	mask11		[integer!]
	mask12		[integer!]
	mask13		[integer!]
	mask14		[integer!]
	mask15		[integer!]
	mask16		[integer!]
	mask17		[integer!]
	mask18		[integer!]
	mask19		[integer!]
	mask20		[integer!]
	mask21		[integer!]
	mask22		[integer!]
	mask23		[integer!]
	mask24		[integer!]
	mask25		[integer!]
	mask26		[integer!]
	mask27		[integer!]
	mask28		[integer!]
	mask29		[integer!]
	mask30		[integer!]
	mask31		[integer!]
	flags		[integer!]
]

siginfo!: alias struct! [
	signal		[integer!]
	error		[integer!]
	code		[integer!]
	address		[integer!]					;-- this field is a C union, dependent on signal
]

#import [									;-- mandatory C bindings
	LIBC-file cdecl [
		sigaction: "sigaction" [
			signum	[integer!]
			action	[sigaction!]
			oldact	[sigaction!]
			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
;; 		http://fxr.watson.org/fxr/source/include/asm-generic/siginfo.h?v=linux-2.6;im=excerpts#L161

#define	SIGILL		 4						;-- Illegal instruction
#define SIGBUS		 7						;-- Bus access error
#define	SIGFPE		 8						;-- Floating point error
#define	SIGSEGV		11						;-- Segmentation violation

_ucontext!: alias struct! [					;@@ CPU-dependent
	flags 		[integer!]
	link		[_ucontext!]
	ss_sp		[byte-ptr!]					;-- stack_t struct inlined
	ss_flags	[integer!]
	ss_size		[integer!]
	gs			[integer!]					;-- sigcontext struct inlined
	fs			[integer!]
	es			[integer!]
	ds			[integer!]
	edi			[integer!]
	esi			[integer!]
	ebp			[integer!]
	esp			[integer!]
	ebx			[integer!]
	edx			[integer!]
	ecx			[integer!]
	eax			[integer!]
	trapno		[integer!]
	err			[integer!]
	eip			[integer!]
	cs			[integer!]
	eflags		[integer!]
	esp_at_sig	[integer!]
	ss			[integer!]
	fpstate		[int-ptr!]
	oldmask		[integer!]
	cr2			[integer!]
	;sigmask	[...]						;-- 128 byte array ignored
]

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

	if signal = SIGILL [
		if code = 1 [error: 17]				;-- illegal opcode
		if code = 2 [error: 23]				;-- illegal operand
		if code = 3 [error: 24]				;-- illegal addressing mode
		if code = 4 [error: 25]				;-- illegal trap
		if code = 5 [error: 15]				;-- privileged opcode
		if code = 6 [error: 31]				;-- privileged register
		if code = 7 [error: 26]				;-- coprocessor error
		if code = 8 [error: 19]				;-- internal stack error
	]
	if signal = SIGBUS [
		if code = 1 [error:  2]				;-- invalid address alignment
		if code = 2 [error: 27]				;-- non-existant physical address
		if code = 3 [error: 28]				;-- object specific hardware error
		if code = 4 [error: 29]				;-- hardware memory error consumed (action required)
		if code = 5 [error: 30]				;-- hardware memory error consumed (action optional)
	]
	if signal = SIGFPE [
		if code = 1 [error: 13]				;-- integer divide by zero
		if code = 2 [error: 14]				;-- integer overflow
		if code = 3 [error:  7]				;-- floating point divide by zero
		if code = 4 [error: 10]				;-- floating point overflow
		if code = 5 [error: 12]				;-- floating point underflow
		if code = 6 [error:  8]				;-- floating point inexact result
		if code = 7 [error:  9]				;-- floating point invalid operation
		if code = 8 [error:  5]				;-- subscript out of range
	]
	if signal = SIGSEGV [
		if code = 1 [error:  1]				;-- address not mapped to object
		if code = 2 [error: 16]				;-- invalid permissions for mapped object
	]

	***-on-quit error ctx/eip
]

__sigaction-options: declare sigaction!

__sigaction-options/handler: 	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


FIX: Case replaced by switch

FIX: Case replaced by switch

Red/System [
  Title:   "Red/System syscall binding"
  Author:  "Bruno Anselme"
  EMail:   "be.red@free.fr"
  File:    %call.reds
  Rights:  "Copyright (c) 2014 Bruno Anselme"
  License: {
    Distributed under the Boost Software License, Version 1.0.
    See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
  }
  Needs: {
    Red/System >= 0.4.1
  }
  Purpose: {
    This binding implements a call function for Red/System (similar to rebol's call function).
    POSIX version uses "wordexp" function to perform word expansion.
    Windows version performs home made string parsing (no expansion nor substitution).
    Any proposal to improve this parsing (with native Windows functions) is welcome.
  }
  Reference: {
    POSIX's wordexp :
      http://pubs.opengroup.org/onlinepubs/9699919799/functions/wordexp.html
  }
]

#include %../stdio.reds
#include %../unistd.reds

syscalls: context [

  free-str-array: func [args [str-array!] /local n][ ; free str-array! created by word-expand
    n: 0
    while [ args/item <> null ][
      free as byte-ptr! args/item
      args: args + 1
      n: n + 1
    ]
    args: args  - n
    free as byte-ptr! args
  ]
  print-str-array: func [ args [str-array!]][        ; used for debug
    while [ args/item <> null ][
      print [ "- " args/item lf ]
      args: args + 1
    ]
  ]
  word-expand: func [
    cmd          [c-string!]
    return:      [str-array!]
    /local
    args-list    [str-array!]
    s-length     [integer!]     ; command length
    n s c        [integer!]     ; number of strings
    str          [c-string!]
  ][
    s-length: length? cmd
    str: make-c-string length? cmd
    args-list: as str-array! allocate (100 * size? c-string!)          ; FIX: Should test memory allocation
    s-length: s-length + 1
    c: 1  ; reset command index
    s: 1  ; reset string index
    n: 0  ; string count
    until [
      switch cmd/c [
        #" "
        null-byte [
          if s > 1 [
            str/s: null-byte                                           ; add termination null-byte to current string
            args-list/item: make-c-string s
            copy-memory as byte-ptr! args-list/item as byte-ptr! str s ; copy string into args-list
            args-list: args-list + 1
            n: n + 1
            s: 1
          ]
        ]
        default  [
          str/s: cmd/c                                                 ; add char to current string index
          s: s + 1
        ]
      ]
      c: c + 1
      c > s-length
    ]
    args-list/item: null
    args-list: args-list - n    ; reset string array
    args-list: as str-array! re-allocate as byte-ptr! args-list ((n + 1) * size? c-string!)  ; FIX: Should test memory allocation
    free as byte-ptr! str
;    print-str-array args-list  ; Debug: Print expanded values
    return args-list
  ]

  #switch OS [
    Windows   [      ; Windows, use home made parsing
      call: func [                     "Executes a DOS command to run another process."
        cmd          [c-string!]       "Command line"
        waitend      [logic!]
        return:      [integer!]
        /local
        status       [integer!]
        args         [str-array!]
        pid          [integer!]
      ][
        args: word-expand cmd
        pid: 0
        either waitend [
          pid: spawnvp P_WAIT   args/item args    ; Windows : wait until end of process
        ][
          pid: spawnvp P_NOWAIT args/item args    ; Windows : continues to execute the calling process
        ]
        free-str-array args
        return pid
      ] ; call
    ] ; Windows
    #default  [      ; POSIX, use wordexp parsing
      call: func [                     "Executes a shell command to run another process."
        cmd          [c-string!]       "The shell command"
        waitend      [logic!]
        return:      [integer!]
        /local
        pid          [integer!]
        wexp         [wordexp-type!]
        status       [integer!]
      ][
        pid: fork
        either pid = 0 [    ; Child process
          wexp: as wordexp-type! allocate size? wordexp-type!   ; Create wordexp struct
          status: wordexp cmd wexp __WRDE_FLAGS                 ; Parse cmd into str-array
          either status = 0 [ ; Parsing ok
;            print-str-array wexp/we_wordv                      ; Debug: Print expanded values
            execvp wexp/we_wordv/item wexp/we_wordv             ; Call execvp with str-array parameters
            print [ "Error while calling execvp : {" cmd "}" lf ]           ; Should never occur
            quit 1
          ][                 ; Parsing nok
            print [ "Error wordexp parsing command : " cmd lf ]
            switch status [
              WRDE_NOSPACE [ print [ "Attempt to allocate memory failed" lf ] ]
              WRDE_BADCHAR [ print [ "Use of the unquoted characters- <newline>, '|', '&', ';', '<', '>', '(', ')', '{', '}'" lf ] ]
              WRDE_BADVAL  [ print [ "Reference to undefined shell variable" lf ] ]
              WRDE_CMDSUB  [ print [ "Command substitution requested" lf ] ]
              WRDE_SYNTAX  [ print [ "Shell syntax error, such as unbalanced parentheses or unterminated string" lf ] ]
            ]
            quit status
          ]
        ][                  ; Parent process
          status: 0
          if waitend [
            wait :status    ; Wait child process terminate
            pid: 0          ; Return 0 after a synchronous process
          ]
        ]
        return pid
      ] ; call
    ] ; #default
  ] ; #switch
] ; context

Red/System [
  Title:   "Red/System syscall binding"
  Author:  "Bruno Anselme"
  EMail:   "be.red@free.fr"
  File:    %call.reds
  Rights:  "Copyright (c) 2014 Bruno Anselme"
  License: {
    Distributed under the Boost Software License, Version 1.0.
    See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
  }
  Needs: {
    Red/System >= 0.4.1
  }
  Purpose: {
    This binding implements a call function for Red/System (similar to rebol's call function).
    POSIX version uses "wordexp" function to perform word expansion.
    Windows version performs home made string parsing (no expansion nor substitution).
    Any proposal to improve this parsing (with native Windows functions) is welcome.
  }
  Reference: {
    POSIX's wordexp :
      http://pubs.opengroup.org/onlinepubs/9699919799/functions/wordexp.html
  }
]

#include %../stdio.reds
#include %../unistd.reds

syscalls: context [

  free-str-array: func [args [str-array!] /local n][ ; free str-array! created by word-expand
    n: 0
    while [ args/item <> null ][
      free as byte-ptr! args/item
      args: args + 1
      n: n + 1
    ]
    args: args  - n
    free as byte-ptr! args
  ]
  print-str-array: func [ args [str-array!]][        ; used for debug
    while [ args/item <> null ][
      print [ "- " args/item lf ]
      args: args + 1
    ]
  ]
  word-expand: func [
    cmd          [c-string!]
    return:      [str-array!]
    /local
    args-list    [str-array!]
    s-length     [integer!]     ; command length
    n s c        [integer!]     ; number of strings
    str          [c-string!]
  ][
    s-length: length? cmd
    str: make-c-string length? cmd
    args-list: as str-array! allocate (100 * size? c-string!)          ; FIX: Should test memory allocation
    s-length: s-length + 1
    c: 1  ; reset command index
    s: 1  ; reset string index
    n: 0  ; string count
    until [
      switch cmd/c [
        #" "
        null-byte [
          if s > 1 [
            str/s: null-byte                                           ; add termination null-byte to current string
            args-list/item: make-c-string s
            copy-memory as byte-ptr! args-list/item as byte-ptr! str s ; copy string into args-list
            args-list: args-list + 1
            n: n + 1
            s: 1
          ]
        ]
        default  [
          str/s: cmd/c                                                 ; add char to current string index
          s: s + 1
        ]
      ]
      c: c + 1
      c > s-length
    ]
    args-list/item: null
    args-list: args-list - n    ; reset string array
    args-list: as str-array! re-allocate as byte-ptr! args-list ((n + 1) * size? c-string!)  ; FIX: Should test memory allocation
    free as byte-ptr! str
;    print-str-array args-list  ; Debug: Print expanded values
    return args-list
  ]

  #switch OS [
    Windows   [      ; Windows, use home made parsing
      call: func [                     "Executes a DOS command to run another process."
        cmd          [c-string!]       "Command line"
        waitend      [logic!]
        return:      [integer!]
        /local
        status       [integer!]
        args         [str-array!]
        pid          [integer!]
      ][
        args: word-expand cmd
        pid: 0
        either waitend [
          pid: spawnvp P_WAIT   args/item args    ; Windows : wait until end of process
        ][
          pid: spawnvp P_NOWAIT args/item args    ; Windows : continues to execute the calling process
        ]
        free-str-array args
        return pid
      ] ; call
    ] ; Windows
    #default  [      ; POSIX, use wordexp parsing
      call: func [                     "Executes a shell command to run another process."
        cmd          [c-string!]       "The shell command"
        waitend      [logic!]
        return:      [integer!]
        /local
        pid          [integer!]
        wexp         [wordexp-type!]
        status       [integer!]
      ][
        pid: fork
        either pid = 0 [    ; Child process
          wexp: as wordexp-type! allocate size? wordexp-type!   ; Create wordexp struct
          status: wordexp cmd wexp __WRDE_FLAGS                 ; Parse cmd into str-array
          either status = 0 [ ; Parsing ok
;            print-str-array wexp/we_wordv                      ; Debug: Print expanded values
            execvp wexp/we_wordv/item wexp/we_wordv             ; Call execvp with str-array parameters
            print [ "Error while calling execvp : {" cmd "}" lf ]           ; Should never occur
            quit 1
          ][                 ; Parsing nok
            print [ "Error wordexp parsing command : " cmd lf ]
            case [
              status = WRDE_NOSPACE [ print [ "Attempt to allocate memory failed" lf ] ]
              status = WRDE_BADCHAR [ print [ "Use of the unquoted characters- <newline>, '|', '&', ';', '<', '>', '(', ')', '{', '}'" lf ] ]
              status = WRDE_BADVAL  [ print [ "Reference to undefined shell variable" lf ] ]
              status = WRDE_CMDSUB  [ print [ "Command substitution requested" lf ] ]
              status = WRDE_SYNTAX  [ print [ "Shell syntax error, such as unbalanced parentheses or unterminated string" lf ] ]
            ]
            quit status
          ]
        ][                  ; Parent process
          status: 0
          if waitend [
            wait :status    ; Wait child process terminate
            pid: 0          ; Return 0 after a synchronous process
          ]
        ]
        return pid
      ] ; call
    ] ; #default
  ] ; #switch
] ; context


FIX: issue #715 (String corruption with control characters)

Red [
	Title:   "Red runtime lexer"
	Author:  "Nenad Rakocevic"
	File: 	 %lexer.red
	Tabs:	 4
	Rights:  "Copyright (C) 2014 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
	}
]

trans-integer: routine [
	start [string!]
	end	  [string!]
	/local
		c	 [integer!]
		n	 [integer!]
		m	 [integer!]
		len  [integer!]
		p	 [byte-ptr!]
		neg? [logic!]
][
	str:  GET_BUFFER(start)
	unit: GET_UNIT(str)
	p:	  string/rs-head start
	len:  end/head - start/head
	neg?: no

	c: string/get-char p unit
	if any [
		c = as-integer #"+"
		c = as-integer #"-"
	][
		neg?: c = as-integer #"-"
		p: p + unit
		len: len - 1
	]
	n: 0
	until [
		c: string/get-char p unit

		m: n * 10
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		m: n + c - #"0"
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		p: p + unit
		len: len - 1
		zero? len
	]
	integer/box either neg? [0 - n][n]
]

trans-hexa: routine [
	start	[string!]
	end		[string!]
	return: [integer!]
	/local
		s	  [series!]
		unit  [integer!]
		p	  [byte-ptr!]
		head  [byte-ptr!]
		p4	  [int-ptr!]
		n	  [integer!]
		power [integer!]
		cp	  [byte!]
][
	s: GET_BUFFER(start)
	unit: GET_UNIT(s)

	p: (string/rs-head end) - unit
	head: string/rs-head start

	n: 0
	power: 0
	while [p >= head][
		cp: switch unit [
			Latin1 [p/value]
			UCS-2  [as-byte ((as-integer p/2) << 8 + p/1)]
			UCS-4  [p4: as int-ptr! p as-byte p4/value]
		]
		if cp <> #"0" [
			case [
				all [#"0" <= cp cp <= #"9"][cp: cp - #"0"]
				all [#"A" <= cp cp <= #"F"][cp: cp - #"A" + 10]
				all [#"a" <= cp cp <= #"f"][cp: cp - #"a" + 10]
			]
			n: n + ((as-integer cp) << power)
		]
		power: power + 4
		p: p - unit
	]
	n
]

trans-push-path: routine [
	stack [block!]
	type  [datatype!]
	/local
		path [red-path!]
][
	path: as red-path! block/make-at as red-block! ALLOC_TAIL(stack) 4
	path/header: switch type/value [
		TYPE_GET_WORD [TYPE_GET_PATH]
		TYPE_LIT_WORD [TYPE_LIT_PATH]
		default [TYPE_PATH]
	]
]

trans-set-path: routine [
	stack [block!]
	/local
		path [red-path!]
][
	path: as red-path! block/pick stack 1 null
	set-type as red-value! path TYPE_SET_PATH
]

trans-word: routine [
	stack [block!]
	src   [string!]
	type  [datatype!]
	/local
		value [red-value!]
][
	value: as red-value! word/push-in (symbol/make-alt src) stack
	set-type value type/value
]

trans-pop: function [stack [block!]][
	value: last stack
	remove back tail stack
	append/only last stack :value
]

transcode: func [
	src		[string!]
	dst		[block! none!]
	return: [block!]
	/local
		cs stack pos s e value line count? wrong-delimiters comment-rule
		digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
		not-file-char not-str-char not-mstr-char caret-char
		non-printable-char integer-end block-rule literal-value
		any-value escaped-char char-rule line-string nested-curly-braces
		multiline-string string-rule cnt trans-string new base c ws
		trans-file decode-hex decode-2hex hex
][
	cs:		[- - - - - - - - - - - - - - - -]			;-- memoized bitsets
	stack:	clear []
	count?:	yes											;-- if TRUE, lines counter is enabled
	line: 	1

	append/only stack any [dst make block! 4]

	trans-string: [
		new: make string! (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				escaped-char (append new value)
				| #"^^"									;-- trash single caret chars
				| set c skip (append new c)
			]
		]
		new
	]

	decode-hex: [
		set c [
			digit 			(value: c - #"0")
			| hexa-upper	(value: c - #"A" + 10)
			| hexa-lower	(value: c - #"a" + 10)
			| (print "*** Syntax Error: invalid file hexa encoding") ;@@ temporary hardcoded
		]
	]

	decode-2hex: [
		decode-hex (hex: value << 4)
		decode-hex (hex: hex + value)
	]

	trans-file: [
		new: make file! (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				#"%" decode-2hex (append new hex)
				| set c skip (append new c)
			]
		]
		new
	]

	if cs/1 = '- [
		cs/1:  charset "0123465798"						;-- digit
		cs/2:  charset "ABCDEF"							;-- hexa-upper
		cs/3:  charset "abcdef"							;-- hexa-lower
		cs/4:  union cs/1 cs/2							;-- hexa
		cs/5:  union cs/4 cs/3							;-- hexa-char
		cs/6:  charset {/\^^,[](){}"#%$@:;}				;-- not-word-char
		cs/7:  union union cs/6 cs/1 charset {'}		;-- not-word-1st
		cs/8:  charset {[](){}"%@:;}					;-- not-file-char
		cs/9:  #"^""									;-- not-str-char
		cs/10: #"}"										;-- not-mstr-char
		cs/11: charset [#"^(40)" - #"^(5F)"]			;-- caret-char
		cs/12: charset [#"^(00)" - #"^(1F)"]			;-- non-printable-char
		cs/13: charset {^{"[]);}						;-- integer-end
		cs/14: charset " ^-^M"							;-- ws-ASCII, ASCII common whitespaces
		cs/15: charset [#"^(80)" - #"^(8A)"]			;-- ws-U+2k, Unicode spaces in the U+2000-U+200A range
		cs/16: charset [#"^(00)" - #"^(1F)"] 			;-- ASCII control characters

	]
	set [
		digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
		not-file-char not-str-char not-mstr-char caret-char
		non-printable-char integer-end ws-ASCII ws-U+2k control-char
	] cs

	;-- Whitespaces list from: http://en.wikipedia.org/wiki/Whitespace_character
	ws: [
		pos: #"^/" (
			if count? [
				line: line + 1
				;append/only lines to block! stack/tail?
			]
		)
		| ws-ASCII										;-- only the common whitespaces are matched
		| #"^(0085)"									;-- U+0085 (Newline)
		| #"^(00A0)"									;-- U+00A0 (No-break space)
		| #"^(1680)"									;-- U+1680 (Ogham space mark)
		| #"^(180E)"									;-- U+180E (Mongolian vowel separator)
		| ws-U+2k										;-- U+2000-U+200A range
		| #"^(2028)"									;-- U+2028 (Line separator)
		| #"^(2029)"									;-- U+2029 (Paragraph separator)
		| #"^(202F)"									;-- U+202F (Narrow no-break space)
		| #"^(205F)"									;-- U+205F (Medium mathematical space)
		| #"^(3000)"									;-- U+3000 (Ideographic space)
	]

	newline-char: [
		#"^/"
		| #"^(0085)"									;-- U+0085 (Newline)
		| #"^(2028)"									;-- U+2028 (Line separator)
		| #"^(2029)"									;-- U+2029 (Paragraph separator)
	]

	counted-newline: [pos: #"^/" (line: line + 1)]

	ws-no-count: [(count?: no) ws (count?: yes)]

	escaped-char: [
		"^^(" [
			[										;-- special case first
				"null" 	 (value: #"^(00)")
				| "back" (value: #"^(08)")
				| "tab"  (value: #"^(09)")
				| "line" (value: #"^(0A)")
				| "page" (value: #"^(0C)")
				| "esc"  (value: #"^(1B)")
				| "del"	 (value: #"^(7F)")
			]
			| pos: [2 6 hexa-char] e: (				;-- Unicode values allowed up to 10FFFFh
				value: encode-UTF8-char pos e
			)
		] #")"
		| #"^^" [
			[
				#"/" 	(value: #"^/")
				| #"-"	(value: #"^-")
				| #"?" 	(value: #"^(del)")			;@@FIXME
				| #"^^" (value: #"^^")				;-- caret escaping case
				| #"{"	(value: #"{")
				| #"}"	(value: #"}")
				| #"^""	(value: #"^"")
			]
			| pos: caret-char (value: pos/1 - 64)
		]
	]

	char-rule: [
		{#"} s: [
			 escaped-char
			| ahead [non-printable-char | not-str-char] break
			| skip (value: s/1)
		] {"}
	]

	line-string: [
		{"} s: any [
			{^^"}
			| ahead [#"^"" | newline-char] break
			| escaped-char
			| skip
		]
		e: {"}
	]

	nested-curly-braces: [
		(cnt: 1)
		any [
			counted-newline
			| "^^{"
			| "^^}"
			| #"{" 	  (cnt: cnt + 1)
			| e: #"}" if (zero? cnt: cnt - 1) break
			| escaped-char
			| skip
		]
	]

	multiline-string: [#"{" s: nested-curly-braces]

	string-rule: [line-string | multiline-string]

	file-rule: [
		#"%" s: any [ahead [not-file-char | ws-no-count] break | skip] e:
	]

	symbol-rule: [
		some [ahead [not-word-char | ws-no-count | control-char] break | skip] e:
	]

	begin-symbol-rule: [								;-- 1st char in symbols is restricted
		[not ahead [not-word-1st | ws-no-count | control-char]]
		symbol-rule
	]

	path-rule: [
		ahead slash (									;-- path detection barrier
			trans-push-path stack type					;-- create empty path
			trans-word last stack copy/part s e type	;-- push 1st path element
		)
		some [
			slash
			s: [
				integer-number-rule			(append last stack trans-integer s e)
				| begin-symbol-rule			(trans-word last stack copy/part s e word!)
				| paren-rule
				| #":" s: begin-symbol-rule	(trans-word last stack copy/part s e get-word!)
				;@@ add more datatypes here
			]
			opt [#":" (trans-set-path back tail stack)]
		] (trans-pop stack)
	]

	word-rule: 	[
		s: begin-symbol-rule (type: word!) [
			path-rule 									;-- path matched
			| opt [#":" (type: set-word!)]
			  (trans-word last stack copy/part s e type) ;-- word or set-word matched
		]
	]

	get-word-rule: [
		#":" (type: get-word!) s: begin-symbol-rule [
			path-rule (type: get-path!)
			| (trans-word last stack copy/part s e type) ;-- get-word matched
		]
	]

	lit-word-rule: [
		#"'" (type: lit-word!) s: begin-symbol-rule [
			path-rule (type: lit-path!)					;-- path matched
			| (trans-word last stack copy/part s e type) ;-- lit-word matched
		]
	]

	issue-rule: [
		#"#" (type: issue!) s: symbol-rule
		(trans-word last stack copy/part s e type)
	]

	refinement-rule: [
		slash (type: refinement!) s: symbol-rule
		(trans-word last stack copy/part s e type)
	]

	slash-rule: [s: [slash opt slash] e:]

	hexa-rule: [2 8 hexa e: #"h"]

	integer-number-rule: [
		opt [#"-" | #"+"] digit any [digit | #"'" digit] e:
	]

	integer-rule: [
		integer-number-rule
		ahead [integer-end | ws-no-count | end]
	]

	block-rule: [
		#"[" (append/only stack make block! 4)
		any-value
		#"]" (trans-pop stack)
	]

	paren-rule: [
		#"(" (append/only stack make paren! 4)
		any-value
		#")" (trans-pop stack)
	]

	escaped-rule: [
		"#[" pos: any ws [
			  "true"  			(value: true)
			| "false" 			(value: false)
			| [
				"none!"			(value: none!)
				| "logic!"		(value: logic!)
				| "block!"		(value: block!)
				| "integer!"	(value: integer!)
				| "word!"		(value: word!)
				| "set-word!"	(value: set-word!)
				| "get-word!"	(value: get-word!)
				| "lit-word!"	(value: lit-word!)
				| "refinement!"	(value: refinement!)
				;| "binary!"	(value: binary!)
				| "string!"		(value: string!)
				| "char!"		(value: char!)
				| "bitset!"		(value: bitset!)
				| "path!"		(value: path!)
				| "set-path!"	(value: set-path!)
				| "lit-path!"	(value: lit-path!)
				| "get-path!"	(value: get-path!)
				| "native!"		(value: native!)
				| "action!"		(value: action!)
				| "op!"			(value: op!)
				| "issue!"		(value: issue!)
				| "paren!"		(value: paren!)
				| "function!"	(value: function!)
				| "routine!"	(value: routine!)
			]
			| "none" 			(value: none)
		] pos: any ws #"]"
	]

	comment-rule: [#";" [to lf | to end]]

	wrong-delimiters: [
		pos: [
			  #"]" (value: #"[") | #")" (value: #"(")
			| #"[" (value: #"]") | #"(" (value: #")")
		] :pos
		(print ["missing matching" value])
	]

	literal-value: [
		pos: (e: none) s: [
			comment-rule
			| escaped-rule		(append last stack value)
			| integer-rule		(append last stack trans-integer s e)
			| hexa-rule			(append last stack trans-hexa s e)
			| word-rule
			| lit-word-rule
			| get-word-rule
			| slash-rule		(trans-word last stack copy/part s e word!)
			| refinement-rule
			| file-rule			(append last stack do trans-file)
			| char-rule			(append last stack value)
			| issue-rule
			| block-rule
			| paren-rule
			| string-rule		(append last stack do trans-string)
			;| binary-rule	  	(stack/push load-binary s e)
		]
	]

	any-value: [pos: any [literal-value | ws]]

	unless parse/case src [any-value opt wrong-delimiters][
		print ["*** Syntax Error: invalid Red value at:" copy/part pos 20]
	]
	stack/1
]

Red [
	Title:   "Red runtime lexer"
	Author:  "Nenad Rakocevic"
	File: 	 %lexer.red
	Tabs:	 4
	Rights:  "Copyright (C) 2014 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
	}
]

trans-integer: routine [
	start [string!]
	end	  [string!]
	/local
		c	 [integer!]
		n	 [integer!]
		m	 [integer!]
		len  [integer!]
		p	 [byte-ptr!]
		neg? [logic!]
][
	str:  GET_BUFFER(start)
	unit: GET_UNIT(str)
	p:	  string/rs-head start
	len:  end/head - start/head
	neg?: no

	c: string/get-char p unit
	if any [
		c = as-integer #"+"
		c = as-integer #"-"
	][
		neg?: c = as-integer #"-"
		p: p + unit
		len: len - 1
	]
	n: 0
	until [
		c: string/get-char p unit

		m: n * 10
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		m: n + c - #"0"
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		p: p + unit
		len: len - 1
		zero? len
	]
	integer/box either neg? [0 - n][n]
]

trans-hexa: routine [
	start	[string!]
	end		[string!]
	return: [integer!]
	/local
		s	  [series!]
		unit  [integer!]
		p	  [byte-ptr!]
		head  [byte-ptr!]
		p4	  [int-ptr!]
		n	  [integer!]
		power [integer!]
		cp	  [byte!]
][
	s: GET_BUFFER(start)
	unit: GET_UNIT(s)

	p: (string/rs-head end) - unit
	head: string/rs-head start

	n: 0
	power: 0
	while [p >= head][
		cp: switch unit [
			Latin1 [p/value]
			UCS-2  [as-byte ((as-integer p/2) << 8 + p/1)]
			UCS-4  [p4: as int-ptr! p as-byte p4/value]
		]
		if cp <> #"0" [
			case [
				all [#"0" <= cp cp <= #"9"][cp: cp - #"0"]
				all [#"A" <= cp cp <= #"F"][cp: cp - #"A" + 10]
				all [#"a" <= cp cp <= #"f"][cp: cp - #"a" + 10]
			]
			n: n + ((as-integer cp) << power)
		]
		power: power + 4
		p: p - unit
	]
	n
]

trans-push-path: routine [
	stack [block!]
	type  [datatype!]
	/local
		path [red-path!]
][
	path: as red-path! block/make-at as red-block! ALLOC_TAIL(stack) 4
	path/header: switch type/value [
		TYPE_GET_WORD [TYPE_GET_PATH]
		TYPE_LIT_WORD [TYPE_LIT_PATH]
		default [TYPE_PATH]
	]
]

trans-set-path: routine [
	stack [block!]
	/local
		path [red-path!]
][
	path: as red-path! block/pick stack 1 null
	set-type as red-value! path TYPE_SET_PATH
]

trans-word: routine [
	stack [block!]
	src   [string!]
	type  [datatype!]
	/local
		value [red-value!]
][
	value: as red-value! word/push-in (symbol/make-alt src) stack
	set-type value type/value
]

trans-pop: function [stack [block!]][
	value: last stack
	remove back tail stack
	append/only last stack :value
]

transcode: func [
	src		[string!]
	dst		[block! none!]
	return: [block!]
	/local
		cs stack pos s e value line count? wrong-delimiters comment-rule
		digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
		not-file-char not-str-char not-mstr-char caret-char
		non-printable-char integer-end block-rule literal-value
		any-value escaped-char char-rule line-string nested-curly-braces
		multiline-string string-rule cnt trans-string new base c ws
		trans-file decode-hex decode-2hex hex
][
	cs:		[- - - - - - - - - - - - - - - -]			;-- memoized bitsets
	stack:	clear []
	count?:	yes											;-- if TRUE, lines counter is enabled
	line: 	1

	append/only stack any [dst make block! 4]

	trans-string: [
		new: make string! (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				escaped-char (append new value)
				| set c skip (append new c)
			]
		]
		new
	]

	decode-hex: [
		set c [
			digit 			(value: c - #"0")
			| hexa-upper	(value: c - #"A" + 10)
			| hexa-lower	(value: c - #"a" + 10)
			| (print "*** Syntax Error: invalid file hexa encoding") ;@@ temporary hardcoded
		]
	]

	decode-2hex: [
		decode-hex (hex: value << 4)
		decode-hex (hex: hex + value)
	]

	trans-file: [
		new: make file! (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				#"%" decode-2hex (append new hex)
				| set c skip (append new c)
			]
		]
		new
	]

	if cs/1 = '- [
		cs/1:  charset "0123465798"						;-- digit
		cs/2:  charset "ABCDEF"							;-- hexa-upper
		cs/3:  charset "abcdef"							;-- hexa-lower
		cs/4:  union cs/1 cs/2							;-- hexa
		cs/5:  union cs/4 cs/3							;-- hexa-char
		cs/6:  charset {/\^^,[](){}"#%$@:;}				;-- not-word-char
		cs/7:  union union cs/6 cs/1 charset {'}		;-- not-word-1st
		cs/8:  charset {[](){}"%@:;}					;-- not-file-char
		cs/9:  #"^""									;-- not-str-char
		cs/10: #"}"										;-- not-mstr-char
		cs/11: charset [#"^(40)" - #"^(5F)"]			;-- caret-char
		cs/12: charset [#"^(00)" - #"^(1F)"]			;-- non-printable-char
		cs/13: charset {^{"[]);}						;-- integer-end
		cs/14: charset " ^-^M"							;-- ws-ASCII, ASCII common whitespaces
		cs/15: charset [#"^(80)" - #"^(8A)"]			;-- ws-U+2k, Unicode spaces in the U+2000-U+200A range
		cs/16: charset [#"^(00)" - #"^(1F)"] 			;-- ASCII control characters

	]
	set [
		digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
		not-file-char not-str-char not-mstr-char caret-char
		non-printable-char integer-end ws-ASCII ws-U+2k control-char
	] cs

	;-- Whitespaces list from: http://en.wikipedia.org/wiki/Whitespace_character
	ws: [
		pos: #"^/" (
			if count? [
				line: line + 1
				;append/only lines to block! stack/tail?
			]
		)
		| ws-ASCII										;-- only the common whitespaces are matched
		| #"^(0085)"									;-- U+0085 (Newline)
		| #"^(00A0)"									;-- U+00A0 (No-break space)
		| #"^(1680)"									;-- U+1680 (Ogham space mark)
		| #"^(180E)"									;-- U+180E (Mongolian vowel separator)
		| ws-U+2k										;-- U+2000-U+200A range
		| #"^(2028)"									;-- U+2028 (Line separator)
		| #"^(2029)"									;-- U+2029 (Paragraph separator)
		| #"^(202F)"									;-- U+202F (Narrow no-break space)
		| #"^(205F)"									;-- U+205F (Medium mathematical space)
		| #"^(3000)"									;-- U+3000 (Ideographic space)
	]

	newline-char: [
		#"^/"
		| #"^(0085)"									;-- U+0085 (Newline)
		| #"^(2028)"									;-- U+2028 (Line separator)
		| #"^(2029)"									;-- U+2029 (Paragraph separator)
	]

	counted-newline: [pos: #"^/" (line: line + 1)]

	ws-no-count: [(count?: no) ws (count?: yes)]

	escaped-char: [
		"^^(" [
			[										;-- special case first
				"null" 	 (value: #"^(00)")
				| "back" (value: #"^(08)")
				| "tab"  (value: #"^(09)")
				| "line" (value: #"^(0A)")
				| "page" (value: #"^(0C)")
				| "esc"  (value: #"^(1B)")
				| "del"	 (value: #"^(7F)")
			]
			| s: [2 6 hexa-char] e: (				;-- Unicode values allowed up to 10FFFFh
				value: encode-UTF8-char s e
			)
		] #")"
		| #"^^" [
			[
				#"/" 	(value: #"^/")
				| #"-"	(value: #"^-")
				| #"?" 	(value: #"^(del)")			;@@FIXME
				| #"^^" (value: #"^^")				;-- caret escaping case
				| #"{"	(value: #"{")
				| #"}"	(value: #"}")
				| #"^""	(value: #"^"")
			]
			| s: caret-char (value: s/1 - 64)
		]
	]

	char-rule: [
		{#"} s: [
			 escaped-char
			| ahead [non-printable-char | not-str-char] break
			| skip (value: s/1)
		] {"}
	]

	line-string: [
		{"} s: any [
			{^^"}
			| ahead [#"^"" | newline-char] break
			| escaped-char
			| skip
		]
		e: {"}
	]

	nested-curly-braces: [
		(cnt: 1)
		any [
			counted-newline
			| "^^{"
			| "^^}"
			| #"{" 	  (cnt: cnt + 1)
			| e: #"}" if (zero? cnt: cnt - 1) break
			| escaped-char
			| skip
		]

	]

	multiline-string: [#"{" s: nested-curly-braces]

	string-rule: [line-string | multiline-string]

	file-rule: [
		#"%" s: any [ahead [not-file-char | ws-no-count] break | skip] e:
	]

	symbol-rule: [
		some [ahead [not-word-char | ws-no-count | control-char] break | skip] e:
	]

	begin-symbol-rule: [								;-- 1st char in symbols is restricted
		[not ahead [not-word-1st | ws-no-count | control-char]]
		symbol-rule
	]

	path-rule: [
		ahead slash (									;-- path detection barrier
			trans-push-path stack type					;-- create empty path
			trans-word last stack copy/part s e type	;-- push 1st path element
		)
		some [
			slash
			s: [
				integer-number-rule			(append last stack trans-integer s e)
				| begin-symbol-rule			(trans-word last stack copy/part s e word!)
				| paren-rule
				| #":" s: begin-symbol-rule	(trans-word last stack copy/part s e get-word!)
				;@@ add more datatypes here
			]
			opt [#":" (trans-set-path back tail stack)]
		] (trans-pop stack)
	]

	word-rule: 	[
		s: begin-symbol-rule (type: word!) [
			path-rule 									;-- path matched
			| opt [#":" (type: set-word!)]
			  (trans-word last stack copy/part s e type) ;-- word or set-word matched
		]
	]

	get-word-rule: [
		#":" (type: get-word!) s: begin-symbol-rule [
			path-rule (type: get-path!)
			| (trans-word last stack copy/part s e type) ;-- get-word matched
		]
	]

	lit-word-rule: [
		#"'" (type: lit-word!) s: begin-symbol-rule [
			path-rule (type: lit-path!)					;-- path matched
			| (trans-word last stack copy/part s e type) ;-- lit-word matched
		]
	]

	issue-rule: [
		#"#" (type: issue!) s: symbol-rule
		(trans-word last stack copy/part s e type)
	]

	refinement-rule: [
		slash (type: refinement!) s: symbol-rule
		(trans-word last stack copy/part s e type)
	]

	slash-rule: [s: [slash opt slash] e:]

	hexa-rule: [2 8 hexa e: #"h"]

	integer-number-rule: [
		opt [#"-" | #"+"] digit any [digit | #"'" digit] e:
	]

	integer-rule: [
		integer-number-rule
		ahead [integer-end | ws-no-count | end]
	]

	block-rule: [
		#"[" (append/only stack make block! 4)
		any-value
		#"]" (trans-pop stack)
	]

	paren-rule: [
		#"(" (append/only stack make paren! 4)
		any-value
		#")" (trans-pop stack)
	]

	escaped-rule: [
		"#[" pos: any ws [
			  "true"  			(value: true)
			| "false" 			(value: false)
			| [
				"none!"			(value: none!)
				| "logic!"		(value: logic!)
				| "block!"		(value: block!)
				| "integer!"	(value: integer!)
				| "word!"		(value: word!)
				| "set-word!"	(value: set-word!)
				| "get-word!"	(value: get-word!)
				| "lit-word!"	(value: lit-word!)
				| "refinement!"	(value: refinement!)
				;| "binary!"	(value: binary!)
				| "string!"		(value: string!)
				| "char!"		(value: char!)
				| "bitset!"		(value: bitset!)
				| "path!"		(value: path!)
				| "set-path!"	(value: set-path!)
				| "lit-path!"	(value: lit-path!)
				| "get-path!"	(value: get-path!)
				| "native!"		(value: native!)
				| "action!"		(value: action!)
				| "op!"			(value: op!)
				| "issue!"		(value: issue!)
				| "paren!"		(value: paren!)
				| "function!"	(value: function!)
				| "routine!"	(value: routine!)
			]
			| "none" 			(value: none)
		] pos: any ws #"]"
	]

	comment-rule: [#";" [to lf | to end]]

	wrong-delimiters: [
		pos: [
			  #"]" (value: #"[") | #")" (value: #"(")
			| #"[" (value: #"]") | #"(" (value: #")")
		] :pos
		(print ["missing matching" value])
	]

	literal-value: [
		pos: (e: none) s: [
			comment-rule
			| escaped-rule		(append last stack value)
			| integer-rule		(append last stack trans-integer s e)
			| hexa-rule			(append last stack trans-hexa s e)
			| word-rule
			| lit-word-rule
			| get-word-rule
			| slash-rule		(trans-word last stack copy/part s e word!)
			| refinement-rule
			| file-rule			(append last stack do trans-file)
			| char-rule			(append last stack value)
			| issue-rule
			| block-rule
			| paren-rule
			| string-rule		(append last stack do trans-string)
			;| binary-rule	  	(stack/push load-binary s e)
		]
	]

	any-value: [pos: any [literal-value | ws]]

	unless parse/case src [any-value opt wrong-delimiters][
		print ["*** Syntax Error: invalid Red value at:" copy/part pos 20]
	]
	stack/1
]