FIX: lit-words were not bound to local context on runtime functions creation.

Red/System [
	Title:   "Function! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %function.reds
	Tabs:	 4
	Rights:  "Copyright (C) 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
	}
]

_function: context [
	verbose: 0

	collect-deep: func [
		list   [red-block!]
		ignore [red-block!]
		blk    [red-block!]
		/local
			value  [red-value!]
			tail   [red-value!]
			end	   [red-value!]
			result [red-value!]
			word   [red-value!]
	][
		value: block/rs-head blk
		tail:  block/rs-tail blk

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_SET_WORD [
					word: stack/push value
					word/header: TYPE_WORD				;-- convert the set-word! into a word!

					result: block/find ignore word null no no no null null no no no no

					if TYPE_OF(result) = TYPE_NONE [
						block/rs-append list word
						block/rs-append ignore word
					]
					stack/pop 2							;-- remove word and FIND result from stack
				]
				TYPE_BLOCK
				TYPE_PAREN [
					collect-deep list ignore as red-block! value
				]
				default [0]
			]
			value: value + 1
		]
	]

	collect-words: func [
		spec	[red-block!]
		body	[red-block!]
		return: [red-block!]
		/local
			list	[red-block!]
			ignore	[red-block!]
			extern	[red-block!]
			value	[red-value!]
			tail	[red-value!]
			s		[series!]
			extern? [logic!]
	][
		list: block/push* 8
		block/rs-append list as red-value! refinements/local

		ignore: block/clone spec no
		block/rs-append ignore as red-value! refinements/local

		value:  as red-value! refinements/extern		;-- process optional /extern
		extern: as red-block! block/find spec value null no no no null null no no no no
		extern?: TYPE_OF(extern) <> TYPE_NONE

		if extern? [
			s: GET_BUFFER(spec)
			s/tail: s/offset + extern/head				;-- cut /extern and extern words out
		]
		stack/pop 1										;-- remove FIND result from stack

		value:  block/rs-head ignore
		tail:	block/rs-tail ignore

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD 	  [0]						;-- do nothing
				TYPE_REFINEMENT
				TYPE_GET_WORD
				TYPE_SET_WORD [
					value/header: TYPE_WORD				;-- convert it to a word!
				]
				default [
					if extern? [
						print-line ["*** Error: invalid /extern values"]
						halt
					]
				]
			]
			value: value + 1
		]

		collect-deep list ignore body

		if 1 < block/rs-length? list [
			block/rs-append-block spec list
		]
		list
	]

	validate: func [									;-- temporary mimalist spec checking
		spec [red-block!]
		/local
			value  [red-value!]
			end	   [red-value!]
			next   [red-value!]
			block? [logic!]
	][
		value: block/rs-head spec
		end:   block/rs-tail spec

		while [value < end][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD [
					next: value + 1
					block?: all [
						next < end
						TYPE_OF(next) = TYPE_BLOCK
					]
					value: value + either block? [2][1]
				]
				TYPE_SET_WORD [
					next: value + 1
					unless all [
						next < end
						TYPE_OF(next) = TYPE_BLOCK
					][
						print-line "*** Error: return: not followed by type in function spec"
						halt
					]
					value: next
				]
				TYPE_LIT_WORD
				TYPE_REFINEMENT
				TYPE_BLOCK
				TYPE_STRING [
					value: value + 1
				]
				default [
					print-line "*** Error: invalid value in function spec"
					halt
				]
			]
		]
	]

	bind: func [
		body [red-block!]
		ctx	 [red-context!]
		/local
			value [red-value!]
			end	  [red-value!]
			w	  [red-word!]
			idx	  [integer!]
			type  [integer!]
	][
		value: block/rs-head body
		end:   block/rs-tail body

		while [value < end][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_SET_WORD
				TYPE_LIT_WORD
				TYPE_REFINEMENT [
					w: as red-word! value
					idx: _context/find-word ctx w/symbol
					if idx >= 0 [
						w/ctx:   ctx
						w/index: idx
					]
				]
				TYPE_BLOCK 					;@@ replace with TYPE_ANY_BLOCK
				TYPE_PAREN
				TYPE_PATH
				TYPE_LIT_PATH
				TYPE_SET_PATH
				TYPE_GET_PATH	[
					bind as red-block! value ctx
				]
				default [0]
			]
			value: value + 1
		]
	]

	init-locals: func [
		nb 	   [integer!]
		/local
			p  [red-value!]
	][
		until [
			p: stack/push*
			p/header: TYPE_NONE
			nb: nb - 1
			zero? nb
		]
	]

	push: func [
		spec	 [red-block!]
		body	 [red-block!]
		code	 [integer!]
		return:	 [red-context!]							;-- return function's local context
		/local
			cell   [red-function!]
			native [red-native!]
			more   [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_function/push"]]

		cell: as red-function! stack/push*
		cell/header: TYPE_FUNCTION						;-- implicit reset of all header flags
		cell/spec:	 spec/node
		cell/ctx:	 _context/make spec yes
		cell/more:	 alloc-cells 3

		more: as series! cell/more/value
		copy-cell
			as cell! body
			alloc-tail more

		alloc-tail more									;-- reserved place for "symbols"

		native: as red-native! alloc-tail more
		native/header: TYPE_NATIVE
		native/code: code

		bind body cell/ctx
		cell/ctx
	]

	;-- Actions --

	reflect: func [
		fun		[red-function!]
		field	[integer!]
		return:	[red-block!]
		/local
			blk [red-block!]
			s	[series!]
	][
		case [
			field = words/spec [
				blk: as red-block! stack/arguments		;-- overwrite the function slot on stack
				blk/header: TYPE_BLOCK
				blk/node: fun/spec						;-- order of assignments matters
				blk/head: 0
			]
			field = words/body [
				s: as series! fun/more/value
				blk: as red-block! s/offset
				stack/set-last as red-value! blk
			]
			field = words/words [
				--NOT_IMPLEMENTED--						;@@ build the words block from spec
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		blk												;@@ TBD: remove it when all cases implemented
	]

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

		string/concatenate-literal buffer "?function?"
		part - 10
	]

	mold: func [
		fun		[red-function!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
		/local
			s	[series!]
			blk [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "function/mold"]]

		string/concatenate-literal buffer "func "

		blk: as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 0
		blk/node: fun/spec
		part: block/mold blk buffer only? all? flat? arg part - 5			;-- spec

		s: as series! fun/more/value
		block/mold as red-block! s/offset buffer only? all? flat? arg part	;-- body
	]

	datatype/register [
		TYPE_FUNCTION
		TYPE_CONTEXT
		"function!"
		;-- General actions --
		null			;make
		null			;random
		:reflect
		null			;to
		:form
		:mold
		null			;get-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
		null			;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:   "Function! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %function.reds
	Tabs:	 4
	Rights:  "Copyright (C) 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
	}
]

_function: context [
	verbose: 0

	collect-deep: func [
		list   [red-block!]
		ignore [red-block!]
		blk    [red-block!]
		/local
			value  [red-value!]
			tail   [red-value!]
			end	   [red-value!]
			result [red-value!]
			word   [red-value!]
	][
		value: block/rs-head blk
		tail:  block/rs-tail blk

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_SET_WORD [
					word: stack/push value
					word/header: TYPE_WORD				;-- convert the set-word! into a word!

					result: block/find ignore word null no no no null null no no no no

					if TYPE_OF(result) = TYPE_NONE [
						block/rs-append list word
						block/rs-append ignore word
					]
					stack/pop 2							;-- remove word and FIND result from stack
				]
				TYPE_BLOCK
				TYPE_PAREN [
					collect-deep list ignore as red-block! value
				]
				default [0]
			]
			value: value + 1
		]
	]

	collect-words: func [
		spec	[red-block!]
		body	[red-block!]
		return: [red-block!]
		/local
			list	[red-block!]
			ignore	[red-block!]
			extern	[red-block!]
			value	[red-value!]
			tail	[red-value!]
			s		[series!]
			extern? [logic!]
	][
		list: block/push* 8
		block/rs-append list as red-value! refinements/local

		ignore: block/clone spec no
		block/rs-append ignore as red-value! refinements/local

		value:  as red-value! refinements/extern		;-- process optional /extern
		extern: as red-block! block/find spec value null no no no null null no no no no
		extern?: TYPE_OF(extern) <> TYPE_NONE

		if extern? [
			s: GET_BUFFER(spec)
			s/tail: s/offset + extern/head				;-- cut /extern and extern words out
		]
		stack/pop 1										;-- remove FIND result from stack

		value:  block/rs-head ignore
		tail:	block/rs-tail ignore

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD 	  [0]						;-- do nothing
				TYPE_REFINEMENT
				TYPE_GET_WORD
				TYPE_SET_WORD [
					value/header: TYPE_WORD				;-- convert it to a word!
				]
				default [
					if extern? [
						print-line ["*** Error: invalid /extern values"]
						halt
					]
				]
			]
			value: value + 1
		]

		collect-deep list ignore body

		if 1 < block/rs-length? list [
			block/rs-append-block spec list
		]
		list
	]

	validate: func [									;-- temporary mimalist spec checking
		spec [red-block!]
		/local
			value  [red-value!]
			end	   [red-value!]
			next   [red-value!]
			block? [logic!]
	][
		value: block/rs-head spec
		end:   block/rs-tail spec

		while [value < end][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD [
					next: value + 1
					block?: all [
						next < end
						TYPE_OF(next) = TYPE_BLOCK
					]
					value: value + either block? [2][1]
				]
				TYPE_SET_WORD [
					next: value + 1
					unless all [
						next < end
						TYPE_OF(next) = TYPE_BLOCK
					][
						print-line "*** Error: return: not followed by type in function spec"
						halt
					]
					value: next
				]
				TYPE_LIT_WORD
				TYPE_REFINEMENT
				TYPE_BLOCK
				TYPE_STRING [
					value: value + 1
				]
				default [
					print-line "*** Error: invalid value in function spec"
					halt
				]
			]
		]
	]

	bind: func [
		body [red-block!]
		ctx	 [red-context!]
		/local
			value [red-value!]
			end	  [red-value!]
			w	  [red-word!]
			idx	  [integer!]
			type  [integer!]
	][
		value: block/rs-head body
		end:   block/rs-tail body

		while [value < end][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_SET_WORD
				TYPE_REFINEMENT [
					w: as red-word! value
					idx: _context/find-word ctx w/symbol
					if idx >= 0 [
						w/ctx:   ctx
						w/index: idx
					]
				]
				TYPE_BLOCK 					;@@ replace with TYPE_ANY_BLOCK
				TYPE_PAREN
				TYPE_PATH
				TYPE_LIT_PATH
				TYPE_SET_PATH
				TYPE_GET_PATH	[
					bind as red-block! value ctx
				]
				default [0]
			]
			value: value + 1
		]
	]

	init-locals: func [
		nb 	   [integer!]
		/local
			p  [red-value!]
	][
		until [
			p: stack/push*
			p/header: TYPE_NONE
			nb: nb - 1
			zero? nb
		]
	]

	push: func [
		spec	 [red-block!]
		body	 [red-block!]
		code	 [integer!]
		return:	 [red-context!]							;-- return function's local context
		/local
			cell   [red-function!]
			native [red-native!]
			more   [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_function/push"]]

		cell: as red-function! stack/push*
		cell/header: TYPE_FUNCTION						;-- implicit reset of all header flags
		cell/spec:	 spec/node
		cell/ctx:	 _context/make spec yes
		cell/more:	 alloc-cells 3

		more: as series! cell/more/value
		copy-cell
			as cell! body
			alloc-tail more

		alloc-tail more									;-- reserved place for "symbols"

		native: as red-native! alloc-tail more
		native/header: TYPE_NATIVE
		native/code: code

		bind body cell/ctx
		cell/ctx
	]

	;-- Actions --

	reflect: func [
		fun		[red-function!]
		field	[integer!]
		return:	[red-block!]
		/local
			blk [red-block!]
			s	[series!]
	][
		case [
			field = words/spec [
				blk: as red-block! stack/arguments		;-- overwrite the function slot on stack
				blk/header: TYPE_BLOCK
				blk/node: fun/spec						;-- order of assignments matters
				blk/head: 0
			]
			field = words/body [
				s: as series! fun/more/value
				blk: as red-block! s/offset
				stack/set-last as red-value! blk
			]
			field = words/words [
				--NOT_IMPLEMENTED--						;@@ build the words block from spec
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		blk												;@@ TBD: remove it when all cases implemented
	]

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

		string/concatenate-literal buffer "?function?"
		part - 10
	]

	mold: func [
		fun		[red-function!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
		/local
			s	[series!]
			blk [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "function/mold"]]

		string/concatenate-literal buffer "func "

		blk: as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 0
		blk/node: fun/spec
		part: block/mold blk buffer only? all? flat? arg part - 5			;-- spec

		s: as series! fun/more/value
		block/mold as red-block! s/offset buffer only? all? flat? arg part	;-- body
	]

	datatype/register [
		TYPE_FUNCTION
		TYPE_CONTEXT
		"function!"
		;-- General actions --
		null			;make
		null			;random
		:reflect
		null			;to
		:form
		:mold
		null			;get-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
		null			;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
	]
]


TESTS: updated tests re: issue #505

TESTS: updated tests re: issue #505

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

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

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

===start-group=== "find"
	--test-- "find-1"
	--assert [1 2 3 4] = find [1 2 3 4] 1
	--test-- "find-2"
	--assert [2 3 4] = find [1 2 3 4] 2
	--test-- "find-3"
	--assert [4] = find [1 2 3 4] 4
	--test-- "find-4"
	--assert none = find [1 2 3 4] 0
	--test-- "find-5"
	--assert none = find [1 2 3 4] 5
	--test-- "find-6"
	--assert none = find [1 2 3 4] "1"
	--test-- "find-7"
	--assert "12345" = find "12345" #"1"
	;--test-- "find-8" 							;; unsupported case, it is unsure if it will be implemented or not
	;--assert "12345" = find "12345" 1			;; keeping it here commented for further reference.
	--test-- "find-9"
	--assert "12345" = find "12345" "1"
	--test-- "find-10"
	--assert "12345" = find "12345" "12"
	--test-- "find-11"
	--assert "2345" = find "12345" #"2"
	--test-- "find-12"
	--assert "5" = find "12345" #"5"
	--test-- "find-13"
	--assert none = find "12345" #"0"
	--test-- "find-14"
	--assert none = find "12345" #"6"
	--test-- "find-15"
	--assert [2 3] = find [1 2 3] [2 3]
	--test-- "find-16"
	--assert none = find [1 2 3] [3 2]
	--test-- "find-17"
	--assert [2 3] = find [1 2 2 3] [2 3]
	--test-- "find-18"
	--assert none = find [1 2] [2 3]
	--test-- "find-19"
	--assert "é" = find "abcdeé" "é"
	--test-- "find-20"
	--assert "eé" = find "abcdeé" "eé"
	--test-- "find-21"
	--assert none = find "abcdeé" "ée"
	--test-- "find-22"
	--assert "✐" = find "abcde✐" "✐"            ;; code point 10000 (decimal)
	--test-- "find-23"
	--assert none = find "abcde✐" "ed✐"
	--test-- "find-24"
	--assert "^(010000)" = find "abcde^(010000)" "^(010000)"
===end-group===

===start-group=== "find/part"
	--test-- "find/part-1"
	--assert none = find/part "1234" "1" 0
	--test-- "find/part-2"
	--assert "1234" = find/part "1234" "1" 1
	--test-- "find/part-3"
	--assert "234" = find/part "1234" "2" 2
	--test-- "find/part-4"
	--assert "234" = find/part "1234" "2" 4
	--test-- "find/part-5"
	--assert "234" = find/part "1234" "2" 5
	--test-- "find/part-6"
	--assert none = find/part "1234" "3" 2
	--test-- "find/part-7"
	--assert none = find/part [1 2 3 4] 1 0
	--test-- "find/part-8"
	--assert [1 2 3 4] = find/part [1 2 3 4] 1 1
	--test-- "find/part-9"
	--assert [2 3 4] = find/part [1 2 3 4] 2 2
	--test-- "find/part-10"
	--assert [2 3 4] = find/part [1 2 3 4] [2 3] 4
	--test-- "find/part-11"
	--assert none = find/part [1 2 3 4] [2 3] 2
	--test-- "find/part-12"
	--assert none = find/part [1 2 3 4] 3 2
	--test-- "find/part-13"
	--assert none = find/part "Χαῖρε, κόσμε!" "Χαῖ" 2
===end-group===

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

===start-group=== "find/case"
	--test-- "find/case-1"
	--assert "abcde" = find/case "Aabcde" "a"
	--test-- "find/case-2"
	--assert "Abcde" = find/case "aAbcde" "A"
	--test-- "find/case-3"
	--assert none = find/case "è" "E"
===end-group===

===start-group=== "find/any"      ; not yet implemented
	--test-- "find/any-1"
	;--assert "12345" = find/any "12345" "*"
	--test-- "find/any-2"
	;--assert "12345" = find/any "12345" "?"
	--test-- "find/any-3"
	;--assert "2345" = find/any "12345" "2?4"
	--test-- "find/any-4"
	;assert "2345" = find/any "12345" "2*"
	--test-- "find/any-5"
	;assert "e✐" = find/any "abcde✐" "e?"        ;; code point 10000 (decimal)
	--test-- "find/any-6"
	;assert "e✐f" = find/any "abcde✐f" "?f"
	--test-- "find/any-7"
	;assert "e✐" = find/any "abcde✐" "e*"
	--test-- "find/any-8"
	;assert "abcde✐f" = find/any "abcde✐f" "*f"
	--test-- "find/any-9"
	;assert "e^(010000)" = find/any "abcde^(010000)" "e?"
	--test-- "find/any-10"
	;assert "e^(010000)f" = find/any "abcde^(010000)f" "?f"
	--test-- "find/any-11"
	;assert "e^(010000)" = find/any "abcde^(010000)" "e*"
	--test-- "find/any-12"
	;assert "abcde^(010000)f" = find/any "abcde^(010000)f" "*f"
===end-group===

===start-group=== "find/with"      ; not yet implemented
	--test-- "find/with-1"
	;--assert "12345" = find/with "12345" "^(FFFF)" "^(FFFE)^(FFFF)"
	--test-- "find/with-2"
	;--assert "12345" = find/with "12345" "^(FFFE)" "^(FFFE)^(FFFF)"
	--test-- "find/with-3"
	;--assert "2345" = find/with "12345" "2^(FFFE)3" "^(FFFE)^(FFFF)"
	--test-- "find/with-4"
	;assert "2345" = find/with "12345" "2^(FFFF)" "^(FFFE)^(FFFF)"
	--test-- "find/with-5"
	;assert "e✐" = find/with "abcde✐" "e^(FFFE)" "^(FFFE)^(FFFF)"
	--test-- "find/with-6"
	;assert "e✐f" = find/with "abcde✐f" "^(FFFE)f" "^(FFFE)^(FFFF)"
	--test-- "find/with-7"
	;assert "e✐" = find/with "abcde✐" "e^(FFFF)" "^(FFFE)^(FFFF)"
	--test-- "find/with-8"
	;assert "abcde✐f" = find/with "abcde✐f" "^(FFFF)f" "^(FFFE)^(FFFF)"
	--test-- "find/with-9"
	;assert "e^(010000)" = find/with "abcde^(010000)" "e^(FFFE)" "^(FFFE)^(FFFF)"
	--test-- "find/with-10"
	;assert "e^(010000)f" = find/with "abcde^(010000)f" "^(FFFE)f" "^(FFFE)^(FFFF)"
	--test-- "find/with-11"
	;assert "e^(010000)" = find/with "abcde^(010000)" "e^(FFFF)" "^(FFFE)^(FFFF)"
	--test-- "find/with-12"
	;assert "abcde^(010000)f" = find/with "abcde^(010000)f" "^(FFFF)f" "^(FFFE)^(FFFF)"
===end-group===

===start-group=== "find/skip"
  --test-- "find/skip-1"
  --assert [6 7 8 9 0] = find/skip [1 2 3 4 5 1 6 6 6 6 1 2 3 4 5 6 7 8 9 0] 6 5
  --test-- "find/skip-2"
  --assert none = find/skip [1 2 3 4 5 1 6 6 6 6 1 2 3 4 5 1 2 3 4 5] 6 5
  --test-- "find/skip-3"
  --assert [6 7 8 9 0] = find/skip [1 2 3 4 5 6 6 6 6 6 1 2 3 4 5 6 7 8 9 0] [6 7] 5
  --test-- "find/skip-4"
  --assert none = find/skip [1 2 3 4 5 1 6 6 6 6 1 2 3 4 5 1 2 3 4 5] [6 7] 5
  --test-- "find/skip-5"
  --assert "67890" = find/skip "12345166661234567890" "6" 5
  --test-- "find/skip-6"
  --assert none = find/skip "12345166661234557890" "6" 5
===end-group===

===start-group=== "find/match"
  --test-- "find/match-1"
  --assert [and now] = find/match [here and now] 'here
  --test-- "find/match-2"
  --assert none = find/match [here and now] 'her
  --test-- "find/match-3"
  --assert none = find/match [her and now] 'here
  --test-- "find/match-4"
  --assert " and now" = find/match "here and now" "here"
  --test-- "find/match-5"
  --assert "andnow" = find/match "hereandnow" "here"
  --test-- "find/match-6"
  --assert none = find/match "her and now" "here"
  --test-- "find/match-7"
  --assert " and now" = find/match "here✐ and now" "here✐"
  --test-- "find/match-8"
  --assert "✐andnow" = find/match "here✐andnow" "here"
  --test-- "find/match-9"
  --assert none = find/match "her and now" "he✐r"
  --test-- "find/match-10"
  --assert none = find/match "here and now" "✐here"
  --test-- "find/match-11"
  --assert "^(010000)andnow" = find/match "here^(010000)andnow" "here"
  --test-- "find/match-12"
  --assert none = find/match "her and now" "here^(010000)"
  --test-- "find/match-13"
  --assert " and now" = find/match "here^(010000) and now" "here^(010000)"
  --test-- "find/match-14"
  --assert "andnow" = find/match "^(010000)hereandnow" "^(010000)here"
  --test-- "find/match-15"
  --assert none = find/match "her^(010000) and now" "here^(010000)"
  --test-- "find/match-16"
  --assert [and now] = find/match [he✐re and now] 'he✐re
===end-group===

===start-group=== "find/tail"
  --test-- "find/tail-1"
  --assert [and now] = find/tail [here and now] 'here
  --test-- "find/tail-2"
  --assert none = find/tail [here and now] 'her
  --test-- "find/tail-3"
  --assert none = find/tail [her and now] 'here
  --test-- "find/tail-4"
  --assert " and now" = find/tail "here and now" "here"
  --test-- "find/tail-5"
  --assert "andnow" = find/tail "hereandnow" "here"
  --test-- "find/tail-6"
  --assert none = find/tail "her and now" "here"
  --test-- "find/tail-7"
  --assert " and now" = find/tail "here✐ and now" "here✐"
  --test-- "find/tail-8"
  --assert "✐andnow" = find/tail "here✐andnow" "here"
  --test-- "find/tail-9"
  --assert none = find/tail "her and now" "he✐r"
  --test-- "find/tail-10"
  --assert none = find/tail "here and now" "✐here"
  --test-- "find/tail-11"
  --assert "^(010000)andnow" = find/tail "here^(010000)andnow" "here"
  --test-- "find/tail-12"
  --assert none = find/tail "her and now" "here^(010000)"
  --test-- "find/tail-13"
  --assert " and now" = find/tail "here^(010000) and now" "here^(010000)"
  --test-- "find/tail-14"
  --assert "andnow" = find/tail "^(010000)hereandnow" "^(010000)here"
  --test-- "find/tail-15"
  --assert none = find/tail "her^(010000) and now" "here^(010000)"
  --test-- "find/tail-16"
  --assert [and now] = find/tail [he✐re and now] 'he✐re
  --test-- "find/tail-17 issue #457"
  --assert "de" = find/tail "abcde" #"c"
  --test-- "find-tail-18"
  --assert "de" = find/tail "abc^^de" #"^^"

===end-group===

===start-group=== "find/last"
  --test-- "find/last-1"
  --assert [1] = find/last [1 1 1 1] 1
  --assert 4 = index? find/last [1 1 1 1] 1
  --test-- "find/last-2"
  --assert [2 1] = find/last [1 2 3 4 3 2 1] 2
  --test-- "find/last-3"
  --assert [3 3 2 1] = find/last [1 2 3 3 2 1] [3 3]
  --test-- "find/last-4"
  --assert "3321" = find/last "123321" "33"
  --test-- "find/last-5"
  --assert "321" = find/last "123321" "3"
  --test-- "find/last-6"
  --assert "1" = find/last "1111" "1"
  --test-- "find/last-7"
  --assert none = find/last "123" "34"
  --test-- "find/last-8"
  --assert "✐5678" = find/last "1234✐5678" "✐"
  --test-- "find/last-9"
  --assert "^(010000)5678" = find/last "1234^(010000)5678" "^(010000)"
===end-group===

===start-group=== "find/reverse"
  --test-- "find/reverse-1"
  --assert none = find/reverse [1 1 1 1] 1
  --test-- "find/reverse-2"
  --assert [2 1] = find/reverse tail [1 2 3 4 3 2 1] 2
  --test-- "find/reverse-3"
  --assert [3 3 2 1] = find/reverse tail [1 2 3 3 2 1] [3 3]
  --test-- "find/reverse-4"
  --assert "3321" = find/reverse back back back tail "123321" "33"
  --test-- "find/reverse-5"
  --assert "3321" = find/reverse back back back tail"123321" "3"
  --test-- "find/reverse-6"
  --assert "1" = find/reverse tail "1111" "1"
  --test-- "find/reverse-7"
  --assert none = find/reverse tail "123" "34"
  --test-- "find/reverse-8"
  --assert "✐5678" = find/reverse tail "1234✐5678" "✐"
  --test-- "find/reverse-9"
  --assert "^(010000)5678" = find/reverse tail "1234^(010000)5678" "^(010000)"
  --test-- "find/reverse-10 issue #505"
  --assert "ab" = find/reverse tail "ab" #"a"
  --assert "ab" = find/reverse tail "ab" "ab"
  --assert [a b] = find/reverse tail [a b] 'a
  --assert [a b] = find/reverse tail [a b] [a b]
===end-group===

===start-group=== "find/last/tail"
	--test-- "find/last/tail-1 issue #459"
	--assert [7 8] = find/last/tail [1 2 3 4 5 6 3 7 8] 3
	--test-- "find/last/tail-2 issue #459"
	--assert "78" = find/last/tail "123456378" #"3"
	--test-- "find/last/tail-3"
	--assert "78" = find/last/tail "123456378" "3"
===end-group===

~~~end-file~~~

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

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

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

===start-group=== "find"
	--test-- "find-1"
	--assert [1 2 3 4] = find [1 2 3 4] 1
	--test-- "find-2"
	--assert [2 3 4] = find [1 2 3 4] 2
	--test-- "find-3"
	--assert [4] = find [1 2 3 4] 4
	--test-- "find-4"
	--assert none = find [1 2 3 4] 0
	--test-- "find-5"
	--assert none = find [1 2 3 4] 5
	--test-- "find-6"
	--assert none = find [1 2 3 4] "1"
	--test-- "find-7"
	--assert "12345" = find "12345" #"1"
	;--test-- "find-8" 							;; unsupported case, it is unsure if it will be implemented or not
	;--assert "12345" = find "12345" 1			;; keeping it here commented for further reference.
	--test-- "find-9"
	--assert "12345" = find "12345" "1"
	--test-- "find-10"
	--assert "12345" = find "12345" "12"
	--test-- "find-11"
	--assert "2345" = find "12345" #"2"
	--test-- "find-12"
	--assert "5" = find "12345" #"5"
	--test-- "find-13"
	--assert none = find "12345" #"0"
	--test-- "find-14"
	--assert none = find "12345" #"6"
	--test-- "find-15"
	--assert [2 3] = find [1 2 3] [2 3]
	--test-- "find-16"
	--assert none = find [1 2 3] [3 2]
	--test-- "find-17"
	--assert [2 3] = find [1 2 2 3] [2 3]
	--test-- "find-18"
	--assert none = find [1 2] [2 3]
	--test-- "find-19"
	--assert "é" = find "abcdeé" "é"
	--test-- "find-20"
	--assert "eé" = find "abcdeé" "eé"
	--test-- "find-21"
	--assert none = find "abcdeé" "ée"
	--test-- "find-22"
	--assert "✐" = find "abcde✐" "✐"            ;; code point 10000 (decimal)
	--test-- "find-23"
	--assert none = find "abcde✐" "ed✐"
	--test-- "find-24"
	--assert "^(010000)" = find "abcde^(010000)" "^(010000)"
===end-group===

===start-group=== "find/part"
	--test-- "find/part-1"
	--assert none = find/part "1234" "1" 0
	--test-- "find/part-2"
	--assert "1234" = find/part "1234" "1" 1
	--test-- "find/part-3"
	--assert "234" = find/part "1234" "2" 2
	--test-- "find/part-4"
	--assert "234" = find/part "1234" "2" 4
	--test-- "find/part-5"
	--assert "234" = find/part "1234" "2" 5
	--test-- "find/part-6"
	--assert none = find/part "1234" "3" 2
	--test-- "find/part-7"
	--assert none = find/part [1 2 3 4] 1 0
	--test-- "find/part-8"
	--assert [1 2 3 4] = find/part [1 2 3 4] 1 1
	--test-- "find/part-9"
	--assert [2 3 4] = find/part [1 2 3 4] 2 2
	--test-- "find/part-10"
	--assert [2 3 4] = find/part [1 2 3 4] [2 3] 4
	--test-- "find/part-11"
	--assert none = find/part [1 2 3 4] [2 3] 2
	--test-- "find/part-12"
	--assert none = find/part [1 2 3 4] 3 2
	--test-- "find/part-13"
	--assert none = find/part "Χαῖρε, κόσμε!" "Χαῖ" 2
===end-group===

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

===start-group=== "find/case"
	--test-- "find/case-1"
	--assert "abcde" = find/case "Aabcde" "a"
	--test-- "find/case-2"
	--assert "Abcde" = find/case "aAbcde" "A"
	--test-- "find/case-3"
	--assert none = find/case "è" "E"
===end-group===

===start-group=== "find/any"      ; not yet implemented
	--test-- "find/any-1"
	;--assert "12345" = find/any "12345" "*"
	--test-- "find/any-2"
	;--assert "12345" = find/any "12345" "?"
	--test-- "find/any-3"
	;--assert "2345" = find/any "12345" "2?4"
	--test-- "find/any-4"
	;assert "2345" = find/any "12345" "2*"
	--test-- "find/any-5"
	;assert "e✐" = find/any "abcde✐" "e?"        ;; code point 10000 (decimal)
	--test-- "find/any-6"
	;assert "e✐f" = find/any "abcde✐f" "?f"
	--test-- "find/any-7"
	;assert "e✐" = find/any "abcde✐" "e*"
	--test-- "find/any-8"
	;assert "abcde✐f" = find/any "abcde✐f" "*f"
	--test-- "find/any-9"
	;assert "e^(010000)" = find/any "abcde^(010000)" "e?"
	--test-- "find/any-10"
	;assert "e^(010000)f" = find/any "abcde^(010000)f" "?f"
	--test-- "find/any-11"
	;assert "e^(010000)" = find/any "abcde^(010000)" "e*"
	--test-- "find/any-12"
	;assert "abcde^(010000)f" = find/any "abcde^(010000)f" "*f"
===end-group===

===start-group=== "find/with"      ; not yet implemented
	--test-- "find/with-1"
	;--assert "12345" = find/with "12345" "^(FFFF)" "^(FFFE)^(FFFF)"
	--test-- "find/with-2"
	;--assert "12345" = find/with "12345" "^(FFFE)" "^(FFFE)^(FFFF)"
	--test-- "find/with-3"
	;--assert "2345" = find/with "12345" "2^(FFFE)3" "^(FFFE)^(FFFF)"
	--test-- "find/with-4"
	;assert "2345" = find/with "12345" "2^(FFFF)" "^(FFFE)^(FFFF)"
	--test-- "find/with-5"
	;assert "e✐" = find/with "abcde✐" "e^(FFFE)" "^(FFFE)^(FFFF)"
	--test-- "find/with-6"
	;assert "e✐f" = find/with "abcde✐f" "^(FFFE)f" "^(FFFE)^(FFFF)"
	--test-- "find/with-7"
	;assert "e✐" = find/with "abcde✐" "e^(FFFF)" "^(FFFE)^(FFFF)"
	--test-- "find/with-8"
	;assert "abcde✐f" = find/with "abcde✐f" "^(FFFF)f" "^(FFFE)^(FFFF)"
	--test-- "find/with-9"
	;assert "e^(010000)" = find/with "abcde^(010000)" "e^(FFFE)" "^(FFFE)^(FFFF)"
	--test-- "find/with-10"
	;assert "e^(010000)f" = find/with "abcde^(010000)f" "^(FFFE)f" "^(FFFE)^(FFFF)"
	--test-- "find/with-11"
	;assert "e^(010000)" = find/with "abcde^(010000)" "e^(FFFF)" "^(FFFE)^(FFFF)"
	--test-- "find/with-12"
	;assert "abcde^(010000)f" = find/with "abcde^(010000)f" "^(FFFF)f" "^(FFFE)^(FFFF)"
===end-group===

===start-group=== "find/skip"
  --test-- "find/skip-1"
  --assert [6 7 8 9 0] = find/skip [1 2 3 4 5 1 6 6 6 6 1 2 3 4 5 6 7 8 9 0] 6 5
  --test-- "find/skip-2"
  --assert none = find/skip [1 2 3 4 5 1 6 6 6 6 1 2 3 4 5 1 2 3 4 5] 6 5
  --test-- "find/skip-3"
  --assert [6 7 8 9 0] = find/skip [1 2 3 4 5 6 6 6 6 6 1 2 3 4 5 6 7 8 9 0] [6 7] 5
  --test-- "find/skip-4"
  --assert none = find/skip [1 2 3 4 5 1 6 6 6 6 1 2 3 4 5 1 2 3 4 5] [6 7] 5
  --test-- "find/skip-5"
  --assert "67890" = find/skip "12345166661234567890" "6" 5
  --test-- "find/skip-6"
  --assert none = find/skip "12345166661234557890" "6" 5
===end-group===

===start-group=== "find/match"
  --test-- "find/match-1"
  --assert [and now] = find/match [here and now] 'here
  --test-- "find/match-2"
  --assert none = find/match [here and now] 'her
  --test-- "find/match-3"
  --assert none = find/match [her and now] 'here
  --test-- "find/match-4"
  --assert " and now" = find/match "here and now" "here"
  --test-- "find/match-5"
  --assert "andnow" = find/match "hereandnow" "here"
  --test-- "find/match-6"
  --assert none = find/match "her and now" "here"
  --test-- "find/match-7"
  --assert " and now" = find/match "here✐ and now" "here✐"
  --test-- "find/match-8"
  --assert "✐andnow" = find/match "here✐andnow" "here"
  --test-- "find/match-9"
  --assert none = find/match "her and now" "he✐r"
  --test-- "find/match-10"
  --assert none = find/match "here and now" "✐here"
  --test-- "find/match-11"
  --assert "^(010000)andnow" = find/match "here^(010000)andnow" "here"
  --test-- "find/match-12"
  --assert none = find/match "her and now" "here^(010000)"
  --test-- "find/match-13"
  --assert " and now" = find/match "here^(010000) and now" "here^(010000)"
  --test-- "find/match-14"
  --assert "andnow" = find/match "^(010000)hereandnow" "^(010000)here"
  --test-- "find/match-15"
  --assert none = find/match "her^(010000) and now" "here^(010000)"
  --test-- "find/match-16"
  --assert [and now] = find/match [he✐re and now] 'he✐re
===end-group===

===start-group=== "find/tail"
  --test-- "find/tail-1"
  --assert [and now] = find/tail [here and now] 'here
  --test-- "find/tail-2"
  --assert none = find/tail [here and now] 'her
  --test-- "find/tail-3"
  --assert none = find/tail [her and now] 'here
  --test-- "find/tail-4"
  --assert " and now" = find/tail "here and now" "here"
  --test-- "find/tail-5"
  --assert "andnow" = find/tail "hereandnow" "here"
  --test-- "find/tail-6"
  --assert none = find/tail "her and now" "here"
  --test-- "find/tail-7"
  --assert " and now" = find/tail "here✐ and now" "here✐"
  --test-- "find/tail-8"
  --assert "✐andnow" = find/tail "here✐andnow" "here"
  --test-- "find/tail-9"
  --assert none = find/tail "her and now" "he✐r"
  --test-- "find/tail-10"
  --assert none = find/tail "here and now" "✐here"
  --test-- "find/tail-11"
  --assert "^(010000)andnow" = find/tail "here^(010000)andnow" "here"
  --test-- "find/tail-12"
  --assert none = find/tail "her and now" "here^(010000)"
  --test-- "find/tail-13"
  --assert " and now" = find/tail "here^(010000) and now" "here^(010000)"
  --test-- "find/tail-14"
  --assert "andnow" = find/tail "^(010000)hereandnow" "^(010000)here"
  --test-- "find/tail-15"
  --assert none = find/tail "her^(010000) and now" "here^(010000)"
  --test-- "find/tail-16"
  --assert [and now] = find/tail [he✐re and now] 'he✐re
  --test-- "find/tail-17 issue #457"
  --assert "de" = find/tail "abcde" #"c"
  --test-- "find-tail-18"
  --assert "de" = find/tail "abc^^de" #"^^"

===end-group===

===start-group=== "find/last"
  --test-- "find/last-1"
  --assert [1] = find/last [1 1 1 1] 1
  --assert 4 = index? find/last [1 1 1 1] 1
  --test-- "find/last-2"
  --assert [2 1] = find/last [1 2 3 4 3 2 1] 2
  --test-- "find/last-3"
  --assert [3 3 2 1] = find/last [1 2 3 3 2 1] [3 3]
  --test-- "find/last-4"
  --assert "3321" = find/last "123321" "33"
  --test-- "find/last-5"
  --assert "321" = find/last "123321" "3"
  --test-- "find/last-6"
  --assert "1" = find/last "1111" "1"
  --test-- "find/last-7"
  --assert none = find/last "123" "34"
  --test-- "find/last-8"
  --assert "✐5678" = find/last "1234✐5678" "✐"
  --test-- "find/last-9"
  --assert "^(010000)5678" = find/last "1234^(010000)5678" "^(010000)"
===end-group===

===start-group=== "find/reverse"
  --test-- "find/reverse-1"
  --assert none = find/reverse [1 1 1 1] 1
  --test-- "find/reverse-2"
  --assert [2 1] = find/reverse tail [1 2 3 4 3 2 1] 2
  --test-- "find/reverse-3"
  --assert [3 3 2 1] = find/reverse tail [1 2 3 3 2 1] [3 3]
  --test-- "find/reverse-4"
  --assert "3321" = find/reverse back back back tail "123321" "33"
  --test-- "find/reverse-5"
  --assert "3321" = find/reverse back back back tail"123321" "3"
  --test-- "find/reverse-6"
  --assert "1" = find/reverse tail "1111" "1"
  --test-- "find/reverse-7"
  --assert none = find/reverse tail "123" "34"
  --test-- "find/reverse-8"
  --assert "✐5678" = find/reverse tail "1234✐5678" "✐"
  --test-- "find/reverse-9"
  --assert "^(010000)5678" = find/reverse tail "1234^(010000)5678" "^(010000)"
  --test-- "find/reverse-9"
  --test-- "ab" = find/reverse tail "ab" #"a"			;-- issue #505
  --test-- "ab" = find/reverse tail "ab" "ab"
  --test-- [a b] = find/reverse tail [a b] 'a 			;-- issue #505
  --test-- [a b] = find/reverse tail [a b] [a b]
===end-group===

===start-group=== "find/last/tail"
	--test-- "find/last/tail-1 issue #459"
	--assert [7 8] = find/last/tail [1 2 3 4 5 6 3 7 8] 3
	--test-- "find/last/tail-2 issue #459"
	--assert "78" = find/last/tail "123456378" #"3"
	--test-- "find/last/tail-3"
	--assert "78" = find/last/tail "123456378" "3"
===end-group===

~~~end-file~~~


TESTS: added more LOAD tests for double quotes and curly braces combinations.

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

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

~~~start-file~~~ "load"

===start-group=== "Delimiter LOAD tests"

	--test-- "load-1"  --assert "" 		 = load {""}
	--test-- "load-2"  --assert "" 		 = load {{}}
	--test-- "load-3"  --assert "{" 	 = load {"^{"}
	--test-- "load-4"  --assert "}" 	 = load {"^}"}
	--test-- "load-5"  --assert "{}"	 = load {"^{^}"}
	--test-- "load-6"  --assert {^}^{} 	 = load {"^}^{"}
	--test-- "load-7"  --assert "^{^}^}" = load {"^{^}^}"}
	--test-- "load-8"  --assert ""		 = load {"^"}
	--test-- "load-9"  --assert ""		 = load "{}"
	--test-- "load-10" --assert "{"		 = load "{^{}"
	--test-- "load-11" --assert {"}		 = load {{"}}
	--test-- "load-12" --assert "^/" 	 = load "{^/}^/"
	--test-- "load-13" --assert "^/" 	 = load "{^/}"
	--test-- "load-14" --assert "{^/}"	 = load {{{^/}}}
	--test-- "load-15" --assert {{"x"}}	 = load {{{"x"}}}
	--test-- "load-16" --assert "{x}"	 = load {{{x}}}
	--test-- "load-17" --assert {"x"}	 = load {{"x"}}
	--test-- "load-18" --assert "x"		 = load {{x}}

