FIX: crash on Linux 64bit caused by 32-bit integer overflow in bitset-tests.red.

Issue caused in test "basic-9" by the following expression:
    pick bs 2147483647

The internal index calculation leads to a wrong test for "virtual bit", trying then to read a not accessible memory address. The fact that this only happens on Linux 64bit and not any other platform suggests a race condition that is probably triggered by a different location for heap memory region on Linux 64bit, making it sensitive to this memory address calculation bug.

Red/System [
	Title:   "Bitset datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %bitset.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
	}
]

bitset: context [
	verbose: 0

	#enum bitset-op! [
		OP_MAX											;-- calculate highest value
		OP_SET											;-- set value bits
		OP_TEST											;-- test if value bits are set
		OP_CLEAR										;-- clear value bits
		OP_UNION
		OP_AND
		OP_OR
		OP_XOR
	]

	rs-head: func [
		bits	[red-bitset!]
		return: [byte-ptr!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(bits)
		as byte-ptr! s/offset
	]

	rs-tail: func [
		bits	[red-bitset!]
		return: [byte-ptr!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(bits)
		as byte-ptr! s/tail
	]

	bound-check: func [
		bits	[red-bitset!]
		index	[integer!]								;-- 0-based
		return: [byte-ptr!]
		/local
			s	 [series!]
			p	 [byte-ptr!]
			not? [logic!]
			byte [byte!]
	][
		s: GET_BUFFER(bits)
		if (s/size << 3) < index [
			byte: either FLAG_NOT?(s) [#"^(FF)"][null-byte]
			s: expand-series-filled s (index >> 3) + 1 byte
		]

		p: (as byte-ptr! s/offset) + (index >> 3) + 1
		if p > as byte-ptr! s/tail [s/tail: as cell! p]	;-- move forward tail pointer if required
		as byte-ptr! s/offset
	]

	virtual-bit?: func [
		bits	[red-bitset!]
		index	[integer!]								;-- 0-based
		return: [logic!]
		/local
			s [series!]
			p [byte-ptr!]
	][
		s: GET_BUFFER(bits)
		p: (as byte-ptr! s/offset) + (index >> 3) + 1
		any [
			index < 0
			p > as byte-ptr! s/tail
			p < as byte-ptr! s/offset					;-- overflow case
		]
	]

	invert-bytes: func [
		s [series!]
		/local
			p	 [byte-ptr!]
			tail [byte-ptr!]
	][
		p:	  as byte-ptr! s/offset
		tail: p + s/size

		while [p < tail][
			p/value: not p/value
			p: p + 1
		]
	]

	form-bytes: func [
		bits	[red-bitset!]
		buffer	[red-string!]
		part?	[logic!]
		part	[integer!]
		invert? [logic!]
		return:	[integer!]
		/local
			s	   [series!]
			p	   [byte-ptr!]
			tail   [byte-ptr!]
			byte   [integer!]
			c	   [byte!]
			nibble [integer!]
	][
		s:	  GET_BUFFER(bits)
		p:	  as byte-ptr! s/offset
		tail: as byte-ptr! s/tail

		while [p < tail][								;@@ could be optimized for speed
			byte: as-integer p/value
			if invert? [byte: 255 - byte]

			nibble: byte >> 4							;-- high nibble
			c: either nibble < 10 [#"0" + nibble][#"A" + (nibble - 10)]
			string/append-char GET_BUFFER(buffer) as-integer c

			nibble: byte and 15							;-- low nibble
			c: either nibble < 10 [#"0" + nibble][#"A" + (nibble - 10)]
			string/append-char GET_BUFFER(buffer) as-integer c

			p: p + 1
			part: part - 1
			if all [part? negative? part][return part]
		]
		part
	]

	do-bitwise: func [
		type	[integer!]
		return: [red-bitset!]
		/local
			set1  [red-bitset!]
			set2  [red-bitset!]
			s1	  [series!]
			s2	  [series!]
			s	  [series!]
			node  [node!]
			p	  [byte-ptr!]
			p1	  [byte-ptr!]
			p2	  [byte-ptr!]
			tail  [byte-ptr!]
			same? [logic!]
	][
		set1: as red-bitset! stack/arguments
		set2: set1 + 1
		s1: GET_BUFFER(set1)
		s2: GET_BUFFER(set2)

		if (length? set1) > (length? set2) [s: s1 s1: s2 s2: s]		;-- exchange s1 <=> s2
		same?: (s1/flags and flag-bitset-not) = (s2/flags and flag-bitset-not)

		node: alloc-bytes s2/size
		s: as series! node/value
		p: as byte-ptr! s/offset
		unless same? [s/flags: s/flags or flag-bitset-not]

		p1:	  as byte-ptr! s1/offset
		tail: as byte-ptr! s1/tail
		p2:	  as byte-ptr! s2/offset

		until [
			p/value: switch type [
				OP_UNION
				OP_OR	[p1/value or p2/value]			;-- OR s1 with part(s2)
				OP_AND	[p1/value and p2/value]
				OP_XOR	[p1/value xor p2/value]
			]
			p:  p  + 1
			p1: p1 + 1
			p2: p2 + 1
			p1 = tail
		]
		tail: as byte-ptr! s2/tail

		if p2 < tail [
			switch type [
				OP_UNION
				OP_OR	[
					copy-memory p p2 as-integer tail - p2	;-- just copy remaining of s2
					p: p + as-integer tail - p2
				]
				OP_AND  []									;-- do nothing
				OP_XOR	[
					until [
						p/value: null-byte xor p2/value
						p:  p  + 1
						p2: p2 + 1
						p2 = tail
					]
				]
			]
		]
		s/tail: as red-value! p

		set1: as red-bitset! stack/push*
		set1/header: TYPE_BITSET
		set1/node:	 node
		stack/set-last as red-value! set1
		set1
	]

	union: func [
		case?	[logic!]
		skip	[red-value!]
		return: [red-bitset!]
	][
		do-bitwise OP_UNION
	]

	and~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "bitset/and~"]]
		as red-value! do-bitwise OP_AND
	]

	or~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "bitset/or~"]]
		as red-value! do-bitwise OP_OR
	]

	xor~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "bitset/xor~"]]
		as red-value! do-bitwise OP_XOR
	]

	process-range: func [
		bits 	[red-bitset!]
		lower	[integer!]
		upper	[integer!]
		op		[integer!]
		return: [integer!]
		/local
			pos	  [byte-ptr!]
			pbits [byte-ptr!]
			set?  [logic!]
			s	  [series!]
			not?  [logic!]
	][
		s: GET_BUFFER(bits)
		not?: FLAG_NOT?(s)
		pbits: rs-head bits

		switch op [
			OP_SET [
				BS_PROCESS_SET_VIRTUAL(bits upper)
				while [lower <= upper][
					BS_SET_BIT(pbits lower)				;-- could be optimized by setting bytes directly
					lower: lower + 1
				]
			]
			OP_TEST [
				if virtual-bit? bits upper [return as-integer not?]
				while [lower <= upper][
					BS_TEST_BIT(pbits lower set?)		;-- could be optimized by testing bytes directly
					unless set? [return 0]
					lower: lower + 1
				]
			]
			OP_CLEAR [
				BS_PROCESS_CLEAR_VIRTUAL(bits upper)
				while [lower <= upper][
					BS_CLEAR_BIT(pbits lower)			;-- could be optimized by clearing bytes directly
					lower: lower + 1
				]
			]
		]
		1
	]

	process-string: func [
		str		[red-string!]
		bits 	[red-bitset!]
		op		[bitset-op!]
		return: [integer!]
		/local
			s	  [series!]
			p	  [byte-ptr!]
			tail  [byte-ptr!]
			pos	  [byte-ptr!]
			pbits [byte-ptr!]
			p4	  [int-ptr!]
			unit  [integer!]
			max   [integer!]
			cp	  [integer!]
			size  [integer!]
			test? [logic!]
			set?  [logic!]
			not?  [logic!]
	][
		s:	  GET_BUFFER(str)
		unit: GET_UNIT(s)
		p:	  (as byte-ptr! s/offset) + (str/head << (unit >> 1))
		tail: as byte-ptr! s/tail
		max:  0
		size: s/size << 3
		not?: FLAG_NOT?(s)

		unless null? bits [pbits: rs-head bits]
		test?: op = OP_TEST

		while [p < tail][
			switch unit [
				Latin1 [cp: as-integer p/1]
				UCS-2  [cp: (as-integer p/2) << 8 + p/1]
				UCS-4  [p4: as int-ptr! p cp: p4/1]
			]
			switch op [
				OP_MAX	 []
				OP_SET	 [BS_SET_BIT(pbits cp)]
				OP_TEST	 [
					if size < cp [return as-integer not?]
					BS_TEST_BIT(pbits cp set?)
				]
				OP_CLEAR [
					if size < cp [return as-integer not?]
					BS_CLEAR_BIT(pbits cp)
				]
			]
			if cp > max [max: cp]

			if all [test? not set?][return 0]
			p: p + unit
		]
		either all [test? set?][1][max]
	]

	process: func [
		spec	[red-value!]
		bits 	[red-bitset!]
		op		[bitset-op!]
		sub?	[logic!]
		return: [integer!]
		/local
			int	  [red-integer!]
			char  [red-char!]
			w	  [red-word!]
			value [red-value!]
			tail  [red-value!]
			pos	  [byte-ptr!]
			pbits [byte-ptr!]
			max	  [integer!]
			min	  [integer!]
			size  [integer!]
			type  [integer!]
			s	  [series!]
			test? [logic!]
			not?  [logic!]
	][
		max: 0

		switch TYPE_OF(spec) [
			TYPE_CHAR
			TYPE_INTEGER [
				type: TYPE_OF(spec)
				max: either type = TYPE_CHAR [
					char: as red-char! spec
					char/value
				][
					int: as red-integer! spec
					int/value
				]
				unless op = OP_MAX [
					s: GET_BUFFER(bits)
					not?: FLAG_NOT?(s)
					pbits: rs-head bits

					switch op [
						OP_SET [
							BS_PROCESS_SET_VIRTUAL(bits max)
							BS_SET_BIT(pbits max)
						]
						OP_TEST [
							if virtual-bit? bits max [return as-integer not?]
							BS_TEST_BIT(pbits max test?)
							max: as-integer test?
						]
						OP_CLEAR [
							BS_PROCESS_CLEAR_VIRTUAL(bits max)
							BS_CLEAR_BIT(pbits max)
						]
					]
				]
			]
			TYPE_STRING [
				unless op = OP_MAX [
					s: GET_BUFFER(bits)
					not?: FLAG_NOT?(s)

					switch op [
						OP_SET [
							max: process-string as red-string! spec bits OP_MAX
							BS_PROCESS_SET_VIRTUAL(bits max)
						]
						OP_CLEAR [
							max: process-string as red-string! spec bits OP_MAX
							BS_PROCESS_CLEAR_VIRTUAL(bits max)
						]
						default []
					]
				]
				max: process-string as red-string! spec bits op
			]
			TYPE_BINARY [
				--NOT_IMPLEMENTED--
			]
			TYPE_BLOCK [
				value: block/rs-head as red-block! spec
				tail:  block/rs-tail as red-block! spec
				test?: op = OP_TEST

				while [value < tail][
					size: process value bits op yes
					if all [test? zero? size][return 0]	;-- size > 0 => TRUE, 0 => FALSE

					type: TYPE_OF(value)
					if all [
						any [type = TYPE_CHAR type = TYPE_INTEGER]
						value + 1 < tail
					][
						w: as red-word! value + 1
						if all [
							TYPE_OF(w) = TYPE_WORD
							w/symbol = words/dash
						][
							value: value + 2
							type: TYPE_OF(value)
							either all [
								value < tail
								any [type = TYPE_CHAR type = TYPE_INTEGER]
							][
								min: size
								size: either type = TYPE_CHAR [
									char: as red-char! value
									char/value
								][
									int: as red-integer! value
									int/value
								]
								switch op [
									OP_MAX	 []			;-- do nothing
									OP_SET	 [process-range 	 bits min size op]
									OP_TEST	 [max: process-range bits min size op]
									OP_CLEAR [process-range		 bits min size op]
								]
							][
								print-line "*** Make Error: invalid upper bound in bitset range"
							]
						]
					]
					if size > max [max: size]
					value: value + 1
				]
			]
			default [
				print-line "*** Make Error: bitset spec argument not supported!"
			]
		]

		if all [not sub? any [op = OP_SET op = OP_MAX]][
			max: max + 8 and -8	>> 3					;-- round to byte
			if zero? max [max: 1]

			if op = OP_SET [
				s: GET_BUFFER(bits)
				tail: as red-value! ((as byte-ptr! s/offset) + max)
				if tail > s/tail [s/tail: tail]			;-- move tail pointer forward if expanded bitset
			]
		]
		max
	]

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

		copy-cell as red-value! bits stack/push*
	]

	;-- Actions --

	make: func [
		proto	[red-value!]
		spec	[red-value!]
		return: [red-bitset!]
		/local
			bits [red-bitset!]
			size [integer!]
			int	 [red-integer!]
			blk	 [red-block!]
			w	 [red-word!]
			s	 [series!]
			op	 [integer!]
			not? [logic!]
			byte [byte!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/make"]]

		bits: as red-bitset! stack/push*
		bits/header: TYPE_BITSET						;-- implicit reset of all header flags

		either TYPE_OF(spec) = TYPE_INTEGER [
			int: as red-integer! spec
			size: int/value
			if size <= 0 [print-line "*** Make Error: bitset invalid integer argument!"]
			size: either zero? (size and 7) [size][size + 8 and -8]	;-- round to byte multiple
			size: size >> 3								;-- convert to bytes
			bits/node: alloc-bytes-filled size null-byte

			s: GET_BUFFER(bits)
			s/tail: as cell! ((as byte-ptr! s/offset) + size)
		][
			not?: no

			if TYPE_OF(spec) = TYPE_BLOCK [
				blk: as red-block! spec
				w: as red-word! block/rs-head blk
				not?: all [
					TYPE_OF(w) = TYPE_WORD
					w/symbol = words/not*
				]
				if not? [blk/head: blk/head + 1]		;-- skip NOT
			]
			byte: either not? [#"^(FF)"][null-byte]
			op: either not? [OP_CLEAR][OP_SET]

			size: process spec null OP_MAX no			;-- 1st pass: determine size
			bits/node: alloc-bytes-filled size byte
			if not? [
				s: GET_BUFFER(bits)
				s/flags: s/flags or flag-bitset-not
			]
			process spec bits op no						;-- 2nd pass: set bits
			if not? [blk/head: blk/head - 1]			;-- restore series argument head
		]
		bits
	]

	form: func [
		bits	[red-bitset!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
		/local
			s	 [series!]
			not? [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/form"]]

		s: GET_BUFFER(bits)
		not?: FLAG_NOT?(s)

		string/concatenate-literal buffer "make bitset! "
		if not? [string/concatenate-literal buffer "[not "]

		string/concatenate-literal buffer "#{"
		part: form-bytes bits buffer OPTION?(arg) part - 13 not?
		string/append-char GET_BUFFER(buffer) as-integer #"}"

		either not? [
			string/append-char GET_BUFFER(buffer)as-integer #"]"
			part - 7									;-- account for extra chars
		][
			part - 1
		]
	]

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

		form bits buffer arg part
	]

	compare: func [
		bs1	   	[red-block!]							;-- first operand
		bs2   	[red-block!]							;-- second operand
		op		[integer!]								;-- type of comparison
		return: [logic!]
		/local
			s1	  [series!]
			s2	  [series!]
			head  [byte-ptr!]
			p	  [byte-ptr!]
			p2	  [byte-ptr!]
			size  [integer!]
			not?  [logic!]
			not2? [logic!]
			res	  [logic!]
			b1	  [byte!]
			b2	  [byte!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/compare"]]

		if TYPE_OF(bs2) <> TYPE_BITSET [RETURN_COMPARE_OTHER]

		s: 	  GET_BUFFER(bs1)
		head: as byte-ptr! s/offset
		p:	  as byte-ptr! s/tail
		size: s/size
		not?: FLAG_NOT?(s)
		s: 	  GET_BUFFER(bs2)
		p2:   as byte-ptr! s/tail

		if size <> s/size [
			switch op [
				COMP_EQUAL 			[res: false]
				COMP_NOT_EQUAL 		[res: true]
				COMP_STRICT_EQUAL	[res: false]
				COMP_LESSER			[res: size <  s/size]
				COMP_LESSER_EQUAL	[res: size <= s/size]
				COMP_GREATER		[res: size >  s/size]
				COMP_GREATER_EQUAL	[res: size >= s/size]
			]
			return res
		]
		not2?: FLAG_NOT?(s)
		if not? <> not2? [
			if any [op = COMP_EQUAL op = COMP_STRICT_EQUAL][return false]
			if op = COMP_NOT_EQUAL [return true]
		]
		if zero? size [									;-- shortcut exit for empty bitsets
			return any [op = COMP_EQUAL op = COMP_STRICT_EQUAL]
		]
		if all [
			op <> COMP_EQUAL
			op <> COMP_NOT_EQUAL
			op <> COMP_STRICT_EQUAL
			any [not? not2?]							;-- lesser/greater with complemented and normal bitsets
		][
			switch op [
				COMP_LESSER			[res: not? <  not2?]
				COMP_LESSER_EQUAL	[res: not? <= not2?]
				COMP_GREATER		[res: not? >  not2?]
				COMP_GREATER_EQUAL	[res: not? >= not2?]
			]
			return res
		]

		until [											;-- bits difference search (starting from highest bits)
			p: p - 1
			p2: p2 - 1
			any [p/value <> p2/value p = head]
		]
		b1: p/value
		b2: p2/value

		switch op [
			COMP_EQUAL 			[res: b1 =  b2]
			COMP_NOT_EQUAL 		[res: b1 <> b2]
			COMP_STRICT_EQUAL	[res: b1 =  b2]
			COMP_LESSER			[res: b1 <  b2]
			COMP_LESSER_EQUAL	[res: b1 <= b2]
			COMP_GREATER		[res: b1 >  b2]
			COMP_GREATER_EQUAL	[res: b1 >= b2]
		]
		res
	]

	eval-path: func [
		parent	[red-bitset!]							;-- implicit type casting
		element	[red-value!]
		set?	[logic!]
		return:	[red-value!]
		/local
			int [red-integer!]
	][
		switch TYPE_OF(element) [
			TYPE_INTEGER [
				int: as red-integer! element
				either set? [
					poke parent int/value stack/arguments element
					stack/arguments
				][
					pick parent int/value element
				]
			]
			default [
				print-line "*** Error: invalid value in path!"
				halt
				null
			]
		]
	]

	negate: func [
		bits	[red-bitset!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/negate"]]

		as red-value! complement bits
	]

	complement: func [
		bits	[red-bitset!]
		return:	[red-value!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/complement"]]

		bits: copy bits as red-bitset! stack/push* null no null
		s: GET_BUFFER(bits)
		s/flags: s/flags xor flag-bitset-not
		invert-bytes s
		as red-value! bits
	]

	clear: func [
		bits	 [red-bitset!]
		return:	[red-value!]
		/local
			s	 [series!]
			p	 [byte-ptr!]
			tail [byte-ptr!]
			byte [byte!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/clear"]]

		s: 	  GET_BUFFER(bits)
		p: 	  as byte-ptr! s/offset
		tail: as byte-ptr! s/tail

		byte: either FLAG_NOT?(s) [#"^(FF)"][null-byte]
		while [p < tail][p/value: byte p: p + 1]
		as red-value! bits
	]

	copy: func [
		bits	 [red-bitset!]
		new		 [red-bitset!]
		part-arg [red-value!]
		deep?	 [logic!]
		types	 [red-value!]
		return:	 [red-bitset!]
		/local
			s [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/copy"]]

		s: GET_BUFFER(bits)
		new/header: TYPE_BITSET
		new/node:	copy-series s
		new
	]

	find: func [
		bits	 [red-bitset!]
		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!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/find"]]

		pick bits 0 value
	]

	insert: func [
		bits	 [red-bitset!]
		value	 [red-value!]
		part-arg [red-value!]
		only?	 [logic!]
		dup-arg	 [red-value!]
		append?	 [logic!]
		return:	 [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/insert"]]

		process value bits OP_SET no
		as red-value! bits
	]

	length?: func [
		bits	[red-bitset!]
		return: [integer!]
		/local
			s [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/length?"]]

		s: GET_BUFFER(bits)
		(as-integer s/tail - s/offset) << 3
	]

	pick: func [
		bits	[red-bitset!]
		index	[integer!]
		boxed	[red-value!]
		return:	[red-value!]
		/local
			set? [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/pick"]]

		set?: process boxed bits OP_TEST yes
		as red-value! either positive? set? [true-value][false-value]
	]

	poke: func [
		bits	[red-bitset!]
		index	[integer!]
		data	[red-value!]
		boxed	[red-value!]
		return:	[red-value!]
		/local
			bool  [red-logic!]
			int	  [red-integer!]
			type  [integer!]
			op	  [integer!]
			s	  [series!]
			not?  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/poke"]]

		type: TYPE_OF(data)
		bool: as red-logic! data
		int:  as red-integer! data
		s:	  GET_BUFFER(bits)
		not?: FLAG_NOT?(s)

		op: either any [
			type = TYPE_NONE
			all [type = TYPE_LOGIC not bool/value]
			all [type = TYPE_INTEGER zero? int/value]
		][
			OP_CLEAR
		][
			OP_SET
		]
		process boxed bits op no
		as red-value! data
	]

	remove: func [
		bits	[red-bitset!]
		part	[red-value!]
		return:	[red-value!]
		/local
			s  [series!]
			op [integer!]
	][
		unless OPTION?(part) [
			print-line "Remove Error: /part is required for bitset argument"
		]
		s: GET_BUFFER(bits)
		op: either FLAG_NOT?(s) [OP_SET][OP_CLEAR]
		process part bits op no
		as red-value! bits
	]

	init: does [
		datatype/register [
			TYPE_BITSET
			TYPE_VALUE
			"bitset!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			null			;absolute
			null			;add
			null			;divide
			null			;multiply
			:negate
			null			;power
			null			;remainder
			null			;round
			null			;subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			:and~
			:complement
			:or~
			:xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			:clear
			:copy
			:find
			null			;head
			null			;head?
			null			;index?
			:insert
			:length?
			null			;next
			:pick
			:poke
			: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:   "Bitset datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %bitset.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
	}
]

bitset: context [
	verbose: 0

	#enum bitset-op! [
		OP_MAX											;-- calculate highest value
		OP_SET											;-- set value bits
		OP_TEST											;-- test if value bits are set
		OP_CLEAR										;-- clear value bits
		OP_UNION
		OP_AND
		OP_OR
		OP_XOR
	]

	rs-head: func [
		bits	[red-bitset!]
		return: [byte-ptr!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(bits)
		as byte-ptr! s/offset
	]

	rs-tail: func [
		bits	[red-bitset!]
		return: [byte-ptr!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(bits)
		as byte-ptr! s/tail
	]

	bound-check: func [
		bits	[red-bitset!]
		index	[integer!]								;-- 0-based
		return: [byte-ptr!]
		/local
			s	 [series!]
			p	 [byte-ptr!]
			not? [logic!]
			byte [byte!]
	][
		s: GET_BUFFER(bits)
		if (s/size << 3) < index [
			byte: either FLAG_NOT?(s) [#"^(FF)"][null-byte]
			s: expand-series-filled s (index >> 3) + 1 byte
		]

		p: (as byte-ptr! s/offset) + (index >> 3) + 1
		if p > as byte-ptr! s/tail [s/tail: as cell! p]	;-- move forward tail pointer if required
		as byte-ptr! s/offset
	]

	virtual-bit?: func [
		bits	[red-bitset!]
		index	[integer!]								;-- 0-based
		return: [logic!]
		/local
			s [series!]
			p [byte-ptr!]
	][
		s: GET_BUFFER(bits)
		p: (as byte-ptr! s/offset) + (index >> 3) + 1
		any [index < 0 p > as byte-ptr! s/tail]
	]

	invert-bytes: func [
		s [series!]
		/local
			p	 [byte-ptr!]
			tail [byte-ptr!]
	][
		p:	  as byte-ptr! s/offset
		tail: p + s/size

		while [p < tail][
			p/value: not p/value
			p: p + 1
		]
	]

	form-bytes: func [
		bits	[red-bitset!]
		buffer	[red-string!]
		part?	[logic!]
		part	[integer!]
		invert? [logic!]
		return:	[integer!]
		/local
			s	   [series!]
			p	   [byte-ptr!]
			tail   [byte-ptr!]
			byte   [integer!]
			c	   [byte!]
			nibble [integer!]
	][
		s:	  GET_BUFFER(bits)
		p:	  as byte-ptr! s/offset
		tail: as byte-ptr! s/tail

		while [p < tail][								;@@ could be optimized for speed
			byte: as-integer p/value
			if invert? [byte: 255 - byte]

			nibble: byte >> 4							;-- high nibble
			c: either nibble < 10 [#"0" + nibble][#"A" + (nibble - 10)]
			string/append-char GET_BUFFER(buffer) as-integer c

			nibble: byte and 15							;-- low nibble
			c: either nibble < 10 [#"0" + nibble][#"A" + (nibble - 10)]
			string/append-char GET_BUFFER(buffer) as-integer c

			p: p + 1
			part: part - 1
			if all [part? negative? part][return part]
		]
		part
	]

	do-bitwise: func [
		type	[integer!]
		return: [red-bitset!]
		/local
			set1  [red-bitset!]
			set2  [red-bitset!]
			s1	  [series!]
			s2	  [series!]
			s	  [series!]
			node  [node!]
			p	  [byte-ptr!]
			p1	  [byte-ptr!]
			p2	  [byte-ptr!]
			tail  [byte-ptr!]
			same? [logic!]
	][
		set1: as red-bitset! stack/arguments
		set2: set1 + 1
		s1: GET_BUFFER(set1)
		s2: GET_BUFFER(set2)

		if (length? set1) > (length? set2) [s: s1 s1: s2 s2: s]		;-- exchange s1 <=> s2
		same?: (s1/flags and flag-bitset-not) = (s2/flags and flag-bitset-not)

		node: alloc-bytes s2/size
		s: as series! node/value
		p: as byte-ptr! s/offset
		unless same? [s/flags: s/flags or flag-bitset-not]

		p1:	  as byte-ptr! s1/offset
		tail: as byte-ptr! s1/tail
		p2:	  as byte-ptr! s2/offset

		until [
			p/value: switch type [
				OP_UNION
				OP_OR	[p1/value or p2/value]			;-- OR s1 with part(s2)
				OP_AND	[p1/value and p2/value]
				OP_XOR	[p1/value xor p2/value]
			]
			p:  p  + 1
			p1: p1 + 1
			p2: p2 + 1
			p1 = tail
		]
		tail: as byte-ptr! s2/tail

		if p2 < tail [
			switch type [
				OP_UNION
				OP_OR	[
					copy-memory p p2 as-integer tail - p2	;-- just copy remaining of s2
					p: p + as-integer tail - p2
				]
				OP_AND  []									;-- do nothing
				OP_XOR	[
					until [
						p/value: null-byte xor p2/value
						p:  p  + 1
						p2: p2 + 1
						p2 = tail
					]
				]
			]
		]
		s/tail: as red-value! p

		set1: as red-bitset! stack/push*
		set1/header: TYPE_BITSET
		set1/node:	 node
		stack/set-last as red-value! set1
		set1
	]

	union: func [
		case?	[logic!]
		skip	[red-value!]
		return: [red-bitset!]
	][
		do-bitwise OP_UNION
	]

	and~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "bitset/and~"]]
		as red-value! do-bitwise OP_AND
	]

	or~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "bitset/or~"]]
		as red-value! do-bitwise OP_OR
	]

	xor~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "bitset/xor~"]]
		as red-value! do-bitwise OP_XOR
	]

	process-range: func [
		bits 	[red-bitset!]
		lower	[integer!]
		upper	[integer!]
		op		[integer!]
		return: [integer!]
		/local
			pos	  [byte-ptr!]
			pbits [byte-ptr!]
			set?  [logic!]
			s	  [series!]
			not?  [logic!]
	][
		s: GET_BUFFER(bits)
		not?: FLAG_NOT?(s)
		pbits: rs-head bits

		switch op [
			OP_SET [
				BS_PROCESS_SET_VIRTUAL(bits upper)
				while [lower <= upper][
					BS_SET_BIT(pbits lower)				;-- could be optimized by setting bytes directly
					lower: lower + 1
				]
			]
			OP_TEST [
				if virtual-bit? bits upper [return as-integer not?]
				while [lower <= upper][
					BS_TEST_BIT(pbits lower set?)		;-- could be optimized by testing bytes directly
					unless set? [return 0]
					lower: lower + 1
				]
			]
			OP_CLEAR [
				BS_PROCESS_CLEAR_VIRTUAL(bits upper)
				while [lower <= upper][
					BS_CLEAR_BIT(pbits lower)			;-- could be optimized by clearing bytes directly
					lower: lower + 1
				]
			]
		]
		1
	]

	process-string: func [
		str		[red-string!]
		bits 	[red-bitset!]
		op		[bitset-op!]
		return: [integer!]
		/local
			s	  [series!]
			p	  [byte-ptr!]
			tail  [byte-ptr!]
			pos	  [byte-ptr!]
			pbits [byte-ptr!]
			p4	  [int-ptr!]
			unit  [integer!]
			max   [integer!]
			cp	  [integer!]
			size  [integer!]
			test? [logic!]
			set?  [logic!]
			not?  [logic!]
	][
		s:	  GET_BUFFER(str)
		unit: GET_UNIT(s)
		p:	  (as byte-ptr! s/offset) + (str/head << (unit >> 1))
		tail: as byte-ptr! s/tail
		max:  0
		size: s/size << 3
		not?: FLAG_NOT?(s)

		unless null? bits [pbits: rs-head bits]
		test?: op = OP_TEST

		while [p < tail][
			switch unit [
				Latin1 [cp: as-integer p/1]
				UCS-2  [cp: (as-integer p/2) << 8 + p/1]
				UCS-4  [p4: as int-ptr! p cp: p4/1]
			]
			switch op [
				OP_MAX	 []
				OP_SET	 [BS_SET_BIT(pbits cp)]
				OP_TEST	 [
					if size < cp [return as-integer not?]
					BS_TEST_BIT(pbits cp set?)
				]
				OP_CLEAR [
					if size < cp [return as-integer not?]
					BS_CLEAR_BIT(pbits cp)
				]
			]
			if cp > max [max: cp]

			if all [test? not set?][return 0]
			p: p + unit
		]
		either all [test? set?][1][max]
	]

	process: func [
		spec	[red-value!]
		bits 	[red-bitset!]
		op		[bitset-op!]
		sub?	[logic!]
		return: [integer!]
		/local
			int	  [red-integer!]
			char  [red-char!]
			w	  [red-word!]
			value [red-value!]
			tail  [red-value!]
			pos	  [byte-ptr!]
			pbits [byte-ptr!]
			max	  [integer!]
			min	  [integer!]
			size  [integer!]
			type  [integer!]
			s	  [series!]
			test? [logic!]
			not?  [logic!]
	][
		max: 0

		switch TYPE_OF(spec) [
			TYPE_CHAR
			TYPE_INTEGER [
				type: TYPE_OF(spec)
				max: either type = TYPE_CHAR [
					char: as red-char! spec
					char/value
				][
					int: as red-integer! spec
					int/value
				]
				unless op = OP_MAX [
					s: GET_BUFFER(bits)
					not?: FLAG_NOT?(s)
					pbits: rs-head bits

					switch op [
						OP_SET [
							BS_PROCESS_SET_VIRTUAL(bits max)
							BS_SET_BIT(pbits max)
						]
						OP_TEST [
							if virtual-bit? bits max [return as-integer not?]
							BS_TEST_BIT(pbits max test?)
							max: as-integer test?
						]
						OP_CLEAR [
							BS_PROCESS_CLEAR_VIRTUAL(bits max)
							BS_CLEAR_BIT(pbits max)
						]
					]
				]
			]
			TYPE_STRING [
				unless op = OP_MAX [
					s: GET_BUFFER(bits)
					not?: FLAG_NOT?(s)

					switch op [
						OP_SET [
							max: process-string as red-string! spec bits OP_MAX
							BS_PROCESS_SET_VIRTUAL(bits max)
						]
						OP_CLEAR [
							max: process-string as red-string! spec bits OP_MAX
							BS_PROCESS_CLEAR_VIRTUAL(bits max)
						]
						default []
					]
				]
				max: process-string as red-string! spec bits op
			]
			TYPE_BINARY [
				--NOT_IMPLEMENTED--
			]
			TYPE_BLOCK [
				value: block/rs-head as red-block! spec
				tail:  block/rs-tail as red-block! spec
				test?: op = OP_TEST

				while [value < tail][
					size: process value bits op yes
					if all [test? zero? size][return 0]	;-- size > 0 => TRUE, 0 => FALSE

					type: TYPE_OF(value)
					if all [
						any [type = TYPE_CHAR type = TYPE_INTEGER]
						value + 1 < tail
					][
						w: as red-word! value + 1
						if all [
							TYPE_OF(w) = TYPE_WORD
							w/symbol = words/dash
						][
							value: value + 2
							type: TYPE_OF(value)
							either all [
								value < tail
								any [type = TYPE_CHAR type = TYPE_INTEGER]
							][
								min: size
								size: either type = TYPE_CHAR [
									char: as red-char! value
									char/value
								][
									int: as red-integer! value
									int/value
								]
								switch op [
									OP_MAX	 []			;-- do nothing
									OP_SET	 [process-range 	 bits min size op]
									OP_TEST	 [max: process-range bits min size op]
									OP_CLEAR [process-range		 bits min size op]
								]
							][
								print-line "*** Make Error: invalid upper bound in bitset range"
							]
						]
					]
					if size > max [max: size]
					value: value + 1
				]
			]
			default [
				print-line "*** Make Error: bitset spec argument not supported!"
			]
		]

		if all [not sub? any [op = OP_SET op = OP_MAX]][
			max: max + 8 and -8	>> 3					;-- round to byte
			if zero? max [max: 1]

			if op = OP_SET [
				s: GET_BUFFER(bits)
				tail: as red-value! ((as byte-ptr! s/offset) + max)
				if tail > s/tail [s/tail: tail]			;-- move tail pointer forward if expanded bitset
			]
		]
		max
	]

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

		copy-cell as red-value! bits stack/push*
	]

	;-- Actions --

	make: func [
		proto	[red-value!]
		spec	[red-value!]
		return: [red-bitset!]
		/local
			bits [red-bitset!]
			size [integer!]
			int	 [red-integer!]
			blk	 [red-block!]
			w	 [red-word!]
			s	 [series!]
			op	 [integer!]
			not? [logic!]
			byte [byte!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/make"]]

		bits: as red-bitset! stack/push*
		bits/header: TYPE_BITSET						;-- implicit reset of all header flags

		either TYPE_OF(spec) = TYPE_INTEGER [
			int: as red-integer! spec
			size: int/value
			if size <= 0 [print-line "*** Make Error: bitset invalid integer argument!"]
			size: either zero? (size and 7) [size][size + 8 and -8]	;-- round to byte multiple
			size: size >> 3								;-- convert to bytes
			bits/node: alloc-bytes-filled size null-byte

			s: GET_BUFFER(bits)
			s/tail: as cell! ((as byte-ptr! s/offset) + size)
		][
			not?: no

			if TYPE_OF(spec) = TYPE_BLOCK [
				blk: as red-block! spec
				w: as red-word! block/rs-head blk
				not?: all [
					TYPE_OF(w) = TYPE_WORD
					w/symbol = words/not*
				]
				if not? [blk/head: blk/head + 1]		;-- skip NOT
			]
			byte: either not? [#"^(FF)"][null-byte]
			op: either not? [OP_CLEAR][OP_SET]

			size: process spec null OP_MAX no			;-- 1st pass: determine size
			bits/node: alloc-bytes-filled size byte
			if not? [
				s: GET_BUFFER(bits)
				s/flags: s/flags or flag-bitset-not
			]
			process spec bits op no						;-- 2nd pass: set bits
			if not? [blk/head: blk/head - 1]			;-- restore series argument head
		]
		bits
	]

	form: func [
		bits	[red-bitset!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
		/local
			s	 [series!]
			not? [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/form"]]

		s: GET_BUFFER(bits)
		not?: FLAG_NOT?(s)

		string/concatenate-literal buffer "make bitset! "
		if not? [string/concatenate-literal buffer "[not "]

		string/concatenate-literal buffer "#{"
		part: form-bytes bits buffer OPTION?(arg) part - 13 not?
		string/append-char GET_BUFFER(buffer) as-integer #"}"

		either not? [
			string/append-char GET_BUFFER(buffer)as-integer #"]"
			part - 7									;-- account for extra chars
		][
			part - 1
		]
	]

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

		form bits buffer arg part
	]

	compare: func [
		bs1	   	[red-block!]							;-- first operand
		bs2   	[red-block!]							;-- second operand
		op		[integer!]								;-- type of comparison
		return: [logic!]
		/local
			s1	  [series!]
			s2	  [series!]
			head  [byte-ptr!]
			p	  [byte-ptr!]
			p2	  [byte-ptr!]
			size  [integer!]
			not?  [logic!]
			not2? [logic!]
			res	  [logic!]
			b1	  [byte!]
			b2	  [byte!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/compare"]]

		if TYPE_OF(bs2) <> TYPE_BITSET [RETURN_COMPARE_OTHER]

		s: 	  GET_BUFFER(bs1)
		head: as byte-ptr! s/offset
		p:	  as byte-ptr! s/tail
		size: s/size
		not?: FLAG_NOT?(s)
		s: 	  GET_BUFFER(bs2)
		p2:   as byte-ptr! s/tail

		if size <> s/size [
			switch op [
				COMP_EQUAL 			[res: false]
				COMP_NOT_EQUAL 		[res: true]
				COMP_STRICT_EQUAL	[res: false]
				COMP_LESSER			[res: size <  s/size]
				COMP_LESSER_EQUAL	[res: size <= s/size]
				COMP_GREATER		[res: size >  s/size]
				COMP_GREATER_EQUAL	[res: size >= s/size]
			]
			return res
		]
		not2?: FLAG_NOT?(s)
		if not? <> not2? [
			if any [op = COMP_EQUAL op = COMP_STRICT_EQUAL][return false]
			if op = COMP_NOT_EQUAL [return true]
		]
		if zero? size [									;-- shortcut exit for empty bitsets
			return any [op = COMP_EQUAL op = COMP_STRICT_EQUAL]
		]
		if all [
			op <> COMP_EQUAL
			op <> COMP_NOT_EQUAL
			op <> COMP_STRICT_EQUAL
			any [not? not2?]							;-- lesser/greater with complemented and normal bitsets
		][
			switch op [
				COMP_LESSER			[res: not? <  not2?]
				COMP_LESSER_EQUAL	[res: not? <= not2?]
				COMP_GREATER		[res: not? >  not2?]
				COMP_GREATER_EQUAL	[res: not? >= not2?]
			]
			return res
		]

		until [											;-- bits difference search (starting from highest bits)
			p: p - 1
			p2: p2 - 1
			any [p/value <> p2/value p = head]
		]
		b1: p/value
		b2: p2/value

		switch op [
			COMP_EQUAL 			[res: b1 =  b2]
			COMP_NOT_EQUAL 		[res: b1 <> b2]
			COMP_STRICT_EQUAL	[res: b1 =  b2]
			COMP_LESSER			[res: b1 <  b2]
			COMP_LESSER_EQUAL	[res: b1 <= b2]
			COMP_GREATER		[res: b1 >  b2]
			COMP_GREATER_EQUAL	[res: b1 >= b2]
		]
		res
	]

	eval-path: func [
		parent	[red-bitset!]							;-- implicit type casting
		element	[red-value!]
		set?	[logic!]
		return:	[red-value!]
		/local
			int [red-integer!]
	][
		switch TYPE_OF(element) [
			TYPE_INTEGER [
				int: as red-integer! element
				either set? [
					poke parent int/value stack/arguments element
					stack/arguments
				][
					pick parent int/value element
				]
			]
			default [
				print-line "*** Error: invalid value in path!"
				halt
				null
			]
		]
	]

	negate: func [
		bits	[red-bitset!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/negate"]]

		as red-value! complement bits
	]

	complement: func [
		bits	[red-bitset!]
		return:	[red-value!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/complement"]]

		bits: copy bits as red-bitset! stack/push* null no null
		s: GET_BUFFER(bits)
		s/flags: s/flags xor flag-bitset-not
		invert-bytes s
		as red-value! bits
	]

	clear: func [
		bits	 [red-bitset!]
		return:	[red-value!]
		/local
			s	 [series!]
			p	 [byte-ptr!]
			tail [byte-ptr!]
			byte [byte!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/clear"]]

		s: 	  GET_BUFFER(bits)
		p: 	  as byte-ptr! s/offset
		tail: as byte-ptr! s/tail

		byte: either FLAG_NOT?(s) [#"^(FF)"][null-byte]
		while [p < tail][p/value: byte p: p + 1]
		as red-value! bits
	]

	copy: func [
		bits	 [red-bitset!]
		new		 [red-bitset!]
		part-arg [red-value!]
		deep?	 [logic!]
		types	 [red-value!]
		return:	 [red-bitset!]
		/local
			s [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/copy"]]

		s: GET_BUFFER(bits)
		new/header: TYPE_BITSET
		new/node:	copy-series s
		new
	]

	find: func [
		bits	 [red-bitset!]
		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!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/find"]]

		pick bits 0 value
	]

	insert: func [
		bits	 [red-bitset!]
		value	 [red-value!]
		part-arg [red-value!]
		only?	 [logic!]
		dup-arg	 [red-value!]
		append?	 [logic!]
		return:	 [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/insert"]]

		process value bits OP_SET no
		as red-value! bits
	]

	length?: func [
		bits	[red-bitset!]
		return: [integer!]
		/local
			s [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/length?"]]

		s: GET_BUFFER(bits)
		(as-integer s/tail - s/offset) << 3
	]

	pick: func [
		bits	[red-bitset!]
		index	[integer!]
		boxed	[red-value!]
		return:	[red-value!]
		/local
			set? [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/pick"]]

		set?: process boxed bits OP_TEST yes
		as red-value! either positive? set? [true-value][false-value]
	]

	poke: func [
		bits	[red-bitset!]
		index	[integer!]
		data	[red-value!]
		boxed	[red-value!]
		return:	[red-value!]
		/local
			bool  [red-logic!]
			int	  [red-integer!]
			type  [integer!]
			op	  [integer!]
			s	  [series!]
			not?  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "bitset/poke"]]

		type: TYPE_OF(data)
		bool: as red-logic! data
		int:  as red-integer! data
		s:	  GET_BUFFER(bits)
		not?: FLAG_NOT?(s)

		op: either any [
			type = TYPE_NONE
			all [type = TYPE_LOGIC not bool/value]
			all [type = TYPE_INTEGER zero? int/value]
		][
			OP_CLEAR
		][
			OP_SET
		]
		process boxed bits op no
		as red-value! data
	]

	remove: func [
		bits	[red-bitset!]
		part	[red-value!]
		return:	[red-value!]
		/local
			s  [series!]
			op [integer!]
	][
		unless OPTION?(part) [
			print-line "Remove Error: /part is required for bitset argument"
		]
		s: GET_BUFFER(bits)
		op: either FLAG_NOT?(s) [OP_SET][OP_CLEAR]
		process part bits op no
		as red-value! bits
	]

	init: does [
		datatype/register [
			TYPE_BITSET
			TYPE_VALUE
			"bitset!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			null			;absolute
			null			;add
			null			;divide
			null			;multiply
			:negate
			null			;power
			null			;remainder
			null			;round
			null			;subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			:and~
			:complement
			:or~
			:xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			:clear
			:copy
			:find
			null			;head
			null			;head?
			null			;index?
			:insert
			:length?
			null			;next
			:pick
			:poke
			: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: now lit-word! are properly coerced to word! by the interpreter when required.

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

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

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

#define CHECK_INFIX [
	if all [
		next < end
		TYPE_OF(next) = TYPE_WORD
	][
		value: _context/get next
		if TYPE_OF(value) = TYPE_OP [
			if verbose > 0 [log "infix detected!"]
			infix?: yes
		]
	]
]

interpreter: context [
	verbose: 0

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

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

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

	eval-function: func [
		fun  [red-function!]
		body [red-block!]
		/local
			saved
	][
		saved: fun/ctx/values
		fun/ctx/values: as node! stack/arguments
		eval body
		fun/ctx/values: saved
	]

	exec-routine: func [
		fun	 [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			count  [integer!]
			call
	][
		s: as series! fun/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: (routine/get-arity fun) - 1				;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert false]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			infix? [logic!]
			op	   [red-op!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op

		if verbose > 0 [
			value: stack/arguments
			print-line ["eval: op return type: " TYPE_OF(value)]
		]

		infix?: no
		next: as red-word! pc
		CHECK_INFIX
		if infix? [pc: eval-infix value pc end sub?]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		path	[red-path!]
		pos 	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			path-end  [red-value!]
			s		  [series!]
			required? [logic!]
			ref?	  [logic!]
			index	  [integer!]
			count	  [integer!]
			prev	  [integer!]
			size	  [integer!]
			ref-array [int-ptr!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]

		s: as series! either function? [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]

		value: s/offset
		tail:  s/tail

		unless null? path [
			path-end: block/rs-tail as red-block! path
			if pos + 1 = path-end [path: null]			;-- no refinement following the function
		]												;-- so, process it as a non-path call

		count:  	 0									;-- nb of fetched arguments (used as offset)
		index: 	 	 1
		return-type: -1
		ref?:		 no
		required?:	 yes								;-- yes: processing mandatory args, no: optonal args

		size: as-integer tail - value
		ref-array: system/stack/top - size
		system/stack/top: ref-array						;-- reserve space on native stack for refs array

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD [
					unless required? [
						either ref? [
							unless function? [
								prev: index - 1			;-- overwrite previous entry if it was a ref marker
								either negative? ref-array/prev [
									ref-array/prev: count
									index: prev
								][
									ref-array/index: count
								]

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

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

					either function? [
						logic/push ref?
					][
						ref-array/index: either ref? [count][-1]
						index: index + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]

		unless function? [
			system/stack/top: ref-array					;-- reset native stack to our custom arguments frame
			call: as function! [] native/code			;-- direct call for actions/natives
			call
		]
		pc
	]

	eval-path-element: func [
		slot     [red-value!]
		head     [red-value!]
		tail     [red-value!]
		result   [red-value!]
		alt-slot [red-value!]							;-- alternative element (computed from paren)
		set?     [logic!]
		return:  [red-value!]
		/local
			value  [red-value!]
			int	   [red-integer!]
	][
		value: case [
			TYPE_OF(slot) = TYPE_GET_WORD [_context/get as red-word! slot]
			null? alt-slot 				  [slot]
			true		   				  [alt-slot]
		]
		switch TYPE_OF(value) [
			TYPE_WORD [
				either slot = head [
					result: _context/get as red-word! value
					switch TYPE_OF(result) [
						TYPE_UNSET [
							return unset-value
						]
						TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
						TYPE_NATIVE
						TYPE_ROUTINE
						TYPE_FUNCTION [
							return result
						]
						TYPE_BLOCK 						;@@ replace with TYPE_SERIES
						TYPE_PATH
						TYPE_LIT_PATH
						TYPE_GET_PATH
						TYPE_SET_PATH
						TYPE_STRING
						TYPE_FILE [

						]
						;TYPE_OBJECT
						;TYPE_PORT [
						;
						;]
						default [
							;; TBD raise an error
						]
					]
				][
					result: either all [set? slot + 1 = tail][
						value: actions/find as red-series! result value null no no no null null no no no no
						actions/poke as red-series! value 2 stack/arguments
						stack/arguments
					][
						actions/select as red-series! result value null no no no null null no no
					]
				]
			]
			TYPE_PAREN [
				stack/mark-native words/_body			;@@ ~paren
				eval as red-block! value				;-- eval paren content
				stack/unwind
				result: eval-path-element slot head tail result stack/top - 1 set?
			]
			TYPE_INTEGER [
				int: as red-integer! value
				result: either all [set? slot + 1 = tail][
					actions/poke as red-series! result int/value stack/arguments
					stack/arguments
				][
					actions/pick as red-series! result int/value
				]
			]
			TYPE_STRING [
				--NOT_IMPLEMENTED--
			]
		]
		result
	]

	eval-path: func [
		value   [red-value!]
		pc		[red-value!]							;-- path to evaluate
		end		[red-value!]
		set?	[logic!]
		return: [red-value!]
		/local
			path   [red-path!]
			head   [red-value!]
			tail   [red-value!]
			slot   [red-value!]
			result [red-value!]
			saved  [red-value!]
	][
		if verbose > 0 [print-line "eval: path"]

		path:  as red-path! value
		head:  block/rs-head as red-block! path
		tail:  block/rs-tail as red-block! path
		slot:  head
		saved: stack/top

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

		result: null

		while [slot < tail][
			if verbose > 1 [print-line ["slot type: " TYPE_OF(slot)]]

			result: eval-path-element slot head tail result null set?

			switch TYPE_OF(result) [
				TYPE_UNSET [
					print-line "*** Error: word in path has no value!"
					stack/push result
					return pc
				]
				TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code result pc end yes path slot
					return pc
				]
				default [0]
			]
			slot: slot + 1
		]

		stack/top: saved
		stack/push result
		pc
	]

	eval-code: func [
		value	[red-value!]
		pc		[red-value!]
		end		[red-value!]
		sub?	[logic!]
		path	[red-path!]
		slot 	[red-value!]
		return: [red-value!]
		/local
			fun	   [red-function!]
			native [red-native!]
			s	   [series!]
			call
	][
		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				if verbose > 0 [log "pushing action/native frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot 	;-- fetch args and exec
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: action/native return type: " TYPE_OF(value)]
				]
			]
			TYPE_ROUTINE [
				if verbose > 0 [log "pushing routine frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot
				exec-routine as red-routine! value
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: routine return type: " TYPE_OF(value)]
				]
			]
			TYPE_FUNCTION [
				if verbose > 0 [log "pushing function frame"]
				stack/mark-func as red-word! pc	;@@
				pc: eval-arguments as red-native! value pc end path slot
				fun: as red-function! value
				s: as series! fun/more/value

				native: as red-native! s/offset + 2
				either zero? native/code [
					eval-function fun as red-block! s/offset
				][
					call: as function! [] native/code
					call
					0
				]
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: function return type: " TYPE_OF(value)]
				]
			]
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		prefix?	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			value  [red-value!]
			w	   [red-word!]
			op	   [red-value!]
			infix? [logic!]
	][
		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

		infix?: no
		unless prefix? [
			next: as red-word! pc + 1
			CHECK_INFIX
			if infix? [
				stack/mark-native as red-word! pc + 1
				sub?: yes								;-- force sub? for infix expressions
				op: value
			]
		]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no yes		;-- yes: push value on top of stack
				pc: eval-path value pc end yes
			]
			TYPE_GET_WORD [
				copy-cell _context/get as red-word! pc stack/push*
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				w: word/push as red-word! pc			;-- push lit-word! on stack
				w/header: TYPE_WORD						;-- coerce it to a word!
				pc: pc + 1
			]
			TYPE_WORD [
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_UNSET [
						print-line "*** Error: word has no value!"
						stack/set-last unset-value
					]
					TYPE_LIT_WORD [
						w: word/push as red-word! value	;-- push lit-word! on stack
						w/header: TYPE_WORD				;-- coerce it to a word!
					]
					TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: word return type: " TYPE_OF(value)]
						]
					]
				]
			]
			TYPE_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no
			]
			TYPE_LIT_PATH [
				value: stack/push pc
				value/header: TYPE_PATH
				pc: pc + 1
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]

		if infix? [
			pc: eval-infix op pc end sub?
			unless prefix? [
				either sub? [stack/unwind][stack/unwind-last]
			]
		]
		pc
	]

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

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

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

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

		stack/unwind-last
	]

]

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

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

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

#define CHECK_INFIX [
	if all [
		next < end
		TYPE_OF(next) = TYPE_WORD
	][
		value: _context/get next
		if TYPE_OF(value) = TYPE_OP [
			if verbose > 0 [log "infix detected!"]
			infix?: yes
		]
	]
]

interpreter: context [
	verbose: 0

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

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

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

	eval-function: func [
		fun  [red-function!]
		body [red-block!]
		/local
			saved
	][
		saved: fun/ctx/values
		fun/ctx/values: as node! stack/arguments
		eval body
		fun/ctx/values: saved
	]

	exec-routine: func [
		fun	 [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			count  [integer!]
			call
	][
		s: as series! fun/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: (routine/get-arity fun) - 1				;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert false]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			infix? [logic!]
			op	   [red-op!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op

		if verbose > 0 [
			value: stack/arguments
			print-line ["eval: op return type: " TYPE_OF(value)]
		]

		infix?: no
		next: as red-word! pc
		CHECK_INFIX
		if infix? [pc: eval-infix value pc end sub?]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		path	[red-path!]
		pos 	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			path-end  [red-value!]
			s		  [series!]
			required? [logic!]
			ref?	  [logic!]
			index	  [integer!]
			count	  [integer!]
			prev	  [integer!]
			size	  [integer!]
			ref-array [int-ptr!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]

		s: as series! either function? [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]

		value: s/offset
		tail:  s/tail

		unless null? path [
			path-end: block/rs-tail as red-block! path
			if pos + 1 = path-end [path: null]			;-- no refinement following the function
		]												;-- so, process it as a non-path call

		count:  	 0									;-- nb of fetched arguments (used as offset)
		index: 	 	 1
		return-type: -1
		ref?:		 no
		required?:	 yes								;-- yes: processing mandatory args, no: optonal args

		size: as-integer tail - value
		ref-array: system/stack/top - size
		system/stack/top: ref-array						;-- reserve space on native stack for refs array

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD [
					unless required? [
						either ref? [
							unless function? [
								prev: index - 1			;-- overwrite previous entry if it was a ref marker
								either negative? ref-array/prev [
									ref-array/prev: count
									index: prev
								][
									ref-array/index: count
								]

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

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

					either function? [
						logic/push ref?
					][
						ref-array/index: either ref? [count][-1]
						index: index + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]

		unless function? [
			system/stack/top: ref-array					;-- reset native stack to our custom arguments frame
			call: as function! [] native/code			;-- direct call for actions/natives
			call
		]
		pc
	]

	eval-path-element: func [
		slot     [red-value!]
		head     [red-value!]
		tail     [red-value!]
		result   [red-value!]
		alt-slot [red-value!]							;-- alternative element (computed from paren)
		set?     [logic!]
		return:  [red-value!]
		/local
			value  [red-value!]
			int	   [red-integer!]
	][
		value: case [
			TYPE_OF(slot) = TYPE_GET_WORD [_context/get as red-word! slot]
			null? alt-slot 				  [slot]
			true		   				  [alt-slot]
		]
		switch TYPE_OF(value) [
			TYPE_WORD [
				either slot = head [
					result: _context/get as red-word! value
					switch TYPE_OF(result) [
						TYPE_UNSET [
							return unset-value
						]
						TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
						TYPE_NATIVE
						TYPE_ROUTINE
						TYPE_FUNCTION [
							return result
						]
						TYPE_BLOCK 						;@@ replace with TYPE_SERIES
						TYPE_PATH
						TYPE_LIT_PATH
						TYPE_GET_PATH
						TYPE_SET_PATH
						TYPE_STRING
						TYPE_FILE [

						]
						;TYPE_OBJECT
						;TYPE_PORT [
						;
						;]
						default [
							;; TBD raise an error
						]
					]
				][
					result: either all [set? slot + 1 = tail][
						value: actions/find as red-series! result value null no no no null null no no no no
						actions/poke as red-series! value 2 stack/arguments
						stack/arguments
					][
						actions/select as red-series! result value null no no no null null no no
					]
				]
			]
			TYPE_PAREN [
				stack/mark-native words/_body			;@@ ~paren
				eval as red-block! value				;-- eval paren content
				stack/unwind
				result: eval-path-element slot head tail result stack/top - 1 set?
			]
			TYPE_INTEGER [
				int: as red-integer! value
				result: either all [set? slot + 1 = tail][
					actions/poke as red-series! result int/value stack/arguments
					stack/arguments
				][
					actions/pick as red-series! result int/value
				]
			]
			TYPE_STRING [
				--NOT_IMPLEMENTED--
			]
		]
		result
	]

	eval-path: func [
		value   [red-value!]
		pc		[red-value!]							;-- path to evaluate
		end		[red-value!]
		set?	[logic!]
		return: [red-value!]
		/local
			path   [red-path!]
			head   [red-value!]
			tail   [red-value!]
			slot   [red-value!]
			result [red-value!]
			saved  [red-value!]
	][
		if verbose > 0 [print-line "eval: path"]

		path:  as red-path! value
		head:  block/rs-head as red-block! path
		tail:  block/rs-tail as red-block! path
		slot:  head
		saved: stack/top

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

		result: null

		while [slot < tail][
			if verbose > 1 [print-line ["slot type: " TYPE_OF(slot)]]

			result: eval-path-element slot head tail result null set?

			switch TYPE_OF(result) [
				TYPE_UNSET [
					print-line "*** Error: word in path has no value!"
					stack/push result
					return pc
				]
				TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code result pc end yes path slot
					return pc
				]
				default [0]
			]
			slot: slot + 1
		]

		stack/top: saved
		stack/push result
		pc
	]

	eval-code: func [
		value	[red-value!]
		pc		[red-value!]
		end		[red-value!]
		sub?	[logic!]
		path	[red-path!]
		slot 	[red-value!]
		return: [red-value!]
		/local
			fun	   [red-function!]
			native [red-native!]
			s	   [series!]
			call
	][
		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				if verbose > 0 [log "pushing action/native frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot 	;-- fetch args and exec
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: action/native return type: " TYPE_OF(value)]
				]
			]
			TYPE_ROUTINE [
				if verbose > 0 [log "pushing routine frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot
				exec-routine as red-routine! value
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: routine return type: " TYPE_OF(value)]
				]
			]
			TYPE_FUNCTION [
				if verbose > 0 [log "pushing function frame"]
				stack/mark-func as red-word! pc	;@@
				pc: eval-arguments as red-native! value pc end path slot
				fun: as red-function! value
				s: as series! fun/more/value

				native: as red-native! s/offset + 2
				either zero? native/code [
					eval-function fun as red-block! s/offset
				][
					call: as function! [] native/code
					call
					0
				]
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: function return type: " TYPE_OF(value)]
				]
			]
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		prefix?	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			value  [red-value!]
			w	   [red-word!]
			op	   [red-value!]
			infix? [logic!]
	][
		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

		infix?: no
		unless prefix? [
			next: as red-word! pc + 1
			CHECK_INFIX
			if infix? [
				stack/mark-native as red-word! pc + 1
				sub?: yes								;-- force sub? for infix expressions
				op: value
			]
		]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no yes		;-- yes: push value on top of stack
				pc: eval-path value pc end yes
			]
			TYPE_GET_WORD [
				word/get as red-word! pc
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				w: word/push as red-word! pc			;-- push lit-word! on stack
				w/header: TYPE_WORD						;-- set correct value type on stack
				pc: pc + 1
			]
			TYPE_WORD [
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_UNSET [
						print-line "*** Error: word has no value!"
						stack/set-last unset-value
					]
					TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: word return type: " TYPE_OF(value)]
						]
					]
				]
			]
			TYPE_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no
			]
			TYPE_LIT_PATH [
				value: stack/push pc
				value/header: TYPE_PATH
				pc: pc + 1
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]

		if infix? [
			pc: eval-infix op pc end sub?
			unless prefix? [
				either sub? [stack/unwind][stack/unwind-last]
			]
		]
		pc
	]

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

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

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

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

		stack/unwind-last
	]

]


FEAT: adds KEY-OF definition.

FEAT: adds KEY-OF definition.

It is just a convenient alias over WORDS-OF.

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

attempt: func [
	"Tries to evaluate and returns result or NONE on error"
	value
][
	if not error? set/any 'value try :value [get/any 'value]
]

comment: func [value][]

quit: func [
	"Stops evaluation and exits the program"
	/return status	[integer!] "Return an exit status"
][
	quit-return any [status 0]
]

empty?: func [
	"Returns true if a series is at its tail"
	series	[series! none!]
	return:	[logic!]
][
	either series = none [true][tail? series]
]

??: func [
	"Prints a word and the value it refers to (molded)"
	'value [word!]
][
	prin mold :value
	prin ": "
	either value? :value [
		probe get/any :value
	][
		print "unset!"
	]
]

probe: func [
	"Returns a value after printing its molded form"
	value
][
	print mold value
	value
]

quote: func [
	:value
][
	:value
]

first:	func ["Returns the first value in a series"  s [series! pair! tuple!]] [pick s 1]	;@@ temporary definitions, should be natives ?
second:	func ["Returns the second value in a series" s [series! pair! tuple!]] [pick s 2]
third:	func ["Returns the third value in a series"  s [series! pair! tuple!]] [pick s 3]
fourth:	func ["Returns the fourth value in a series" s [series! pair! tuple!]] [pick s 4]
fifth:	func ["Returns the fifth value in a series"  s [series! pair! tuple!]] [pick s 5]

last:	func ["Returns the last value in a series"  s [series!]][pick back tail s 1]

action?:	 func ["Returns true if the value is this type" value [any-type!]] [action!		= type? :value]
bitset?:	 func ["Returns true if the value is this type" value [any-type!]] [bitset!		= type? :value]
block?:		 func ["Returns true if the value is this type" value [any-type!]] [block!		= type? :value]
char?: 		 func ["Returns true if the value is this type" value [any-type!]] [char!		= type? :value]
datatype?:	 func ["Returns true if the value is this type" value [any-type!]] [datatype!	= type? :value]
error?:		 func ["Returns true if the value is this type" value [any-type!]] [error!		= type? :value]
file?:		 func ["Returns true if the value is this type" value [any-type!]] [file!		= type? :value]
float?:		 func ["Returns true if the value is this type" value [any-type!]] [float!		= type? :value]
function?:	 func ["Returns true if the value is this type" value [any-type!]] [function!	= type? :value]
get-path?:	 func ["Returns true if the value is this type" value [any-type!]] [get-path!	= type? :value]
get-word?:	 func ["Returns true if the value is this type" value [any-type!]] [get-word!	= type? :value]
hash?:		 func ["Returns true if the value is this type" value [any-type!]] [hash!		= type? :value]
integer?:    func ["Returns true if the value is this type" value [any-type!]] [integer!	= type? :value]
issue?:    	 func ["Returns true if the value is this type" value [any-type!]] [issue!		= type? :value]
lit-path?:	 func ["Returns true if the value is this type" value [any-type!]] [lit-path!	= type? :value]
lit-word?:	 func ["Returns true if the value is this type" value [any-type!]] [lit-word!	= type? :value]
logic?:		 func ["Returns true if the value is this type" value [any-type!]] [logic!		= type? :value]
map?:		 func ["Returns true if the value is this type" value [any-type!]] [map!		= type? :value]
native?:	 func ["Returns true if the value is this type" value [any-type!]] [native!		= type? :value]
none?:		 func ["Returns true if the value is this type" value [any-type!]] [none!		= type? :value]
object?:	 func ["Returns true if the value is this type" value [any-type!]] [object!		= type? :value]
op?:		 func ["Returns true if the value is this type" value [any-type!]] [op!			= type? :value]
pair?:		 func ["Returns true if the value is this type" value [any-type!]] [pair!		= type? :value]
paren?:		 func ["Returns true if the value is this type" value [any-type!]] [paren!		= type? :value]
path?:		 func ["Returns true if the value is this type" value [any-type!]] [path!		= type? :value]
percent?:	 func ["Returns true if the value is this type" value [any-type!]] [percent!	= type? :value]
refinement?: func ["Returns true if the value is this type" value [any-type!]] [refinement! = type? :value]
routine?:	 func ["Returns true if the value is this type" value [any-type!]] [routine!	= type? :value]
set-path?:	 func ["Returns true if the value is this type" value [any-type!]] [set-path!	= type? :value]
set-word?:	 func ["Returns true if the value is this type" value [any-type!]] [set-word!	= type? :value]
string?:	 func ["Returns true if the value is this type" value [any-type!]] [string!		= type? :value]
typeset?:	 func ["Returns true if the value is this type" value [any-type!]] [typeset!	= type? :value]
tuple?:		 func ["Returns true if the value is this type" value [any-type!]] [tuple!		= type? :value]
unset?:		 func ["Returns true if the value is this type" value [any-type!]] [unset!		= type? :value]
url?:		 func ["Returns true if the value is this type" value [any-type!]] [url!		= type? :value]
vector?:	 func ["Returns true if the value is this type" value [any-type!]] [vector!		= type? :value]
word?:		 func ["Returns true if the value is this type" value [any-type!]] [word!		= type? :value]

any-block?:		func ["Returns true if the value is any type of block"	  value [any-type!]][find any-block! 	type? :value]
any-function?:	func ["Returns true if the value is any type of function" value [any-type!]][find any-function! type? :value]
any-object?:	func ["Returns true if the value is any type of object"	  value [any-type!]][find any-object!	type? :value]
any-path?:		func ["Returns true if the value is any type of path"	  value [any-type!]][find any-path!		type? :value]
any-string?:	func ["Returns true if the value is any type of string"	  value [any-type!]][find any-string!	type? :value]
any-word?:		func ["Returns true if the value is any type of word"	  value [any-type!]][find any-word!		type? :value]
series?:		func ["Returns true if the value is any type of series"	  value [any-type!]][find series!		type? :value]

spec-of: func [
	"Returns the spec of a value that supports reflection"
	value
][
	reflect :value 'spec
]

body-of: func [
	"Returns the body of a value that supports reflection"
	value
][
	reflect :value 'body
]

words-of: func [
	"Returns the list of words of a value that supports reflection"
	value
][
	reflect :value 'words
]

values-of: func [
	"Returns the list of values of a value that supports reflection"
	value
][
	reflect :value 'values
]

keys-of: :words-of

context: func [spec [block!]][make object! spec]

replace: func [
	series [series!]
	pattern
	value
	/all
	/local pos len
][
	len: either series? :pattern [length? pattern][1]

	either all [
		pos: series
		either series? :pattern [
			while [pos: find pos pattern][
				remove/part pos len
				pos: insert pos value
			]
		][
			while [pos: find pos pattern][pos/1: value]
		]
	][
		if pos: find series pattern [
			remove/part pos len
			insert pos value
		]
	]
	series
]

zero?: func [
	value [number! pair!]
][
	either pair! = type? value [
		make logic! all [value/1 = 0 value/2 = 0]
	][
		value = 0
	]
]

charset: func [
	spec [block! integer! char! string!]
][
	make bitset! spec
]

p-indent: make string! 30								;@@ to be put in an local context

on-parse-event: func [
	event	[word!]   "Trace events: push, pop, fetch, match, iterate, paren, end"
	match?	[logic!]  "Result of last matching operation"
	rule	[block!]  "Current rule at current position"
	input	[series!] "Input series at next position to match"
	stack	[block!]  "Internal parse rules stack"
	return: [logic!]  "TRUE: continue parsing, FALSE: stop and exit parsing"
][
	switch event [
		push  [
			print [p-indent "-->"]
			append p-indent "  "
		]
		pop	  [
			clear back back tail p-indent
			print [p-indent "<--"]
		]
		fetch [
			print [
				p-indent "match:" mold/part rule  50 newline
				p-indent "input:" mold/part input 50 p-indent
			]
		]
		match [print [p-indent "==>" either match? ["matched"]["not matched"]]]
		end   [print ["return:" match?]]
	]
	true
]

parse-trace: func [
	"Wrapper for parse/trace using the default event processor"
	input [series!]
	rules [block!]
	/case
	/part
		limit [integer!]
	return: [logic! block!]
][
	either case [
		parse/case/trace input rules :on-parse-event
	][
		either part [
			parse/part/trace input rules limit :on-parse-event
		][
			parse/trace input rules :on-parse-event
		]
	]
]

load: function [
	"Returns a value or block of values by reading and evaluating a source"
	source [file! url! string!]
	/header "TBD: Include Red header as a loaded value"
	/all    "TBD: Don't evaluate Red header"
	/type	"TBD:"
	/part
		length [integer! string!]
	/into "Put results in out block, instead of creating a new block"
		out [block!] "Target block for results"
][
	if part [
		case [
			zero? length [return make block! 1]
			string? length [
				if (index? length) = index? source [
					return make block! 1
				]
			]
		]
	]

	unless out [out: make block! 4]
	;switch type?/word [
	;	file!	[]
	;	url!	[]
	;	binary! []
	;]
	either part [
		system/lexer/transcode/part source out length
	][
		system/lexer/transcode source out
	]
	unless :all [if 1 = length? out [out: out/1]]
	out
]

cause-error: function [
	"Causes an immediate error throw, with the provided information"
	err-type [word!]
	err-id	 [word!]
	args	 [block!]
][
	args: reduce args
	do make error! [
		type: err-type
		id: err-id
		arg1: first args
		arg2: second args
		arg3: third args
	]
]

pad: func [
	"Align a string to a given size prepending whitespaces"
	str [string!]		"String to pad"
	n	[integer!]		"Size (in characters) to align to"
	/left				"Align the string to the left side"
	return: [string!]	"Modified input string at head"
][
	head insert/dup
		any [all [left str] tail str]
		#" "
		(n - length? str)
]

modulo: func [
	"Compute a nonnegative remainder of A divided by B"
	a		[number! char! pair! tuple! vector!]
	b		[number! char! pair! tuple! vector!]
	return: [number! char! pair! tuple! vector!]
	/local r
][
	b: absolute b
    all [0 > r: a % b r: r + b]
    a: absolute a
    either all [a + r = (a + b) 0 < r + r - b] [r - b] [r]
]

eval-set-path: func [value1][]

;------------------------------------------
;-				Aliases					  -
;------------------------------------------

atan2: :arctangent2
object: :context

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

attempt: func [
	"Tries to evaluate and returns result or NONE on error"
	value
][
	if not error? set/any 'value try :value [get/any 'value]
]

comment: func [value][]

quit: func [
	"Stops evaluation and exits the program"
	/return status	[integer!] "Return an exit status"
][
	quit-return any [status 0]
]

empty?: func [
	"Returns true if a series is at its tail"
	series	[series! none!]
	return:	[logic!]
][
	either series = none [true][tail? series]
]

??: func [
	"Prints a word and the value it refers to (molded)"
	'value [word!]
][
	prin mold :value
	prin ": "
	either value? :value [
		probe get/any :value
	][
		print "unset!"
	]
]

probe: func [
	"Returns a value after printing its molded form"
	value
][
	print mold value
	value
]

quote: func [
	:value
][
	:value
]

first:	func ["Returns the first value in a series"  s [series! pair! tuple!]] [pick s 1]	;@@ temporary definitions, should be natives ?
second:	func ["Returns the second value in a series" s [series! pair! tuple!]] [pick s 2]
third:	func ["Returns the third value in a series"  s [series! pair! tuple!]] [pick s 3]
fourth:	func ["Returns the fourth value in a series" s [series! pair! tuple!]] [pick s 4]
fifth:	func ["Returns the fifth value in a series"  s [series! pair! tuple!]] [pick s 5]

last:	func ["Returns the last value in a series"  s [series!]][pick back tail s 1]

action?:	 func ["Returns true if the value is this type" value [any-type!]] [action!		= type? :value]
bitset?:	 func ["Returns true if the value is this type" value [any-type!]] [bitset!		= type? :value]
block?:		 func ["Returns true if the value is this type" value [any-type!]] [block!		= type? :value]
char?: 		 func ["Returns true if the value is this type" value [any-type!]] [char!		= type? :value]
datatype?:	 func ["Returns true if the value is this type" value [any-type!]] [datatype!	= type? :value]
error?:		 func ["Returns true if the value is this type" value [any-type!]] [error!		= type? :value]
file?:		 func ["Returns true if the value is this type" value [any-type!]] [file!		= type? :value]
float?:		 func ["Returns true if the value is this type" value [any-type!]] [float!		= type? :value]
function?:	 func ["Returns true if the value is this type" value [any-type!]] [function!	= type? :value]
get-path?:	 func ["Returns true if the value is this type" value [any-type!]] [get-path!	= type? :value]
get-word?:	 func ["Returns true if the value is this type" value [any-type!]] [get-word!	= type? :value]
hash?:		 func ["Returns true if the value is this type" value [any-type!]] [hash!		= type? :value]
integer?:    func ["Returns true if the value is this type" value [any-type!]] [integer!	= type? :value]
issue?:    	 func ["Returns true if the value is this type" value [any-type!]] [issue!		= type? :value]
lit-path?:	 func ["Returns true if the value is this type" value [any-type!]] [lit-path!	= type? :value]
lit-word?:	 func ["Returns true if the value is this type" value [any-type!]] [lit-word!	= type? :value]
logic?:		 func ["Returns true if the value is this type" value [any-type!]] [logic!		= type? :value]
map?:		 func ["Returns true if the value is this type" value [any-type!]] [map!		= type? :value]
native?:	 func ["Returns true if the value is this type" value [any-type!]] [native!		= type? :value]
none?:		 func ["Returns true if the value is this type" value [any-type!]] [none!		= type? :value]
object?:	 func ["Returns true if the value is this type" value [any-type!]] [object!		= type? :value]
op?:		 func ["Returns true if the value is this type" value [any-type!]] [op!			= type? :value]
pair?:		 func ["Returns true if the value is this type" value [any-type!]] [pair!		= type? :value]
paren?:		 func ["Returns true if the value is this type" value [any-type!]] [paren!		= type? :value]
path?:		 func ["Returns true if the value is this type" value [any-type!]] [path!		= type? :value]
percent?:	 func ["Returns true if the value is this type" value [any-type!]] [percent!	= type? :value]
refinement?: func ["Returns true if the value is this type" value [any-type!]] [refinement! = type? :value]
routine?:	 func ["Returns true if the value is this type" value [any-type!]] [routine!	= type? :value]
set-path?:	 func ["Returns true if the value is this type" value [any-type!]] [set-path!	= type? :value]
set-word?:	 func ["Returns true if the value is this type" value [any-type!]] [set-word!	= type? :value]
string?:	 func ["Returns true if the value is this type" value [any-type!]] [string!		= type? :value]
typeset?:	 func ["Returns true if the value is this type" value [any-type!]] [typeset!	= type? :value]
tuple?:		 func ["Returns true if the value is this type" value [any-type!]] [tuple!		= type? :value]
unset?:		 func ["Returns true if the value is this type" value [any-type!]] [unset!		= type? :value]
url?:		 func ["Returns true if the value is this type" value [any-type!]] [url!		= type? :value]
vector?:	 func ["Returns true if the value is this type" value [any-type!]] [vector!		= type? :value]
word?:		 func ["Returns true if the value is this type" value [any-type!]] [word!		= type? :value]

any-block?:		func ["Returns true if the value is any type of block"	  value [any-type!]][find any-block! 	type? :value]
any-function?:	func ["Returns true if the value is any type of function" value [any-type!]][find any-function! type? :value]
any-object?:	func ["Returns true if the value is any type of object"	  value [any-type!]][find any-object!	type? :value]
any-path?:		func ["Returns true if the value is any type of path"	  value [any-type!]][find any-path!		type? :value]
any-string?:	func ["Returns true if the value is any type of string"	  value [any-type!]][find any-string!	type? :value]
any-word?:		func ["Returns true if the value is any type of word"	  value [any-type!]][find any-word!		type? :value]
series?:		func ["Returns true if the value is any type of series"	  value [any-type!]][find series!		type? :value]

spec-of: func [
	"Returns the spec of a value that supports reflection"
	value
][
	reflect :value 'spec
]

body-of: func [
	"Returns the body of a value that supports reflection"
	value
][
	reflect :value 'body
]

words-of: func [
	"Returns the list of words of a value that supports reflection"
	value
][
	reflect :value 'words
]

values-of: func [
	"Returns the list of values of a value that supports reflection"
	value
][
	reflect :value 'values
]

context: func [spec [block!]][make object! spec]

replace: func [
	series [series!]
	pattern
	value
	/all
	/local pos len
][
	len: either series? :pattern [length? pattern][1]

	either all [
		pos: series
		either series? :pattern [
			while [pos: find pos pattern][
				remove/part pos len
				pos: insert pos value
			]
		][
			while [pos: find pos pattern][pos/1: value]
		]
	][
		if pos: find series pattern [
			remove/part pos len
			insert pos value
		]
	]
	series
]

zero?: func [
	value [number! pair!]
][
	either pair! = type? value [
		make logic! all [value/1 = 0 value/2 = 0]
	][
		value = 0
	]
]

charset: func [
	spec [block! integer! char! string!]
][
	make bitset! spec
]

p-indent: make string! 30								;@@ to be put in an local context

on-parse-event: func [
	event	[word!]   "Trace events: push, pop, fetch, match, iterate, paren, end"
	match?	[logic!]  "Result of last matching operation"
	rule	[block!]  "Current rule at current position"
	input	[series!] "Input series at next position to match"
	stack	[block!]  "Internal parse rules stack"
	return: [logic!]  "TRUE: continue parsing, FALSE: stop and exit parsing"
][
	switch event [
		push  [
			print [p-indent "-->"]
			append p-indent "  "
		]
		pop	  [
			clear back back tail p-indent
			print [p-indent "<--"]
		]
		fetch [
			print [
				p-indent "match:" mold/part rule  50 newline
				p-indent "input:" mold/part input 50 p-indent
			]
		]
		match [print [p-indent "==>" either match? ["matched"]["not matched"]]]
		end   [print ["return:" match?]]
	]
	true
]

parse-trace: func [
	"Wrapper for parse/trace using the default event processor"
	input [series!]
	rules [block!]
	/case
	/part
		limit [integer!]
	return: [logic! block!]
][
	either case [
		parse/case/trace input rules :on-parse-event
	][
		either part [
			parse/part/trace input rules limit :on-parse-event
		][
			parse/trace input rules :on-parse-event
		]
	]
]

load: function [
	"Returns a value or block of values by reading and evaluating a source"
	source [file! url! string!]
	/header "TBD: Include Red header as a loaded value"
	/all    "TBD: Don't evaluate Red header"
	/type	"TBD:"
	/part
		length [integer! string!]
	/into "Put results in out block, instead of creating a new block"
		out [block!] "Target block for results"
][
	if part [
		case [
			zero? length [return make block! 1]
			string? length [
				if (index? length) = index? source [
					return make block! 1
				]
			]
		]
	]

	unless out [out: make block! 4]
	;switch type?/word [
	;	file!	[]
	;	url!	[]
	;	binary! []
	;]
	either part [
		system/lexer/transcode/part source out length
	][
		system/lexer/transcode source out
	]
	unless :all [if 1 = length? out [out: out/1]]
	out
]

cause-error: function [
	"Causes an immediate error throw, with the provided information"
	err-type [word!]
	err-id	 [word!]
	args	 [block!]
][
	args: reduce args
	do make error! [
		type: err-type
		id: err-id
		arg1: first args
		arg2: second args
		arg3: third args
	]
]

pad: func [
	"Align a string to a given size prepending whitespaces"
	str [string!]		"String to pad"
	n	[integer!]		"Size (in characters) to align to"
	/left				"Align the string to the left side"
	return: [string!]	"Modified input string at head"
][
	head insert/dup
		any [all [left str] tail str]
		#" "
		(n - length? str)
]

modulo: func [
	"Compute a nonnegative remainder of A divided by B"
	a		[number! char! pair! tuple! vector!]
	b		[number! char! pair! tuple! vector!]
	return: [number! char! pair! tuple! vector!]
	/local r
][
	b: absolute b
    all [0 > r: a % b r: r + b]
    a: absolute a
    either all [a + r = (a + b) 0 < r + r - b] [r - b] [r]
]

eval-set-path: func [value1][]

;------------------------------------------
;-				Aliases					  -
;------------------------------------------

atan2: :arctangent2
object: :context