FIX: issue #1003 (on-change* not called on copied objects)

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

object: context [
	verbose: 0

	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
		][
			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!]
			s	  [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		ctx: GET_CTX(obj)

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

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

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

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

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

		serialize obj buffer no no no arg part no 0
	]

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

		string/concatenate-literal buffer "make object! ["
		part: serialize obj buffer only? all? flat? arg part - 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:	[logic!]
		/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	   [logic!]
	][
		#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 [
			switch op [
				COMP_EQUAL
				COMP_STRICT_EQUAL  [res: false]
				COMP_NOT_EQUAL 	   [res: true]
				COMP_LESSER
				COMP_LESSER_EQUAL  [res: diff > 0]
				COMP_GREATER
				COMP_GREATER_EQUAL [res: diff < 0]
			]
			return res
		]
		if zero? (as-integer tail - sym1) [			;-- empty objects case
			switch op [
				COMP_EQUAL
				COMP_STRICT_EQUAL
				COMP_LESSER_EQUAL
				COMP_GREATER_EQUAL [res: true]
				COMP_NOT_EQUAL 	   [res: false]
				default 		   [res: false]
			]
			return res
		]

		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 [
				switch op [
					COMP_EQUAL
					COMP_STRICT_EQUAL  [res: false]
					COMP_NOT_EQUAL 	   [res: true]
					COMP_LESSER
					COMP_LESSER_EQUAL  [res: s1 < s2]
					COMP_GREATER
					COMP_GREATER_EQUAL [res: s1 > s2]
				]
				return res
			]
			type1: TYPE_OF(value1)
			type2: TYPE_OF(value2)
			either any [
				type1 = type2
				all [word/any-word? type1 word/any-word? type2]
				all [type1 = TYPE_INTEGER type2 = TYPE_INTEGER]	 ;@@ replace by ANY_NUMBER?
			][
				res: actions/compare value1 value2 op
				sym1: sym1 + 1
				sym2: sym2 + 2
				value1: value1 + 1
				value2: value2 + 1
			][
				switch op [
					COMP_EQUAL
					COMP_STRICT_EQUAL	[res: false]
					COMP_NOT_EQUAL 		[res: true]
					COMP_LESSER_EQUAL	[res: type1 <= type2]
					COMP_GREATER_EQUAL	[res: type1 >= type2]
				]
				return res
			]
			any [
				not res
				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
		][
			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!]
			s	  [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		ctx: GET_CTX(obj)

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

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

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

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

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

		serialize obj buffer no no no arg part no 0
	]

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

		string/concatenate-literal buffer "make object! ["
		part: serialize obj buffer only? all? flat? arg part - 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:	[logic!]
		/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	   [logic!]
	][
		#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 [
			switch op [
				COMP_EQUAL
				COMP_STRICT_EQUAL  [res: false]
				COMP_NOT_EQUAL 	   [res: true]
				COMP_LESSER
				COMP_LESSER_EQUAL  [res: diff > 0]
				COMP_GREATER
				COMP_GREATER_EQUAL [res: diff < 0]
			]
			return res
		]
		if zero? (as-integer tail - sym1) [			;-- empty objects case
			switch op [
				COMP_EQUAL
				COMP_STRICT_EQUAL
				COMP_LESSER_EQUAL
				COMP_GREATER_EQUAL [res: true]
				COMP_NOT_EQUAL 	   [res: false]
				default 		   [res: false]
			]
			return res
		]

		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 [
				switch op [
					COMP_EQUAL
					COMP_STRICT_EQUAL  [res: false]
					COMP_NOT_EQUAL 	   [res: true]
					COMP_LESSER
					COMP_LESSER_EQUAL  [res: s1 < s2]
					COMP_GREATER
					COMP_GREATER_EQUAL [res: s1 > s2]
				]
				return res
			]
			type1: TYPE_OF(value1)
			type2: TYPE_OF(value2)
			either any [
				type1 = type2
				all [word/any-word? type1 word/any-word? type2]
				all [type1 = TYPE_INTEGER type2 = TYPE_INTEGER]	 ;@@ replace by ANY_NUMBER?
			][
				res: actions/compare value1 value2 op
				sym1: sym1 + 1
				sym2: sym2 + 2
				value1: value1 + 1
				value2: value2 + 1
			][
				switch op [
					COMP_EQUAL
					COMP_STRICT_EQUAL	[res: false]
					COMP_NOT_EQUAL 		[res: true]
					COMP_LESSER_EQUAL	[res: type1 <= type2]
					COMP_GREATER_EQUAL	[res: type1 >= type2]
				]
				return res
			]
			any [
				not res
				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

		new: make-at new slots
		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: test re issue #468

TESTS: test re issue #468

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

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

~~~start-file~~~ "routine"

===start-group=== "routine return tests"

	--test-- "rr1"
		rr1-r: routine [
			return:		[integer!]
		][
			1
		]
	--assert 1 = rr1-r

	--test-- "rr4"
		rr4-r: routine [
			return:			[logic!]
		][
			true
		]
	--assert rr4-r

===end-group===

===start-group=== "routine yo-yo tests"

	--test-- "ry1"
		ry1-r: routine [
			i			[integer!]
			return:		[integer!]
		][
			i
		]
	--assert 1 = ry1-r 1

	--test-- "ry4"
		ry4-r: routine [
			l				[logic!]
			return:			[logic!]
		][
			l
		]
	--assert ry4-r true
	--assert not ry4-r false

===end-group===

===start-group=== "routine return local tests"

	--test-- "rrl1"
		rrl1-r: routine [
			return:		[integer!]
			/local
			i			[integer!]
		][
			i: 1
			i
		]
	--assert 1 = rrl1-r

	--test-- "rrl4"
		rrl4-r: routine [
			return:			[logic!]
			/local
			l				[logic!]
		][
			l: true
			l
		]
	--assert rrl4-r true

===end-group===

===start-group=== "routine simple tests"

	--test-- "rs1"
		rs1-r: routine [
			i			[integer!]
			return:		[integer!]
		][
			i + 1
		]
	--assert 2 = rs1-r 1

	--test-- "rs4"
		rs4-r: routine [
			l				[logic!]
			return:			[logic!]
		][
			not l
		]
	--assert rs4-r false
	--assert not rs4-r true

===end-group===

===start-group=== "routine reported issues"

	--test-- "rri1 - issue #468"
		rri1-r: routine [
			return:			[integer!]
			/local
				b			[byte!]
				cp          [integer!]
		][
			cp: 1
			b: as byte! (cp >>> 6)
			cp: as integer! b
			cp
		]
	--assert 0 = rri1-r

===end-group===

~~~end-file~~~

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

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

~~~start-file~~~ "routine"

===start-group=== "routine return tests"

	--test-- "rr1"
		rr1-r: routine [
			return:		[integer!]
		][
			1
		]
	--assert 1 = rr1-r

	--test-- "rr4"
		rr4-r: routine [
			return:			[logic!]
		][
			true
		]
	--assert rr4-r

===end-group===

===start-group=== "routine yo-yo tests"

	--test-- "ry1"
		ry1-r: routine [
			i			[integer!]
			return:		[integer!]
		][
			i
		]
	--assert 1 = ry1-r 1

	--test-- "ry4"
		ry4-r: routine [
			l				[logic!]
			return:			[logic!]
		][
			l
		]
	--assert ry4-r true
	--assert not ry4-r false

===end-group===

===start-group=== "routine return local tests"

	--test-- "rrl1"
		rrl1-r: routine [
			return:		[integer!]
			/local
			i			[integer!]
		][
			i: 1
			i
		]
	--assert 1 = rrl1-r

	--test-- "rrl4"
		rrl4-r: routine [
			return:			[logic!]
			/local
			l				[logic!]
		][
			l: true
			l
		]
	--assert rrl4-r true

===end-group===

===start-group=== "routine simple tests"

	--test-- "rs1"
		rs1-r: routine [
			i			[integer!]
			return:		[integer!]
		][
			i + 1
		]
	--assert 2 = rs1-r 1

	--test-- "rs4"
		rs4-r: routine [
			l				[logic!]
			return:			[logic!]
		][
			not l
		]
	--assert rs4-r false
	--assert not rs4-r true

===end-group===

~~~end-file~~~


TESTS: added tests re issue #420

TESTS: added tests re issue #420

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

===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"
		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

===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
		--assert [a + b] = body-of :ref1

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

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

===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"
		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

===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
		--assert [a + b] = body-of :ref1

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

===end-group===

~~~end-file~~~


FIX: issues #1115 and #1122 (unix console not handling ESC properly).

Red/System [
	Title:	"INPUT POSIX API imported functions and structures definitions"
	Author: "Nenad Rakocevic, Xie Qingtian"
	File: 	%POSIX.reds
	Tabs: 	4
	Rights: "Copyright (C) 2014 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
	Notes: {
		Freely inspired by linenoise fork from msteveb:
		https://github.com/msteveb/linenoise/blob/master/linenoise.c
	}
]

#define OS_POLLIN 		1

#case [
	any [OS = 'MacOSX OS = 'FreeBSD] [
		#define TIOCGWINSZ		40087468h
		#define TERM_TCSADRAIN	1
		#define TERM_VTIME		18
		#define TERM_VMIN		17

		#define TERM_BRKINT		02h
		#define TERM_INPCK		10h
		#define TERM_ISTRIP		20h
		#define TERM_ICRNL		0100h
		#define TERM_IXON		0200h
		#define TERM_OPOST		01h
		#define TERM_CS8		0300h
		#define TERM_ISIG		80h
		#define TERM_ICANON		0100h
		#define TERM_ECHO		08h
		#define TERM_IEXTEN		4000h

		termios!: alias struct! [
			c_iflag			[integer!]
			c_oflag			[integer!]
			c_cflag			[integer!]
			c_lflag			[integer!]
			c_cc1			[integer!]						;-- c_cc[20]
			c_cc2			[integer!]
			c_cc3			[integer!]
			c_cc4			[integer!]
			c_cc5			[integer!]
			c_ispeed		[integer!]
			c_ospeed		[integer!]
		]
	]
	true [													;-- Linux
		#define TIOCGWINSZ		5413h
		#define TERM_VTIME		6
		#define TERM_VMIN		7

		#define TERM_BRKINT		2
		#define TERM_INPCK		20
		#define TERM_ISTRIP		40
		#define TERM_ICRNL		400
		#define TERM_IXON		2000
		#define TERM_OPOST		1
		#define TERM_CS8		60
		#define TERM_ISIG		1
		#define TERM_ICANON		2
		#define TERM_ECHO		10
		#define TERM_IEXTEN		100000

		#either OS = 'Android [
			#define TERM_TCSADRAIN	5403h

			termios!: alias struct! [
				c_iflag			[integer!]
				c_oflag			[integer!]
				c_cflag			[integer!]
				c_lflag			[integer!]
				;c_line			[byte!]
				c_cc1			[integer!]					;-- c_cc[19]
				c_cc2			[integer!]
				c_cc3			[integer!]
				c_cc4			[integer!]
				c_cc5			[integer!]
			]
		][
			#define TERM_TCSADRAIN	1

			termios!: alias struct! [						;-- sizeof(termios) = 60
				c_iflag			[integer!]
				c_oflag			[integer!]
				c_cflag			[integer!]
				c_lflag			[integer!]
				c_line			[byte!]
				c_cc1			[byte!]						;-- c_cc[32]
				c_cc2			[byte!]
				c_cc3			[byte!]
				c_cc4			[integer!]
				c_cc5			[integer!]
				c_cc6			[integer!]
				c_cc7			[integer!]
				c_cc8			[integer!]
				c_cc9			[integer!]
				c_cc10			[integer!]
				pad				[integer!]					;-- for proper alignment
				c_ispeed		[integer!]
				c_ospeed		[integer!]
			]
		]
	]
]

