FIX: issue #440 (A doc string between a refinement and its parameter causes strange behavior)

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"]
		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 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-line "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"]
		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 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
								]
							]
						][
							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-line "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
	]

]


TESTS: minor typo fixed.

TESTS: minor typo fixed.

Red [
	Title:	"Red Float! datatype tests"
	Author:	"Peter W A Wood, Nenad Rakocevic, Xie Qing Tian"
	File:	%float-test.red
	Version: 0.2.0
	Rights:	"Copyright (C) 2012-2014 Peter W A Wood, Nenad Rakocevic, Xie Qing Tian. 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~~~ "float"

===start-group=== "float assignment"
	--test-- "float-1"
		ff: 100.0
		--assert ff = 100.0
	--test-- "float-2"
		ff: 1.222090944E+33
		--assert ff = 1.222090944E+33
	--test-- "float-3"
		ff: 9.99999E-45
		--assert ff = 9.99999E-45
	--test-- "float-4"
		ff: 1.0
		f1: ff
		--assert f1 = 1.0
===end-group===

===start-group=== "trigonometric function"
	pi: 3.14159265358979

	--test-- "float-cosine-1"
		--assert -1.0 = cosine/radians pi

	--test-- "float-cosine-2"
		--assert 0.0 = cosine 90

	--test-- "float-sine-1"
		--assertf~= 0.0 sine/radians pi 1E-13

	--test-- "float-sine-2"
		--assert 1 = sine 90

	--test-- "float-tangent-1"
		--assert 0.0 = tangent/radians 0

	--test-- "float-tangent-2"
		--assert -1 = tangent 135

	--test-- "float-arcsine-1"
		--assertf~= -1.5707963267949 arcsine/radians -1 1E-13

	--test-- "float-arcsine-2"
		--assert 90 = arcsine 1

	--test-- "float-arccosine-1"
		--assertf~= 1.5707963267949 arccosine/radians 0 1E-13

	--test-- "float-arccosine-2"
		--assert 90 = arccosine 0

	--test-- "float-arctangent-1"
		--assertf~= -0.785398163397448 arctangent/radians -1 1E-13

	--test-- "float-arctangent-2"
		--assert 45 = arctangent 1
===end-group===

===start-group=== "float function arguments"
	ff: func [
		fff		[float!]
		ffg		[float!]
		return: [integer!]
		/local
			ffl [float!]
	][
		ffl: fff
		if ffl <> fff [return 1]
		ffl: ffg
		if ffl <> ffg [return 2]
		1
	]

	--test-- "float-func-args-1"
		--assert 1 = ff 1.0 2.0

	--test-- "float-func-args-2"
		--assert 1 = ff 1.222090944E+33 9.99999E-45

===end-group===

===start-group=== "float locals"

	local-float: func [n [float!] return: [float!] /local p][p: n p]

	--test-- "float-loc-1"
		pi: local-float 3.14159265358979
		--assert pi = 3.14159265358979
		;--assert -1.0 = cos pi
		;--assert -1.0 = local-float cos pi

	--test-- "float-loc-2"
		ff: local-float pi
		--assert pi = local-float ff

	--test-- "float-loc-3"
		local-float2: func [n [float!] return: [float!] /local p][p: n local-float p]

		pi: local-float2 3.14159265358979
		;--assert -1.0 = local-float2 cos pi
		ff: local-float2 pi
		--assert pi = local-float2 ff

	--test-- "float-loc-4"
		local-float3: func [n [float!] return: [float!] /local p [float!]][p: n local-float p]

		pi: local-float3 3.14159265358979
		;--assert -1.0 = local-float3 cos pi
		ff: local-float3 pi
		--assert pi = local-float3 ff

	--test-- "float-loc-5"
		local-float4: func [n [float!] return: [float!] /local r p][p: n p]
		;--assert -1.0 = local-float4 cos pi
		ff: local-float4 pi
		--assert pi = local-float4 ff

	--test-- "float-loc-6"
		local-float5: func [n [float!] return: [float!] /local r p][p: n local-float p]
		;--assert -1.0 = local-float5 cos pi
		ff: local-float5 pi
		--assert pi = local-float5 ff

===end-group===

===start-group=== "float function return"

	ff1: func [
		ff1i	[integer!]
		return: [float!]
	][
		switch ff1i [
			1 [1.0]
			2 [1.222090944E+33]
			3 [9.99999E-45]
		]
	]
	--test-- "float return 1"
		--assert 1.0 = ff1 1
	--test-- "float return 2"
		--assert 1.222090944E+33 = ff1 2
	--test-- "float return 3"
		--assert 9.99999E-45 = ff1 3

===end-group===

;===start-group=== "float members in object!"

;	--test-- "float-object-1"
;		sf1: make object! [
;			a: 0.0
;		]
;		--assert 0.0 = sf1/a

;	--test-- "float-object-2"
;		sf2: make object! [
;			a: 0.0
;		]
;		sf1/a: 1.222090944E+33
;		--assert 1.222090944E+33 = sf1/a

;	--test-- "float-object-3"
;		sf3: make object! [
;			a: 0.0
;			b: 0.0
;		]
;		sf3/a: 1.222090944E+33
;		sf3/b: 9.99999E-45

;		--assert 1.222090944E+33 = sf3/a
;		--assert 9.99999E-45 = sf3/b

;	--test-- "float-object-4"
;		sf4: make object! [
;			c: none
;			a: 0.0
;			l: false
;			b: 0.0
;		]
;		sf4/a: 1.222090944E+33
;		sf4/b: 9.99999E-45
;		--assert 1.222090944E+33 = sf4/a
;		--assert 9.99999E-45 = sf4/b

;	--test-- "float-object-5"
;		sf5: make object! [f: 0.0 i: 0]

;		sf5/i: 1234567890
;		sf5/f: 3.14159265358979
;		--assert sf5/i = 1234567890
;		--assert sf5/f = pi

;	--test-- "float-object-6"
;		sf6: make object! [i: 0 f: 0.0]

;		sf6/i: 1234567890
;		sf6/f: 3.14159265358979
;		--assert sf6/i = 1234567890
;		--assert sf6/f = pi

;===end-group===

===start-group=== "expressions with returned float values"

	fe1: function [
		return: [float!]
	][
		1.0
	]
	fe2: function [
		return: [float!]
	][
		2.0
	]

	--test-- "ewrfv0"
		--assert 1.0 = (fe1 * 1.0)

	--test-- "ewrfv1"
		--assert 1.0 = (1.0 * fe1)

	--test-- "ewrfv2"
		--assert 0.5 = (fe1 / fe2)

===end-group===

===start-group=== "calculations"

	fcfoo: func [a [float!] return: [float!]][a]

	;fcptr: declare struct! [a [float!]]
	;fcptr/a: 3.0

	fc2: 3.0

	--test-- "fc-1"
		fc1: 2.0
		fc1: fc1 / (fc1 - 1.0)
		--assert 2.0 = fc1

	--test-- "fc-2"
		--assert 5.0 - 3.0 = 2.0							;-- imm/imm

	--test-- "fc-3"
		--assert 5.0 - fc2 = 2.0							;-- imm/ref

	--test-- "fc-4"
		--assert 5.0 - (fcfoo 3.0) = 2.0					;-- imm/reg(block!)

	;--test-- "fc-5"
		;--assertf~= 5.0 - fcptr/a 2.0 1E-10				;-- imm/reg(path!)

	--test-- "fc-6"
		--assert fc2 - 5.0 = -2.0							;-- ref/imm

	--test-- "fc-7"
		--assert fc2 - (fcfoo 5.0) = -2.0					;-- ref/reg(block!)

	;--test-- "fc-8"
		;--assert fc2 - fcptr/a = 0.0						;-- ref/reg(path!)

	--test-- "fc-9"
		--assert (fcfoo 5.0) - 3.0 = 2.0					;-- reg(block!)/imm

	--test-- "fc-10"
		--assert (fcfoo 5.0) - (fcfoo 3.0) = 2.0			;-- reg(block!)/reg(block!)

	;--test-- "fc-11"
		;--assert (fcfoo 5.0) - fcptr/a = 2.0				;-- reg(block!)/reg(path!)

	;--test-- "fc-12"
		;--assert fcptr/a - (fcfoo 5.0) = 2.0				;-- reg(path!)/reg(block!)

===end-group===

===start-group=== "absolute"
	--test-- "abs1" --assert 0.0 = absolute -0.0
	--test-- "abs2" --assert 1.2 = absolute 1.2
	--test-- "abs3" --assert 1.2 = absolute -1.2
	--test-- "abs4" --assert 2.2E-308 = absolute -2.2E-308
	--test-- "abs5" --assert 2147483647 = absolute 2147483647.0
===end-group===

===start-group=== "power"
	--test-- "pow1" --assert 2.25 = power 1.5 2
	--test-- "pow2" --assert 9 	 = power -3.0 2.0
	--test-- "pow3" --assertf~= -0.3333333333333333 (power -3.0 -1) 1E-13
	--test-- "pow4" --assertf~= 11.211578456539659 (power 3 2.2) 1E-13
	;--test-- "pow5" --assert 0.0 = power 0.0 -1		;@@ return INF or 0.0 ?
	;--test-- "pow6" --assert 0.0 = power -0.0 -1		;@@ return -INF or 0.0 ?
===end-group===

===start-group=== "max/min"
	--test-- "max1"
		--assert 3 	 = max  3 1.0
		--assert integer! = type? max 3 1.0
	--test-- "max2"
		--assert 3.0 = max  1.0 3.0
		--assert float! = type? max 1.0 3.0

	--test-- "min1"
		--assert -3  = min -3 2
		--assert integer! = type? min -3 2.0
	--test-- "min2"
		--assert -2.0 = min 3.0 -2.0
		--assert float! = type? min 3.0 -2.0

===end-group===

===start-group=== "negative?/positive?"
	--test-- "neg1" --assert true  = negative? -1.0
	--test-- "neg2" --assert false = negative? 0.0
	--test-- "neg3" --assert false = negative? 1.0
	--test-- "pos1" --assert true  = positive? 1.0
	--test-- "pos2" --assert false = positive? 0.0
	--test-- "pos3" --assert false = positive? -1.0
===end-group===

===start-group=== "round"
	--test-- "round1"  --assert 1.375 = round/to 1.333 .125
	--test-- "round2"  --assert 1.33  = round/to 1.333 .01

	--test-- "round3"  --assert  1 = round/down  1.999
	--test-- "round4"  --assert -1 = round/down -1.999

	--test-- "round5"  --assert  2 = round/even  1.5
	--test-- "round6"  --assert -2 = round/even -1.5

	--test-- "round7"  --assert  1 = round/half-down  1.5
	--test-- "round8"  --assert -1 = round/half-down -1.5

	--test-- "round9"  --assert  1 = round/floor  1.999
	--test-- "round10" --assert -2 = round/floor -1.0000001

	--test-- "round11" --assert  2 = round/ceiling  1.0000001
	--test-- "round12" --assert -1 = round/ceiling -1.999

	--test-- "round13" --assert  2 = round/half-ceiling  1.5
	--test-- "round14" --assert -1 = round/half-ceiling -1.5

	--test-- "round15" --assert  1 = round  1.4999
	--test-- "round16" --assert  2 = round  1.5
	--test-- "round17" --assert -2 = round -1.5
===end-group===

===start-group=== "various regression tests from bugtracker"

	;--test-- "issue #227 for Red/System"
	;	t: 2.2
	;	ss: make object! [v: [float!]]
	;	ss/v: 2.0
	;	--assertf~= t - ss/v 0.2 1E-10

	--test-- "issue #221"
		x: -1.0
		y: either x < 0.0 [0.0 - x][x]
		--assert y = 1.0

		fabs: func [x [float!] return: [float!] ][
			either x < 0.0 [0.0 - x][x]
		]
		--assert 3.14 = fabs -3.14

===end-group===

===start-group=== "almost equal"
	--test-- "almost-equal1"  --assert 1.000000000000001 = 1.000000000000002
	;--test-- "almost-equal2"  --assert not 1.000000000000001 = 1.000000000000003		;@@ works correctly only on interpreter

	--test-- "almost-equal3"  --assert -1.999999999999999 = -1.999999999999999
	--test-- "almost-equal4"  --assert 1.732050807568876 = 1.732050807568877

	NaN1: 0.0 / 0.0
	NaN2: 0.0 / 0.0
	--test-- "almost-equal5"  --assert not 123 = NaN1
	--test-- "almost-equal6"  --assert not NaN1 = NaN1

	INF: 1E308 + 1E308
	;--test-- "almost-equal7"  --assert 1.7976931348623157e308 = INF	;@@ works on interpreter, but cause compiler error.(Maybe Rebol2's problem)
	--test-- "almost-equal8"  --assert 4.94065645841247E-324 = 0

	--test-- "almost-equal9"  --assert  0.4E-323 = -0.4E-323
~~~end-file~~~

===start-group=== "special arithmetic"

	--test-- "special-arithmetic-1"  --assert "0.0"     = to string! 1.0 / 1.#INF
	--test-- "special-arithmetic-2"  --assert "1.#INF"  = to string! 1.0 / 0.0
	--test-- "special-arithmetic-3"  --assert "-1.#INF" = to string! -1.0 / 0.0
	--test-- "special-arithmetic-4"  --assert "1.#NaN"  = to string! 0.0 / 0.0
	--test-- "special-arithmetic-5"  --assert "1.#INF"  = to string! 9999999.9 + 1.#INF
	--test-- "special-arithmetic-6"  --assert "-1.#INF" = to string! 9999999.9 - 1.#INF
	--test-- "special-arithmetic-7"  --assert "1.#INF"  = to string! 1.#INF + 1.#INF
	--test-- "special-arithmetic-8"  --assert "1.#INF"  = to string! 1.#INF * 1.#INF
	--test-- "special-arithmetic-9"  --assert "1.#NaN"  = to string! 1.#INF - 1.#INF
	--test-- "special-arithmetic-10" --assert "1.#NaN"  = to string! 1.#INF / 1.#INF
	--test-- "special-arithmetic-11" --assert "1.#NaN"  = to string! 0.0 * 1.#INF
	--test-- "special-arithmetic-12" --assert "1.#INF"  = to string! 1e308 + 1e308

~~~end-file~~~

===start-group=== "comparison"

	--test-- "comparison-1"  --assert 1.#NaN = 1.#NaN			= false
	--test-- "comparison-2"  --assert (same? 1.#NaN 1.#NaN)     = true
	--test-- "comparison-3"  --assert 1.#NaN <> 1.#NaN          = true
	--test-- "comparison-4"  --assert 1.#NaN < 1.#NaN           = false
	--test-- "comparison-5"  --assert 1.#NaN > 1.#NaN           = false
	--test-- "comparison-6"  --assert [1 1.#NaN] = [1 1.#NaN]   = false
	--test-- "comparison-7"  --assert 1.#INF < 1.#NaN           = false
	--test-- "comparison-8"  --assert 1.#INF > 1.#NaN           = false
	--test-- "comparison-9"  --assert -0.0 = 0.0                = true
	--test-- "comparison-10" --assert (same? -0.0 0.0)          = false

~~~end-file~~~

Red [
	Title:	"Red Float! datatype tests"
	Author:	"Peter W A Wood, Nenad Rakocevic, Xie Qing Tian"
	File:	%float-test.red
	Version: 0.2.0
	Rights:	"Copyright (C) 2012-2014 Peter W A Wood, Nenad Rakocevic, Xie Qing Tian. 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~~~ "float"

===start-group=== "float assignment"
	--test-- "float-1"
		ff: 100.0
		--assert ff = 100.0
	--test-- "float-2"
		ff: 1.222090944E+33
		--assert ff = 1.222090944E+33
	--test-- "float-3"
		ff: 9.99999E-45
		--assert ff = 9.99999E-45
	--test-- "float-4"
		ff: 1.0
		f1: ff
		--assert f1 = 1.0
===end-group===

===start-group=== "trigonometric function"
	pi: 3.14159265358979

	--test-- "float-cosine-1"
		--assert -1.0 = cosine/radians pi

	--test-- "float-cosine-2"
		--assert 0.0 = cosine 90

	--test-- "float-sine-1"
		--assertf~= 0.0 sine/radians pi 1E-13

	--test-- "float-sine-2"
		--assert 1 = sine 90

	--test-- "float-tangent-1"
		--assert 0.0 = tangent/radians 0

	--test-- "float-tangent-2"
		--assert -1 = tangent 135

	--test-- "float-arcsine-1"
		--assertf~= -1.5707963267949 arcsine/radians -1 1E-13

	--test-- "float-arcsine-2"
		--assert 90 = arcsine 1

	--test-- "float-arccosine-1"
		--assertf~= 1.5707963267949 arccosine/radians 0 1E-13

	--test-- "float-arccosine-2"
		--assert 90 = arccosine 0

	--test-- "float-arctangent-1"
		--assertf~= -0.785398163397448 arctangent/radians -1 1E-13

	--test-- "float-arctangent-2"
		--assert 45 = arctangent 1
===end-group===

===start-group=== "float function arguments"
	ff: func [
		fff		[float!]
		ffg		[float!]
		return: [integer!]
		/local
			ffl [float!]
	][
		ffl: fff
		if ffl <> fff [return 1]
		ffl: ffg
		if ffl <> ffg [return 2]
		1
	]

	--test-- "float-func-args-1"
		--assert 1 = ff 1.0 2.0

	--test-- "float-func-args-2"
		--assert 1 = ff 1.222090944E+33 9.99999E-45

===end-group===

===start-group=== "float locals"

	local-float: func [n [float!] return: [float!] /local p][p: n p]

	--test-- "float-loc-1"
		pi: local-float 3.14159265358979
		--assert pi = 3.14159265358979
		;--assert -1.0 = cos pi
		;--assert -1.0 = local-float cos pi

	--test-- "float-loc-2"
		ff: local-float pi
		--assert pi = local-float ff

	--test-- "float-loc-3"
		local-float2: func [n [float!] return: [float!] /local p][p: n local-float p]

		pi: local-float2 3.14159265358979
		;--assert -1.0 = local-float2 cos pi
		ff: local-float2 pi
		--assert pi = local-float2 ff

	--test-- "float-loc-4"
		local-float3: func [n [float!] return: [float!] /local p [float!]][p: n local-float p]

		pi: local-float3 3.14159265358979
		;--assert -1.0 = local-float3 cos pi
		ff: local-float3 pi
		--assert pi = local-float3 ff

	--test-- "float-loc-5"
		local-float4: func [n [float!] return: [float!] /local r p][p: n p]
		;--assert -1.0 = local-float4 cos pi
		ff: local-float4 pi
		--assert pi = local-float4 ff

	--test-- "float-loc-6"
		local-float5: func [n [float!] return: [float!] /local r p][p: n local-float p]
		;--assert -1.0 = local-float5 cos pi
		ff: local-float5 pi
		--assert pi = local-float5 ff

===end-group===

===start-group=== "float function return"

	ff1: func [
		ff1i	[integer!]
		return: [float!]
	][
		switch ff1i [
			1 [1.0]
			2 [1.222090944E+33]
			3 [9.99999E-45]
		]
	]
	--test-- "float return 1"
		--assert 1.0 = ff1 1
	--test-- "float return 2"
		--assert 1.222090944E+33 = ff1 2
	--test-- "float return 3"
		--assert 9.99999E-45 = ff1 3

===end-group===

;===start-group=== "float members in object!"

;	--test-- "float-object-1"
;		sf1: make object! [
;			a: 0.0
;		]
;		--assert 0.0 = sf1/a

;	--test-- "float-object-2"
;		sf2: make object! [
;			a: 0.0
;		]
;		sf1/a: 1.222090944E+33
;		--assert 1.222090944E+33 = sf1/a

;	--test-- "float-object-3"
;		sf3: make object! [
;			a: 0.0
;			b: 0.0
;		]
;		sf3/a: 1.222090944E+33
;		sf3/b: 9.99999E-45

;		--assert 1.222090944E+33 = sf3/a
;		--assert 9.99999E-45 = sf3/b

;	--test-- "float-object-4"
;		sf4: make object! [
;			c: none
;			a: 0.0
;			l: false
;			b: 0.0
;		]
;		sf4/a: 1.222090944E+33
;		sf4/b: 9.99999E-45
;		--assert 1.222090944E+33 = sf4/a
;		--assert 9.99999E-45 = sf4/b

;	--test-- "float-object-5"
;		sf5: make object! [f: 0.0 i: 0]

;		sf5/i: 1234567890
;		sf5/f: 3.14159265358979
;		--assert sf5/i = 1234567890
;		--assert sf5/f = pi

;	--test-- "float-object-6"
;		sf6: make object! [i: 0 f: 0.0]

;		sf6/i: 1234567890
;		sf6/f: 3.14159265358979
;		--assert sf6/i = 1234567890
;		--assert sf6/f = pi

;===end-group===

===start-group=== "expressions with returned float values"

	fe1: function [
		return: [float!]
	][
		1.0
	]
	fe2: function [
		return: [float!]
	][
		2.0
	]

	--test-- "ewrfv0"
		--assert 1.0 = (fe1 * 1.0)

	--test-- "ewrfv1"
		--assert 1.0 = (1.0 * fe1)

	--test-- "ewrfv2"
		--assert 0.5 = (fe1 / fe2)

===end-group===

===start-group=== "calculations"

	fcfoo: func [a [float!] return: [float!]][a]

	;fcptr: declare struct! [a [float!]]
	;fcptr/a: 3.0

	fc2: 3.0

	--test-- "fc-1"
		fc1: 2.0
		fc1: fc1 / (fc1 - 1.0)
		--assert 2.0 = fc1

	--test-- "fc-2"
		--assert 5.0 - 3.0 = 2.0							;-- imm/imm

	--test-- "fc-3"
		--assert 5.0 - fc2 = 2.0							;-- imm/ref

	--test-- "fc-4"
		--assert 5.0 - (fcfoo 3.0) = 2.0					;-- imm/reg(block!)

	;--test-- "fc-5"
		;--assertf~= 5.0 - fcptr/a 2.0 1E-10				;-- imm/reg(path!)

	--test-- "fc-6"
		--assert fc2 - 5.0 = -2.0							;-- ref/imm

	--test-- "fc-7"
		--assert fc2 - (fcfoo 5.0) = -2.0					;-- ref/reg(block!)

	;--test-- "fc-8"
		;--assert fc2 - fcptr/a = 0.0						;-- ref/reg(path!)

	--test-- "fc-9"
		--assert (fcfoo 5.0) - 3.0 = 2.0					;-- reg(block!)/imm

	--test-- "fc-10"
		--assert (fcfoo 5.0) - (fcfoo 3.0) = 2.0			;-- reg(block!)/reg(block!)

	;--test-- "fc-11"
		;--assert (fcfoo 5.0) - fcptr/a = 2.0				;-- reg(block!)/reg(path!)

	;--test-- "fc-12"
		;--assert fcptr/a - (fcfoo 5.0) = 2.0				;-- reg(path!)/reg(block!)

===end-group===

===start-group=== "absolute"
	--test-- "abs1" --assert 0.0 = absolute -0.0
	--test-- "abs2" --assert 1.2 = absolute 1.2
	--test-- "abs3" --assert 1.2 = absolute -1.2
	--test-- "abs4" --assert 2.2E-308 = absolute -2.2E-308
	--test-- "abs5" --assert 2147483647 = absolute 2147483647.0
===end-group===

===start-group=== "power"
	--test-- "pow1" --assert 2.25 = power 1.5 2
	--test-- "pow2" --assert 9 	 = power -3.0 2.0
	--test-- "pow3" --assertf~= -0.3333333333333333 (power -3.0 -1) 1E-13
	--test-- "pow4" --assertf~= 11.211578456539659 (power 3 2.2) 1E-13
	;--test-- "pow5" --assert 0.0 = power 0.0 -1		;@@ return INF or 0.0 ?
	;--test-- "pow6" --assert 0.0 = power -0.0 -1		;@@ return -INF or 0.0 ?
===end-group===

===start-group=== "max/min"
	--test-- "max1"
		--assert 3 	 = max  3 1.0
		--assert integer! = type? max 3 1.0
	--test-- "max2"
		--assert 3.0 = max  1.0 3.0
		--assert float! = type? max 1.0 3.0

	--test-- "min1"
		--assert -3  = min -3 2
		--assert integer! = type? min -3 2.0
	--test-- "min2"
		--assert -2.0 = min 3.0 -2.0
		--assert float! = type? min 3.0 -2.0

===end-group===

===start-group=== "negative?/positive?"
	--test-- "neg1" --assert true  = negative? -1.0
	--test-- "neg2" --assert false = negative? 0.0
	--test-- "neg3" --assert false = negative? 1.0
	--test-- "pos1" --assert true  = positive? 1.0
	--test-- "pos2" --assert false = positive? 0.0
	--test-- "pos3" --assert false = positive? -1.0
===end-group===

===start-group=== "round"
	--test-- "round1"  --assert 1.375 = round/to 1.333 .125
	--test-- "round2"  --assert 1.33  = round/to 1.333 .01

	--test-- "round3"  --assert  1 = round/down  1.999
	--test-- "round4"  --assert -1 = round/down -1.999

	--test-- "round5"  --assert  2 = round/even  1.5
	--test-- "round6"  --assert -2 = round/even -1.5

	--test-- "round7"  --assert  1 = round/half-down  1.5
	--test-- "round8"  --assert -1 = round/half-down -1.5

	--test-- "round9"  --assert  1 = round/floor  1.999
	--test-- "round10" --assert -2 = round/floor -1.0000001

	--test-- "round11" --assert  2 = round/ceiling  1.0000001
	--test-- "round12" --assert -1 = round/ceiling -1.999

	--test-- "round13" --assert  2 = round/half-ceiling  1.5
	--test-- "round14" --assert -1 = round/half-ceiling -1.5

	--test-- "round15" --assert  1 = round  1.4999
	--test-- "round16" --assert  2 = round  1.5
	--test-- "round17" --assert -2 = round -1.5
===end-group===

===start-group=== "various regression tests from bugtracker"

	;--test-- "issue #227 for Red/System"
	;	t: 2.2
	;	ss: make object! [v: [float!]]
	;	ss/v: 2.0
	;	--assertf~= t - ss/v 0.2 1E-10

	--test-- "issue #221"
		x: -1.0
		y: either x < 0.0 [0.0 - x][x]
		--assert y = 1.0

		fabs: func [x [float!] return: [float!] ][
			either x < 0.0 [0.0 - x][x]
		]
		--assert 3.14 = fabs -3.14

===end-group===

===start-group=== "almost equal"
	--test-- "almost-equal1"  --assert 1.000000000000001 = 1.000000000000002
	;--test-- "almost-equal2"  --assert not 1.000000000000001 = 1.000000000000003		;@@ works correctly only on interpreter

	--test-- "almost-equal3"  --assert -1.999999999999999 = -1.999999999999999
	--test-- "almost-equal4"  --assert 1.732050807568876 = 1.732050807568877

	NaN1: 0.0 / 0.0
	NaN2: 0.0 / 0.0
	--test-- "almost-equal5"  --assert not 123 = NaN1
	--test-- "almost-equal6"  --assert not NaN1 = NaN1

	INF: 1E308 + 1E308
	;--test-- "almost-equal7"  --assert 1.7976931348623157e308 = INF	;@@ works on interpreter, but cause compiler error.(Maybe Rebol2's problem)
	--test-- "almost-equal8"  --assert 4.94065645841247E-324 = 0

	--test-- "almost-equal9"  --assert  0.4E-323 = -0.4E-323
~~~end-file~~~

===start-group=== "special arithmetic"

	--test-- "special-arithmetic-1"  --assert "0.0"     = to string! 1.0 / 1.#INF
	--test-- "special-arithmetic-2"  --assert "1.#INF"  = to string! 1.0 / 0.0
	--test-- "special-arithmetic-3"  --assert "-1.#INF" = to string! -1.0 / 0.0
	--test-- "special-arithmetic-4"  --assert "1.#NaN"  = to string! 0.0 / 0.0
	--test-- "special-arithmetic-5"  --assert "1.#INF"  = to string! 9999999.9 + 1.#INF
	--test-- "special-arithmetic-6"  --assert "-1.#INF" = to string! 9999999.9 - 1.#INF
	--test-- "special-arithmetic-7"  --assert "1.#INF"  = to string! 1.#INF + 1.#INF
	--test-- "special-arithmetic-8"  --assert "1.#INF"  = to string! 1.#INF * 1.#INF
	--test-- "special-arithmetic-9"  --assert "1.#NaN"  = to string! 1.#INF - 1.#INF
	--test-- "special-arithmetic-10" --assert "1.#NaN"  = to string! 1.#INF / 1.#INF
	--test-- "special-arithmetic-11" --assert "1.#NaN"  = to string! 0.0 * 1.#INF
	--test-- "special-arithmetic-12" --assert "1.#INF"  = to string! 1e308 + 1e308

~~~end-file~~~

===start-group=== "comparasion"

	--test-- "comparasion-1"  --assert 1.#NaN = 1.#NaN			 = false
	--test-- "comparasion-2"  --assert (same? 1.#NaN 1.#NaN)     = true
	--test-- "comparasion-3"  --assert 1.#NaN <> 1.#NaN          = true
	--test-- "comparasion-4"  --assert 1.#NaN < 1.#NaN           = false
	--test-- "comparasion-5"  --assert 1.#NaN > 1.#NaN           = false
	--test-- "comparasion-6"  --assert [1 1.#NaN] = [1 1.#NaN]   = false
	--test-- "comparasion-7"  --assert 1.#INF < 1.#NaN           = false
	--test-- "comparasion-8"  --assert 1.#INF > 1.#NaN           = false
	--test-- "comparasion-9"  --assert -0.0 = 0.0                = true
	--test-- "comparasion-10" --assert (same? -0.0 0.0)          = false

~~~end-file~~~


FIX: functions were not properly recreated during a rebinding in objects.

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

object: context [
	verbose: 0

	do-indent: func [
		buffer	[red-string!]
		tabs	[integer!]
		part	[integer!]
		return:	[integer!]
		/local
			n [integer!]
	][
		n: tabs
		until [
			string/concatenate-literal buffer "    "
			n: n - 1
			zero? n
		]
		part - (4 * tabs)
	]

	serialize: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent?	[logic!]
		tabs	[integer!]
		return: [integer!]
		/local
			ctx		[red-context!]
			syms	[series!]
			values	[series!]
			sym		[red-value!]
			s-tail	[red-value!]
			value	[red-value!]
	][
		ctx: 	GET_CTX(obj)
		syms:   as series! ctx/symbols/value
		values: as series! ctx/values/value

		sym:	syms/offset
		s-tail: syms/tail
		value: 	values/offset

		while [sym < s-tail][
			if indent? [part: do-indent buffer tabs part]

			part: word/mold as red-word! sym buffer no no flat? arg part tabs
			string/concatenate-literal buffer ": "
			part: part - 2

			part: actions/mold value buffer only? all? flat? arg part tabs

			if any [indent? sym + 1 < s-tail][			;-- no final LF when FORMed
				string/append-char GET_BUFFER(buffer) as-integer lf
				part: part - 1
			]
			sym: sym + 1
			value: value + 1
		]
		part
	]

	extend: func [
		ctx	  [red-context!]
		spec  [red-context!]
		/local
			syms  [red-value!]
			tail  [red-value!]
			vals  [red-value!]
			value [red-value!]
			s	  [series!]
	][
		s: as series! spec/symbols/value
		syms: s/offset
		tail: s/tail

		s: as series! spec/values/value
		vals: s/offset

		while [syms < tail][
			value: _context/add-with ctx as red-word! syms vals

			unless null? value [
				switch TYPE_OF(value) [					;@@ replace it with ANY_SERIES?()
					TYPE_BLOCK
					TYPE_PAREN
					TYPE_PATH
					TYPE_SET_PATH
					TYPE_GET_PATH
					TYPE_LIT_PATH
					TYPE_STRING
					TYPE_FILE [
						actions/copy value value null yes null ;-- overwrite the value
					]
					TYPE_FUNCTION [
						rebind as red-function! value ctx
					]
					default [0]
				]
			]
			syms: syms + 1
			vals: vals + 1
		]
	]

	rebind: func [
		fun		[red-function!]
		ctx 	[red-context!]
		/local
			s	 [series!]
			more [red-value!]
			blk  [red-block!]
			spec [red-block!]
	][
		s: as series! fun/more/value
		more: s/offset

		if TYPE_OF(more) = TYPE_NONE [
			print-line "*** Error: COPY stuck on missing function's body block"
			halt
		]
		spec: as red-block! stack/push*
		spec/head: 0
		spec/node: fun/spec

		blk: block/clone as red-block! more yes
		_context/bind blk ctx yes						;-- rebind new body to object
		_function/push spec blk	fun/ctx null			;-- recreate function
		copy-cell stack/top - 1	as red-value! fun		;-- overwrite function slot in object
		stack/pop 2										;-- remove extra stack slots (block/clone and _function/push)

		s: as series! fun/more/value
		more: s/offset + 2
		more/header: TYPE_UNSET							;-- invalidate compiled body
	]

	make-at: func [
		obj		[red-object!]
		slots	[integer!]
		return: [red-object!]
	][
		obj/header: TYPE_OBJECT
		obj/ctx: _context/create slots no yes
		obj
	]

	;-- Actions --

	make: func [
		proto	[red-object!]
		spec	[red-value!]
		return:	[red-object!]
		/local
			obj	 [red-object!]
			obj2 [red-object!]
			ctx  [red-context!]
			blk  [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/make"]]

		obj: as red-object! stack/push*

		either TYPE_OF(proto) = TYPE_OBJECT [
			copy proto obj null yes null				;-- /deep
		][
			make-at obj 4								;-- arbitrary value
		]
		ctx: GET_CTX(obj)

		switch TYPE_OF(spec) [
			TYPE_OBJECT [
				obj2: as red-object! spec
				extend ctx GET_CTX(obj2)
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				_context/collect-set-words ctx blk
				_context/bind blk ctx yes
				interpreter/eval blk
			]
			default [
				print-line "*** Error: invalid spec value for object construction"
				halt
			]
		]
		obj
	]

	reflect: func [
		obj		[red-object!]
		field	[integer!]
		return:	[red-block!]
		/local
			ctx	  [red-context!]
			blk   [red-block!]
			syms  [red-value!]
			vals  [red-value!]
			tail  [red-value!]
			value [red-value!]
			s	  [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		ctx: GET_CTX(obj)

		case [
			field = words/words [
				blk/node: ctx/symbols
				blk: block/clone blk no
			]
			field = words/values [
				blk/node: ctx/values
				blk: block/clone blk no
			]
			field = words/body [
				blk/node: ctx/symbols
				blk/node: alloc-cells block/rs-length? blk

				s: as series! ctx/symbols/value
				syms: s/offset
				tail: s/tail

				s: as series! ctx/values/value
				vals: s/offset

				while [syms < tail][
					value: block/rs-append blk syms
					value/header: TYPE_SET_WORD
					block/rs-append blk vals
					syms: syms + 1
					vals: vals + 1
				]
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		as red-block! stack/set-last as red-value! blk
	]

	form: func [
		obj		[red-object!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/form"]]

		serialize obj buffer no no no arg part no 0
	]

	mold: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/mold"]]

		string/concatenate-literal buffer "make object! [^/"
		part: serialize obj buffer only? all? flat? arg part - 15 yes indent + 1
		if indent > 0 [part: do-indent buffer indent part]
		string/append-char GET_BUFFER(buffer) as-integer #"]"
		part - 1
	]

	eval-path: func [
		parent	[red-object!]							;-- implicit type casting
		element	[red-value!]
		set?	[logic!]
		return:	[red-value!]
		/local
			word [red-word!]
			ctx  [red-context!]
	][
		word: as red-word! element
		ctx:  GET_CTX(parent)

		if word/ctx <> parent/ctx [						;-- bind the word to object's context
			word/index: _context/find-word ctx word/symbol
			word/ctx: parent/ctx
		]
		either set? [
			_context/set-in word stack/arguments ctx
			stack/arguments
		][
			_context/get-in word ctx
		]
	]

	copy: func [
		obj      [red-object!]
		new	  	 [red-object!]
		part-arg [red-value!]
		deep?	 [logic!]
		types	 [red-value!]
		return:	 [red-object!]
		/local
			ctx	  [red-context!]
			nctx  [red-context!]
			value [red-value!]
			tail  [red-value!]
			src	  [series!]
			dst	  [series!]
			size  [integer!]
			slots [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/copy"]]

		if OPTION?(types) [--NOT_IMPLEMENTED--]

		if OPTION?(part-arg) [
			print-line "***Error: copy/part is not supported on objects"
			halt
		]

		ctx:	GET_CTX(obj)
		src:	as series! ctx/symbols/value
		size:   as-integer src/tail - src/offset
		slots:	size >> 4

		new:  make-at new slots
		nctx: GET_CTX(new)

		;-- process SYMBOLS
		dst: as series! nctx/symbols/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots
		_context/set-context-each dst new/ctx

		;-- process VALUES
		src: as series! ctx/values/value
		dst: as series! nctx/values/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots

		if deep? [
			value: dst/offset
			tail:  dst/tail

			while [value < tail][
				switch TYPE_OF(value) [					;@@ replace it with ANY_SERIES?()
					TYPE_BLOCK
					TYPE_PAREN
					TYPE_PATH
					TYPE_SET_PATH
					TYPE_GET_PATH
					TYPE_LIT_PATH
					TYPE_STRING
					TYPE_FILE [
						actions/copy value value null yes null ;-- overwrite the value
					]
					TYPE_FUNCTION [
						rebind as red-function! value nctx
					]
					default [0]
				]
				value: value + 1
			]
		]

		new
	]

	init: does [
		datatype/register [
			TYPE_OBJECT
			TYPE_VALUE
			"object!"
			;-- General actions --
			:make
			null			;random
			:reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			null			;compare
			;-- Scalar actions --
			null			;absolute
			null			;add
			null			;divide
			null			;multiply
			null			;negate
			null			;power
			null			;remainder
			null			;round
			null			;subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			:copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]

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

object: context [
	verbose: 0

	do-indent: func [
		buffer	[red-string!]
		tabs	[integer!]
		part	[integer!]
		return:	[integer!]
		/local
			n [integer!]
	][
		n: tabs
		until [
			string/concatenate-literal buffer "    "
			n: n - 1
			zero? n
		]
		part - (4 * tabs)
	]

	serialize: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent?	[logic!]
		tabs	[integer!]
		return: [integer!]
		/local
			ctx		[red-context!]
			syms	[series!]
			values	[series!]
			sym		[red-value!]
			s-tail	[red-value!]
			value	[red-value!]
	][
		ctx: 	GET_CTX(obj)
		syms:   as series! ctx/symbols/value
		values: as series! ctx/values/value

		sym:	syms/offset
		s-tail: syms/tail
		value: 	values/offset

		while [sym < s-tail][
			if indent? [part: do-indent buffer tabs part]

			part: word/mold as red-word! sym buffer no no flat? arg part tabs
			string/concatenate-literal buffer ": "
			part: part - 2

			part: actions/mold value buffer only? all? flat? arg part tabs

			if any [indent? sym + 1 < s-tail][			;-- no final LF when FORMed
				string/append-char GET_BUFFER(buffer) as-integer lf
				part: part - 1
			]
			sym: sym + 1
			value: value + 1
		]
		part
	]

	extend: func [
		ctx	  [red-context!]
		spec  [red-context!]
		/local
			syms  [red-value!]
			tail  [red-value!]
			vals  [red-value!]
			value [red-value!]
			s	  [series!]
	][
		s: as series! spec/symbols/value
		syms: s/offset
		tail: s/tail

		s: as series! spec/values/value
		vals: s/offset

		while [syms < tail][
			value: _context/add-with ctx as red-word! syms vals

			unless null? value [
				switch TYPE_OF(value) [					;@@ replace it with ANY_SERIES?()
					TYPE_BLOCK
					TYPE_PAREN
					TYPE_PATH
					TYPE_SET_PATH
					TYPE_GET_PATH
					TYPE_LIT_PATH
					TYPE_STRING
					TYPE_FILE [
						actions/copy value value null yes null ;-- overwrite the value
					]
					TYPE_FUNCTION [
						rebind as red-function! value ctx
					]
					default [0]
				]
			]
			syms: syms + 1
			vals: vals + 1
		]
	]

	rebind: func [
		fun		[red-function!]
		ctx 	[red-context!]
		/local
			s	 [series!]
			more [red-value!]
			blk  [red-block!]
	][
		s: as series! fun/more/value
		more: s/offset

		if TYPE_OF(more) = TYPE_NONE [
			print-line "*** Error: COPY stuck on missing function's body block"
			halt
		]
		blk: block/clone as red-block! more yes
		copy-cell as red-value! blk s/offset
		blk: as red-block! s/offset

		_context/bind blk ctx yes
		_context/bind blk GET_CTX(fun) no

		more: more + 2
		more/header: TYPE_UNSET			;-- invalidate compiled body
	]

	make-at: func [
		obj		[red-object!]
		slots	[integer!]
		return: [red-object!]
	][
		obj/header: TYPE_OBJECT
		obj/ctx: _context/create slots no yes
		obj
	]

	;-- Actions --

	make: func [
		proto	[red-object!]
		spec	[red-value!]
		return:	[red-object!]
		/local
			obj	 [red-object!]
			obj2 [red-object!]
			ctx  [red-context!]
			blk  [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/make"]]

		obj: as red-object! stack/push*

		either TYPE_OF(proto) = TYPE_OBJECT [
			copy proto obj null yes null				;-- /deep
		][
			make-at obj 4								;-- arbitrary value
		]
		ctx: GET_CTX(obj)

		switch TYPE_OF(spec) [
			TYPE_OBJECT [
				obj2: as red-object! spec
				extend ctx GET_CTX(obj2)
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				_context/collect-set-words ctx blk
				_context/bind blk ctx yes
				interpreter/eval blk
			]
			default [
				print-line "*** Error: invalid spec value for object construction"
				halt
			]
		]
		obj
	]

	reflect: func [
		obj		[red-object!]
		field	[integer!]
		return:	[red-block!]
		/local
			ctx	  [red-context!]
			blk   [red-block!]
			syms  [red-value!]
			vals  [red-value!]
			tail  [red-value!]
			value [red-value!]
			s	  [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		ctx: GET_CTX(obj)

		case [
			field = words/words [
				blk/node: ctx/symbols
				blk: block/clone blk no
			]
			field = words/values [
				blk/node: ctx/values
				blk: block/clone blk no
			]
			field = words/body [
				blk/node: ctx/symbols
				blk/node: alloc-cells block/rs-length? blk

				s: as series! ctx/symbols/value
				syms: s/offset
				tail: s/tail

				s: as series! ctx/values/value
				vals: s/offset

				while [syms < tail][
					value: block/rs-append blk syms
					value/header: TYPE_SET_WORD
					block/rs-append blk vals
					syms: syms + 1
					vals: vals + 1
				]
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		as red-block! stack/set-last as red-value! blk
	]

	form: func [
		obj		[red-object!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/form"]]

		serialize obj buffer no no no arg part no 0
	]

	mold: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/mold"]]

		string/concatenate-literal buffer "make object! [^/"
		part: serialize obj buffer only? all? flat? arg part - 15 yes indent + 1
		if indent > 0 [part: do-indent buffer indent part]
		string/append-char GET_BUFFER(buffer) as-integer #"]"
		part - 1
	]

	eval-path: func [
		parent	[red-object!]							;-- implicit type casting
		element	[red-value!]
		set?	[logic!]
		return:	[red-value!]
		/local
			word [red-word!]
			ctx  [red-context!]
	][
		word: as red-word! element
		ctx:  GET_CTX(parent)

		if word/ctx <> parent/ctx [						;-- bind the word to object's context
			word/index: _context/find-word ctx word/symbol
			word/ctx: parent/ctx
		]
		either set? [
			_context/set-in word stack/arguments ctx
			stack/arguments
		][
			_context/get-in word ctx
		]
	]

	copy: func [
		obj      [red-object!]
		new	  	 [red-object!]
		part-arg [red-value!]
		deep?	 [logic!]
		types	 [red-value!]
		return:	 [red-object!]
		/local
			ctx	  [red-context!]
			nctx  [red-context!]
			value [red-value!]
			tail  [red-value!]
			src	  [series!]
			dst	  [series!]
			size  [integer!]
			slots [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/copy"]]

		if OPTION?(types) [--NOT_IMPLEMENTED--]

		if OPTION?(part-arg) [
			print-line "***Error: copy/part is not supported on objects"
			halt
		]

		ctx:	GET_CTX(obj)
		src:	as series! ctx/symbols/value
		size:   as-integer src/tail - src/offset
		slots:	size >> 4

		new:  make-at new slots
		nctx: GET_CTX(new)

		;-- process SYMBOLS
		dst: as series! nctx/symbols/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots
		_context/set-context-each dst new/ctx

		;-- process VALUES
		src: as series! ctx/values/value
		dst: as series! nctx/values/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots

		if deep? [
			value: dst/offset
			tail:  dst/tail

			while [value < tail][
				switch TYPE_OF(value) [					;@@ replace it with ANY_SERIES?()
					TYPE_BLOCK
					TYPE_PAREN
					TYPE_PATH
					TYPE_SET_PATH
					TYPE_GET_PATH
					TYPE_LIT_PATH
					TYPE_STRING
					TYPE_FILE [
						actions/copy value value null yes null ;-- overwrite the value
					]
					TYPE_FUNCTION [
						rebind as red-function! value nctx
					]
					default [0]
				]
				value: value + 1
			]
		]

		new
	]

	init: does [
		datatype/register [
			TYPE_OBJECT
			TYPE_VALUE
			"object!"
			;-- General actions --
			:make
			null			;random
			:reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			null			;compare
			;-- Scalar actions --
			null			;absolute
			null			;add
			null			;divide
			null			;multiply
			null			;negate
			null			;power
			null			;remainder
			null			;round
			null			;subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			:copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]


FEAT: added hexa and integer values for type IDs in macros.reds

Red/System [
	Title:   "Red runtime macro definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %macros.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
	}
]

#enum datatypes! [
	TYPE_VALUE											;-- 00		00
	TYPE_DATATYPE										;-- 01		01
	TYPE_UNSET											;-- 02		02
	TYPE_NONE											;-- 03		03
	TYPE_LOGIC											;-- 04		04
	TYPE_BLOCK											;-- 05		05
	TYPE_PAREN											;-- 06		06
	TYPE_STRING											;-- 07		07
	TYPE_FILE											;-- 08		08
	TYPE_URL											;-- 09		09
	TYPE_CHAR											;-- 0A		10
	TYPE_INTEGER										;-- 0B		11
	TYPE_FLOAT											;-- 0C		12
	TYPE_SYMBOL											;-- 0D		13
	TYPE_CONTEXT										;-- 0E		14
	TYPE_WORD											;-- 0F		15
	TYPE_SET_WORD										;-- 10		16
	TYPE_LIT_WORD										;-- 11		17
	TYPE_GET_WORD										;-- 12		18
	TYPE_REFINEMENT										;-- 13		19
	TYPE_ISSUE											;-- 14		20
	TYPE_NATIVE											;-- 15		21
	TYPE_ACTION											;-- 16		22
	TYPE_OP												;-- 17		23
	TYPE_FUNCTION										;-- 18		24
	TYPE_PATH											;-- 19		25
	TYPE_LIT_PATH										;-- 1A		26
	TYPE_SET_PATH										;-- 1B		27
	TYPE_GET_PATH										;-- 1C		28
	TYPE_ROUTINE										;-- 1D		29
	TYPE_BITSET											;-- 1E		30
	TYPE_POINT											;-- 1F		31
	TYPE_OBJECT											;-- 20		32
	TYPE_TYPESET										;-- 21		33
	TYPE_ERROR											;-- 22		34
	TYPE_VECTOR											;-- 23		35

	TYPE_BINARY
	TYPE_CLOSURE
	TYPE_PORT
]

#enum actions! [

	;-- General actions --
	ACT_MAKE: 	1										;-- used as index in action-table (one-based)
	ACT_RANDOM
	ACT_REFLECT
	ACT_TO
	ACT_FORM
	ACT_MOLD

	ACT_EVALPATH
	ACT_SETPATH											;@@ Deprecate it?
	ACT_COMPARE

	;-- Scalar actions --
	ACT_ABSOLUTE
	ACT_ADD
	ACT_DIVIDE
	ACT_MULTIPLY
	ACT_NEGATE
	ACT_POWER
	ACT_REMAINDER
	ACT_ROUND
	ACT_SUBTRACT
	ACT_EVEN?
	ACT_ODD?

	;-- Bitwise actions --
	ACT_AND~
	ACT_COMPLEMENT
	ACT_OR~
	ACT_XOR~

	;-- Series actions --
	ACT_APPEND
	ACT_AT
	ACT_BACK
	ACT_CHANGE
	ACT_CLEAR
	ACT_COPY
	ACT_FIND
	ACT_HEAD
	ACT_HEAD?
	ACT_INDEX?
	ACT_INSERT
	ACT_LENGTH?
	ACT_NEXT
	ACT_PICK
	ACT_POKE
	ACT_REMOVE
	ACT_REVERSE
	ACT_SELECT
	ACT_SORT
	ACT_SKIP
	ACT_SWAP
	ACT_TAIL
	ACT_TAIL?
	ACT_TAKE
	ACT_TRIM

	;-- I/O actions --
	ACT_CREATE
	ACT_CLOSE
	ACT_DELETE
	ACT_MODIFY
	ACT_OPEN
	ACT_OPEN?
	ACT_QUERY
	ACT_READ
	ACT_RENAME
	ACT_UPDATE
	ACT_WRITE

	;ACT_APPLY											;; add it? @@
]

#enum natives! [
	NAT_IF: 	1										;-- one-based index
	NAT_UNLESS
	NAT_EITHER
	NAT_ANY
	NAT_ALL
	NAT_WHILE
	NAT_UNTIL
	NAT_LOOP
	NAT_REPEAT
	NAT_FOREVER
	NAT_FOREACH
	NAT_FORALL
	NAT_FUNC
	NAT_FUNCTION
	NAT_DOES
	NAT_HAS
	NAT_SWITCH
	NAT_CASE
	NAT_DO
	NAT_GET
	NAT_SET
	NAT_PRINT
	NAT_PRIN
	NAT_EQUAL?
	NAT_NOT_EQUAL?
	NAT_STRICT_EQUAL?
	NAT_LESSER?
	NAT_GREATER?
	NAT_LESSER_OR_EQUAL?
	NAT_GREATER_OR_EQUAL?
	NAT_SAME?
	NAT_NOT
	NAT_HALT
	NAT_TYPE?
	NAT_REDUCE
	NAT_COMPOSE
	NAT_STATS
	NAT_BIND
	NAT_IN
	NAT_PARSE
	NAT_UNION
	NAT_INTERSECT
	NAT_UNIQUE
	NAT_DIFFERENCE
	NAT_COMPLEMENT?
	NAT_DEHEX
	NAT_NEGATIVE?
	NAT_POSITIVE?
	NAT_MAX
	NAT_MIN
	NAT_SHIFT
	NAT_TO_HEX
	NAT_SINE
	NAT_COSINE
	NAT_TANGENT
	NAT_ARCSINE
	NAT_ARCCOSINE
	NAT_ARCTANGENT
	NAT_ARCTANGENT2
	NAT_NAN?
	NAT_LOG_2
	NAT_LOG_10
	NAT_LOG_E
	NAT_EXP
	NAT_SQUARE_ROOT
	NAT_CONSTRUCT
	NAT_VALUE?
	NAT_TRY
]

#enum math-op! [
	OP_ADD
	OP_SUB
	OP_MUL
	OP_DIV
	OP_REM
	;-- bitwise op!
	OP_OR
	OP_AND
	OP_XOR
]

#enum comparison-op! [
	COMP_EQUAL
	COMP_NOT_EQUAL
	COMP_STRICT_EQUAL
	COMP_LESSER
	COMP_LESSER_EQUAL
	COMP_GREATER
	COMP_GREATER_EQUAL
	COMP_SORT
	COMP_CASE_SORT
]

#enum exceptions! [
	NO_EXCEPTION
	THROWN_EXIT
	THROWN_RETURN
]

#define NATIVES_NB		100							;-- max number of natives (arbitrary set)
#define ACTIONS_NB		60							;-- number of actions (exact number)
#define INHERIT_ACTION	-1							;-- placeholder for letting parent's action pass through

#either debug? = yes [
	#define ------------| 	print-line
][
	#define ------------| 	comment
]

#define RED_ERROR			195939070				;-- #0BADCAFE (keep it positive)

#define TYPE_OF(value)		(value/header and get-type-mask)
#define GET_BUFFER(series)  (as series! series/node/value)
#define GET_UNIT(series)	(series/flags and get-unit-mask)
#define ALLOC_TAIL(series)	[alloc-at-tail series]
#define FLAG_SET?(flag)		(flags and flag <> 0)
#define OPTION?(ref-ptr)	(ref-ptr > stack/arguments)	;-- a bit inelegant, but saves a lot of code
#define ON_STACK?(ctx)		(ctx/header and flag-series-stk <> 0)
#define EQUAL_SYMBOLS?(a b) ((symbol/resolve a) = (symbol/resolve b))
#define EQUAL_WORDS?(a b) 	((symbol/resolve a/symbol) = (symbol/resolve b/symbol))
#define TO_CTX(node)		(as red-context! ((as series! node/value) + 1))
#define GET_CTX(obj)		(as red-context! ((as series! obj/ctx/value) + 1))
#define FLAG_NOT?(s)		(s/flags and flag-bitset-not <> 0)
#define SET_RETURN(value)	[stack/set-last as red-value! value]
#define TO_ERROR(cat id)	[#in system/catalog/errors cat #in system/catalog/errors/cat id]

#define WHITE_CHAR?(char)	[
	any [
		all [0 < char char < 33]			;-- All white chars: NL, CR, BS, etc...
		char = 133							;-- #"^(85)"
		char = 160							;-- #"^(A0)"
		char = 5760							;-- #"^(1680)"
		char = 6158							;-- #"^(180E)"
		all [8192 <= char char <= 8202]		;-- #"^(2000)" - #"^(200A)"
		char = 8232							;-- #"^(2028)"
		char = 8233							;-- #"^(2029)"
		char = 8239							;-- #"^(202F)"
		char = 8287							;-- #"^(205F)"
		char = 12288						;-- #"^(3000)"
	]
]

#define SPACE_CHAR?(char)	[
	any [
		char = 32							;-- #" "
		char = 9							;-- #"^-"
		char = 133							;-- #"^(85)"
		char = 160							;-- #"^(A0)"
		char = 5760							;-- #"^(1680)"
		char = 6158							;-- #"^(180E)"
		all [8192 <= char char <= 8202]		;-- #"^(2000)" - #"^(200A)"
		char = 8232							;-- #"^(2028)"
		char = 8233							;-- #"^(2029)"
		char = 8239							;-- #"^(202F)"
		char = 8287							;-- #"^(205F)"
		char = 12288						;-- #"^(3000)"
	]
]

#define ANY_SERIES?(type)	[
	any [
		type = TYPE_BLOCK
		type = TYPE_PAREN
		type = TYPE_PATH
		type = TYPE_LIT_PATH
		type = TYPE_SET_PATH
		type = TYPE_GET_PATH
		type = TYPE_STRING
		type = TYPE_FILE
		type = TYPE_URL
	]
]

#define BS_SET_BIT(array bit)  [
	pos: array + (bit >> 3)
	pos/value: pos/value or (as-byte 128 >> (bit and 7))
]

#define BS_CLEAR_BIT(array bit)  [
	pos: array + (bit >> 3)
	pos/value: pos/value and (as-byte 128 >> (bit and 7) xor 255)
]

#define BS_TEST_BIT(array bit set?)  [
	pos: array + (bit >> 3)
	set?: pos/value and (as-byte 128 >> (bit and 7)) <> null-byte
]

#define BS_PROCESS_SET_VIRTUAL(bs bit) [
	either not? [
		if virtual-bit? bs bit [return 1]
	][
		pbits: bound-check bs bit
	]
]

#define BS_PROCESS_CLEAR_VIRTUAL(bs bit) [
	either not? [
		pbits: bound-check bs bit
	][
		if virtual-bit? bs bit [return 0]
	]
]

#define ERR_INVALID_REFINEMENT_ARG(refine arg) [
	fire [
		TO_ERROR(script invalid-refine-arg)
		refine
		arg
	]
]

#define ERR_EXPECT_ARGUMENT(type arg-idx) [
	fire [
		TO_ERROR(script expect-arg)
		stack/get-call
		datatype/push type
		error/get-call-argument arg-idx
	]
]

#define --NOT_IMPLEMENTED--	[
	fire [TO_ERROR(internal not-done)]
]

#define RETURN_COMPARE_OTHER [
	return -2
]