===end-group===

~~~end-file~~~

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

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

~~~start-file~~~ "load"

===start-group=== "Delimiter LOAD tests"

	--test-- "load-1"  --assert "" 		 = load {""}
	--test-- "load-2"  --assert "" 		 = load {{}}
	--test-- "load-3"  --assert "{" 	 = load {"^{"}
	--test-- "load-4"  --assert "}" 	 = load {"^}"}
	--test-- "load-5"  --assert "{}"	 = load {"^{^}"}
	--test-- "load-6"  --assert {^}^{} 	 = load {"^}^{"}
	--test-- "load-7"  --assert "^{^}^}" = load {"^{^}^}"}
	--test-- "load-8"  --assert ""		 = load {"^"}
	--test-- "load-9"  --assert ""		 = load "{}"
	--test-- "load-10" --assert "{"		 = load "{^{}"
	--test-- "load-11" --assert {"}		 = load {{"}}

===end-group===

~~~end-file~~~


FIX: chained infix expressions not returning correct value when last expression in a block (interpreter).

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

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

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

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

interpreter: context [
	verbose: 0

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

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

	find-refinement?: func [
		ref		[red-word!]
		path	[red-path!]
		slot	[red-word!]
		end		[red-value!]
		return: [logic!]
	][
		while [slot < end][
			if TYPE_OF(slot) <> TYPE_WORD [
				print-line "*** Error: function call with non-word refinement!"
				halt
			]
			if (symbol/resolve slot/symbol) = (symbol/resolve ref/symbol) [
				return yes
			]
			slot: slot + 1
		]
		no
	]

	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!]
		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
		stack/unwind-last

		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]
		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!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			path-end  [red-value!]
			s		  [series!]
			required? [logic!]
			ref?	  [logic!]
			index	  [integer!]
			count	  [integer!]
			prev	  [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
		]

		value: s/offset
		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									;-- nb of fetched arguments (used as offset)
		index: 	 	 1
		return-type: -1
		ref?:		 no
		required?:	 yes								;-- yes: processing mandatory args, no: optonal args

		size: as-integer tail - value
		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 [
					unless required? [
						either ref? [
							unless function? [
								prev: index - 1			;-- overwrite previous entry if it was a ref marker
								either negative? ref-array/prev [
									ref-array/prev: count
									index: prev
								][
									ref-array/index: count
								]

							]
						][
							either function? [
								none/push
							][
								ref-array/index: -1
							]
						]
						index: index + 1
					]
					if any [required? ref?][
						EVAL_CHECK_INPUT
						if verbose > 0 [log "evaluating argument"]
						pc: eval-expression pc end no yes	;-- eval argument
						count: count + 1
					]
				]
				TYPE_LIT_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_GET_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_REFINEMENT [
					if required? [required?: no]		;-- no more mandatory arguments

					ref?: either null? path [no][
						find-refinement? as red-word! value path as red-word! pos path-end
					]

					either function? [
						logic/push ref?
					][
						ref-array/index: either ref? [count][-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 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_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_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_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!]
			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 [
				word/get as red-word! pc
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				w: word/push as red-word! pc			;-- push lit-word! on stack
				w/header: TYPE_WORD						;-- set correct value type on stack
				pc: pc + 1
			]
			TYPE_WORD [
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_ACTION							;@@ 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]
		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 EVAL_CHECK_INPUT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
]

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

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

interpreter: context [
	verbose: 0

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

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

	find-refinement?: func [
		ref		[red-word!]
		path	[red-path!]
		slot	[red-word!]
		end		[red-value!]
		return: [logic!]
	][
		while [slot < end][
			if TYPE_OF(slot) <> TYPE_WORD [
				print-line "*** Error: function call with non-word refinement!"
				halt
			]
			if (symbol/resolve slot/symbol) = (symbol/resolve ref/symbol) [
				return yes
			]
			slot: slot + 1
		]
		no
	]

	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!]
		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
		stack/unwind

		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]
		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!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			path-end  [red-value!]
			s		  [series!]
			required? [logic!]
			ref?	  [logic!]
			index	  [integer!]
			count	  [integer!]
			prev	  [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
		]

		value: s/offset
		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									;-- nb of fetched arguments (used as offset)
		index: 	 	 1
		return-type: -1
		ref?:		 no
		required?:	 yes								;-- yes: processing mandatory args, no: optonal args

		size: as-integer tail - value
		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 [
					unless required? [
						either ref? [
							unless function? [
								prev: index - 1			;-- overwrite previous entry if it was a ref marker
								either negative? ref-array/prev [
									ref-array/prev: count
									index: prev
								][
									ref-array/index: count
								]

							]
						][
							either function? [
								none/push
							][
								ref-array/index: -1
							]
						]
						index: index + 1
					]
					if any [required? ref?][
						EVAL_CHECK_INPUT
						if verbose > 0 [log "evaluating argument"]
						pc: eval-expression pc end no yes	;-- eval argument
						count: count + 1
					]
				]
				TYPE_LIT_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_GET_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_REFINEMENT [
					if required? [required?: no]		;-- no more mandatory arguments

					ref?: either null? path [no][
						find-refinement? as red-word! value path as red-word! pos path-end
					]

					either function? [
						logic/push ref?
					][
						ref-array/index: either ref? [count][-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 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_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_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_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!]
			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 [
				word/get as red-word! pc
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				w: word/push as red-word! pc			;-- push lit-word! on stack
				w/header: TYPE_WORD						;-- set correct value type on stack
				pc: pc + 1
			]
			TYPE_WORD [
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_ACTION							;@@ 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]
		pc
	]

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

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

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

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

		stack/unwind-last
	]

]