pollfd!: alias struct! [
	fd				[integer!]
	events			[integer!]						;-- high 16-bit: events
]													;-- low  16-bit: revents

winsize!: alias struct! [
	rowcol			[integer!]
	xypixel			[integer!]
]

#either OS = 'Android [
	tcgetattr: func [
		fd		[integer!]
		termios [termios!]
		return: [integer!]
	][
		ioctl fd 5401h as winsize! termios
	]
	tcsetattr: func [
		fd			[integer!]
		opt_actions [integer!]
		termios 	[termios!]
		return: 	[integer!]
	][
		ioctl fd opt_actions as winsize! termios
	]
][
	#import [
	LIBC-file cdecl [
		tcgetattr: "tcgetattr" [
			fd		[integer!]
			termios [termios!]
			return: [integer!]
		]
		tcsetattr: "tcsetattr" [
			fd			[integer!]
			opt_actions [integer!]
			termios 	[termios!]
			return: 	[integer!]
		]
	]]
]

#import [
	LIBC-file cdecl [
		read: "read" [
			fd		[integer!]
			buf		[byte-ptr!]
			size	[integer!]
			return: [integer!]
		]
		write: "write" [
			fd		[integer!]
			buf		[byte-ptr!]
			size	[integer!]
			return: [integer!]
		]
		poll: "poll" [
			fds		[pollfd!]
			nfds	[integer!]
			timeout [integer!]
			return: [integer!]
		]
		ioctl: "ioctl" [
			fd		[integer!]
			request	[integer!]
			ws		[winsize!]
			return: [integer!]
		]
	]
]