#define CHECK_COMPARE_OTHER(type) [
	if all [
		TYPE_OF(str2) <> type
		any [
			all [
				op <> COMP_EQUAL
				op <> COMP_NOT_EQUAL
			]
			all [
				TYPE_OF(str2) <> TYPE_STRING		;@@ use ANY_STRING?
				TYPE_OF(str2) <> TYPE_FILE
				TYPE_OF(str2) <> TYPE_URL
			]
		]
	][RETURN_COMPARE_OTHER]
]

#define SIGN_COMPARE_RESULT(a b) [
	either a < b [-1][either a > b [1][0]]
]

#if debug? = yes [
	#define dump4	[dump-hex4 as int-ptr!]
	#define dump1	[dump-hex  as byte-ptr!]
]

Red/System [
	Title:   "Red runtime macro definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %macros.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
	}
]

#enum datatypes! [
	TYPE_VALUE
	TYPE_DATATYPE
	TYPE_UNSET
	TYPE_NONE
	TYPE_LOGIC
	TYPE_BLOCK
	TYPE_PAREN
	TYPE_STRING
	TYPE_FILE
	TYPE_URL
	TYPE_CHAR
	TYPE_INTEGER
	TYPE_FLOAT
	TYPE_SYMBOL
	TYPE_CONTEXT
	TYPE_WORD
	TYPE_SET_WORD
	TYPE_LIT_WORD
	TYPE_GET_WORD
	TYPE_REFINEMENT
	TYPE_ISSUE
	TYPE_NATIVE
	TYPE_ACTION
	TYPE_OP
	TYPE_FUNCTION
	TYPE_PATH
	TYPE_LIT_PATH
	TYPE_SET_PATH
	TYPE_GET_PATH
	TYPE_ROUTINE
	TYPE_BITSET
	TYPE_POINT
	TYPE_OBJECT
	TYPE_TYPESET
	TYPE_ERROR
	TYPE_VECTOR

	TYPE_BINARY
	TYPE_CLOSURE
	TYPE_PORT
]