FIX: Incorrect ROUND macros on ARM platform.

Red/System [
	Title:   "Float! datatype runtime functions"
	Author:  "Nenad Rakocevic, Oldes"
	File: 	 %decimal.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 DBL_EPSILON		2.2204460492503131E-16

float: context [
	verbose: 4

	uint64!: alias struct! [int1 [byte-ptr!] int2 [byte-ptr!]]
	int64!:  alias struct! [int1 [integer!] int2 [integer!]]

	DOUBLE_MAX: 0.0
	+INF: 0.0											;-- rebol can't load INF, NaN
	QNaN: 0.0

	double-int-union: as int64! :DOUBLE_MAX				;-- set to largest number
	double-int-union/int2: 7FEFFFFFh
	double-int-union/int1: FFFFFFFFh

	double-int-union: as int64! :+INF
	double-int-union/int2: 7FF00000h

	double-int-union: as int64! :QNaN					;-- smallest quiet NaN
	double-int-union/int2: 7FF80000h

	abs: func [
		value	[float!]
		return: [float!]
		/local
			n	[int-ptr!]
	][
		n: (as int-ptr! :value) + 1
		n/value: n/value and 7FFFFFFFh
		value
	]

	get*: func [										;-- unboxing float value from stack
		return: [float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		assert TYPE_OF(fl) = TYPE_FLOAT
		fl/value
	]

	get-any*: func [									;-- special get* variant for SWITCH
		return: [float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		either TYPE_OF(fl) = TYPE_FLOAT [fl/value][0.0] ;-- accept NONE values
	]

	get: func [											;-- unboxing float value
		value	[red-value!]
		return: [float!]
		/local
			fl [red-float!]
	][
		assert TYPE_OF(value) = TYPE_FLOAT
		fl: as red-float! value
		fl/value
	]

	box: func [
		value	[float!]
		return: [red-float!]
		/local
			int [red-float!]
	][
		fl: as red-float! stack/arguments
		fl/header: TYPE_FLOAT
		fl/value: value
		fl
	]

	to-integer: func [
		number 	[float!]
		return:	[integer!]
		/local
			f	[float!]
			d	[int-ptr!]
	][
		;-- Based on this method: http://stackoverflow.com/a/429812/494472
		;-- A bit more explanation: http://lolengine.net/blog/2011/3/20/understanding-fast-float-integer-conversions
		f: number + 6755399441055744.0
		d: as int-ptr! :f
		d/value
	]

	form-float: func [
		f 		[float!]
		return: [c-string!]
		/local
			s	[c-string!]
			s0	[c-string!]
			p0	[c-string!]
			p	[c-string!]
			p1	[c-string!]
			dot? [logic!]
			d	[int64!]
			w0	[integer!]
	][
		d: as int64! :f
		w0: d/int2												;@@ Use little endian. Watch out big endian !

		if w0 and 7FF00000h = 7FF00000h [
			if all [
				zero? d/int1									;@@ Use little endian. Watch out big endian !
				zero? (w0 and 000FFFFFh)
			][
				return either 0 = (w0 and 80000000h) ["1.#INF"]["-1.#INF"]
			]
			return "1.#NaN"
		]

		s: "0000000000000000000000000000000"					;-- 32 bytes wide, big enough.
		sprintf [s "%.14g" f]

		dot?: no
		p:  null
		p1: null
		s0: s
		until [
			if s/1 = #"." [dot?: yes]
			if s/1 = #"e" [
				p: s
				until [
					s: s + 1
					s/1 > #"0"
				]
				p1: s
			]
			s: s + 1
			s/1 = #"^@"
		]

		if p1 <> null [											;-- remove #"+" and leading zero
			p0: p
			either p/2 = #"-" [p: p + 2][p: p + 1]
			move-memory as byte-ptr! p as byte-ptr! p1 as-integer s - p1
			s: p + as-integer s - p1
			s/1: #"^@"
			p: p0
		]
		unless dot? [											;-- added tailing ".0"
			either p = null [
				p: s
			][
				move-memory as byte-ptr! p + 2 as byte-ptr! p as-integer s - p
			]
			p/1: #"."
			p/2: #"0"
			s/3: #"^@"
		]
		s0
	]

	do-math: func [
		type	  [integer!]
		return:	  [red-float!]
		/local
			left  [red-float!]
			right [red-float!]
			int   [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/do-math"]]

		left:  as red-float! stack/arguments
		right: as red-float! left + 1

		assert any [									;@@ replace by typeset check when possible
			TYPE_OF(left) = TYPE_INTEGER
			TYPE_OF(left) = TYPE_FLOAT
		]
		assert any [
			TYPE_OF(right) = TYPE_INTEGER
			TYPE_OF(right) = TYPE_CHAR
			TYPE_OF(right) = TYPE_FLOAT
		]

		if TYPE_OF(left) <> TYPE_FLOAT [
			int: as red-integer! left
			left/header: TYPE_FLOAT
			left/value: integer/to-float int/value
		]
		if TYPE_OF(right) <> TYPE_FLOAT [
			int: as red-integer! right
			right/value: integer/to-float int/value
		]

		left/value: switch type [
			OP_ADD [left/value + right/value]
			OP_SUB [left/value - right/value]
			OP_MUL [left/value * right/value]
			OP_DIV [left/value / right/value]
			OP_REM [left/value % right/value]
			default [print-line "*** Math Error: float don't support BITWISE OP!" left/value]
		]
		left
	]

	load-in: func [
		blk	  	[red-block!]
		value 	[float!]
		/local
			fl [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/load-in"]]

		fl: as red-float! ALLOC_TAIL(blk)
		fl/header: TYPE_FLOAT
		fl/value: value
	]

	push64: func [
		high	[integer!]
		low		[integer!]
		return: [red-float!]
		/local
			cell [cell!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/push64"]]

		cell: stack/push*
		cell/header: TYPE_FLOAT
		cell/data2: low
		cell/data3: high
		as red-float! cell
	]

	push: func [
		value	[float!]
		return: [red-float!]
		/local
			fl [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/push"]]

		fl: as red-float! stack/push*
		fl/header: TYPE_FLOAT
		fl/value: value
		fl
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/make"]]

		switch TYPE_OF(spec) [
			TYPE_FLOAT [
				as red-float! spec
			]
			default [
				--NOT_IMPLEMENTED--
				as red-float! spec					;@@ just for making it compilable
			]
		]
	]

	random: func [
		f		[red-float!]
		seed?	[logic!]
		secure? [logic!]
		only?   [logic!]
		return: [red-float!]
		/local
			t	[float!]
			s	[float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/random"]]

		either seed? [
			_random/srand to-integer f/value
			f/header: TYPE_UNSET
		][
			s: (integer/to-float _random/rand) / 2147483647.0
			if s < 0.0 [s: 0.0 - s]
			f/value: s * f/value
		]
		f
	]

	to: func [
		type	[red-datatype!]
		spec	[red-float!]
		return: [red-value!]
		/local
			int [red-integer!]
			buf [red-string!]
			f	[float!]
	][
		f: spec/value
		switch type/value [
			TYPE_INTEGER [
				int: as red-integer! type
				int/header: TYPE_INTEGER
				int/value: to-integer either f < 0.0 [f + 0.499999999999999][f - 0.499999999999999]
			]
			TYPE_STRING [
				buf: string/rs-make-at as cell! type 1			;-- 16 bits string
				string/concatenate-literal buf form-float f
			]
			default [
				print-line "** Script error: Invalid argument for TO float!"
				type/header: TYPE_UNSET
			]
		]
		as red-value! type
	]

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

		formed: form-float fl/value
		string/concatenate-literal buffer formed
		part - length? formed							;@@ optimize by removing length?
	]

	mold: func [
		fl		[red-float!]
		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 "float/mold"]]

		form fl buffer arg part
	]

	NaN?: func [
		value	[float!]
		return: [logic!]
		/local
			n	[int-ptr!]
			m	[int-ptr!]
	][
		m: as int-ptr! :value
		n: m + 1
		either n/value and 7FF00000h = 7FF00000h [		;-- the exponent bits are all ones
			either any [								;-- the fraction bits are not entirely zeros
				m/value <> 0
				n/value and 000FFFFFh <> 0
			] [true][false]
		][false]
	]

	;@@ using 64bit integer will simplify it significantly.
	;-- returns false if either number is (or both are) NAN.
	;-- treats really large numbers as almost equal to infinity.
	;-- thinks +0.0 and -0.0 are 0 DLP's apart.
	;-- Max ULP: 4 (enough for ordinary use)
	;-- Ref: https://github.com/svn2github/googletest/blob/master/include/gtest/internal/gtest-internal.h
	;--      https://github.com/rebol/rebol/blob/master/src/core/t-decimal.c
	almost-equal: func [
		left	[float!]
		right	[float!]
		return: [logic!]
		/local
			a	 [uint64!]
			b	 [uint64!]
			lo1  [byte-ptr!]
			lo2  [byte-ptr!]
			hi1  [byte-ptr!]
			hi2  [byte-ptr!]
			diff [byte-ptr!]
	][
		if left = right [return true]					;-- for NaN, also raise error in default mode
		if any [NaN? left NaN? right] [return false]

		a: as uint64! :left
		b: as uint64! :right
		lo1: a/int1
		lo2: b/int1
		hi1: a/int2
		hi2: b/int2

		either (as-integer hi1) < 0 [
			hi1: as byte-ptr! (not as-integer hi1)
			lo1: as byte-ptr! (not as-integer lo1)
			either (as-integer lo1) = -1 [hi1: hi1 + 1 lo1: null][lo1: lo1 + 1]
		][
			hi1: as byte-ptr! (as-integer hi1) or 80000000h
		]

		either (as-integer hi2) < 0 [
			hi2: as byte-ptr! (not as-integer hi2)
			lo2: as byte-ptr! (not as-integer lo2)
			either (as-integer lo2) = -1 [hi2: hi2 + 1 lo2: null][lo2: lo2 + 1]
		][
			hi2: as byte-ptr! (as-integer hi2) or 80000000h
		]

		diff: either hi1 > hi2 [hi1 - hi2][hi2 - hi1]
		if diff > (as byte-ptr! 1) [return false]

		case [
			hi1 = hi2 [
				diff: either lo1 < lo2 [lo2 - lo1][lo1 - lo2]
			]
			hi1 > hi2 [
				either lo1 >= lo2 [return false][
					diff: (as byte-ptr! -1) - lo2 + lo1 + 1
				]
			]
			hi2 > hi1 [
				either lo2 >= lo1 [return false][
					diff: (as byte-ptr! -1) - lo1 + lo2 + 1
				]
			]
		]

		diff <= (as byte-ptr! 4)
	]

	compare: func [
		value1    [red-float!]						;-- first operand
		value2    [red-float!]						;-- second operand
		op	      [integer!]						;-- type of comparison
		return:   [logic!]
		/local
			int   [red-integer!]
			left  [float!]
			right [float!]
			res	  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/compare"]]

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_CHAR
			TYPE_INTEGER [
				int: as red-integer! value2
				right: integer/to-float int/value
			]
			TYPE_FLOAT [right: value2/value]
			default [RETURN_COMPARE_OTHER]
		]
		switch op [
			COMP_EQUAL 			[res: almost-equal left right]
			COMP_NOT_EQUAL 		[res: not almost-equal left right]
			COMP_STRICT_EQUAL	[res: all [TYPE_OF(value2) = TYPE_FLOAT left = right]]
			COMP_LESSER			[res: left <  right]
			COMP_LESSER_EQUAL	[res: left <= right]
			COMP_GREATER		[res: left >  right]
			COMP_GREATER_EQUAL	[res: left >= right]
		]
		res
	]

	complement: func [
		fl		[red-float!]
		return:	[red-value!]
	][
		--NOT_IMPLEMENTED--
		;fl/value: not fl/value
		as red-value! fl
	]

	absolute: func [
		return: [red-float!]
		/local
			f	  [red-float!]
			value [float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/absolute"]]

		f: as red-float! stack/arguments
		f/value: abs f/value
		f 											;-- re-use argument slot for return value
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/subtract"]]
		as red-value! do-math OP_SUB
	]

	remainder: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/remainder"]]
		as red-value! do-math OP_REM
	]

	negate: func [
		return: [red-float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		fl/value: 0.0 - fl/value
		fl 											;-- re-use argument slot for return value
	]

	power: func [
		return:	 [red-float!]
		/local
			base [red-float!]
			exp  [red-float!]
			int	 [red-integer!]
	][
		base: as red-float! stack/arguments
		exp: base + 1
		if TYPE_OF(exp) = TYPE_INTEGER [
			int: as red-integer! exp
			exp/value: integer/to-float int/value
		]
		base/value: float-power base/value exp/value
		base
	]

	even?: func [
		int		[red-float!]
		return: [logic!]
	][
		;requires conversion to integer
		;not as-logic float/value and 1
		--NOT_IMPLEMENTED--
		false
	]

	odd?: func [
		int		[red-integer!]
		return: [logic!]
	][
		;requires conversion to integer
		;as-logic int/value and 1
		--NOT_IMPLEMENTED--
		false
	]

	#define FLOAT_TRUNC(x) [d: floor float/abs x either x < 0.0 [0.0 - d][d]]
	#define FLOAT_AWAY(x)  [d: ceil float/abs x  either x < 0.0 [0.0 - d][d]]

	round: func [
		value		[red-value!]
		scale		[red-float!]
		_even?		[logic!]
		down?		[logic!]
		half-down?	[logic!]
		floor?		[logic!]
		ceil?		[logic!]
		half-ceil?	[logic!]
		return:		[red-value!]
		/local
			int		[red-integer!]
			f		[red-float!]
			dec		[float!]
			sc		[float!]
			r		[float!]
			d		[float!]
			e		[integer!]
			v		[logic!]
	][
		e: 0
		f: as red-float! value
		dec: f/value
		sc: 1.0
		if OPTION?(scale) [
			if TYPE_OF(scale) = TYPE_INTEGER [
				int: as red-integer! value
				int/value: to-integer dec
				int/header: TYPE_INTEGER
				return integer/round value as red-integer! scale _even? down? half-down? floor? ceil? half-ceil?
			]
			sc: abs scale/value
		]

		if sc = 0.0 [
			print-line "*** Math Error: float overflow on ROUND"
			value/header: TYPE_UNSET
			return value
		]

		if sc < ldexp abs dec -53 [return value]		;-- is scale negligible?

		v: sc >= 1.0
		dec: either v [dec / sc][
			r: frexp sc :e
			either e <= -1022 [
				sc: r
				dec: ldexp dec e
			][e: 0]
			sc: 1.0 / sc
			dec * sc
		]

		d: abs dec
		r: 0.5 + floor d
		dec: case [
			down?		[FLOAT_TRUNC(dec)]
			floor?		[floor dec		 ]
			ceil?		[ceil dec		 ]
			r < d		[FLOAT_AWAY(dec) ]
			r > d		[FLOAT_TRUNC(dec)]
			_even?		[either d % 2.0 < 1.0 [FLOAT_TRUNC(dec)][FLOAT_AWAY(dec)]]
			half-down?	[FLOAT_TRUNC(dec)]
			half-ceil?	[ceil dec		 ]
			true		[FLOAT_AWAY(dec) ]
		]

		f/value: either v [
			dec: dec * sc
			if DOUBLE_MAX = abs dec [
				print-line "*** Math Error: float overflow on ROUND"
				value/header: TYPE_UNSET
			]
			dec
		][
			ldexp dec / sc e
		]
		value
	]

	init: does [
		datatype/register [
			TYPE_FLOAT
			TYPE_VALUE
			"float!"
			;-- General actions --
			:make
			:random
			null			;reflect
			:to
			:form
			:mold
			null			;eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			:absolute
			:add
			:divide
			:multiply
			:negate
			:power
			:remainder
			:round
			: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
			null			;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:   "Float! datatype runtime functions"
	Author:  "Nenad Rakocevic, Oldes"
	File: 	 %decimal.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 FLOAT_TRUNC(x) ((either (x) < 0.0 [-1.0][1.0]) * (floor float/abs x))
#define FLOAT_AWAY(x) ((either (x) < 0.0 [-1.0][1.0]) * (ceil float/abs x))
#define DBL_EPSILON		2.2204460492503131E-16

float: context [
	verbose: 4

	uint64!: alias struct! [int1 [byte-ptr!] int2 [byte-ptr!]]
	int64!:  alias struct! [int1 [integer!] int2 [integer!]]

	DOUBLE_MAX: 0.0
	+INF: 0.0											;-- rebol can't load INF, NaN
	QNaN: 0.0

	double-int-union: as int64! :DOUBLE_MAX				;-- set to largest number
	double-int-union/int2: 7FEFFFFFh
	double-int-union/int1: FFFFFFFFh

	double-int-union: as int64! :+INF
	double-int-union/int2: 7FF00000h

	double-int-union: as int64! :QNaN					;-- smallest quiet NaN
	double-int-union/int2: 7FF80000h

	abs: func [
		value	[float!]
		return: [float!]
		/local
			n	[int-ptr!]
	][
		n: (as int-ptr! :value) + 1
		n/value: n/value and 7FFFFFFFh
		value
	]

	get*: func [										;-- unboxing float value from stack
		return: [float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		assert TYPE_OF(fl) = TYPE_FLOAT
		fl/value
	]

	get-any*: func [									;-- special get* variant for SWITCH
		return: [float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		either TYPE_OF(fl) = TYPE_FLOAT [fl/value][0.0] ;-- accept NONE values
	]

	get: func [											;-- unboxing float value
		value	[red-value!]
		return: [float!]
		/local
			fl [red-float!]
	][
		assert TYPE_OF(value) = TYPE_FLOAT
		fl: as red-float! value
		fl/value
	]

	box: func [
		value	[float!]
		return: [red-float!]
		/local
			int [red-float!]
	][
		fl: as red-float! stack/arguments
		fl/header: TYPE_FLOAT
		fl/value: value
		fl
	]

	to-integer: func [
		number 	[float!]
		return:	[integer!]
		/local
			f	[float!]
			d	[int-ptr!]
	][
		;-- Based on this method: http://stackoverflow.com/a/429812/494472
		;-- A bit more explanation: http://lolengine.net/blog/2011/3/20/understanding-fast-float-integer-conversions
		f: number + 6755399441055744.0
		d: as int-ptr! :f
		d/value
	]

	form-float: func [
		f 		[float!]
		return: [c-string!]
		/local
			s	[c-string!]
			s0	[c-string!]
			p0	[c-string!]
			p	[c-string!]
			p1	[c-string!]
			dot? [logic!]
			d	[int64!]
			w0	[integer!]
	][
		d: as int64! :f
		w0: d/int2												;@@ Use little endian. Watch out big endian !

		if w0 and 7FF00000h = 7FF00000h [
			if all [
				zero? d/int1									;@@ Use little endian. Watch out big endian !
				zero? (w0 and 000FFFFFh)
			][
				return either 0 = (w0 and 80000000h) ["1.#INF"]["-1.#INF"]
			]
			return "1.#NaN"
		]

		s: "0000000000000000000000000000000"					;-- 32 bytes wide, big enough.
		sprintf [s "%.14g" f]

		dot?: no
		p:  null
		p1: null
		s0: s
		until [
			if s/1 = #"." [dot?: yes]
			if s/1 = #"e" [
				p: s
				until [
					s: s + 1
					s/1 > #"0"
				]
				p1: s
			]
			s: s + 1
			s/1 = #"^@"
		]

		if p1 <> null [											;-- remove #"+" and leading zero
			p0: p
			either p/2 = #"-" [p: p + 2][p: p + 1]
			move-memory as byte-ptr! p as byte-ptr! p1 as-integer s - p1
			s: p + as-integer s - p1
			s/1: #"^@"
			p: p0
		]
		unless dot? [											;-- added tailing ".0"
			either p = null [
				p: s
			][
				move-memory as byte-ptr! p + 2 as byte-ptr! p as-integer s - p
			]
			p/1: #"."
			p/2: #"0"
			s/3: #"^@"
		]
		s0
	]

	do-math: func [
		type	  [integer!]
		return:	  [red-float!]
		/local
			left  [red-float!]
			right [red-float!]
			int   [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/do-math"]]

		left:  as red-float! stack/arguments
		right: as red-float! left + 1

		assert any [									;@@ replace by typeset check when possible
			TYPE_OF(left) = TYPE_INTEGER
			TYPE_OF(left) = TYPE_FLOAT
		]
		assert any [
			TYPE_OF(right) = TYPE_INTEGER
			TYPE_OF(right) = TYPE_CHAR
			TYPE_OF(right) = TYPE_FLOAT
		]

		if TYPE_OF(left) <> TYPE_FLOAT [
			int: as red-integer! left
			left/header: TYPE_FLOAT
			left/value: integer/to-float int/value
		]
		if TYPE_OF(right) <> TYPE_FLOAT [
			int: as red-integer! right
			right/value: integer/to-float int/value
		]

		left/value: switch type [
			OP_ADD [left/value + right/value]
			OP_SUB [left/value - right/value]
			OP_MUL [left/value * right/value]
			OP_DIV [left/value / right/value]
			OP_REM [left/value % right/value]
			default [print-line "*** Math Error: float don't support BITWISE OP!" left/value]
		]
		left
	]

	load-in: func [
		blk	  	[red-block!]
		value 	[float!]
		/local
			fl [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/load-in"]]

		fl: as red-float! ALLOC_TAIL(blk)
		fl/header: TYPE_FLOAT
		fl/value: value
	]

	push64: func [
		high	[integer!]
		low		[integer!]
		return: [red-float!]
		/local
			cell [cell!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/push64"]]

		cell: stack/push*
		cell/header: TYPE_FLOAT
		cell/data2: low
		cell/data3: high
		as red-float! cell
	]

	push: func [
		value	[float!]
		return: [red-float!]
		/local
			fl [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/push"]]

		fl: as red-float! stack/push*
		fl/header: TYPE_FLOAT
		fl/value: value
		fl
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/make"]]

		switch TYPE_OF(spec) [
			TYPE_FLOAT [
				as red-float! spec
			]
			default [
				--NOT_IMPLEMENTED--
				as red-float! spec					;@@ just for making it compilable
			]
		]
	]

	random: func [
		f		[red-float!]
		seed?	[logic!]
		secure? [logic!]
		only?   [logic!]
		return: [red-float!]
		/local
			t	[float!]
			s	[float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/random"]]

		either seed? [
			_random/srand to-integer f/value
			f/header: TYPE_UNSET
		][
			s: (integer/to-float _random/rand) / 2147483647.0
			if s < 0.0 [s: 0.0 - s]
			f/value: s * f/value
		]
		f
	]

	to: func [
		type	[red-datatype!]
		spec	[red-float!]
		return: [red-value!]
		/local
			int [red-integer!]
			buf [red-string!]
			f	[float!]
	][
		f: spec/value
		switch type/value [
			TYPE_INTEGER [
				int: as red-integer! type
				int/header: TYPE_INTEGER
				int/value: to-integer either f < 0.0 [f + 0.499999999999999][f - 0.499999999999999]
			]
			TYPE_STRING [
				buf: string/rs-make-at as cell! type 1			;-- 16 bits string
				string/concatenate-literal buf form-float f
			]
			default [
				print-line "** Script error: Invalid argument for TO float!"
				type/header: TYPE_UNSET
			]
		]
		as red-value! type
	]

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

		formed: form-float fl/value
		string/concatenate-literal buffer formed
		part - length? formed							;@@ optimize by removing length?
	]

	mold: func [
		fl		[red-float!]
		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 "float/mold"]]

		form fl buffer arg part
	]

	NaN?: func [
		value	[float!]
		return: [logic!]
		/local
			n	[int-ptr!]
			m	[int-ptr!]
	][
		m: as int-ptr! :value
		n: m + 1
		either n/value and 7FF00000h = 7FF00000h [		;-- the exponent bits are all ones
			either any [								;-- the fraction bits are not entirely zeros
				m/value <> 0
				n/value and 000FFFFFh <> 0
			] [true][false]
		][false]
	]

	;@@ using 64bit integer will simplify it significantly.
	;-- returns false if either number is (or both are) NAN.
	;-- treats really large numbers as almost equal to infinity.
	;-- thinks +0.0 and -0.0 are 0 DLP's apart.
	;-- Max ULP: 4 (enough for ordinary use)
	;-- Ref: https://github.com/svn2github/googletest/blob/master/include/gtest/internal/gtest-internal.h
	;--      https://github.com/rebol/rebol/blob/master/src/core/t-decimal.c
	almost-equal: func [
		left	[float!]
		right	[float!]
		return: [logic!]
		/local
			a	 [uint64!]
			b	 [uint64!]
			lo1  [byte-ptr!]
			lo2  [byte-ptr!]
			hi1  [byte-ptr!]
			hi2  [byte-ptr!]
			diff [byte-ptr!]
	][
		if left = right [return true]					;-- for NaN, also raise error in default mode
		if any [NaN? left NaN? right] [return false]

		a: as uint64! :left
		b: as uint64! :right
		lo1: a/int1
		lo2: b/int1
		hi1: a/int2
		hi2: b/int2

		either (as-integer hi1) < 0 [
			hi1: as byte-ptr! (not as-integer hi1)
			lo1: as byte-ptr! (not as-integer lo1)
			either (as-integer lo1) = -1 [hi1: hi1 + 1 lo1: null][lo1: lo1 + 1]
		][
			hi1: as byte-ptr! (as-integer hi1) or 80000000h
		]

		either (as-integer hi2) < 0 [
			hi2: as byte-ptr! (not as-integer hi2)
			lo2: as byte-ptr! (not as-integer lo2)
			either (as-integer lo2) = -1 [hi2: hi2 + 1 lo2: null][lo2: lo2 + 1]
		][
			hi2: as byte-ptr! (as-integer hi2) or 80000000h
		]

		diff: either hi1 > hi2 [hi1 - hi2][hi2 - hi1]
		if diff > (as byte-ptr! 1) [return false]

		case [
			hi1 = hi2 [
				diff: either lo1 < lo2 [lo2 - lo1][lo1 - lo2]
			]
			hi1 > hi2 [
				either lo1 >= lo2 [return false][
					diff: (as byte-ptr! -1) - lo2 + lo1 + 1
				]
			]
			hi2 > hi1 [
				either lo2 >= lo1 [return false][
					diff: (as byte-ptr! -1) - lo1 + lo2 + 1
				]
			]
		]

		diff <= (as byte-ptr! 4)
	]

	compare: func [
		value1    [red-float!]						;-- first operand
		value2    [red-float!]						;-- second operand
		op	      [integer!]						;-- type of comparison
		return:   [logic!]
		/local
			int   [red-integer!]
			left  [float!]
			right [float!]
			res	  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/compare"]]

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_CHAR
			TYPE_INTEGER [
				int: as red-integer! value2
				right: integer/to-float int/value
			]
			TYPE_FLOAT [right: value2/value]
			default [RETURN_COMPARE_OTHER]
		]
		switch op [
			COMP_EQUAL 			[res: almost-equal left right]
			COMP_NOT_EQUAL 		[res: not almost-equal left right]
			COMP_STRICT_EQUAL	[res: all [TYPE_OF(value2) = TYPE_FLOAT left = right]]
			COMP_LESSER			[res: left <  right]
			COMP_LESSER_EQUAL	[res: left <= right]
			COMP_GREATER		[res: left >  right]
			COMP_GREATER_EQUAL	[res: left >= right]
		]
		res
	]

	complement: func [
		fl		[red-float!]
		return:	[red-value!]
	][
		--NOT_IMPLEMENTED--
		;fl/value: not fl/value
		as red-value! fl
	]

	absolute: func [
		return: [red-float!]
		/local
			f	  [red-float!]
			value [float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/absolute"]]

		f: as red-float! stack/arguments
		f/value: abs f/value
		f 											;-- re-use argument slot for return value
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/subtract"]]
		as red-value! do-math OP_SUB
	]

	remainder: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/remainder"]]
		as red-value! do-math OP_REM
	]

	negate: func [
		return: [red-float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		fl/value: 0.0 - fl/value
		fl 											;-- re-use argument slot for return value
	]

	power: func [
		return:	 [red-float!]
		/local
			base [red-float!]
			exp  [red-float!]
			int	 [red-integer!]
	][
		base: as red-float! stack/arguments
		exp: base + 1
		if TYPE_OF(exp) = TYPE_INTEGER [
			int: as red-integer! exp
			exp/value: integer/to-float int/value
		]
		base/value: float-power base/value exp/value
		base
	]

	even?: func [
		int		[red-float!]
		return: [logic!]
	][
		;requires conversion to integer
		;not as-logic float/value and 1
		--NOT_IMPLEMENTED--
		false
	]

	odd?: func [
		int		[red-integer!]
		return: [logic!]
	][
		;requires conversion to integer
		;as-logic int/value and 1
		--NOT_IMPLEMENTED--
		false
	]

	round: func [
		value		[red-value!]
		scale		[red-float!]
		_even?		[logic!]
		down?		[logic!]
		half-down?	[logic!]
		floor?		[logic!]
		ceil?		[logic!]
		half-ceil?	[logic!]
		return:		[red-value!]
		/local
			int		[red-integer!]
			f		[red-float!]
			dec		[float!]
			sc		[float!]
			r		[float!]
			d		[float!]
			e		[integer!]
			v		[logic!]
	][
		e: 0
		f: as red-float! value
		dec: f/value
		sc: 1.0
		if OPTION?(scale) [
			if TYPE_OF(scale) = TYPE_INTEGER [
				int: as red-integer! value
				int/value: to-integer dec
				int/header: TYPE_INTEGER
				return integer/round value as red-integer! scale _even? down? half-down? floor? ceil? half-ceil?
			]
			sc: abs scale/value
		]

		if sc = 0.0 [
			print-line "*** Math Error: float overflow on ROUND"
			value/header: TYPE_UNSET
			return value
		]

		if sc < ldexp abs dec -53 [return value]		;-- is scale negligible?

		v: sc >= 1.0
		dec: either v [dec / sc][
			r: frexp sc :e
			either e <= -1022 [
				sc: r
				dec: ldexp dec e
			][e: 0]
			sc: 1.0 / sc
			dec * sc
		]

		d: abs dec
		r: 0.5 + floor d
		dec: case [
			down?		[FLOAT_TRUNC(dec)]
			floor?		[floor dec		 ]
			ceil?		[ceil dec		 ]
			r < d		[FLOAT_AWAY(dec) ]
			r > d		[FLOAT_TRUNC(dec)]
			_even?		[either d % 2.0 < 1.0 [FLOAT_TRUNC(dec)][FLOAT_AWAY(dec)]]
			half-down?	[FLOAT_TRUNC(dec)]
			half-ceil?	[ceil dec		 ]
			true		[FLOAT_AWAY(dec) ]
		]

		f/value: either v [
			dec: dec * sc
			if DOUBLE_MAX = abs dec [
				print-line "*** Math Error: float overflow on ROUND"
				value/header: TYPE_UNSET
			]
			dec
		][
			ldexp dec / sc e
		]
		value
	]

	init: does [
		datatype/register [
			TYPE_FLOAT
			TYPE_VALUE
			"float!"
			;-- General actions --
			:make
			:random
			null			;reflect
			:to
			:form
			:mold
			null			;eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			:absolute
			:add
			:divide
			:multiply
			:negate
			:power
			:remainder
			:round
			: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
			null			;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
		]
	]
]