saved-term: declare termios!
utf-char:	declare c-string!
poller: 	declare pollfd!
relative-y:	0

fd-read-char: func [
	timeout [integer!]
	return: [byte!]
	/local
		c [byte!]
][
	c: as-byte -1
	if any [
		zero? poll poller 1 timeout
		1 <> read stdin :c 1
	][
		return as-byte -1
	]
	c
]

fd-read: func [
	return: [integer!]								;-- input codepoint or -1
	/local
		c	[integer!]
		len [integer!]
		i	[integer!]
		p	[byte-ptr!]
][
	if 1 <> read stdin as byte-ptr! utf-char 1 [return -1]
	c: as-integer utf-char/1
	case [
		c and 80h = 0	[len: 1]
		c and E0h = C0h [len: 2]
		c and F0h = E0h [len: 3]
		c and F8h = F0h [len: 4]
	]
	if any [len < 1 len > 4][return -1]

	i: 1
	while [i < len][
		if all [
			len >= (i + 1)
			1 <> read stdin as byte-ptr! utf-char + i 1
		][
			return -1
		]
		i: i + 1
	]
	c: unicode/decode-utf8-char utf-char :len
	c
]

check-special: func [
	return: [integer!]
	/local
		c  [byte!]
		c2 [byte!]
][
	c: fd-read-char 50
	if (as-integer c) > 127 [return 27]

	c2: fd-read-char 50
	if (as-integer c2) > 127 [return as-integer c2]

	if any [c = #"[" c = #"O"][
		switch c2 [
			#"A" [return KEY_UP]
			#"B" [return KEY_DOWN]
			#"C" [return KEY_RIGHT]
			#"D" [return KEY_LEFT]
			#"F" [return KEY_END]
			#"H" [return KEY_HOME]
			default []
		]
	]
	if all [c = #"[" #"1" <= c2 c2 <= #"8"][
		c: fd-read-char 50
		if c = #"~" [
			switch c2 [
				#"2" [return KEY_INSERT]
				#"3" [return KEY_DELETE]
				#"5" [return KEY_PAGE_UP]
				#"6" [return KEY_PAGE_DOWN]
				#"7" [return KEY_HOME]
				#"8" [return KEY_END]
				default []
			]
		]
		while [all [(as-integer c) <> -1 c <> #"~"]][
			c: fd-read-char 50
		]
	]
	KEY_NONE
]

emit: func [c [byte!]][
	write stdout :c 1
]

emit-string: func [
	s [c-string!]
][
	write stdout as byte-ptr! s length? s
]

emit-string-int: func [
	begin [c-string!]
	n	  [integer!]
	end	  [byte!]
][
	emit-string begin
	emit-string integer/form-signed n
	emit end
]

emit-red-char: func [
	cp			[integer!]
][
	case [
		cp <= 7Fh [
			pbuffer/1: as-byte cp
			pbuffer: pbuffer + 1
		]
		cp <= 07FFh [
			pbuffer/1: as-byte cp >> 6 or C0h
			pbuffer/2: as-byte cp and 3Fh or 80h
			pbuffer: pbuffer + 2
		]
		cp <= FFFFh [
			pbuffer/1: as-byte cp >> 12 or E0h
			pbuffer/2: as-byte cp >> 6 and 3Fh or 80h
			pbuffer/3: as-byte cp and 3Fh or 80h
			pbuffer: pbuffer + 3
		]
		cp <= 001FFFFFh [
			pbuffer/1: as-byte cp >> 18 or F0h
			pbuffer/2: as-byte cp >> 12 and 3Fh or 80h
			pbuffer/3: as-byte cp >>  6 and 3Fh or 80h
			pbuffer/4: as-byte cp and 3Fh or 80h
			pbuffer: pbuffer + 4
		]
		true [
			print-line "Error in emit-red-string: codepoint > 1FFFFFh"
		]
	]
]