#enum actions! [

	;-- General actions --
	ACT_MAKE: 	1										;-- used as index in action-table (one-based)
	ACT_RANDOM
	ACT_REFLECT
	ACT_TO
	ACT_FORM
	ACT_MOLD

	ACT_EVALPATH
	ACT_SETPATH											;@@ Deprecate it?
	ACT_COMPARE

	;-- Scalar actions --
	ACT_ABSOLUTE
	ACT_ADD
	ACT_DIVIDE
	ACT_MULTIPLY
	ACT_NEGATE
	ACT_POWER
	ACT_REMAINDER
	ACT_ROUND
	ACT_SUBTRACT
	ACT_EVEN?
	ACT_ODD?

	;-- Bitwise actions --
	ACT_AND~
	ACT_COMPLEMENT
	ACT_OR~
	ACT_XOR~

	;-- Series actions --
	ACT_APPEND
	ACT_AT
	ACT_BACK
	ACT_CHANGE
	ACT_CLEAR
	ACT_COPY
	ACT_FIND
	ACT_HEAD
	ACT_HEAD?
	ACT_INDEX?
	ACT_INSERT
	ACT_LENGTH?
	ACT_NEXT
	ACT_PICK
	ACT_POKE
	ACT_REMOVE
	ACT_REVERSE
	ACT_SELECT
	ACT_SORT
	ACT_SKIP
	ACT_SWAP
	ACT_TAIL
	ACT_TAIL?
	ACT_TAKE
	ACT_TRIM

	;-- I/O actions --
	ACT_CREATE
	ACT_CLOSE
	ACT_DELETE
	ACT_MODIFY
	ACT_OPEN
	ACT_OPEN?
	ACT_QUERY
	ACT_READ
	ACT_RENAME
	ACT_UPDATE
	ACT_WRITE

	;ACT_APPLY											;; add it? @@
]

