FIX: regression after fixing issue #1008

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

object: context [
	verbose: 0

	class-id: 1'000'000									;-- base ID for dynamically created objects

	get-new-id: func [return: [integer!]][				;@@ protect from concurrent accesses
		class-id: class-id + 1
		class-id
	]

	save-self-object: func [
		obj		[red-object!]
		return: [node!]
		/local
			int	 [red-integer!]
			node [node!]
			s	 [series!]
	][
		node: alloc-cells 1								;-- hidden object value storage used by SELF
		s: as series! node/value
		copy-cell as red-value! obj s/offset
		node
	]

	make-callback-node: func [
		ctx		[red-context!]
		index   [integer!]
		locals  [integer!]
		return: [node!]
		/local
			node [node!]
			int  [red-integer!]
			s	 [series!]
	][
		node: alloc-cells 2
		s: as series! node/value
		int: as red-integer! s/offset
		int/header: TYPE_INTEGER
		int/value: index

		int: as red-integer! s/offset + 1
		int/header: TYPE_INTEGER
		s: as series! ctx/values/value
		int/value: locals
		node
	]

	on-set-defined?: func [
		ctx		[red-context!]
		return: [node!]
		/local
			head   [red-word!]
			tail   [red-word!]
			word   [red-word!]
			fun	   [red-function!]
			s	   [series!]
			on-set [integer!]
			index  [integer!]
	][
		s:		as series! ctx/symbols/value
		head:	as red-word! s/offset
		tail:	as red-word! s/tail
		word:	head
		on-set:	words/_on-change*/symbol
		index:	-1

		while [all [index < 0 word < tail]][
			if on-set = symbol/resolve word/symbol [
				index: (as-integer word - head) >> 4
			]
			word: word + 1
		]
		if index = -1 [return null]						;-- callback is not found

		s: as series! ctx/values/value
		fun: as red-function! s/offset + index

		make-callback-node
			ctx
			index
			_function/calc-arity null fun 0				;-- passing a null path triggers short code branch
	]

	fire-on-set*: func [								;-- compiled code entry point
		parent [red-word!]
		field  [red-word!]
	][
		fire-on-set
			as red-object! _context/get parent
			field
			stack/top - 1
			stack/top - 2
	]

	fire-on-set: func [
		obj	 [red-object!]
		word [red-word!]
		old	 [red-value!]
		new	 [red-value!]
		/local
			fun	  [red-function!]
			int	  [red-integer!]
			index [integer!]
			count [integer!]
			s	  [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/fire-on-set"]]

		assert TYPE_OF(obj) = TYPE_OBJECT
		assert obj/on-set <> null
		s: as series! obj/on-set/value

		int: as red-integer! s/offset
		assert TYPE_OF(int) = TYPE_INTEGER
		index: int/value

		int: as red-integer! s/offset + 1
		assert TYPE_OF(int) = TYPE_INTEGER
		count: int/value

		ctx: GET_CTX(obj)
		s: as series! ctx/values/value
		fun: as red-function! s/offset + index
		assert TYPE_OF(fun) = TYPE_FUNCTION

		stack/mark-func words/_on-change*
		stack/push as red-value! word
		stack/push old
		stack/push new
		if positive? count [_function/init-locals count]
		_function/call fun obj/ctx
		stack/unwind
	]

	unchanged?: func [
		word	[red-word!]
		id		[integer!]
		return: [logic!]
		/local
			obj [red-object!]
	][
		obj: as red-object! _context/get word
		all [
			TYPE_OF(obj) = TYPE_OBJECT
			obj/class = id
		]
	]

	unchanged2?: func [
		node	[node!]
		index	[integer!]
		id		[integer!]
		return: [logic!]
		/local
			obj	   [red-object!]
			ctx	   [red-context!]
			values [series!]
	][
		ctx: TO_CTX(node)
		values: as series! ctx/values/value
		obj: as red-object! values/offset + index
		all [
			TYPE_OF(obj) = TYPE_OBJECT
			obj/class = id
		]
	]

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

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

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

		if sym = s-tail [return part]					;-- exit if empty

		either flat? [
			indent?: no
			blank: space
		][
			if mold? [
				string/append-char GET_BUFFER(buffer) as-integer lf
				part: part - 1
			]
			blank: lf
		]

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

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

			if TYPE_OF(value) = TYPE_VALUE [value/header: TYPE_UNSET] ;-- force uninitialized slot to UNSET
			if TYPE_OF(value) = TYPE_WORD [
				string/append-char GET_BUFFER(buffer) as-integer #"'" ;-- create a literal word
				part: part - 1
			]
			part: actions/mold value buffer only? all? flat? arg part tabs

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

	transfer: func [
		src    [node!]									;-- src context
		dst	   [node!]									;-- dst context (extension of src)
		/local
			from   [red-context!]
			to	   [red-context!]
			word   [red-word!]
			symbol [red-value!]
			value  [red-value!]
			tail   [red-value!]
			target [red-value!]
			s	   [series!]
			idx	   [integer!]
			type   [integer!]
	][
		from: TO_CTX(src)
		to:	  TO_CTX(dst)

		s: as series! from/symbols/value
		symbol: s/offset
		tail: s/tail

		s: as series! from/values/value
		value: s/offset

		s: as series! to/values/value
		target: s/offset

		while [symbol < tail][
			word: as red-word! symbol
			idx: _context/find-word to word/symbol no

			type: TYPE_OF(value)
			either ANY_SERIES?(type) [					;-- copy series value in extended object
				actions/copy
					as red-series! value
					target + idx
					null
					yes
					null
			][
				copy-cell value target + idx			;-- just propagate the old value by default
			]
			symbol: symbol + 1
			value: value + 1
		]
	]

	duplicate: func [
		src    [node!]									;-- src context
		dst	   [node!]									;-- dst context (extension of src)
		/local
			from   [red-context!]
			to	   [red-context!]
			value  [red-value!]
			tail   [red-value!]
			target [red-value!]
			s	   [series!]
			type   [integer!]
	][
		from: TO_CTX(src)
		to:	  TO_CTX(dst)

		s: as series! from/values/value
		value: s/offset
		tail:  s/tail

		s: as series! to/values/value
		target: s/offset

		while [value < tail][
			type: TYPE_OF(value)
			either ANY_SERIES?(type) [					;-- copy series value in extended object
				actions/copy
					as red-series! value
					target
					null
					yes
					null
			][
				copy-cell value target					;-- just propagate the old value by default
			]
			value: value + 1
			target: target + 1
		]
	]

	extend: func [
		ctx		[red-context!]
		spec	[red-context!]
		return: [logic!]
		/local
			syms  [red-value!]
			tail  [red-value!]
			vals  [red-value!]
			value [red-value!]
			base  [red-value!]
			word  [red-word!]
			type  [integer!]
			s	  [series!]
	][
		s: as series! spec/symbols/value
		syms: s/offset
		tail: s/tail

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

		s: as series! ctx/symbols/value
		base: s/tail - s/offset

		s: as series! ctx/values/value

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

			if null? value [
				word: as red-word! syms
				value: s/offset + _context/find-word ctx word/symbol no
				copy-cell vals value
			]
			type: TYPE_OF(value)
			case [
				ANY_SERIES?(type) [
					actions/copy
						as red-series! value
						value						;-- overwrite the value
						null
						yes
						null
				]
				type = TYPE_FUNCTION [
					rebind as red-function! value ctx
				]
				true [0]
			]
			syms: syms + 1
			vals: vals + 1
		]
		s: as series! ctx/symbols/value					;-- refreshing pointer
		s/tail - s/offset > base						;-- TRUE: new words added
	]

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

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

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

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

	init-push: func [
		node	[node!]
		class	[integer!]
		return: [red-object!]
		/local
			ctx [red-context!]
			obj	[red-object!]
	][
		ctx: TO_CTX(node)
		s: as series! ctx/values/value
		if s/offset = s/tail [
			s/tail: s/offset + (s/size >> 4)			;-- (late) setting of 'values right tail pointer
		]

		obj: as red-object! stack/push*
		obj/header: TYPE_OBJECT
		obj/ctx:	node
		obj/class:	class
		obj/on-set: null								;-- deferred setting, once object's body is evaluated
		obj
	]

	init-on-set: func [
		ctx	   [node!]
		index  [integer!]
		locals [integer!]
		/local
			obj [red-object!]
	][
		obj: as red-object! stack/top - 1
		assert TYPE_OF(obj) = TYPE_OBJECT
		obj/on-set: make-callback-node TO_CTX(ctx) index locals
	]

	push: func [
		ctx		[node!]
		class	[integer!]
		index	[integer!]
		locals	[integer!]
		return: [red-object!]
		/local
			obj	[red-object!]
	][
		obj: as red-object! stack/push*
		obj/header: TYPE_OBJECT
		obj/ctx:	ctx
		obj/class:	class
		obj/on-set: make-callback-node TO_CTX(ctx) index locals
		obj
	]

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

	collect-couples: func [
		ctx	 	[red-context!]
		spec 	[red-block!]
		only?	[logic!]
		return: [logic!]
		/local
			cell   [red-value!]
			tail   [red-value!]
			value  [red-value!]
			values [red-value!]
			base   [red-value!]
			word   [red-word!]
			s	   [series!]
			id	   [integer!]
			sym	   [integer!]
	][
		s: GET_BUFFER(spec)
		cell: s/offset
		tail: s/tail

		s: as series! ctx/symbols/value
		base: s/tail - s/offset

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

		while [cell < tail][
			if TYPE_OF(cell) = TYPE_SET_WORD [
				id: _context/add ctx as red-word! cell

				value: cell + 1							;-- fetch next value to assign
				while [all [
					TYPE_OF(value) = TYPE_SET_WORD
					value < tail
				]][
					value: value + 1
				]
				if value = tail [value: as red-value! none-value]

				if all [not only? TYPE_OF(value) = TYPE_WORD][ ;-- reduce the value if allowed
					word: as red-word! value
					sym: symbol/resolve word/symbol
					if any [
						sym = words/_true
						sym = words/_yes
						sym = words/_on
					][
						value: as red-value! true-value
					]
					if any [
						sym = words/_false
						sym = words/_no
						sym = words/_off
					][
						value: as red-value! false-value
					]
					if sym = words/none [value: as red-value! none-value]
				]

				copy-cell value values + id
			]
			cell: cell + 1
		]
		s/tail - s/offset > base						;-- TRUE: new words added
	]

	construct: func [
		spec	[red-block!]
		proto	[red-object!]
		only?	[logic!]
		return:	[red-object!]
		/local
			obj	 [red-object!]
			ctx	 [red-context!]
	][
		obj: as red-object! stack/push*
		make-at obj 4								;-- arbitrary value
		ctx: GET_CTX(obj)
		unless null? proto [extend ctx GET_CTX(proto)]
		collect-couples ctx spec only?
		obj/class: get-new-id
		obj/on-set: null
		obj
	]

	;-- Actions --

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

		obj: as red-object! stack/push*

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

		switch TYPE_OF(spec) [
			TYPE_OBJECT [
				obj2: as red-object! spec
				obj/class: either extend ctx GET_CTX(obj2) [get-new-id][proto/class]
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				_context/collect-set-words ctx blk
				_context/bind blk ctx save-self-object obj yes
				interpreter/eval blk no
				obj/class: get-new-id
				obj/on-set: on-set-defined? ctx
			]
			default [
				print-line "*** Error: invalid spec value for object construction"
				halt
			]
		]
		obj
	]

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

		ctx: GET_CTX(obj)

		case [
			field = words/words [
				blk/node: ctx/symbols
				blk: block/clone blk no

				word: as red-word! block/rs-head blk
				tail: block/rs-tail blk

				while [word < as red-word! tail][
					word/ctx: obj/ctx
					word: word + 1
				]
			]
			field = words/values [
				blk/node: ctx/values
				blk: block/clone blk no
			]
			field = words/body [
				blk/node: ctx/symbols
				blk/node: alloc-cells block/rs-length? blk

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

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

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

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

		serialize obj buffer no no no arg part no 0 no
	]

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

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

	eval-path: func [
		parent	[red-object!]							;-- implicit type casting
		element	[red-value!]
		value	[red-value!]
		return:	[red-value!]
		/local
			word	[red-word!]
			ctx		[red-context!]
			old		[red-value!]
			on-set? [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/eval-path"]]

		word: as red-word! element
		assert TYPE_OF(word) = TYPE_WORD
		ctx:  GET_CTX(parent)

		if word/ctx <> parent/ctx [						;-- bind the word to object's context
			word/index: _context/find-word ctx word/symbol no
			word/ctx: parent/ctx
		]
		either value <> null [
			on-set?: parent/on-set <> null
			if on-set? [old: stack/push _context/get-in word ctx]
			_context/set-in word value ctx
			if on-set? [fire-on-set parent as red-word! element old value]
			value
		][
			_context/get-in word ctx
		]
	]

	compare: func [
		obj1	[red-object!]							;-- first operand
		obj2	[red-object!]							;-- second operand
		op		[integer!]								;-- type of comparison
		return:	[integer!]
		/local
			ctx1   [red-context!]
			ctx2   [red-context!]
			sym1   [red-word!]
			sym2   [red-word!]
			tail   [red-word!]
			value1 [red-value!]
			value2 [red-value!]
			s	   [series!]
			diff   [integer!]
			s1	   [integer!]
			s2	   [integer!]
			type1  [integer!]
			type2  [integer!]
			res	   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/compare"]]

		if TYPE_OF(obj2) <> TYPE_OBJECT [RETURN_COMPARE_OTHER]

		ctx1: GET_CTX(obj1)
		s: as series! ctx1/symbols/value
		sym1: as red-word! s/offset
		tail: as red-word! s/tail

		ctx2: GET_CTX(obj2)
		s: as series! ctx2/symbols/value

		diff: (as-integer s/tail - s/offset) - (as-integer tail - sym1)
		if diff <> 0 [
			return either positive? diff [-1][1]
		]
		if zero? (as-integer tail - sym1) [			;-- empty objects case
			return 0
		]

		sym2: as red-word! s/offset
		s: as series! ctx1/values/value
		value1: s/offset
		s: as series! ctx2/values/value
		value2: s/offset

		until [
			s1: symbol/resolve sym1/symbol
			s2: symbol/resolve sym2/symbol
			if s1 <> s2 [
				return SIGN_COMPARE_RESULT(s1 s2)
			]
			type1: TYPE_OF(value1)
			type2: TYPE_OF(value2)
			either any [
				type1 = type2
				all [word/any-word? type1 word/any-word? type2]
				all [											;@@ replace by ANY_NUMBER?
					any [type1 = TYPE_INTEGER type1 = TYPE_FLOAT]
					any [type2 = TYPE_INTEGER type2 = TYPE_FLOAT]
				]
			][
				res: actions/compare-value value1 value2 op
				sym1: sym1 + 1
				sym2: sym2 + 1
				value1: value1 + 1
				value2: value2 + 1
			][
				return SIGN_COMPARE_RESULT(type1 type2)
			]
			any [
				res <> 0
				sym1 >= tail
			]
		]
		res
	]

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

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

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

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

		copy-cell as cell! obj as cell! new
		new/ctx: _context/create slots no yes
		new/class: obj/class
		nctx: GET_CTX(new)

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

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

		value: dst/offset
		tail:  dst/tail

		either deep? [
			while [value < tail][
				type: TYPE_OF(value)
				case [
					ANY_SERIES?(type) [
						actions/copy
							as red-series! value
							value						;-- overwrite the value
							null
							yes
							null
					]
					type = TYPE_FUNCTION [
						rebind as red-function! value nctx
					]
					true [0]
				]
				value: value + 1
			]
		][
			while [value < tail][
				if TYPE_OF(value) = TYPE_FUNCTION [
					rebind as red-function! value nctx
				]
				value: value + 1
			]
		]
		new
	]

	find: func [
		obj		 [red-object!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		tail?	 [logic!]
		match?	 [logic!]
		return:	 [red-value!]
		/local
			word [red-word!]
			ctx	 [node!]
			id	 [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/find"]]

		assert any [									;@@ replace with ANY_WORD?
			TYPE_OF(value) = TYPE_WORD
			TYPE_OF(value) = TYPE_LIT_WORD
			TYPE_OF(value) = TYPE_GET_WORD
			TYPE_OF(value) = TYPE_SET_WORD
		]
		word: as red-word! value
		ctx: obj/ctx
		id: _context/find-word TO_CTX(ctx) word/symbol yes
		as red-value! either id = -1 [none-value][true-value]
	]

	select: func [
		obj		 [red-object!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		return:	 [red-value!]
		/local
			word   [red-word!]
			ctx	   [red-context!]
			values [series!]
			node   [node!]
			id	   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/select"]]

		assert any [									;@@ replace with ANY_WORD?
			TYPE_OF(value) = TYPE_WORD
			TYPE_OF(value) = TYPE_LIT_WORD
			TYPE_OF(value) = TYPE_GET_WORD
			TYPE_OF(value) = TYPE_SET_WORD
		]
		word: as red-word! value
		node: obj/ctx
		ctx: TO_CTX(node)
		id: _context/find-word ctx word/symbol yes
		if id = -1 [return as red-value! none-value]

		values: as series! ctx/values/value
		values/offset + id
	]

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

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

object: context [
	verbose: 0

	class-id: 1'000'000									;-- base ID for dynamically created objects

	get-new-id: func [return: [integer!]][				;@@ protect from concurrent accesses
		class-id: class-id + 1
		class-id
	]

	save-self-object: func [
		obj		[red-object!]
		return: [node!]
		/local
			int	 [red-integer!]
			node [node!]
			s	 [series!]
	][
		node: alloc-cells 1								;-- hidden object value storage used by SELF
		s: as series! node/value
		copy-cell as red-value! obj s/offset
		node
	]

	make-callback-node: func [
		ctx		[red-context!]
		index   [integer!]
		locals  [integer!]
		return: [node!]
		/local
			node [node!]
			int  [red-integer!]
			s	 [series!]
	][
		node: alloc-cells 2
		s: as series! node/value
		int: as red-integer! s/offset
		int/header: TYPE_INTEGER
		int/value: index

		int: as red-integer! s/offset + 1
		int/header: TYPE_INTEGER
		s: as series! ctx/values/value
		int/value: locals
		node
	]

	on-set-defined?: func [
		ctx		[red-context!]
		return: [node!]
		/local
			head   [red-word!]
			tail   [red-word!]
			word   [red-word!]
			fun	   [red-function!]
			s	   [series!]
			on-set [integer!]
			index  [integer!]
	][
		s:		as series! ctx/symbols/value
		head:	as red-word! s/offset
		tail:	as red-word! s/tail
		word:	head
		on-set:	words/_on-change*/symbol
		index:	-1

		while [all [index < 0 word < tail]][
			if on-set = symbol/resolve word/symbol [
				index: (as-integer word - head) >> 4
			]
			word: word + 1
		]
		if index = -1 [return null]						;-- callback is not found

		s: as series! ctx/values/value
		fun: as red-function! s/offset + index

		make-callback-node
			ctx
			index
			_function/calc-arity null fun 0				;-- passing a null path triggers short code branch
	]

	fire-on-set*: func [								;-- compiled code entry point
		parent [red-word!]
		field  [red-word!]
	][
		fire-on-set
			as red-object! _context/get parent
			field
			stack/top - 1
			stack/top - 2
	]

	fire-on-set: func [
		obj	 [red-object!]
		word [red-word!]
		old	 [red-value!]
		new	 [red-value!]
		/local
			fun	  [red-function!]
			int	  [red-integer!]
			index [integer!]
			count [integer!]
			s	  [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/fire-on-set"]]

		assert TYPE_OF(obj) = TYPE_OBJECT
		assert obj/on-set <> null
		s: as series! obj/on-set/value

		int: as red-integer! s/offset
		assert TYPE_OF(int) = TYPE_INTEGER
		index: int/value

		int: as red-integer! s/offset + 1
		assert TYPE_OF(int) = TYPE_INTEGER
		count: int/value

		ctx: GET_CTX(obj)
		s: as series! ctx/values/value
		fun: as red-function! s/offset + index
		assert TYPE_OF(fun) = TYPE_FUNCTION

		stack/mark-func words/_on-change*
		stack/push as red-value! word
		stack/push old
		stack/push new
		if positive? count [_function/init-locals count]
		_function/call fun obj/ctx
		stack/unwind
	]

	unchanged?: func [
		word	[red-word!]
		id		[integer!]
		return: [logic!]
		/local
			obj [red-object!]
	][
		obj: as red-object! _context/get word
		all [
			TYPE_OF(obj) = TYPE_OBJECT
			obj/class = id
		]
	]

	unchanged2?: func [
		node	[node!]
		index	[integer!]
		id		[integer!]
		return: [logic!]
		/local
			obj	   [red-object!]
			ctx	   [red-context!]
			values [series!]
	][
		ctx: TO_CTX(node)
		values: as series! ctx/values/value
		obj: as red-object! values/offset + index
		all [
			TYPE_OF(obj) = TYPE_OBJECT
			obj/class = id
		]
	]

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

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

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

		if sym = s-tail [return part]					;-- exit if empty

		either flat? [
			indent?: no
			blank: space
		][
			blank: lf
		]

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

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

			if TYPE_OF(value) = TYPE_VALUE [value/header: TYPE_UNSET] ;-- force uninitialized slot to UNSET
			if TYPE_OF(value) = TYPE_WORD [
				string/append-char GET_BUFFER(buffer) as-integer #"'" ;-- create a literal word
				part: part - 1
			]
			part: actions/mold value buffer only? all? flat? arg part tabs

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

	transfer: func [
		src    [node!]									;-- src context
		dst	   [node!]									;-- dst context (extension of src)
		/local
			from   [red-context!]
			to	   [red-context!]
			word   [red-word!]
			symbol [red-value!]
			value  [red-value!]
			tail   [red-value!]
			target [red-value!]
			s	   [series!]
			idx	   [integer!]
			type   [integer!]
	][
		from: TO_CTX(src)
		to:	  TO_CTX(dst)

		s: as series! from/symbols/value
		symbol: s/offset
		tail: s/tail

		s: as series! from/values/value
		value: s/offset

		s: as series! to/values/value
		target: s/offset

		while [symbol < tail][
			word: as red-word! symbol
			idx: _context/find-word to word/symbol no

			type: TYPE_OF(value)
			either ANY_SERIES?(type) [					;-- copy series value in extended object
				actions/copy
					as red-series! value
					target + idx
					null
					yes
					null
			][
				copy-cell value target + idx			;-- just propagate the old value by default
			]
			symbol: symbol + 1
			value: value + 1
		]
	]

	duplicate: func [
		src    [node!]									;-- src context
		dst	   [node!]									;-- dst context (extension of src)
		/local
			from   [red-context!]
			to	   [red-context!]
			value  [red-value!]
			tail   [red-value!]
			target [red-value!]
			s	   [series!]
			type   [integer!]
	][
		from: TO_CTX(src)
		to:	  TO_CTX(dst)

		s: as series! from/values/value
		value: s/offset
		tail:  s/tail

		s: as series! to/values/value
		target: s/offset

		while [value < tail][
			type: TYPE_OF(value)
			either ANY_SERIES?(type) [					;-- copy series value in extended object
				actions/copy
					as red-series! value
					target
					null
					yes
					null
			][
				copy-cell value target					;-- just propagate the old value by default
			]
			value: value + 1
			target: target + 1
		]
	]

	extend: func [
		ctx		[red-context!]
		spec	[red-context!]
		return: [logic!]
		/local
			syms  [red-value!]
			tail  [red-value!]
			vals  [red-value!]
			value [red-value!]
			base  [red-value!]
			word  [red-word!]
			type  [integer!]
			s	  [series!]
	][
		s: as series! spec/symbols/value
		syms: s/offset
		tail: s/tail

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

		s: as series! ctx/symbols/value
		base: s/tail - s/offset

		s: as series! ctx/values/value

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

			if null? value [
				word: as red-word! syms
				value: s/offset + _context/find-word ctx word/symbol no
				copy-cell vals value
			]
			type: TYPE_OF(value)
			case [
				ANY_SERIES?(type) [
					actions/copy
						as red-series! value
						value						;-- overwrite the value
						null
						yes
						null
				]
				type = TYPE_FUNCTION [
					rebind as red-function! value ctx
				]
				true [0]
			]
			syms: syms + 1
			vals: vals + 1
		]
		s: as series! ctx/symbols/value					;-- refreshing pointer
		s/tail - s/offset > base						;-- TRUE: new words added
	]

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

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

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

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

	init-push: func [
		node	[node!]
		class	[integer!]
		return: [red-object!]
		/local
			ctx [red-context!]
			obj	[red-object!]
	][
		ctx: TO_CTX(node)
		s: as series! ctx/values/value
		if s/offset = s/tail [
			s/tail: s/offset + (s/size >> 4)			;-- (late) setting of 'values right tail pointer
		]

		obj: as red-object! stack/push*
		obj/header: TYPE_OBJECT
		obj/ctx:	node
		obj/class:	class
		obj/on-set: null								;-- deferred setting, once object's body is evaluated
		obj
	]

	init-on-set: func [
		ctx	   [node!]
		index  [integer!]
		locals [integer!]
		/local
			obj [red-object!]
	][
		obj: as red-object! stack/top - 1
		assert TYPE_OF(obj) = TYPE_OBJECT
		obj/on-set: make-callback-node TO_CTX(ctx) index locals
	]

	push: func [
		ctx		[node!]
		class	[integer!]
		index	[integer!]
		locals	[integer!]
		return: [red-object!]
		/local
			obj	[red-object!]
	][
		obj: as red-object! stack/push*
		obj/header: TYPE_OBJECT
		obj/ctx:	ctx
		obj/class:	class
		obj/on-set: make-callback-node TO_CTX(ctx) index locals
		obj
	]

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

	collect-couples: func [
		ctx	 	[red-context!]
		spec 	[red-block!]
		only?	[logic!]
		return: [logic!]
		/local
			cell   [red-value!]
			tail   [red-value!]
			value  [red-value!]
			values [red-value!]
			base   [red-value!]
			word   [red-word!]
			s	   [series!]
			id	   [integer!]
			sym	   [integer!]
	][
		s: GET_BUFFER(spec)
		cell: s/offset
		tail: s/tail

		s: as series! ctx/symbols/value
		base: s/tail - s/offset

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

		while [cell < tail][
			if TYPE_OF(cell) = TYPE_SET_WORD [
				id: _context/add ctx as red-word! cell

				value: cell + 1							;-- fetch next value to assign
				while [all [
					TYPE_OF(value) = TYPE_SET_WORD
					value < tail
				]][
					value: value + 1
				]
				if value = tail [value: as red-value! none-value]

				if all [not only? TYPE_OF(value) = TYPE_WORD][ ;-- reduce the value if allowed
					word: as red-word! value
					sym: symbol/resolve word/symbol
					if any [
						sym = words/_true
						sym = words/_yes
						sym = words/_on
					][
						value: as red-value! true-value
					]
					if any [
						sym = words/_false
						sym = words/_no
						sym = words/_off
					][
						value: as red-value! false-value
					]
					if sym = words/none [value: as red-value! none-value]
				]

				copy-cell value values + id
			]
			cell: cell + 1
		]
		s/tail - s/offset > base						;-- TRUE: new words added
	]

	construct: func [
		spec	[red-block!]
		proto	[red-object!]
		only?	[logic!]
		return:	[red-object!]
		/local
			obj	 [red-object!]
			ctx	 [red-context!]
	][
		obj: as red-object! stack/push*
		make-at obj 4								;-- arbitrary value
		ctx: GET_CTX(obj)
		unless null? proto [extend ctx GET_CTX(proto)]
		collect-couples ctx spec only?
		obj/class: get-new-id
		obj/on-set: null
		obj
	]

	;-- Actions --

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

		obj: as red-object! stack/push*

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

		switch TYPE_OF(spec) [
			TYPE_OBJECT [
				obj2: as red-object! spec
				obj/class: either extend ctx GET_CTX(obj2) [get-new-id][proto/class]
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				_context/collect-set-words ctx blk
				_context/bind blk ctx save-self-object obj yes
				interpreter/eval blk no
				obj/class: get-new-id
				obj/on-set: on-set-defined? ctx
			]
			default [
				print-line "*** Error: invalid spec value for object construction"
				halt
			]
		]
		obj
	]

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

		ctx: GET_CTX(obj)

		case [
			field = words/words [
				blk/node: ctx/symbols
				blk: block/clone blk no

				word: as red-word! block/rs-head blk
				tail: block/rs-tail blk

				while [word < as red-word! tail][
					word/ctx: obj/ctx
					word: word + 1
				]
			]
			field = words/values [
				blk/node: ctx/values
				blk: block/clone blk no
			]
			field = words/body [
				blk/node: ctx/symbols
				blk/node: alloc-cells block/rs-length? blk

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

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

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

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

		serialize obj buffer no no no arg part no 0
	]

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

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

	eval-path: func [
		parent	[red-object!]							;-- implicit type casting
		element	[red-value!]
		value	[red-value!]
		return:	[red-value!]
		/local
			word	[red-word!]
			ctx		[red-context!]
			old		[red-value!]
			on-set? [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/eval-path"]]

		word: as red-word! element
		assert TYPE_OF(word) = TYPE_WORD
		ctx:  GET_CTX(parent)

		if word/ctx <> parent/ctx [						;-- bind the word to object's context
			word/index: _context/find-word ctx word/symbol no
			word/ctx: parent/ctx
		]
		either value <> null [
			on-set?: parent/on-set <> null
			if on-set? [old: stack/push _context/get-in word ctx]
			_context/set-in word value ctx
			if on-set? [fire-on-set parent as red-word! element old value]
			value
		][
			_context/get-in word ctx
		]
	]

	compare: func [
		obj1	[red-object!]							;-- first operand
		obj2	[red-object!]							;-- second operand
		op		[integer!]								;-- type of comparison
		return:	[integer!]
		/local
			ctx1   [red-context!]
			ctx2   [red-context!]
			sym1   [red-word!]
			sym2   [red-word!]
			tail   [red-word!]
			value1 [red-value!]
			value2 [red-value!]
			s	   [series!]
			diff   [integer!]
			s1	   [integer!]
			s2	   [integer!]
			type1  [integer!]
			type2  [integer!]
			res	   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/compare"]]

		if TYPE_OF(obj2) <> TYPE_OBJECT [RETURN_COMPARE_OTHER]

		ctx1: GET_CTX(obj1)
		s: as series! ctx1/symbols/value
		sym1: as red-word! s/offset
		tail: as red-word! s/tail

		ctx2: GET_CTX(obj2)
		s: as series! ctx2/symbols/value

		diff: (as-integer s/tail - s/offset) - (as-integer tail - sym1)
		if diff <> 0 [
			return either positive? diff [-1][1]
		]
		if zero? (as-integer tail - sym1) [			;-- empty objects case
			return 0
		]

		sym2: as red-word! s/offset
		s: as series! ctx1/values/value
		value1: s/offset
		s: as series! ctx2/values/value
		value2: s/offset

		until [
			s1: symbol/resolve sym1/symbol
			s2: symbol/resolve sym2/symbol
			if s1 <> s2 [
				return SIGN_COMPARE_RESULT(s1 s2)
			]
			type1: TYPE_OF(value1)
			type2: TYPE_OF(value2)
			either any [
				type1 = type2
				all [word/any-word? type1 word/any-word? type2]
				all [											;@@ replace by ANY_NUMBER?
					any [type1 = TYPE_INTEGER type1 = TYPE_FLOAT]
					any [type2 = TYPE_INTEGER type2 = TYPE_FLOAT]
				]
			][
				res: actions/compare-value value1 value2 op
				sym1: sym1 + 1
				sym2: sym2 + 1
				value1: value1 + 1
				value2: value2 + 1
			][
				return SIGN_COMPARE_RESULT(type1 type2)
			]
			any [
				res <> 0
				sym1 >= tail
			]
		]
		res
	]

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

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

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

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

		copy-cell as cell! obj as cell! new
		new/ctx: _context/create slots no yes
		new/class: obj/class
		nctx: GET_CTX(new)

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

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

		value: dst/offset
		tail:  dst/tail

		either deep? [
			while [value < tail][
				type: TYPE_OF(value)
				case [
					ANY_SERIES?(type) [
						actions/copy
							as red-series! value
							value						;-- overwrite the value
							null
							yes
							null
					]
					type = TYPE_FUNCTION [
						rebind as red-function! value nctx
					]
					true [0]
				]
				value: value + 1
			]
		][
			while [value < tail][
				if TYPE_OF(value) = TYPE_FUNCTION [
					rebind as red-function! value nctx
				]
				value: value + 1
			]
		]
		new
	]

	find: func [
		obj		 [red-object!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		tail?	 [logic!]
		match?	 [logic!]
		return:	 [red-value!]
		/local
			word [red-word!]
			ctx	 [node!]
			id	 [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/find"]]

		assert any [									;@@ replace with ANY_WORD?
			TYPE_OF(value) = TYPE_WORD
			TYPE_OF(value) = TYPE_LIT_WORD
			TYPE_OF(value) = TYPE_GET_WORD
			TYPE_OF(value) = TYPE_SET_WORD
		]
		word: as red-word! value
		ctx: obj/ctx
		id: _context/find-word TO_CTX(ctx) word/symbol yes
		as red-value! either id = -1 [none-value][true-value]
	]

	select: func [
		obj		 [red-object!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		return:	 [red-value!]
		/local
			word   [red-word!]
			ctx	   [red-context!]
			values [series!]
			node   [node!]
			id	   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/select"]]

		assert any [									;@@ replace with ANY_WORD?
			TYPE_OF(value) = TYPE_WORD
			TYPE_OF(value) = TYPE_LIT_WORD
			TYPE_OF(value) = TYPE_GET_WORD
			TYPE_OF(value) = TYPE_SET_WORD
		]
		word: as red-word! value
		node: obj/ctx
		ctx: TO_CTX(node)
		id: _context/find-word ctx word/symbol yes
		if id = -1 [return as red-value! none-value]

		values: as series! ctx/values/value
		values/offset + id
	]

	init: does [
		datatype/register [
			TYPE_OBJECT
			TYPE_VALUE
			"object!"
			;-- General actions --
			:make
			null			;random
			:reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			null			;absolute
			null			;add
			null			;divide
			null			;multiply
			null			;negate
			null			;power
			null			;remainder
			null			;round
			null			;subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			:copy
			:find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			: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: more case tests

TESTS: more case tests

Red/System [
	Title:   "Red/System case function test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %case-test.reds
	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.reds

~~~start-file~~~ "case"

===start-group=== "case integer!"

#define case-int-1 [case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]]

	--test-- "case-int-1"
	  ci: 1
	  cia: 0
	  case-int-1
	--assert 1 = cia

	--test-- "case-int-2"
	  ci: 2
	  cia: 0
	  case-int-1
	--assert 2 = cia

	--test-- "case-int-3"
	  ci: 3
	  cia: 0
	  case-int-1
	--assert 3 = cia

	--test-- "case-int-4"
	  ci: 9
	  cia: 0
	  case-int-1
	--assert 3 = cia

	#define case-int-2 [case [ ci = 1 [1] ci = 2 [2] true [3]]]

	--test-- "case-int-5"
	  ci: 1
	--assert 1 = case-int-2

	--test-- "case-int-6"
	  ci: 1
	  cres: case-int-2
	--assert 1 = cres

	--test-- "case-int-7"
	  ci: 2
	--assert 2 = case-int-2

	--test-- "case-int-8"
	  ci: 2
	  cres: case-int-2
	--assert 2 = cres

	--test-- "case-int-9"
	  ci: 3
	--assert 3 = case-int-2

	--test-- "case-int-10"
	  ci: 3
	  cres: case-int-2
	--assert 3 = cres

	--test-- "case-int-11"
	  ci: 10
	--assert 3 = case-int-2

	--test-- "case-int-12"
	  ci: 10
	  cres: case-int-2
	--assert 3 = cres

	#define case-int-3 [case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]] ]

	--test-- "case-int-13"
	  ci: 1
	  cia: 0
	--assert 1 = case-int-3

	--test-- "case-int-14"
	  ci: 1
	  cia: 0
	  cres: case-int-3
	--assert 1 = cres

	--test-- "case-int-15"
	  ci: 2
	  cia: 0
	--assert 2 = case-int-3

	--test-- "case-int-16"
	  ci: 2
	  cia: 0
	  cres: case-int-3
	--assert 2 = cres

	--test-- "case-int-17"
	  ci: 3
	  cia: 0
	--assert 3 = case-int-3

	--test-- "case-int-18"
	  ci: 3
	  cia: 0
	  cres: case-int-3
	--assert 3 = cres

	--test-- "case-int-19"
	  ci: 9
	  cia: 0
	--assert 3 = case-int-3

	--test-- "case-int-20"
	  ci: 9
	  cia: 0
	  cres: case-int-3
	--assert 3 = cres

===end-group===

===start-group=== "case byte!"

#define case-byte-1 [case [ cb = #"1" [cba: #"1"] cb = #"2" [cba: #"2"] true [cba: #"3"]]]

	--test-- "case-byte-1"
	  cb: #"1"
	  cba: #"0"
	  case-byte-1
	--assert #"1" = cba

	--test-- "case-byte-2"
	  cb: #"2"
	  cba: #"0"
	  case-byte-1
	--assert #"2" = cba

	--test-- "case-byte-3"
	  cb: #"3"
	  cba: #"0"
	  case-byte-1
	--assert #"3" = cba

	--test-- "case-byte-4"
	  cb: #"9"
	  cba: #"0"
	  case-byte-1
	--assert #"3" = cba

	#define case-byte-2 [case [ cb = #"1" [#"1"] cb = #"2" [#"2"] true [#"3"]]]

	--test-- "case-byte-5"
	  cb: #"1"
	--assert #"1" = case-byte-2

	--test-- "case-byte-6"
	  cb: #"1"
	  cbres: case-byte-2
	--assert #"1" = cbres

	--test-- "case-byte-7"
	  cb: #"2"
	--assert #"2" = case-byte-2

	--test-- "case-byte-8"
	  cb: #"2"
	  cbres: case-byte-2
	--assert #"2" = cbres

	--test-- "case-byte-9"
	  cb: #"3"
	--assert #"3" = case-byte-2

	--test-- "case-byte-10"
	  cb: #"3"
	  cbres: case-byte-2
	--assert #"3" = cbres

	--test-- "case-byte-11"
	  cb: #"9"
	--assert #"3" = case-byte-2

	--test-- "case-byte-12"
	  cb: #"9"
	  cbres: case-byte-2
	--assert #"3" = cbres

	#define case-byte-3 [case [ cb = #"1" [cba: #"1"] cb = #"2" [cba: #"2"] true [cba: #"3"]] ]

	--test-- "case-byte-13"
	  cb: #"1"
	  cba: #"0"
	--assert #"1" = case-byte-3

	--test-- "case-byte-14"
	  cb: #"1"
	  cba: #"0"
	  cbres: case-byte-3
	--assert #"1" = cbres

	--test-- "case-byte-15"
	  cb: #"2"
	  cba: #"0"
	--assert #"2" = case-byte-3

	--test-- "case-byte-16"
	  cb: #"2"
	  cba: #"0"
	  cbres: case-byte-3
	--assert #"2" = cbres

	--test-- "case-byte-17"
	  cb: #"3"
	  cba: #"0"
	--assert #"3" = case-byte-3

	--test-- "case-byte-18"
	  cb: #"3"
	  cba: #"0"
	  cbres: case-byte-3
	--assert #"3" = cbres

	--test-- "case-byte-19"
	  cb: #"9"
	  cba: #"0"
	--assert #"3" = case-byte-3

	--test-- "case-byte-20"
	  cb: #"9"
	  cba: #"0"
	  cbres: case-byte-3
	--assert #"3" = cbres

===end-group===

===start-group=== "case logic!"

  --test-- "case-logic-1"
    cl: true
  --assert case [ cl = true [true] cl = false [false] true [false]]

  --test-- "case-logic-2"
    cl: false
  --assert false = case [ cl = true [true] cl = false [false] true [true]]

===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System case function test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %case-test.reds
	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.reds

~~~start-file~~~ "case"

===start-group=== "case integer!"

#define case-int-1 [case [ ci = 1 [ca: 1] ci = 2 [ca: 2] true [ca: 3]]]

	--test-- "case-int-1"
	  ci: 1
	  ca: 0
	  case-int-1
	--assert 1 = ca

	--test-- "case-int-2"
	  ci: 2
	  ca: 0
	  case-int-1
	--assert 2 = ca

	--test-- "case-int-3"
	  ci: 3
	  ca: 0
	  case-int-1
	--assert 3 = ca

	--test-- "case-int-4"
	  ci: 3
	  ca: 0
	  case-int-1
	--assert 3 = ca

===end-group===

~~~end-file~~~


TESTS: added new regression test for issue #150

Red/System [
	Title:   "Red/System datatype casting test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %cast-test.reds
	Rights:  "Copyright (C) 2011 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.reds

~~~start-file~~~ "cast"

===start-group=== "cast from byte!"

	--test-- "byte-cast-1"
	--assert 65 = as integer! #"A"

	--test-- "byte-cast-2"
	  cast-b: #"A"
	  cast-i: 65
	--assert cast-i = as integer! cast-b

	--test-- "byte-cast-3"
	--assert false = as logic! #"^(00)"

	--test-- "byte-cast-4"
    cast-b: #"^(00)"
	  l: false
	--assert l = as logic! cast-b

	--test-- "byte-cast-5"
	--assert true = as logic! #"A"

	--test-- "byte-cast-6"
	  cast-b: #"A"
	  l: true
	--assert l = as logic! cast-b

	--test-- "byte-cast-7"
	--assert true = as logic! #"^(FF)"

	--test-- "byte-cast-8"
	  cast-b: #"^(FF)"
	  l: true
	--assert l = as logic! cast-b

	--test-- "byte-cast-9"							;-- issue #158
	  a: as-byte 10h
	  b: as-byte 80h
	--assert 10h = as-integer a

	--test-- "byte-cast-10"							;-- issue #159
	  a: as-byte 10h
	  b: as-byte 80h
	  c: as-integer a
	--assert 10h = c

	--test-- "byte-cast-11"							;-- issue #160
	  a: as-byte 1
	  b: as-byte 2
	  --assert (as byte-ptr! (as-integer a) * 2) = (as byte-ptr! 2)
	  --assert (as byte-ptr! (as-integer a) << 2) = (as byte-ptr! 4)

	--test-- "byte-cast-12"							;-- issue #161
	  a: as-byte 1
	  b: as-byte 2
	  c: (as-integer b) << 16 or as-integer a
	  --assert 00020001h = c

	--test-- "byte-cast-13"							;-- issue #162
	  sb: declare struct! [
	      a   [byte!]
	      b   [byte!]
	  ]
	  sb/a: as-byte 0
	  sb/b: as-byte 1
	  --assert not as-logic sb/a

	--test-- "byte-cast-13"							;-- issue #150
	 s!: alias struct! [
	     a   [byte!]
	     b   [byte!]
	     c   [byte!]
	     d   [byte!]
	 ]
	 t: declare s!
	 t/a: as-byte 1
	 t/b: as-byte 1
	 t/c: as-byte 0
	 t/d: as-byte 0
	 h: as-integer t/a
	 --assert h = 1

===end-group===

===start-group=== "cast from integer!"
comment {
  --test-- "int-cast-1"
  --assert #"^(00)" = as byte! 0
}
  --test-- "int-cast-2"
    i: 0
    cast-test-b: #"^(00)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-3"
  --assert #"^(01)" = as byte! 1

  --test-- "int-cast-4"
    i: 1
    cast-test-b: #"^(01)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-5"
  --assert #"^(FF)" = as byte! 255

  --test-- "int-cast-6"
    i: 255
    cast-test-b: #"^(FF)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-7"
  --assert #"^(00)" = as byte! 256

  --test-- "int-cast-8"
    i: 256
    cast-test-b: #"^(00)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-9"
  --assert false = as logic! 0

  --test-- "int-cast-10"
    i: 0
    l: false
  --assert l = as logic! i

  --test-- "int-cast-11"
  --assert true = as logic! FFFFFFFFh

  --test-- "int-cast-12"
    i: FFFFFFFFh
    l: true
  --assert l = as logic! i

  --test-- "int-cast-13"
  --assert true = as logic! 1

  --test-- "int-cast-14"
    i: 1
    l: true
  --assert l = as logic! i

  --test-- "int-cast-15"
    cs: "Hello"
    cs2: ""
    i: as integer! cs
    i: i + 1
    cs2: as c-string! i
  --assert cs2/1 = #"e"
  --assert 4 = length? cs2

  --test-- "int-cast-16"           ;; This test assumes 32-bit target
    i: 1
    p: declare pointer! [integer!]
    p: as [pointer! [integer!]] i
    P: P + 1
    i2: as integer! p
  --assert i2 = 5

  --test-- "int-cast-17"           ;; This test assumes 32-bit target
    ;; currently fails as p-int-cast is not declared
    i: 1
    p-int-cast-17: as [pointer! [integer!]] i
    P-int-cast-17: P-int-cast-17 + 1
    i2: as integer! p-int-cast-17
  --assert i2 = 5

  --test-- "int-cast-18"
    i: 1
    s: declare struct! [
      a [integer!]
      b [integer!]
    ]
    s: as [struct! [a [integer!] b [integer!]]] i
    s: s + 1
    i2: as integer! s
  --assert i2 = 9

  --test-- "int-cast-19"
    ic19-logic: either as-logic 0 [
      false
    ][
      true
    ]
  --assert ic19-logic

  --test-- "int-cast-20"
    ic20-dummy: func [return: [integer!]][0]
    ic20-logic: either as-logic ic20-dummy [
       false
    ][
      true
    ]
  --assert ic20-logic

===end-group===

===start-group=== "cast from logic!"

  --test-- "logic-cast-1"
  --assert #"^(01)" = as byte! true

  --test-- "logic-cast-2"
    cast-test-b: #"^(01)"
    l: true
  --assert cast-test-b = as byte! l

  --test-- "logic-cast-3"
  --assert #"^(00)" = as byte! false

  --test-- "logic-cast-4"
    cast-test-b: #"^(00)"
    l: false
  --assert cast-test-b = as byte! l

    --test-- "logic-cast-5"
  --assert 1 = as integer! true

  --test-- "logic-cast-6"
    i: 1
    l: true
  --assert i = as integer! l

  --test-- "logic-cast-7"
  --assert 0 = as integer! false

  --test-- "logic-cast-8"
    i: 0
    l: false
  --assert i = as integer! l

===end-group===

===start-group=== "cast c-string! tests"

  --test-- "c-string-cast-1"
    csc1-str: "Hello, Nenad"
    i: 0
    i: as integer! csc1-str
    i: i + 7
    csc1-str: as c-string! i
  --assert csc1-str/1 = #"N"
  --assert csc1-str/2 = #"e"
  --assert csc1-str/3 = #"n"
  --assert csc1-str/4 = #"a"
  --assert csc1-str/5 = #"d"
  comment {
  --test-- "c-string-cast-2"
  --assert false = as logic! ""
  }
    --test-- "c-string-cast-3"
    csc3-str: ""
  --assert true = as logic! csc3-str

  --test-- "c-string-cast-4"
  --assert true = as logic! "Any old iron, any old iron"

  --test-- "c-string-cast-5"
    csc5-str: "Why not?"
  --assert true = as logic! csc5-str

  --test-- "c-string-cast-6"
    csc6-str: "Tour de France"
    csc6-p: declare pointer! [integer!]
    csc6-p: as [pointer! [integer!]] csc6-str
    csc6-p: csc6-p + 2
    csc6-str2: as c-string! csc6-p
  --assert csc6-str2/1 = #"F"
  --assert csc6-str2/2 = #"r"
  --assert csc6-str2/3 = #"a"
  --assert csc6-str2/4 = #"n"
  --assert csc6-str2/5 = #"c"
  --assert csc6-str2/6 = #"e"

  --test-- "C-string-cast-7"
    csc7-struct: declare struct! [
      c1 [byte!]
      c2 [byte!]
      c3 [byte!]
      c4 [byte!]
      c5 [byte!]
    ]
    csc7-str: "Peter"
    csc7-struct: as [struct! [
      c1 [byte!] c2 [byte!] c3 [byte!] c4 [byte!] c5 [byte!]
    ]] csc7-str
  --assert csc7-struct/c1 = #"P"
  --assert csc7-struct/c2 = #"e"
  --assert csc7-struct/c3 = #"t"
  --assert csc7-struct/c4 = #"e"
  --assert csc7-struct/c5 = #"r"

===end-group===

===start-group=== "cast from pointer!"

  --test-- "csp-1"
    csp1-p: declare pointer! [integer!]
    csp1-p: as [pointer! [integer!]] 256
    i: 0
    i: as integer! csp1-p
  --assert i = 256

  --test-- "csp-2"
    csp2-p: declare pointer! [integer!]
    csp2-p: as [pointer! [integer!]] 0
  --assert false = as logic! csp2-p

  --test-- "csp-3"
    csp3-p: declare pointer! [integer!]
    csp3-p: as [pointer! [integer!]] 1
  --assert true = as logic! csp3-p

  --test-- "csp-4"
    csp4-p: declare pointer! [integer!]
    csp4-p: as [pointer! [integer!]] FFFFFFFFh
  --assert true = as logic! csp4-p

  --test-- "csp-5"
    csp5-p: declare pointer! [integer!]
    csp5-p: as [pointer! [integer!]] 7FFFFFFFh
  --assert true = as logic! csp5-p

  ;; No test for pointer! to c-string! as it would simply
  ;;  duplicate the one of c-string! to pointer!

  --test-- "csp-6"
    csp6-p: declare pointer! [integer!]
    csp6-s: declare struct! [
      a [integer!]
      b [integer!]
    ]
    csp6-s/a: 1
    csp6-s/b: 2
    csp6-p: as [pointer! [integer!]] csp6-s
  --assert csp6-p/value = 1
    csp6-p: csp6-p + 1
  --assert csp6-p/value = 2
    csp6-p: csp6-p - 1
    csp6-s: as [struct! [a [integer!] b [integer!]]] csp6-p
  --assert csp6-s/a = 1
    csp6-p: csp6-p + 1
    csp6-s: as [struct! [a [integer!] b [integer!]]] csp6-p
  --assert csp6-s/a = 2

===end-group===

===start-group=== "cast from struct!"

  ;; no test for cast to integer as it would simply
  ;;  duplicate the test from integer! to struct!

  --test-- "cfstruc-1"
    cfs1-struct: declare struct! [
      a [integer!]
      b [integer!]
    ]
    cfs1-struct: as [struct! [a [integer!] b [integer!]]] 0
  --assert false = as logic! cfs1-struct

  --test-- "cfstruc-2"
    cfs2-struct: declare struct! [
      a [integer!]
      b [integer!]
    ]
  --assert true = as logic! cfs2-struct

  ;; no test for cast to c-string! as it would simply
  ;;  duplicate the test from c-string! to struct!

  ;; no test for cast to pointer! as it would simply
  ;;  duplicate the test from pointer! to struct!

===end-group===

===start-group=== "byte-integer-cast"

  --test-- "bic-1"
    bic-a: as-byte 1
  --assert 1 = as-integer bic-a

  --test-- "bic-2"
    bic-a: as-byte 1
  --assert 65536 = ((as-integer bic-a) << 16)

  --test-- "bic-3"
    bic-a: as-byte 2
  --assert 131072 = ((as-integer bic-a) << 16)

  --test-- "bic-4"
    bic-a: #"^(01)"
  --assert 65537 = (65536 or (as-integer bic-a))

  --test-- "bic-5"
    bic-a: #"^(01)"
    bic-b: #"^(02)"
  --assert 131073 = ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-6"
    bic-a: #"^(01)"
    bic-b: #"^(02)"
  --assert 131073 = ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-7"
    bic-a: #"^(01)"
    bic-b: #"^(02)"
  --assert (as byte-ptr! 131073) = as byte-ptr! ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-8"
    bic-a: as-byte 1
    bic-b: as-byte 2
  --assert 131073 = ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-9"
    bic-a: as-byte 1
    bic-b: as-byte 2
  --assert (as byte-ptr! 131073) = as byte-ptr! ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-10"
    bic-s: declare struct! [
      bic-a [byte!]
      bic-b [byte!]
      bic-c [integer!]
      bic-d [byte!]
      bic-e [byte!]
      bic-f [integer!]
    ]
    bic-s/bic-a: as-byte 0
    bic-s/bic-b: as-byte 1
    bic-s/bic-c: 2
    bic-s/bic-d: as-byte 3
    bic-s/bic-e: as-byte 255
    bic-s/bic-f: 255
  --assert false = as-logic bic-s/bic-a
  --assert true = as-logic bic-s/bic-b
  --assert bic-s/bic-e = as-byte bic-s/bic-f
  --assert bic-s/bic-f = as-integer bic-s/bic-e

===end-group===

===start-group=== "Cast in conditional tests"
    cic-r: false
  --test-- "cic-1"
    cic-d: as-byte 0
    either as-logic cic-d [cic-r: false] [cic-r: true]
  --assert cic-r

  --test-- "cic-2"
    cic-s: declare struct! [
      a   [byte!]
      b   [byte!]
    ]
    cic-s/a: as-byte 0
    cic-s/b: as-byte 1
    either as-logic cic-s/a [cic-r: false] [cic-r: true]
  --assert cic-r

===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System datatype casting test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %cast-test.reds
	Rights:  "Copyright (C) 2011 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.reds

~~~start-file~~~ "cast"

===start-group=== "cast from byte!"

	--test-- "byte-cast-1"
	--assert 65 = as integer! #"A"

	--test-- "byte-cast-2"
	  cast-b: #"A"
	  cast-i: 65
	--assert cast-i = as integer! cast-b

	--test-- "byte-cast-3"
	--assert false = as logic! #"^(00)"

	--test-- "byte-cast-4"
    cast-b: #"^(00)"
	  l: false
	--assert l = as logic! cast-b

	--test-- "byte-cast-5"
	--assert true = as logic! #"A"

	--test-- "byte-cast-6"
	  cast-b: #"A"
	  l: true
	--assert l = as logic! cast-b

	--test-- "byte-cast-7"
	--assert true = as logic! #"^(FF)"

	--test-- "byte-cast-8"
	  cast-b: #"^(FF)"
	  l: true
	--assert l = as logic! cast-b

	--test-- "byte-cast-9"							;-- issue #158
	  a: as-byte 10h
	  b: as-byte 80h
	--assert 10h = as-integer a

	--test-- "byte-cast-10"							;-- issue #159
	  a: as-byte 10h
	  b: as-byte 80h
	  c: as-integer a
	--assert 10h = c

	--test-- "byte-cast-11"							;-- issue #160
	  a: as-byte 1
	  b: as-byte 2
	  --assert (as byte-ptr! (as-integer a) * 2) = (as byte-ptr! 2)
	  --assert (as byte-ptr! (as-integer a) << 2) = (as byte-ptr! 4)

	--test-- "byte-cast-12"							;-- issue #161
	  a: as-byte 1
	  b: as-byte 2
	  c: (as-integer b) << 16 or as-integer a
	  --assert 00020001h = c

	--test-- "byte-cast-13"							;-- issue #162
	  sb: declare struct! [
	      a   [byte!]
	      b   [byte!]
	  ]
	  sb/a: as-byte 0
	  sb/b: as-byte 1
	  --assert not as-logic sb/a

===end-group===

===start-group=== "cast from integer!"
comment {
  --test-- "int-cast-1"
  --assert #"^(00)" = as byte! 0
}
  --test-- "int-cast-2"
    i: 0
    cast-test-b: #"^(00)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-3"
  --assert #"^(01)" = as byte! 1

  --test-- "int-cast-4"
    i: 1
    cast-test-b: #"^(01)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-5"
  --assert #"^(FF)" = as byte! 255

  --test-- "int-cast-6"
    i: 255
    cast-test-b: #"^(FF)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-7"
  --assert #"^(00)" = as byte! 256

  --test-- "int-cast-8"
    i: 256
    cast-test-b: #"^(00)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-9"
  --assert false = as logic! 0

  --test-- "int-cast-10"
    i: 0
    l: false
  --assert l = as logic! i

  --test-- "int-cast-11"
  --assert true = as logic! FFFFFFFFh

  --test-- "int-cast-12"
    i: FFFFFFFFh
    l: true
  --assert l = as logic! i

  --test-- "int-cast-13"
  --assert true = as logic! 1

  --test-- "int-cast-14"
    i: 1
    l: true
  --assert l = as logic! i

  --test-- "int-cast-15"
    cs: "Hello"
    cs2: ""
    i: as integer! cs
    i: i + 1
    cs2: as c-string! i
  --assert cs2/1 = #"e"
  --assert 4 = length? cs2

  --test-- "int-cast-16"           ;; This test assumes 32-bit target
    i: 1
    p: declare pointer! [integer!]
    p: as [pointer! [integer!]] i
    P: P + 1
    i2: as integer! p
  --assert i2 = 5

  --test-- "int-cast-17"           ;; This test assumes 32-bit target
    ;; currently fails as p-int-cast is not declared
    i: 1
    p-int-cast-17: as [pointer! [integer!]] i
    P-int-cast-17: P-int-cast-17 + 1
    i2: as integer! p-int-cast-17
  --assert i2 = 5

  --test-- "int-cast-18"
    i: 1
    s: declare struct! [
      a [integer!]
      b [integer!]
    ]
    s: as [struct! [a [integer!] b [integer!]]] i
    s: s + 1
    i2: as integer! s
  --assert i2 = 9

  --test-- "int-cast-19"
    ic19-logic: either as-logic 0 [
      false
    ][
      true
    ]
  --assert ic19-logic

  --test-- "int-cast-20"
    ic20-dummy: func [return: [integer!]][0]
    ic20-logic: either as-logic ic20-dummy [
       false
    ][
      true
    ]
  --assert ic20-logic

===end-group===

===start-group=== "cast from logic!"

  --test-- "logic-cast-1"
  --assert #"^(01)" = as byte! true

  --test-- "logic-cast-2"
    cast-test-b: #"^(01)"
    l: true
  --assert cast-test-b = as byte! l

  --test-- "logic-cast-3"
  --assert #"^(00)" = as byte! false

  --test-- "logic-cast-4"
    cast-test-b: #"^(00)"
    l: false
  --assert cast-test-b = as byte! l

    --test-- "logic-cast-5"
  --assert 1 = as integer! true

  --test-- "logic-cast-6"
    i: 1
    l: true
  --assert i = as integer! l

  --test-- "logic-cast-7"
  --assert 0 = as integer! false

  --test-- "logic-cast-8"
    i: 0
    l: false
  --assert i = as integer! l

===end-group===

===start-group=== "cast c-string! tests"

  --test-- "c-string-cast-1"
    csc1-str: "Hello, Nenad"
    i: 0
    i: as integer! csc1-str
    i: i + 7
    csc1-str: as c-string! i
  --assert csc1-str/1 = #"N"
  --assert csc1-str/2 = #"e"
  --assert csc1-str/3 = #"n"
  --assert csc1-str/4 = #"a"
  --assert csc1-str/5 = #"d"
  comment {
  --test-- "c-string-cast-2"
  --assert false = as logic! ""
  }
    --test-- "c-string-cast-3"
    csc3-str: ""
  --assert true = as logic! csc3-str

  --test-- "c-string-cast-4"
  --assert true = as logic! "Any old iron, any old iron"

  --test-- "c-string-cast-5"
    csc5-str: "Why not?"
  --assert true = as logic! csc5-str

  --test-- "c-string-cast-6"
    csc6-str: "Tour de France"
    csc6-p: declare pointer! [integer!]
    csc6-p: as [pointer! [integer!]] csc6-str
    csc6-p: csc6-p + 2
    csc6-str2: as c-string! csc6-p
  --assert csc6-str2/1 = #"F"
  --assert csc6-str2/2 = #"r"
  --assert csc6-str2/3 = #"a"
  --assert csc6-str2/4 = #"n"
  --assert csc6-str2/5 = #"c"
  --assert csc6-str2/6 = #"e"

  --test-- "C-string-cast-7"
    csc7-struct: declare struct! [
      c1 [byte!]
      c2 [byte!]
      c3 [byte!]
      c4 [byte!]
      c5 [byte!]
    ]
    csc7-str: "Peter"
    csc7-struct: as [struct! [
      c1 [byte!] c2 [byte!] c3 [byte!] c4 [byte!] c5 [byte!]
    ]] csc7-str
  --assert csc7-struct/c1 = #"P"
  --assert csc7-struct/c2 = #"e"
  --assert csc7-struct/c3 = #"t"
  --assert csc7-struct/c4 = #"e"
  --assert csc7-struct/c5 = #"r"

===end-group===

===start-group=== "cast from pointer!"

  --test-- "csp-1"
    csp1-p: declare pointer! [integer!]
    csp1-p: as [pointer! [integer!]] 256
    i: 0
    i: as integer! csp1-p
  --assert i = 256

  --test-- "csp-2"
    csp2-p: declare pointer! [integer!]
    csp2-p: as [pointer! [integer!]] 0
  --assert false = as logic! csp2-p

  --test-- "csp-3"
    csp3-p: declare pointer! [integer!]
    csp3-p: as [pointer! [integer!]] 1
  --assert true = as logic! csp3-p

  --test-- "csp-4"
    csp4-p: declare pointer! [integer!]
    csp4-p: as [pointer! [integer!]] FFFFFFFFh
  --assert true = as logic! csp4-p

  --test-- "csp-5"
    csp5-p: declare pointer! [integer!]
    csp5-p: as [pointer! [integer!]] 7FFFFFFFh
  --assert true = as logic! csp5-p

  ;; No test for pointer! to c-string! as it would simply
  ;;  duplicate the one of c-string! to pointer!

  --test-- "csp-6"
    csp6-p: declare pointer! [integer!]
    csp6-s: declare struct! [
      a [integer!]
      b [integer!]
    ]
    csp6-s/a: 1
    csp6-s/b: 2
    csp6-p: as [pointer! [integer!]] csp6-s
  --assert csp6-p/value = 1
    csp6-p: csp6-p + 1
  --assert csp6-p/value = 2
    csp6-p: csp6-p - 1
    csp6-s: as [struct! [a [integer!] b [integer!]]] csp6-p
  --assert csp6-s/a = 1
    csp6-p: csp6-p + 1
    csp6-s: as [struct! [a [integer!] b [integer!]]] csp6-p
  --assert csp6-s/a = 2

===end-group===

===start-group=== "cast from struct!"

  ;; no test for cast to integer as it would simply
  ;;  duplicate the test from integer! to struct!

  --test-- "cfstruc-1"
    cfs1-struct: declare struct! [
      a [integer!]
      b [integer!]
    ]
    cfs1-struct: as [struct! [a [integer!] b [integer!]]] 0
  --assert false = as logic! cfs1-struct

  --test-- "cfstruc-2"
    cfs2-struct: declare struct! [
      a [integer!]
      b [integer!]
    ]
  --assert true = as logic! cfs2-struct

  ;; no test for cast to c-string! as it would simply
  ;;  duplicate the test from c-string! to struct!

  ;; no test for cast to pointer! as it would simply
  ;;  duplicate the test from pointer! to struct!

===end-group===

===start-group=== "byte-integer-cast"

  --test-- "bic-1"
    bic-a: as-byte 1
  --assert 1 = as-integer bic-a

  --test-- "bic-2"
    bic-a: as-byte 1
  --assert 65536 = ((as-integer bic-a) << 16)

  --test-- "bic-3"
    bic-a: as-byte 2
  --assert 131072 = ((as-integer bic-a) << 16)

  --test-- "bic-4"
    bic-a: #"^(01)"
  --assert 65537 = (65536 or (as-integer bic-a))

  --test-- "bic-5"
    bic-a: #"^(01)"
    bic-b: #"^(02)"
  --assert 131073 = ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-6"
    bic-a: #"^(01)"
    bic-b: #"^(02)"
  --assert 131073 = ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-7"
    bic-a: #"^(01)"
    bic-b: #"^(02)"
  --assert (as byte-ptr! 131073) = as byte-ptr! ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-8"
    bic-a: as-byte 1
    bic-b: as-byte 2
  --assert 131073 = ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-9"
    bic-a: as-byte 1
    bic-b: as-byte 2
  --assert (as byte-ptr! 131073) = as byte-ptr! ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-10"
    bic-s: declare struct! [
      bic-a [byte!]
      bic-b [byte!]
      bic-c [integer!]
      bic-d [byte!]
      bic-e [byte!]
      bic-f [integer!]
    ]
    bic-s/bic-a: as-byte 0
    bic-s/bic-b: as-byte 1
    bic-s/bic-c: 2
    bic-s/bic-d: as-byte 3
    bic-s/bic-e: as-byte 255
    bic-s/bic-f: 255
  --assert false = as-logic bic-s/bic-a
  --assert true = as-logic bic-s/bic-b
  --assert bic-s/bic-e = as-byte bic-s/bic-f
  --assert bic-s/bic-f = as-integer bic-s/bic-e

===end-group===

===start-group=== "Cast in conditional tests"
    cic-r: false
  --test-- "cic-1"
    cic-d: as-byte 0
    either as-logic cic-d [cic-r: false] [cic-r: true]
  --assert cic-r

  --test-- "cic-2"
    cic-s: declare struct! [
      a   [byte!]
      b   [byte!]
    ]
    cic-s/a: as-byte 0
    cic-s/b: as-byte 1
    either as-logic cic-s/a [cic-r: false] [cic-r: true]
  --assert cic-r

===end-group===

~~~end-file~~~


TESTS: corrected test funfun5 in function-test.red

Red [
	Title:   "Red function test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %function-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~~~ "function"

===start-group=== "Basic function tests"

	--test-- "fun-1"
		foo1: func [][1]
		--assert 1 = foo1

	--test-- "fun-2"
		foo2: func [a][a]
		--assert 5 = foo2 5
		--assert "a" = foo2 "a"
		--assert [123] = foo2 [123]

	--test-- "fun-3"
		foo3: func [a /local c][c: 1 a + c]
		--assert 3 = foo3 2

	--test-- "fun-4"
		foo4: func [a /ref][either ref [a][0]]
		--assert 0 = foo4 5
		--assert 5 = foo4/ref 5

	--test-- "fun-5"
		foo5: func [a /ref b][if ref [a: a + b] a * 2]
		--assert 10 = foo5 5
		--assert 16 = foo5/ref 5 3

	--test-- "fun-6"
		z: 10
		foo6: func [a [integer!] b [integer!] /ref d /local c][
			c: 2
			unless ref [d: 0]
			a + b * c + z + d
		]

		--assert 16 = foo6 1 2
		--assert 21 = foo6/ref 1 2 5

	--test-- "fun-7"
		bar:  func [] [foo7]
		foo7: func [] [42]
		--assert 42 = bar

	--test-- "fun-8"
		foo8: func ['a :b][
			--assert a = 'test
			--assert "(1 + 2)" = mold b
		]
		foo8 test (1 + 2)

	--test-- "fun-9"
		foo9: func [/local cnt][
			cnt: [0]
			cnt/1: cnt/1 + 1
		]
		--assert 1 = foo9
		--assert 2 = foo9
		--assert 3 = foo9

	--test-- "fun-10"
		foo10: func [a][a + 0]
		foo10: func [][1]
		--assert 1 = foo10 "dummy"						;-- make it crash if wrong function referenced

	--test-- "fun-11"
		non-evaluated: func ['param] [param]
		res: first [(1 + 2)]
		--assert quote (1 + 2) = res
		--assert non-evaluated (quote (1 + 2)) = res
		--assert non-evaluated quote (1 + 2) = 3

===end-group===

===start-group=== "Alternate constructor tests"

	--test-- "fun-alt-1"
		z: 0
		alt1: function [a][
			z: 2
			a + z
		]
		--assert 10 = alt1 8
		--assert z = 0

	--test-- "fun-alt-2"
		alt2: does [123]
		--assert 123 = alt2

	--test-- "fun-alt-3"
		alt3: has [c][c: 1 c]
		--assert 1 = alt3

===end-group===

===start-group=== "Exit and Return tests"

	--test-- "fun-exit-1"
		ex1: does [123 exit 0]
		--assert unset! = type? ex1

	--test-- "fun-exit-2"
		ex2: does [if true [exit] 0]
		--assert unset! = type? ex2

	--test-- "fun-exit-3"
		ex3: does [until [if true [if true [exit]] true] 0]
		--assert unset! = type? ex3

	--test-- "fun-ret-1"
		ret1: does [return true]
		--assert ret1

	--test-- "fun-ret-2"
		ret2: does [return 123]
		--assert 123 = ret2

	--test-- "fun-ret-3"
		ret3: does [if true [return 3]]
		--assert 3 = ret3

	--test-- "fun-ret-4"
		ret4: does [return 1 + 1]
		--assert 2 = ret4

	--test-- "fun-ret-5"
		ret5: does [return either false [12][34]]
		--assert 34 = ret5

	--test-- "fun-ret-6"								;-- issue #770
		ret6: func [i [integer!]][
			until [
				if true [
					if i = 0 [
						if true [return 0]
						return 1
					]
					return 2
				]
				return 3
				true
			]
		]
		--assert 0 = ret6 0
		--assert 2 = ret6 1

	--test-- "fun-ret-7"
		f: function [][
			blk: [1 2 3 4 5]
			foreach i blk [
				case [
					i > 1 [return i]
				]
			]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-8"
		f: function [][
		    case [
		        2 > 1 [return true]
		    ]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-9"
		f: function [][if true [return true]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		g: function [][if true [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		f: function [][true]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-11"
		f: function [][if true [return true]]
		g: function [][if (f) [return 1]]
		--assert g = 1

	--test-- "fun-ret-12"
		f: function [][if true [return true] ]
		g: function [][if not not f [return 1]]
		--assert g = 1

	--test-- "fun-ret-13"
		f: function [][if true [return 'X]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-14"								;-- issue #778
	 	--assert 1 = do load "f: func [][return 1] t: f"

===end-group===

===start-group=== "Reflection"
	clean-strings: func [blk [block!]][
		blk: copy blk
		forall blk [if string? blk/1 [remove blk blk: back blk]]
		blk
	]

	--test-- "fun-ref-1"
		ref1: func [a b][a + b]
		--assert [a b] = spec-of :ref1
		body: body-of :ref1
		--assert any [
			[a + b] = body
			none? body									;-- if option store-bodies = no
		]

	--test-- "fun-ref-2"
		blk: clean-strings spec-of :append
		--assert blk = [
			series [series!] value [any-type!] /part length [number! series!]
			/only /dup count [number!] return: [series!]
		]

	--test-- "fun-ref-3"
		blk: clean-strings spec-of :set
		--assert blk = [word [any-word! block!] value [any-type!] /any return: [any-type!]]

	--test-- "fun-ref-4"
		blk: clean-strings spec-of :<
		--assert blk = [value1 [any-type!] value2 [any-type!]]

===end-group===

===start-group=== "Capturing of iterators counter word(s)"

	--test-- "fun-capt-1"
		f1: function [] [repeat ii 5 [ii]]
		--assert none <> find spec-of :f1 'ii
		f1
		--assert unset? get/any 'ii

	--test-- "fun-capt-2"
		f2: function [] [foreach ii [1 2 3] [ii]]
		--assert none <> find spec-of :f2 'ii
		f2
		--assert unset? get/any 'ii

	--test-- "fun-capt-3"
		f3: function [] [foreach [ii jj] [1 2 3 4] [ii jj]]
		--assert none <> find spec-of :f3 'ii
		--assert none <> find spec-of :f3 'jj
		f3
		--assert unset? get/any 'ii
		--assert unset? get/any 'jj

===end-group===

===start-group=== "Reported issues"
  	--test-- "ri1 issue #415"
    	i415-f: func [] [
    		g: func [] [1]
    		g
    	]
    --assert 1 = i415-f

  	--test-- "ri2 issue #461"
  		ri2-fn: func ['word] [:word]
  	--assert op? ri2-fn :+

  	--test-- "ri3 issue #461"
  		ri3-fn: func ['word] [mold :word]
  	--assert "'+" = ri3-fn '+

  	--test-- "ri4 issue #461"
  		ri4-fn: func ['word] [mold :word]
  	--assert "+" = ri4-fn +

  	;--test-- "ri5 issue #420"
  	;	ri5-fn: function [][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri5-fn

  	;--test-- "ri6 issue #420"
  	;	ri6-fn: func [
  	;		/local
  	;			g
  	;	][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri6-fn

  	;--test-- "ri7 issue #420"
  	;	ri7-g: func [][true]
  	;	ri7-f: func [][g]
  	;--assert ri7-f

  	--test-- "ri8 issue #443"
  		ri8-fn: func[
  			/local
  				ri8-b
  				ri8-i
  				ri8-j
  		][
  			ri8-b: copy []
  			foreach [ri8-i ri8-j] [1 2 3 4] [append ri8-b ri8-i * ri8-j]
  			ri8-b
  		]
  		ri8-i: 100
  		ri8-j: 200
  	--assert [2 12] = ri8-fn
  	--assert 100 = ri8-i
  	--assert 200 = ri8-j

  	--test-- "ri9 issue #443"
  		ri9-i: -1
  		ri9-j: -2
  		ri9-fn: function[][
  			ri9-b: copy []
  			foreach [ri9-i ri9-j] [1 2 3 4] [append ri9-b ri9-i * ri9-j]
  			ri9-b
  		]
  	--assert [2 12] = ri9-fn
  	--assert ri9-i = -1
  	--assert ri9-j = -2
  	;--assert unset! = type? get 'ri9-i		;-- temporary disabled to avoid the hardcoded error msg
  	;--assert unset! = type? get 'ri9-j

===end-group===

===start-group=== "Infix operators creation"

	--test-- "infix-1"
		infix: function [a b][a * 10 + b]
		***: make op! :infix
		--assert 7 *** 3 = 73

		infix2: routine [a [integer!] b [integer!]][integer/box a * 20 + b]

	unless system/interpreted? [			;-- routine creation not supported by interpreter
		--test-- "infix-2"
				*+*: make op! :infix2
			--assert 5 *+* 6 = 106

		--test-- "infix-3"
			--assert 5 *+* 6 *** 7 = 1067
	]

===end-group===

===start-group=== "Scope of Varibles"

	--test-- "scope1 issue #825"
		s1-text: "abcde"
		s1-f: function [/extern s1-text] [
			s1-text
		]
		--assert s1-f = "abcde"

	--test-- "scope2 issue #825"
		s2-f: function [/extern s2-text] [
			s2-text
		]
		s2-text: "abcde"
		--assert s2-f = "abcde"

	--test-- "scope3 issue #825"
		s3-text: "abcde"
		s3-f: func [/local s3-text] [
			s3-text: "12345"
		]

	--test-- "scope4 issue #825"
		s4-text: "abcde"
		s4-f: function [extern s4-text] [
			if extern [s4-text: "12345"]
			s4-text
		]
		--assert "12345" = s4-f true "00000"

	--test-- "scope5 issue #825"
		s5-text: "abcde"
		s5-f: func[/extern s5-text] [
			either extern [
				s5-text
			][
				"00000"
			]
		]
		--assert "12345" s5-f/extern "12345"

	--test-- "scope6 issue #825"
		s6-text: "abcde"
		s6-f: func [local s6-text] [
			s6-text
		]
		--assert "12345" = s6-f "filler" "12345"

	--test-- "scope7 issue #825"
		s7-text: "abcde"
		s7-f: function [local s7-text] [
			s7-text
		]
		--assert "12345" = s7-f "filler" "12345"

===end-group===

===start-group=== "functionfunction"
comment {                                       ####################################
    --test-- "funfun1"
        ff1-i: 1
        ff1-f: function [][ff1-i: 2 f: func[][ff1-i] f]
        --assert 2 = ff1-f
                                                #################################### }

    --test-- "funfun2"
        ff2-i: 1
        ff2-f: function [][ff2-i: 2 ff2-i]
        ff2-r: ff2-f
        --assert 1 = ff2-i
        --assert 2 = ff2-r

    --test-- "funfun3"
        ff3-i: 1
        ff3-f: function [][
            ff3-i: 2
            o: make object! [
                ff3-i: 3
            ]
            o/ff3-i
        ]
        --assert 3 = ff3-f

    --test-- "funfun4"
        ff4-i: 1
        ff4-f: function [][
            ff4-i: 2
            o: make object! [
                ff4-i: 3
            ]
            ff4-i
        ]
        --assert 2 = ff4-f

    --test-- "funfun5 #964"
        ff5-f: function [] [
            ff5-x: 1
            either true [
                ff5-x
             ][
                ff5-x: 0
            ]
        ]
        --assert 1 = ff5-f

    --test-- "funfun6 #964"
        ff6-f: function [] [
            ff6-x: 1
            either false [
                ff6-x
             ][
                ff6-x: 0
            ]
        ]
        --assert 0 = ff6-f

===end-group===

~~~end-file~~~

Red [
	Title:   "Red function test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %function-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~~~ "function"

===start-group=== "Basic function tests"

	--test-- "fun-1"
		foo1: func [][1]
		--assert 1 = foo1

	--test-- "fun-2"
		foo2: func [a][a]
		--assert 5 = foo2 5
		--assert "a" = foo2 "a"
		--assert [123] = foo2 [123]

	--test-- "fun-3"
		foo3: func [a /local c][c: 1 a + c]
		--assert 3 = foo3 2

	--test-- "fun-4"
		foo4: func [a /ref][either ref [a][0]]
		--assert 0 = foo4 5
		--assert 5 = foo4/ref 5

	--test-- "fun-5"
		foo5: func [a /ref b][if ref [a: a + b] a * 2]
		--assert 10 = foo5 5
		--assert 16 = foo5/ref 5 3

	--test-- "fun-6"
		z: 10
		foo6: func [a [integer!] b [integer!] /ref d /local c][
			c: 2
			unless ref [d: 0]
			a + b * c + z + d
		]

		--assert 16 = foo6 1 2
		--assert 21 = foo6/ref 1 2 5

	--test-- "fun-7"
		bar:  func [] [foo7]
		foo7: func [] [42]
		--assert 42 = bar

	--test-- "fun-8"
		foo8: func ['a :b][
			--assert a = 'test
			--assert "(1 + 2)" = mold b
		]
		foo8 test (1 + 2)

	--test-- "fun-9"
		foo9: func [/local cnt][
			cnt: [0]
			cnt/1: cnt/1 + 1
		]
		--assert 1 = foo9
		--assert 2 = foo9
		--assert 3 = foo9

	--test-- "fun-10"
		foo10: func [a][a + 0]
		foo10: func [][1]
		--assert 1 = foo10 "dummy"						;-- make it crash if wrong function referenced

	--test-- "fun-11"
		non-evaluated: func ['param] [param]
		res: first [(1 + 2)]
		--assert quote (1 + 2) = res
		--assert non-evaluated (quote (1 + 2)) = res
		--assert non-evaluated quote (1 + 2) = 3

===end-group===

===start-group=== "Alternate constructor tests"

	--test-- "fun-alt-1"
		z: 0
		alt1: function [a][
			z: 2
			a + z
		]
		--assert 10 = alt1 8
		--assert z = 0

	--test-- "fun-alt-2"
		alt2: does [123]
		--assert 123 = alt2

	--test-- "fun-alt-3"
		alt3: has [c][c: 1 c]
		--assert 1 = alt3

===end-group===

===start-group=== "Exit and Return tests"

	--test-- "fun-exit-1"
		ex1: does [123 exit 0]
		--assert unset! = type? ex1

	--test-- "fun-exit-2"
		ex2: does [if true [exit] 0]
		--assert unset! = type? ex2

	--test-- "fun-exit-3"
		ex3: does [until [if true [if true [exit]] true] 0]
		--assert unset! = type? ex3

	--test-- "fun-ret-1"
		ret1: does [return true]
		--assert ret1

	--test-- "fun-ret-2"
		ret2: does [return 123]
		--assert 123 = ret2

	--test-- "fun-ret-3"
		ret3: does [if true [return 3]]
		--assert 3 = ret3

	--test-- "fun-ret-4"
		ret4: does [return 1 + 1]
		--assert 2 = ret4

	--test-- "fun-ret-5"
		ret5: does [return either false [12][34]]
		--assert 34 = ret5

	--test-- "fun-ret-6"								;-- issue #770
		ret6: func [i [integer!]][
			until [
				if true [
					if i = 0 [
						if true [return 0]
						return 1
					]
					return 2
				]
				return 3
				true
			]
		]
		--assert 0 = ret6 0
		--assert 2 = ret6 1

	--test-- "fun-ret-7"
		f: function [][
			blk: [1 2 3 4 5]
			foreach i blk [
				case [
					i > 1 [return i]
				]
			]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-8"
		f: function [][
		    case [
		        2 > 1 [return true]
		    ]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-9"
		f: function [][if true [return true]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		g: function [][if true [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		f: function [][true]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-11"
		f: function [][if true [return true]]
		g: function [][if (f) [return 1]]
		--assert g = 1

	--test-- "fun-ret-12"
		f: function [][if true [return true] ]
		g: function [][if not not f [return 1]]
		--assert g = 1

	--test-- "fun-ret-13"
		f: function [][if true [return 'X]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-14"								;-- issue #778
	 	--assert 1 = do load "f: func [][return 1] t: f"

===end-group===

===start-group=== "Reflection"
	clean-strings: func [blk [block!]][
		blk: copy blk
		forall blk [if string? blk/1 [remove blk blk: back blk]]
		blk
	]

	--test-- "fun-ref-1"
		ref1: func [a b][a + b]
		--assert [a b] = spec-of :ref1
		body: body-of :ref1
		--assert any [
			[a + b] = body
			none? body									;-- if option store-bodies = no
		]

	--test-- "fun-ref-2"
		blk: clean-strings spec-of :append
		--assert blk = [
			series [series!] value [any-type!] /part length [number! series!]
			/only /dup count [number!] return: [series!]
		]

	--test-- "fun-ref-3"
		blk: clean-strings spec-of :set
		--assert blk = [word [any-word! block!] value [any-type!] /any return: [any-type!]]

	--test-- "fun-ref-4"
		blk: clean-strings spec-of :<
		--assert blk = [value1 [any-type!] value2 [any-type!]]

===end-group===

===start-group=== "Capturing of iterators counter word(s)"

	--test-- "fun-capt-1"
		f1: function [] [repeat ii 5 [ii]]
		--assert none <> find spec-of :f1 'ii
		f1
		--assert unset? get/any 'ii

	--test-- "fun-capt-2"
		f2: function [] [foreach ii [1 2 3] [ii]]
		--assert none <> find spec-of :f2 'ii
		f2
		--assert unset? get/any 'ii

	--test-- "fun-capt-3"
		f3: function [] [foreach [ii jj] [1 2 3 4] [ii jj]]
		--assert none <> find spec-of :f3 'ii
		--assert none <> find spec-of :f3 'jj
		f3
		--assert unset? get/any 'ii
		--assert unset? get/any 'jj

===end-group===

===start-group=== "Reported issues"
  	--test-- "ri1 issue #415"
    	i415-f: func [] [
    		g: func [] [1]
    		g
    	]
    --assert 1 = i415-f

  	--test-- "ri2 issue #461"
  		ri2-fn: func ['word] [:word]
  	--assert op? ri2-fn :+

  	--test-- "ri3 issue #461"
  		ri3-fn: func ['word] [mold :word]
  	--assert "'+" = ri3-fn '+

  	--test-- "ri4 issue #461"
  		ri4-fn: func ['word] [mold :word]
  	--assert "+" = ri4-fn +

  	;--test-- "ri5 issue #420"
  	;	ri5-fn: function [][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri5-fn

  	;--test-- "ri6 issue #420"
  	;	ri6-fn: func [
  	;		/local
  	;			g
  	;	][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri6-fn

  	;--test-- "ri7 issue #420"
  	;	ri7-g: func [][true]
  	;	ri7-f: func [][g]
  	;--assert ri7-f

  	--test-- "ri8 issue #443"
  		ri8-fn: func[
  			/local
  				ri8-b
  				ri8-i
  				ri8-j
  		][
  			ri8-b: copy []
  			foreach [ri8-i ri8-j] [1 2 3 4] [append ri8-b ri8-i * ri8-j]
  			ri8-b
  		]
  		ri8-i: 100
  		ri8-j: 200
  	--assert [2 12] = ri8-fn
  	--assert 100 = ri8-i
  	--assert 200 = ri8-j

  	--test-- "ri9 issue #443"
  		ri9-i: -1
  		ri9-j: -2
  		ri9-fn: function[][
  			ri9-b: copy []
  			foreach [ri9-i ri9-j] [1 2 3 4] [append ri9-b ri9-i * ri9-j]
  			ri9-b
  		]
  	--assert [2 12] = ri9-fn
  	--assert ri9-i = -1
  	--assert ri9-j = -2
  	;--assert unset! = type? get 'ri9-i		;-- temporary disabled to avoid the hardcoded error msg
  	;--assert unset! = type? get 'ri9-j

===end-group===

===start-group=== "Infix operators creation"

	--test-- "infix-1"
		infix: function [a b][a * 10 + b]
		***: make op! :infix
		--assert 7 *** 3 = 73

		infix2: routine [a [integer!] b [integer!]][integer/box a * 20 + b]

	unless system/interpreted? [			;-- routine creation not supported by interpreter
		--test-- "infix-2"
				*+*: make op! :infix2
			--assert 5 *+* 6 = 106

		--test-- "infix-3"
			--assert 5 *+* 6 *** 7 = 1067
	]

===end-group===

===start-group=== "Scope of Varibles"

	--test-- "scope1 issue #825"
		s1-text: "abcde"
		s1-f: function [/extern s1-text] [
			s1-text
		]
		--assert s1-f = "abcde"

	--test-- "scope2 issue #825"
		s2-f: function [/extern s2-text] [
			s2-text
		]
		s2-text: "abcde"
		--assert s2-f = "abcde"

	--test-- "scope3 issue #825"
		s3-text: "abcde"
		s3-f: func [/local s3-text] [
			s3-text: "12345"
		]

	--test-- "scope4 issue #825"
		s4-text: "abcde"
		s4-f: function [extern s4-text] [
			if extern [s4-text: "12345"]
			s4-text
		]
		--assert "12345" = s4-f true "00000"

	--test-- "scope5 issue #825"
		s5-text: "abcde"
		s5-f: func[/extern s5-text] [
			either extern [
				s5-text
			][
				"00000"
			]
		]
		--assert "12345" s5-f/extern "12345"

	--test-- "scope6 issue #825"
		s6-text: "abcde"
		s6-f: func [local s6-text] [
			s6-text
		]
		--assert "12345" = s6-f "filler" "12345"

	--test-- "scope7 issue #825"
		s7-text: "abcde"
		s7-f: function [local s7-text] [
			s7-text
		]
		--assert "12345" = s7-f "filler" "12345"

===end-group===

===start-group=== "functionfunction"
comment {                                       ####################################
    --test-- "funfun1"
        ff1-i: 1
        ff1-f: function [][ff1-i: 2 f: func[][ff1-i] f]
        --assert 2 = ff1-f
                                                #################################### }

    --test-- "funfun2"
        ff2-i: 1
        ff2-f: function [][ff2-i: 2 ff2-i]
        ff2-r: ff2-f
        --assert 1 = ff2-i
        --assert 2 = ff2-r

    --test-- "funfun3"
        ff3-i: 1
        ff3-f: function [][
            ff3-i: 2
            o: make object! [
                ff3-i: 3
            ]
            o/ff3-i
        ]
        --assert 3 = ff3-f

    --test-- "funfun4"
        ff4-i: 1
        ff4-f: function [][
            ff4-i: 2
            o: make object! [
                ff4-i: 3
            ]
            ff4-i
        ]
        --assert 2 = ff4-f
 comment {                                      ###################################
    --test-- "funfun5 #964"
        ff5-f: function [] [
            either true [
                x
             ][
                x: 0
            ]
        ]
        --assert none = ff5-f
                                                ################################### }

===end-group===

~~~end-file~~~


TESTS: updated tests to match new alloc-series specification.

Red/System [
	Title:   "Red memory allocator tests"
	Author:  "Nenad Rakocevic"
	File: 	 %allocator-tests.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt"
]

#include %../runtime/runtime.reds
#include %../runtime/debug.reds

;-- add a minimal number of memory frames
alloc-node-frame nodes-per-frame
alloc-series-frame

print [lf ">> allocating 3 series" lf]
s1: alloc-series 5 1
s2: alloc-series 100 1
s3: alloc-series 5 1

memory-stats 3

dump-series-frame memory/s-active

print [lf ">> freeing 2nd series" lf]
free-series memory/s-head s2
dump-series-frame memory/s-active

print [lf ">> compacting frame" lf]
compact-series-frame memory/s-active
dump-series-frame memory/s-active

memory-stats 3

print [lf ">> allocating 25 series" lf]

array: as int-ptr! allocate 25 * size? pointer!
c: 50
alt?: no
series: as int-ptr! 0
idx: 1
until [
	series: alloc-series either alt? [5][100] 1
	unless alt? [
		array/idx: as-integer series
		print-wide [idx ":" as byte-ptr! array/idx lf]
		idx: idx + 1
	]
	alt?: not alt?
	c: c - 1
	zero? c
]
dump-series-frame memory/s-active

memory-stats 3

print [lf ">> freeing all new short series" lf]
idx: 26
until [
	idx: idx - 1
	print-wide [idx ":" as byte-ptr! array/idx lf]
	free-series memory/s-head as int-ptr! array/idx
	idx = 1
]

print [lf ">> compacting frame" lf]
compact-series-frame memory/s-active
dump-series-frame memory/s-active

memory-stats 3

free as byte-ptr! array
free-all

Red/System [
	Title:   "Red memory allocator tests"
	Author:  "Nenad Rakocevic"
	File: 	 %allocator-tests.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt"
]

#include %../runtime/runtime.reds

;-- add a minimal number of memory frames
alloc-node-frame nodes-per-frame
alloc-series-frame

print [lf ">> allocating 3 series" lf]
s1: alloc-series 5
s2: alloc-series 100
s3: alloc-series 5

memory-stats 3

dump-series-frame memory/s-active

print [lf ">> freeing 2nd series" lf]
free-series memory/s-head s2
dump-series-frame memory/s-active

print [lf ">> compacting frame" lf]
compact-series-frame memory/s-active
dump-series-frame memory/s-active

memory-stats 3

print [lf ">> allocating 25 series" lf]

array: as int-ptr! allocate 25 * size? pointer!
c: 50
alt?: no
series: as int-ptr! 0
idx: 1
until [
	series: alloc-series either alt? [5][100]
	unless alt? [
		array/idx: as-integer series
		print-wide [idx ":" as byte-ptr! array/idx lf]
		idx: idx + 1
	]
	alt?: not alt?
	c: c - 1
	zero? c
]
dump-series-frame memory/s-active

memory-stats 3

print [lf ">> freeing all new short series" lf]
idx: 26
until [
	idx: idx - 1
	print-wide [idx ":" as byte-ptr! array/idx lf]
	free-series memory/s-head as int-ptr! array/idx
	idx = 1
]

print [lf ">> compacting frame" lf]
compact-series-frame memory/s-active
dump-series-frame memory/s-active

memory-stats 3

free as byte-ptr! array
free-all