query-cursor: func [
	col		[int-ptr!]
	return: [logic!]								;-- FALSE: failed to retrieve it
	/local
		c [byte!]
		n [integer!]
][
	emit-string "^[[6n"								;-- ask for cursor location
	if all [
		  esc = fd-read-char 100
		 #"[" = fd-read-char 100
	][
		while [true][
			c: fd-read-char 100
			n: 0
			case [
				c = #";" [n: 0]
				all [c = #"R" n <> 0 n < 1000][
					col/value: n
					return true
				]
				all [#"0" <= c c <= #"9"][
					n: n * 10 + (c - #"0")
				]
				true [
					return true
				]
			]
		]
	]
	false
]

get-window-size: func [
	/local
		ws	 [winsize!]
		here [integer!]
][
	ws: declare winsize!

	ioctl stdout TIOCGWINSZ ws
	columns: ws/rowcol >> 16

	if zero? columns [
		columns: 80
		here: 0
		if query-cursor :here [
			emit-string "^[[999C"

			either query-cursor :columns [
				if columns > here [				;-- reset cursor position
					emit-string-int "^[[" columns - here #"D"
				]
			][
				emit cr
			]
		]
	]
]

reset-cursor-pos: does [
	if positive? relative-y [emit-string-int "^[[" relative-y #"A"]	;-- move to origin row
	emit cr
]

erase-to-bottom: does [
	emit-string "^[[0J"				;-- erase down to the bottom of the screen
]

set-cursor-pos: func [
	line	[red-string!]
	offset	[integer!]
	size	[integer!]
	/local
		x	[integer!]
		y	[integer!]
][
	relative-y: size / columns		;-- the lines of all outputs occupy
	y: size / columns - (offset / columns)
	x: offset // columns

	if all [						;-- special case: when moving cursor to the first char of a line
		widechar? line				;-- the first char of the line is a widechar
		columns - x = 1				;-- but in pre line only 1 space left
	][
		y: y - 1
		x: 0
	]

	if zero? (size % columns) [emit #"^(0A)"]

	if positive? y [				;-- set cursor position: y
	    emit-string-int "^[[" y #"A"
	    relative-y: relative-y - y
	]
	either zero? x [		 		;-- set cursor position: x
		emit #"^(0D)"
	][
		emit-string-int "^(0D)^[[" x #"C"
	]
]

output-to-screen: does [
	write stdout buffer (as-integer pbuffer - buffer)
]

init: func [
	line 	 [red-string!]
	hist-blk [red-block!]
	/local
		term [termios!]
		cc	 [byte-ptr!]
		so	 [sigaction!]
		mask [integer!]
][
	relative-y: 0
	utf-char: as-c-string allocate 10

	copy-cell as red-value! line as red-value! input-line
	copy-cell as red-value! hist-blk as red-value! history

	so: declare sigaction!						;-- install resizing signal trap
	mask: (as-integer so) + 4
	sigemptyset mask
	so/sigaction: as-integer :on-resize
	so/flags: 0
	sigaction SIGWINCH so as sigaction! 0

	term: declare termios!
	tcgetattr stdin saved-term					;@@ check returned value

	copy-memory
		as byte-ptr! term
		as byte-ptr! saved-term
		size? term

	term/c_iflag: term/c_iflag and not (
		TERM_BRKINT or TERM_ICRNL or TERM_INPCK or TERM_ISTRIP or TERM_IXON
	)
	term/c_oflag: term/c_oflag and not TERM_OPOST
	term/c_cflag: term/c_cflag or TERM_CS8
	term/c_lflag: term/c_lflag and not (
		TERM_ECHO or TERM_ICANON or TERM_IEXTEN or TERM_ISIG
	)
	#case [
		any [OS = 'MacOSX OS = 'FreeBSD] [
			cc: (as byte-ptr! term) + (4 * size? integer!)
		]
		true [cc: (as byte-ptr! term) + (4 * size? integer!) + 1]
	]
	cc/TERM_VMIN:  as-byte 1
	cc/TERM_VTIME: as-byte 0

	tcsetattr stdin TERM_TCSADRAIN term

	poller/fd: stdin
	poller/events: OS_POLLIN

	buffer: allocate buf-size
]

restore: does [
	tcsetattr stdin TERM_TCSADRAIN saved-term
	free buffer
	free as byte-ptr! utf-char
]

Red/System [
	Title:	"INPUT POSIX API imported functions and structures definitions"
	Author: "Nenad Rakocevic, Xie Qingtian"
	File: 	%POSIX.reds
	Tabs: 	4
	Rights: "Copyright (C) 2014 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
	Notes: {
		Freely inspired by linenoise fork from msteveb:
		https://github.com/msteveb/linenoise/blob/master/linenoise.c
	}
]

#define OS_POLLIN 		1

#case [
	any [OS = 'MacOSX OS = 'FreeBSD] [
		#define TIOCGWINSZ		40087468h
		#define TERM_TCSADRAIN	1
		#define TERM_VTIME		18
		#define TERM_VMIN		17

		#define TERM_BRKINT		02h
		#define TERM_INPCK		10h
		#define TERM_ISTRIP		20h
		#define TERM_ICRNL		0100h
		#define TERM_IXON		0200h
		#define TERM_OPOST		01h
		#define TERM_CS8		0300h
		#define TERM_ISIG		80h
		#define TERM_ICANON		0100h
		#define TERM_ECHO		08h
		#define TERM_IEXTEN		4000h

		termios!: alias struct! [
			c_iflag			[integer!]
			c_oflag			[integer!]
			c_cflag			[integer!]
			c_lflag			[integer!]
			c_cc1			[integer!]						;-- c_cc[20]
			c_cc2			[integer!]
			c_cc3			[integer!]
			c_cc4			[integer!]
			c_cc5			[integer!]
			c_ispeed		[integer!]
			c_ospeed		[integer!]
		]
	]
	true [													;-- Linux
		#define TIOCGWINSZ		5413h
		#define TERM_VTIME		6
		#define TERM_VMIN		7

		#define TERM_BRKINT		2
		#define TERM_INPCK		20
		#define TERM_ISTRIP		40
		#define TERM_ICRNL		400
		#define TERM_IXON		2000
		#define TERM_OPOST		1
		#define TERM_CS8		60
		#define TERM_ISIG		1
		#define TERM_ICANON		2
		#define TERM_ECHO		10
		#define TERM_IEXTEN		100000

		#either OS = 'Android [
			#define TERM_TCSADRAIN	5403h

			termios!: alias struct! [
				c_iflag			[integer!]
				c_oflag			[integer!]
				c_cflag			[integer!]
				c_lflag			[integer!]
				;c_line			[byte!]
				c_cc1			[integer!]					;-- c_cc[19]
				c_cc2			[integer!]
				c_cc3			[integer!]
				c_cc4			[integer!]
				c_cc5			[integer!]
			]
		][
			#define TERM_TCSADRAIN	1

			termios!: alias struct! [						;-- sizeof(termios) = 60
				c_iflag			[integer!]
				c_oflag			[integer!]
				c_cflag			[integer!]
				c_lflag			[integer!]
				c_line			[byte!]
				c_cc1			[byte!]						;-- c_cc[32]
				c_cc2			[byte!]
				c_cc3			[byte!]
				c_cc4			[integer!]
				c_cc5			[integer!]
				c_cc6			[integer!]
				c_cc7			[integer!]
				c_cc8			[integer!]
				c_cc9			[integer!]
				c_cc10			[integer!]
				pad				[integer!]					;-- for proper alignment
				c_ispeed		[integer!]
				c_ospeed		[integer!]
			]
		]
	]
]