#enum natives! [
	NAT_IF: 	1										;-- one-based index
	NAT_UNLESS
	NAT_EITHER
	NAT_ANY
	NAT_ALL
	NAT_WHILE
	NAT_UNTIL
	NAT_LOOP
	NAT_REPEAT
	NAT_FOREVER
	NAT_FOREACH
	NAT_FORALL
	NAT_FUNC
	NAT_FUNCTION
	NAT_DOES
	NAT_HAS
	NAT_SWITCH
	NAT_CASE
	NAT_DO
	NAT_GET
	NAT_SET
	NAT_PRINT
	NAT_PRIN
	NAT_EQUAL?
	NAT_NOT_EQUAL?
	NAT_STRICT_EQUAL?
	NAT_LESSER?
	NAT_GREATER?
	NAT_LESSER_OR_EQUAL?
	NAT_GREATER_OR_EQUAL?
	NAT_SAME?
	NAT_NOT
	NAT_HALT
	NAT_TYPE?
	NAT_REDUCE
	NAT_COMPOSE
	NAT_STATS
	NAT_BIND
	NAT_IN
	NAT_PARSE
	NAT_UNION
	NAT_INTERSECT
	NAT_UNIQUE
	NAT_DIFFERENCE
	NAT_COMPLEMENT?
	NAT_DEHEX
	NAT_NEGATIVE?
	NAT_POSITIVE?
	NAT_MAX
	NAT_MIN
	NAT_SHIFT
	NAT_TO_HEX
	NAT_SINE
	NAT_COSINE
	NAT_TANGENT
	NAT_ARCSINE
	NAT_ARCCOSINE
	NAT_ARCTANGENT
	NAT_ARCTANGENT2
	NAT_NAN?
	NAT_LOG_2
	NAT_LOG_10
	NAT_LOG_E
	NAT_EXP
	NAT_SQUARE_ROOT
	NAT_CONSTRUCT
	NAT_VALUE?
	NAT_TRY
]

#enum math-op! [
	OP_ADD
	OP_SUB
	OP_MUL
	OP_DIV
	OP_REM
	;-- bitwise op!
	OP_OR
	OP_AND
	OP_XOR
]

#enum comparison-op! [
	COMP_EQUAL
	COMP_NOT_EQUAL
	COMP_STRICT_EQUAL
	COMP_LESSER
	COMP_LESSER_EQUAL
	COMP_GREATER
	COMP_GREATER_EQUAL
	COMP_SORT
	COMP_CASE_SORT
]

#enum exceptions! [
	NO_EXCEPTION
	THROWN_EXIT
	THROWN_RETURN
]

#define NATIVES_NB		100							;-- max number of natives (arbitrary set)
#define ACTIONS_NB		60							;-- number of actions (exact number)
#define INHERIT_ACTION	-1							;-- placeholder for letting parent's action pass through

#either debug? = yes [
	#define ------------| 	print-line
][
	#define ------------| 	comment
]

#define RED_ERROR			195939070				;-- #0BADCAFE (keep it positive)

#define TYPE_OF(value)		(value/header and get-type-mask)
#define GET_BUFFER(series)  (as series! series/node/value)
#define GET_UNIT(series)	(series/flags and get-unit-mask)
#define ALLOC_TAIL(series)	[alloc-at-tail series]
#define FLAG_SET?(flag)		(flags and flag <> 0)
#define OPTION?(ref-ptr)	(ref-ptr > stack/arguments)	;-- a bit inelegant, but saves a lot of code
#define ON_STACK?(ctx)		(ctx/header and flag-series-stk <> 0)
#define EQUAL_SYMBOLS?(a b) ((symbol/resolve a) = (symbol/resolve b))
#define EQUAL_WORDS?(a b) 	((symbol/resolve a/symbol) = (symbol/resolve b/symbol))
#define TO_CTX(node)		(as red-context! ((as series! node/value) + 1))
#define GET_CTX(obj)		(as red-context! ((as series! obj/ctx/value) + 1))
#define FLAG_NOT?(s)		(s/flags and flag-bitset-not <> 0)
#define SET_RETURN(value)	[stack/set-last as red-value! value]
#define TO_ERROR(cat id)	[#in system/catalog/errors cat #in system/catalog/errors/cat id]