pollfd!: alias struct! [
	fd				[integer!]
	events			[integer!]						;-- high 16-bit: events
]													;-- low  16-bit: revents

winsize!: alias struct! [
	rowcol			[integer!]
	xypixel			[integer!]
]

#either OS = 'Android [
	tcgetattr: func [
		fd		[integer!]
		termios [termios!]
		return: [integer!]
	][
		ioctl fd 5401h as winsize! termios
	]
	tcsetattr: func [
		fd			[integer!]
		opt_actions [integer!]
		termios 	[termios!]
		return: 	[integer!]
	][
		ioctl fd opt_actions as winsize! termios
	]
][
	#import [
	LIBC-file cdecl [
		tcgetattr: "tcgetattr" [
			fd		[integer!]
			termios [termios!]
			return: [integer!]
		]
		tcsetattr: "tcsetattr" [
			fd			[integer!]
			opt_actions [integer!]
			termios 	[termios!]
			return: 	[integer!]
		]
	]]
]

#import [
	LIBC-file cdecl [
		read: "read" [
			fd		[integer!]
			buf		[byte-ptr!]
			size	[integer!]
			return: [integer!]
		]
		write: "write" [
			fd		[integer!]
			buf		[byte-ptr!]
			size	[integer!]
			return: [integer!]
		]
		poll: "poll" [
			fds		[pollfd!]
			nfds	[integer!]
			timeout [integer!]
			return: [integer!]
		]
		ioctl: "ioctl" [
			fd		[integer!]
			request	[integer!]
			ws		[winsize!]
			return: [integer!]
		]
	]
]

saved-term: declare termios!
utf-char:	declare c-string!
poller: 	declare pollfd!
relative-y:	0

fd-read-char: func [
	timeout [integer!]
	return: [byte!]
	/local
		c [byte!]
][
	c: as-byte -1
	if any [
		zero? poll poller 1 timeout
		1 <> read stdin :c 1
	][
		return as-byte -1
	]
	c
]

fd-read: func [
	return: [integer!]								;-- input codepoint or -1
	/local
		c	[integer!]
		len [integer!]
		i	[integer!]
		p	[byte-ptr!]
][
	if 1 <> read stdin as byte-ptr! utf-char 1 [return -1]
	c: as-integer utf-char/1
	case [
		c and 80h = 0	[len: 1]
		c and E0h = C0h [len: 2]
		c and F0h = E0h [len: 3]
		c and F8h = F0h [len: 4]
	]
	if any [len < 1 len > 4][return -1]

	i: 1
	while [i < len][
		if all [
			len >= (i + 1)
			1 <> read stdin as byte-ptr! utf-char + i 1
		][
			return -1
		]
		i: i + 1
	]
	c: unicode/decode-utf8-char utf-char :len
	c
]

check-special: func [
	return: [integer!]
	/local
		c  [byte!]
		c2 [byte!]
][
	c: fd-read-char 50
	if (as-integer c) < 0 [return 27]

	c2: fd-read-char 50
	if (as-integer c) < 0 [return as-integer c2]

	if any [c = #"[" c = #"O"][
		switch c2 [
			#"A" [return KEY_UP]
			#"B" [return KEY_DOWN]
			#"C" [return KEY_RIGHT]
			#"D" [return KEY_LEFT]
			#"F" [return KEY_END]
			#"H" [return KEY_HOME]
			default []
		]
	]
	if all [c = #"[" #"1" <= c2 c2 <= #"8"][
		c: fd-read-char 50
		if c = #"~" [
			switch c2 [
				#"2" [return KEY_INSERT]
				#"3" [return KEY_DELETE]
				#"5" [return KEY_PAGE_UP]
				#"6" [return KEY_PAGE_DOWN]
				#"7" [return KEY_HOME]
				#"8" [return KEY_END]
				default []
			]
		]
		while [all [(as-integer c) <> -1 c <> #"~"]][
			c: fd-read-char 50
		]
	]
	KEY_NONE
]

emit: func [c [byte!]][
	write stdout :c 1
]

emit-string: func [
	s [c-string!]
][
	write stdout as byte-ptr! s length? s
]

emit-string-int: func [
	begin [c-string!]
	n	  [integer!]
	end	  [byte!]
][
	emit-string begin
	emit-string integer/form-signed n
	emit end
]