#define WHITE_CHAR?(char)	[
	any [
		all [0 < char char < 33]			;-- All white chars: NL, CR, BS, etc...
		char = 133							;-- #"^(85)"
		char = 160							;-- #"^(A0)"
		char = 5760							;-- #"^(1680)"
		char = 6158							;-- #"^(180E)"
		all [8192 <= char char <= 8202]		;-- #"^(2000)" - #"^(200A)"
		char = 8232							;-- #"^(2028)"
		char = 8233							;-- #"^(2029)"
		char = 8239							;-- #"^(202F)"
		char = 8287							;-- #"^(205F)"
		char = 12288						;-- #"^(3000)"
	]
]

#define SPACE_CHAR?(char)	[
	any [
		char = 32							;-- #" "
		char = 9							;-- #"^-"
		char = 133							;-- #"^(85)"
		char = 160							;-- #"^(A0)"
		char = 5760							;-- #"^(1680)"
		char = 6158							;-- #"^(180E)"
		all [8192 <= char char <= 8202]		;-- #"^(2000)" - #"^(200A)"
		char = 8232							;-- #"^(2028)"
		char = 8233							;-- #"^(2029)"
		char = 8239							;-- #"^(202F)"
		char = 8287							;-- #"^(205F)"
		char = 12288						;-- #"^(3000)"
	]
]