emit-red-char: func [
	cp			[integer!]
][
	case [
		cp <= 7Fh [
			pbuffer/1: as-byte cp
			pbuffer: pbuffer + 1
		]
		cp <= 07FFh [
			pbuffer/1: as-byte cp >> 6 or C0h
			pbuffer/2: as-byte cp and 3Fh or 80h
			pbuffer: pbuffer + 2
		]
		cp <= FFFFh [
			pbuffer/1: as-byte cp >> 12 or E0h
			pbuffer/2: as-byte cp >> 6 and 3Fh or 80h
			pbuffer/3: as-byte cp and 3Fh or 80h
			pbuffer: pbuffer + 3
		]
		cp <= 001FFFFFh [
			pbuffer/1: as-byte cp >> 18 or F0h
			pbuffer/2: as-byte cp >> 12 and 3Fh or 80h
			pbuffer/3: as-byte cp >>  6 and 3Fh or 80h
			pbuffer/4: as-byte cp and 3Fh or 80h
			pbuffer: pbuffer + 4
		]
		true [
			print-line "Error in emit-red-string: codepoint > 1FFFFFh"
		]
	]
]

query-cursor: func [
	col		[int-ptr!]
	return: [logic!]								;-- FALSE: failed to retrieve it
	/local
		c [byte!]
		n [integer!]
][
	emit-string "^[[6n"								;-- ask for cursor location
	if all [
		  esc = fd-read-char 100
		 #"[" = fd-read-char 100
	][
		while [true][
			c: fd-read-char 100
			n: 0
			case [
				c = #";" [n: 0]
				all [c = #"R" n <> 0 n < 1000][
					col/value: n
					return true
				]
				all [#"0" <= c c <= #"9"][
					n: n * 10 + (c - #"0")
				]
				true [
					return true
				]
			]
		]
	]
	false
]

get-window-size: func [
	/local
		ws	 [winsize!]
		here [integer!]
][
	ws: declare winsize!

	ioctl stdout TIOCGWINSZ ws
	columns: ws/rowcol >> 16

	if zero? columns [
		columns: 80
		here: 0
		if query-cursor :here [
			emit-string "^[[999C"

			either query-cursor :columns [
				if columns > here [				;-- reset cursor position
					emit-string-int "^[[" columns - here #"D"
				]
			][
				emit cr
			]
		]
	]
]

reset-cursor-pos: does [
	if positive? relative-y [emit-string-int "^[[" relative-y #"A"]	;-- move to origin row
	emit cr
]

erase-to-bottom: does [
	emit-string "^[[0J"				;-- erase down to the bottom of the screen
]

set-cursor-pos: func [
	line	[red-string!]
	offset	[integer!]
	size	[integer!]
	/local
		x	[integer!]
		y	[integer!]
][
	relative-y: size / columns		;-- the lines of all outputs occupy
	y: size / columns - (offset / columns)
	x: offset // columns

	if all [						;-- special case: when moving cursor to the first char of a line
		widechar? line				;-- the first char of the line is a widechar
		columns - x = 1				;-- but in pre line only 1 space left
	][
		y: y - 1
		x: 0
	]

	if zero? (size % columns) [emit #"^(0A)"]

	if positive? y [				;-- set cursor position: y
	    emit-string-int "^[[" y #"A"
	    relative-y: relative-y - y
	]
	either zero? x [		 		;-- set cursor position: x
		emit #"^(0D)"
	][
		emit-string-int "^(0D)^[[" x #"C"
	]
]

output-to-screen: does [
	write stdout buffer (as-integer pbuffer - buffer)
]

init: func [
	line 	 [red-string!]
	hist-blk [red-block!]
	/local
		term [termios!]
		cc	 [byte-ptr!]
		so	 [sigaction!]
		mask [integer!]
][
	relative-y: 0
	utf-char: as-c-string allocate 10

	copy-cell as red-value! line as red-value! input-line
	copy-cell as red-value! hist-blk as red-value! history

	so: declare sigaction!						;-- install resizing signal trap
	mask: (as-integer so) + 4
	sigemptyset mask
	so/sigaction: as-integer :on-resize
	so/flags: 0
	sigaction SIGWINCH so as sigaction! 0

	term: declare termios!
	tcgetattr stdin saved-term					;@@ check returned value

	copy-memory
		as byte-ptr! term
		as byte-ptr! saved-term
		size? term

	term/c_iflag: term/c_iflag and not (
		TERM_BRKINT or TERM_ICRNL or TERM_INPCK or TERM_ISTRIP or TERM_IXON
	)
	term/c_oflag: term/c_oflag and not TERM_OPOST
	term/c_cflag: term/c_cflag or TERM_CS8
	term/c_lflag: term/c_lflag and not (
		TERM_ECHO or TERM_ICANON or TERM_IEXTEN or TERM_ISIG
	)
	#case [
		any [OS = 'MacOSX OS = 'FreeBSD] [
			cc: (as byte-ptr! term) + (4 * size? integer!)
		]
		true [cc: (as byte-ptr! term) + (4 * size? integer!) + 1]
	]
	cc/TERM_VMIN:  as-byte 1
	cc/TERM_VTIME: as-byte 0

	tcsetattr stdin TERM_TCSADRAIN term

	poller/fd: stdin
	poller/events: OS_POLLIN

	buffer: allocate buf-size
]

restore: does [
	tcsetattr stdin TERM_TCSADRAIN saved-term
	free buffer
	free as byte-ptr! utf-char
]


FEAT: minor code reduction.

FEAT: minor code reduction.

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

datatype: context [
	verbose: 0
	top-id:  0											;-- last type ID registered

	make-words: func [
		/local
			name [names!]
			i	 [integer!]
	][
		i: 1
		until [
			name: name-table + i
			name/word: word/load name/buffer
			i: i + 1
			i > top-id
		]
	]

	;-------------------------------------
	;-- Load actions table with a new datatype set of function pointers
	;--
	;-- Input: block of values with type ID in first place followed by
	;-- actions pointers.
	;--
	;-- Returns: -
	;-------------------------------------
	register: func [
		[variadic]
		count		[integer!]
		list		[int-ptr!]
		/local
			type	[integer!]
			index	[integer!]
			parent	[integer!]
			idx		[integer!]
			name	[names!]
	][
		type: list/value
		assert type < 50								;-- hard limit of action table
		if type > top-id [top-id: type]					;@@ unreliable, needs automatic type IDs
		list: list + 1

		parent: list/value
		list: list + 1

		name: name-table + type
		name/buffer: as c-string! list/value			;-- store datatype string name
		name/size: (length? name/buffer) - 1			;-- store string size (not counting terminal `!`)
		list: list + 1
		count: count - 3								;-- skip the "header" data

		if count <> ACTIONS_NB [
			print [
				"*** Datatype Error: invalid actions count for type: " type lf
				"*** Found: " count lf
				"*** Expected: " ACTIONS_NB lf
			]
			halt
		]

		index: type << 8 + 1							;-- consume first argument (type ID), one-based index
		until [
			action-table/index: either all [
				parent <> TYPE_VALUE
				list/value = INHERIT_ACTION
			][
				idx: parent << 8 + 1 + (ACTIONS_NB - count)
				action-table/idx						;-- inherit action from parent
			][
				list/value
			]
			index: index + 1
			list: list + 1
			count: count - 1
			zero? count
		]
	]

	push: func [
		type	[integer!]
		return: [red-datatype!]
		/local
			dt  [red-datatype!]
	][
		#if debug? = yes [if verbose > 0 [print-line "datatype/push"]]

		dt: as red-datatype! stack/push*
		dt/header: TYPE_DATATYPE						;-- implicit reset of all header flags
		dt/value: type
		dt
	]

	;-- Actions --

	make: func [
		proto 	[red-value!]
		spec	[red-value!]
		return:	[red-datatype!]							;-- return datatype cell pointer
		/local
			int [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "datatype/make"]]

		assert TYPE_OF(spec) = TYPE_INTEGER
		int: as red-integer! spec
		push int/value
	]

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

		name: name-table + dt/value
		string/concatenate-literal-part buffer name/buffer name/size
		part - name/size
	]

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

		name: name-table + dt/value
		string/concatenate-literal-part buffer name/buffer name/size + 1
		part - name/size - 1
	]

	compare: func [
		arg1      [red-datatype!]						;-- first operand
		arg2	  [red-datatype!]						;-- second operand
		op	      [integer!]							;-- type of comparison
		return:   [integer!]
		/local
			res	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "datatype/compare"]]

		switch op [
			COMP_EQUAL
			COMP_STRICT_EQUAL
			COMP_NOT_EQUAL	  [
				res: as-integer any [TYPE_OF(arg2) <> TYPE_DATATYPE arg1/value <> arg2/value]
			]
			default [
				print-line ["Error: cannot use: " op " comparison on datatype! value"]
				res: -2
			]
		]
		res
	]

	init: does [
		register [
			TYPE_DATATYPE
			TYPE_VALUE
			"datatype!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			null			;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
			null			;copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]

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

datatype: context [
	verbose: 0
	top-id:  0											;-- last type ID registered

	make-words: func [
		/local
			name [names!]
			i	 [integer!]
	][
		i: 1
		until [
			name: name-table + i
			name/word: word/load name/buffer
			i: i + 1
			i > top-id
		]
	]

	;-------------------------------------
	;-- Load actions table with a new datatype set of function pointers
	;--
	;-- Input: block of values with type ID in first place followed by
	;-- actions pointers.
	;--
	;-- Returns: -
	;-------------------------------------
	register: func [
		[variadic]
		count		[integer!]
		list		[int-ptr!]
		/local
			type	[integer!]
			index	[integer!]
			parent	[integer!]
			idx		[integer!]
			name	[names!]
	][
		type: list/value
		assert type < 50								;-- hard limit of action table
		if type > top-id [top-id: type]					;@@ unreliable, needs automatic type IDs
		list: list + 1

		parent: list/value
		list: list + 1

		name: name-table + type
		name/buffer: as c-string! list/value			;-- store datatype string name
		name/size: (length? name/buffer) - 1			;-- store string size (not counting terminal `!`)
		list: list + 1
		count: count - 3								;-- skip the "header" data

		if count <> ACTIONS_NB [
			print [
				"*** Datatype Error: invalid actions count for type: " type lf
				"*** Found: " count lf
				"*** Expected: " ACTIONS_NB lf
			]
			halt
		]

		index: type << 8 + 1							;-- consume first argument (type ID), one-based index
		until [
			action-table/index: either all [
				parent <> TYPE_VALUE
				list/value = INHERIT_ACTION
			][
				idx: parent << 8 + 1 + (ACTIONS_NB - count)
				action-table/idx						;-- inherit action from parent
			][
				list/value
			]
			index: index + 1
			list: list + 1
			count: count - 1
			zero? count
		]
	]

	push: func [
		type	[integer!]
		/local
			dt  [red-datatype!]
	][
		#if debug? = yes [if verbose > 0 [print-line "datatype/push"]]

		dt: as red-datatype! stack/push*
		dt/header: TYPE_DATATYPE						;-- implicit reset of all header flags
		dt/value: type
	]

	;-- Actions --

	make: func [
		proto 	[red-value!]
		spec	[red-value!]
		return:	[red-datatype!]							;-- return datatype cell pointer
		/local
			dt   [red-datatype!]
			int [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "datatype/make"]]

		assert TYPE_OF(spec) = TYPE_INTEGER
		int: as red-integer! spec
		dt: as red-datatype! stack/push*
		dt/header: TYPE_DATATYPE
		dt/value: int/value
		dt
	]

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

		name: name-table + dt/value
		string/concatenate-literal-part buffer name/buffer name/size
		part - name/size
	]

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

		name: name-table + dt/value
		string/concatenate-literal-part buffer name/buffer name/size + 1
		part - name/size - 1
	]

	compare: func [
		arg1      [red-datatype!]						;-- first operand
		arg2	  [red-datatype!]						;-- second operand
		op	      [integer!]							;-- type of comparison
		return:   [integer!]
		/local
			res	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "datatype/compare"]]

		switch op [
			COMP_EQUAL
			COMP_STRICT_EQUAL
			COMP_NOT_EQUAL	  [
				res: as-integer any [TYPE_OF(arg2) <> TYPE_DATATYPE arg1/value <> arg2/value]
			]
			default [
				print-line ["Error: cannot use: " op " comparison on datatype! value"]
				res: -2
			]
		]
		res
	]

	init: does [
		register [
			TYPE_DATATYPE
			TYPE_VALUE
			"datatype!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			null			;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
			null			;copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]


Fix: local vars in string/swap

Fix: local vars in string/swap


FIX: removed dead code in paren! implementation. (ticket #336)

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

paren: context [
	verbose: 0

	push*: func [
		size	  [integer!]
		return:   [red-paren!]
		/local
			paren [red-paren!]
	][
		#if debug? = yes [if verbose > 0 [print-line "paren/push*"]]

		paren: as red-block! ALLOC_TAIL(root)
		paren/header: TYPE_PAREN					;-- implicit reset of all header flags
		paren/head:   0
		paren/node:   alloc-cells size
		push paren
		paren
	]

	push: func [
		paren [red-paren!]
	][
		#if debug? = yes [if verbose > 0 [print-line "paren/push"]]

		paren/header: TYPE_PAREN					;-- implicit reset of all header flags
		copy-cell as red-value! paren stack/push*
	]

	;--- Actions ---

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

		paren: as red-paren! block/make proto spec
		paren/header: TYPE_PAREN						;-- implicit reset of all header flags
		paren
	]

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

		string/append-char GET_BUFFER(buffer) as-integer #"("
		part: part - 1
		part: block/mold-each paren buffer only? all? flat? arg part
		string/append-char GET_BUFFER(buffer) as-integer #")"
		part - 1
	]

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

		if TYPE_OF(value2) <> TYPE_PAREN [RETURN_COMPARE_OTHER]
		block/compare-each as red-block! value1 as red-block! value2 op
	]

	datatype/register [
		TYPE_PAREN
		TYPE_BLOCK
		"paren!"
		;-- General actions --
		:make
		null			;random
		null			;reflect
		null			;to
		INHERIT_ACTION	;form
		:mold
		null			;get-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 --
		INHERIT_ACTION	;append
		INHERIT_ACTION	;at
		INHERIT_ACTION	;back
		null			;change
		INHERIT_ACTION	;clear
		null			;copy
		null			;find
		INHERIT_ACTION	;head
		INHERIT_ACTION	;head?
		INHERIT_ACTION	;index?
		null			;insert
		INHERIT_ACTION	;length?
		INHERIT_ACTION	;next
		INHERIT_ACTION	;pick
		INHERIT_ACTION	;poke
		null			;remove
		null			;reverse
		null			;select
		null			;sort
		INHERIT_ACTION	;skip
		null			;swap
		INHERIT_ACTION	;tail
		INHERIT_ACTION	;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:   "Paren! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %paren.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

paren: context [
	verbose: 0

	depth: 0

	append*: func [
		return: [red-paren!]
	][
		#if debug? = yes [if verbose > 0 [print-line "paren/append*"]]

		block/append*
	]

	push*: func [
		size	  [integer!]
		return:   [red-paren!]
		/local
			paren [red-paren!]
	][
		#if debug? = yes [if verbose > 0 [print-line "paren/push*"]]

		paren: as red-block! ALLOC_TAIL(root)
		paren/header: TYPE_PAREN					;-- implicit reset of all header flags
		paren/head:   0
		paren/node:   alloc-cells size
		push paren
		paren
	]

	push: func [
		paren [red-paren!]
	][
		#if debug? = yes [if verbose > 0 [print-line "paren/push"]]

		paren/header: TYPE_PAREN					;-- implicit reset of all header flags
		copy-cell as red-value! paren stack/push*
	]

	;--- Actions ---

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

		paren: as red-paren! block/make proto spec
		paren/header: TYPE_PAREN						;-- implicit reset of all header flags
		paren
	]

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

		string/append-char GET_BUFFER(buffer) as-integer #"("
		part: part - 1
		part: block/mold-each paren buffer only? all? flat? arg part
		string/append-char GET_BUFFER(buffer) as-integer #")"
		part - 1
	]

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

		if TYPE_OF(value2) <> TYPE_PAREN [RETURN_COMPARE_OTHER]
		block/compare-each as red-block! value1 as red-block! value2 op
	]

	datatype/register [
		TYPE_PAREN
		TYPE_BLOCK
		"paren!"
		;-- General actions --
		:make
		null			;random
		null			;reflect
		null			;to
		INHERIT_ACTION	;form
		:mold
		null			;get-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 --
		INHERIT_ACTION	;append
		INHERIT_ACTION	;at
		INHERIT_ACTION	;back
		null			;change
		INHERIT_ACTION	;clear
		null			;copy
		null			;find
		INHERIT_ACTION	;head
		INHERIT_ACTION	;head?
		INHERIT_ACTION	;index?
		null			;insert
		INHERIT_ACTION	;length?
		INHERIT_ACTION	;next
		INHERIT_ACTION	;pick
		INHERIT_ACTION	;poke
		null			;remove
		null			;reverse
		null			;select
		null			;sort
		INHERIT_ACTION	;skip
		null			;swap
		INHERIT_ACTION	;tail
		INHERIT_ACTION	;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
	]
]