#define ANY_SERIES?(type)	[
	any [
		type = TYPE_BLOCK
		type = TYPE_PAREN
		type = TYPE_PATH
		type = TYPE_LIT_PATH
		type = TYPE_SET_PATH
		type = TYPE_GET_PATH
		type = TYPE_STRING
		type = TYPE_FILE
		type = TYPE_URL
	]
]

#define BS_SET_BIT(array bit)  [
	pos: array + (bit >> 3)
	pos/value: pos/value or (as-byte 128 >> (bit and 7))
]

#define BS_CLEAR_BIT(array bit)  [
	pos: array + (bit >> 3)
	pos/value: pos/value and (as-byte 128 >> (bit and 7) xor 255)
]

#define BS_TEST_BIT(array bit set?)  [
	pos: array + (bit >> 3)
	set?: pos/value and (as-byte 128 >> (bit and 7)) <> null-byte
]

#define BS_PROCESS_SET_VIRTUAL(bs bit) [
	either not? [
		if virtual-bit? bs bit [return 1]
	][
		pbits: bound-check bs bit
	]
]

#define BS_PROCESS_CLEAR_VIRTUAL(bs bit) [
	either not? [
		pbits: bound-check bs bit
	][
		if virtual-bit? bs bit [return 0]
	]
]

#define ERR_INVALID_REFINEMENT_ARG(refine arg) [
	fire [
		TO_ERROR(script invalid-refine-arg)
		refine
		arg
	]
]

#define ERR_EXPECT_ARGUMENT(type arg-idx) [
	fire [
		TO_ERROR(script expect-arg)
		stack/get-call
		datatype/push type
		error/get-call-argument arg-idx
	]
]

#define --NOT_IMPLEMENTED--	[
	fire [TO_ERROR(internal not-done)]
]

#define RETURN_COMPARE_OTHER [
	return -2
]

#define CHECK_COMPARE_OTHER(type) [
	if all [
		TYPE_OF(str2) <> type
		any [
			all [
				op <> COMP_EQUAL
				op <> COMP_NOT_EQUAL
			]
			all [
				TYPE_OF(str2) <> TYPE_STRING		;@@ use ANY_STRING?
				TYPE_OF(str2) <> TYPE_FILE
				TYPE_OF(str2) <> TYPE_URL
			]
		]
	][RETURN_COMPARE_OTHER]
]

#define SIGN_COMPARE_RESULT(a b) [
	either a < b [-1][either a > b [1][0]]
]

#if debug? = yes [
	#define dump4	[dump-hex4 as int-ptr!]
	#define dump1	[dump-hex  as byte-ptr!]
]