FIX: avoid runtime crash when testing of clearing out of bounds bits.

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
	]

	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!]
	][
		s: GET_BUFFER(bits)
		if (s/size << 3) < index [s: expand-series s (index >> 3) + 1]
;zeroing buffer!!!
		as byte-ptr! s/offset
	]

	out-of-bound?: func [
		bits	[red-bitset!]
		index	[integer!]								;-- 0-based
		return: [logic!]
		/local
			s [series!]
	][
		s: GET_BUFFER(bits)
		any [index < 0 (s/size << 3) < index]
	]

	form-bytes: func [
		bits	[red-bitset!]
		buffer	[red-string!]
		part?	[logic!]
		part	[integer!]
		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
			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
	]

	process-range: func [
		bits 	[red-bitset!]
		lower	[integer!]
		upper	[integer!]
		op		[integer!]
		return: [integer!]
		/local
			pos	  [byte-ptr!]
			pbits [byte-ptr!]
			set?  [logic!]
	][
		switch op [
			OP_SET [
				pbits: bound-check bits upper
				while [lower <= upper][
					BS_SET_BIT(pbits lower)				;-- could be optimized by setting bytes directly
					lower: lower + 1
				]
			]
			OP_TEST [
				if out-of-bound? bits upper [return 0]
				pbits: rs-head bits
				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 [
				if out-of-bound? bits upper [return 0]
				pbits: rs-head bits
				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		[integer!]
		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!]
	][
		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

		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 0] BS_TEST_BIT(pbits cp set?)]
				OP_CLEAR [if size < cp [return 0] BS_CLEAR_BIT(pbits max)]
			]
			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		[integer!]
		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!]
	][
		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 [
					switch op [
						OP_SET   [
							pbits: bound-check bits max
							BS_SET_BIT(pbits max)
						]
						OP_TEST  [
							if out-of-bound? bits max [return 0]
							pbits: rs-head bits
							BS_TEST_BIT(pbits max test?)
							max: either test? [1][0]
						]
						OP_CLEAR [
							if out-of-bound? bits max [return 0]
							pbits: rs-head bits
							BS_CLEAR_BIT(pbits max)
						]
					]
				]
			]
			TYPE_STRING [
				if op = OP_SET [
					max: process-string as red-string! spec bits OP_MAX
					pbits: bound-check bits max
				]
				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!]
			s	 [series!]
	][
		#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
			size: size >> 3
			bits/node: alloc-bytes size
			s: GET_BUFFER(bits)
			s/tail: as cell! ((as byte-ptr! s/offset) + size)
		][
			size: process spec null OP_MAX no
			bits/node: alloc-bytes size
			process spec bits OP_SET no
		]
;zeroing buffer!!!
		bits
	]

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

		string/concatenate-literal buffer "make bitset! #{"
		part: form-bytes bits buffer OPTION?(arg) part - 15
		string/append-char GET_BUFFER(buffer) as-integer #"}"
		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
	]

	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
	]

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

		type: TYPE_OF(data)
		bool: as red-logic! data
		int:  as red-integer! data

		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
	]

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

	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!]
	][
		s: GET_BUFFER(bits)
		if (s/size << 3) < index [s: expand-series s (index >> 3) + 1]
;zeroing buffer!!!
		as byte-ptr! s/offset
	]

	form-bytes: func [
		bits	[red-bitset!]
		buffer	[red-string!]
		part?	[logic!]
		part	[integer!]
		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
			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
	]

	process-range: func [
		bits 	[red-bitset!]
		lower	[integer!]
		upper	[integer!]
		op		[integer!]
		return: [integer!]
		/local
			pos	  [byte-ptr!]
			pbits [byte-ptr!]
			set?  [logic!]
	][
		switch op [
			OP_SET [
				pbits: bound-check bits upper
				while [lower <= upper][
					BS_SET_BIT(pbits lower)				;-- could be optimized by setting bytes directly
					lower: lower + 1
				]
			]
			OP_TEST [
				pbits: rs-head bits
				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 [
				pbits: rs-head bits
				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		[integer!]
		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!]
			test? [logic!]
			set?  [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

		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	 [BS_TEST_BIT(pbits cp set?)]
				OP_CLEAR [BS_CLEAR_BIT(pbits max)]
			]
			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		[integer!]
		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!]
	][
		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 [
					switch op [
						OP_SET   [
							pbits: bound-check bits max
							BS_SET_BIT(pbits max)
						]
						OP_TEST  [
							pbits: rs-head bits
							BS_TEST_BIT(pbits max test?)
							max: either test? [1][0]
						]
						OP_CLEAR [
							pbits: rs-head bits
							BS_CLEAR_BIT(pbits max)
						]
					]
				]
			]
			TYPE_STRING [
				if op = OP_SET [
					max: process-string as red-string! spec bits OP_MAX
					pbits: bound-check bits max
				]
				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!]
			s	 [series!]
	][
		#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
			size: size >> 3
			bits/node: alloc-bytes size
			s: GET_BUFFER(bits)
			s/tail: as cell! ((as byte-ptr! s/offset) + size)
		][
			size: process spec null OP_MAX no
			bits/node: alloc-bytes size
			process spec bits OP_SET no
		]
;zeroing buffer!!!
		bits
	]

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

		string/concatenate-literal buffer "make bitset! #{"
		part: form-bytes bits buffer OPTION?(arg) part - 15
		string/append-char GET_BUFFER(buffer) as-integer #"}"
		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
	]

	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
	]

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

		type: TYPE_OF(data)
		bool: as red-logic! data
		int:  as red-integer! data

		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
	]

	init: does [
		datatype/register [
			TYPE_BITSET
			TYPE_VALUE
			"bitset!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			null			;get-path
			null			;set-path
			null			;compare
			;-- Scalar actions --
			null			;absolute
			null			;add
			null			;divide
			null			;multiply
			null			;negate
			null			;power
			null			;remainder
			null			;round
			null			;subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			null			;copy
			:find
			null			;head
			null			;head?
			null			;index?
			:insert
			null			;length?
			null			;next
			:pick
			: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: minor refactoring of stack unwinding code (doesn't change behavior).

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

stack: context [										;-- call stack
	verbose: 0

	call!: alias struct! [
		header 	[integer!]								;-- cell header
		symbol	[integer!]								;-- index in symbol table
		spec	[node!]									;-- spec block (cleaned-up form)
		args	[red-value!]							;-- pointer to first argument in args stack
	]

	arg-stk:  block/make-in root 1024					;-- argument stack (should never be relocated)
	call-stk: block/make-in root 512					;-- call stack (should never be relocated)

	set-flag arg-stk/node flag-series-fixed or flag-series-nogc
	set-flag call-stk/node flag-series-fixed or flag-series-nogc

	;-- Shortcuts for stack buffers simpler and faster access
	;-- (stack buffers are not resizable with such approach
	;-- this can be made more flexible (but slower) if necessary
	;-- in the future)

	args-series:  GET_BUFFER(arg-stk)
	calls-series: GET_BUFFER(call-stk)

	a-end: as cell! (as byte-ptr! args-series)  + args-series/size
	c-end: as cell! (as byte-ptr! calls-series) + calls-series/size

	arguments:	args-series/tail
	bottom:  	args-series/offset
	top:	 	args-series/tail
	cbottom: 	calls-series/offset
	ctop:	 	calls-series/tail

	last-value: arguments

	reset: func [
		return:  [cell!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/reset"]]

		top: arguments									;-- overwrite last value
		last-value: arguments
		arguments
	]

	keep: func [
		return:  [cell!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/keep"]]

		top: arguments + 1								;-- keep last value in arguments slot
		last-value: arguments
		arguments
	]

	mark: func [
		fun		 [red-word!]
		/local
			call [call!]
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/mark"]]

		arguments: top

		if ctop = c-end [
			print-line ["^/*** Error: call stack overflow!^/"]
			halt
		]
		call: as call! ctop
		call/header: TYPE_STACK_CALL
		call/symbol: either null? fun [-1][fun/symbol]
		call/args: arguments
		ctop: ctop + 1

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind: func [
		/local
			s	   [series!]
			call  [call!]
			offset [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind"]]

		assert cbottom < ctop
		ctop: ctop - 1

		last-value: arguments							;-- for immediate use only!

		either ctop = cbottom [
			arguments: bottom
			top: bottom
		][
			top: arguments + 1
			call: as call! ctop
			call: call - 1
			arguments: call/args
		]

		#if debug? = yes [if verbose > 1 [dump]]
	]

	set-last: func [
		last	[red-value!]
		return: [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/set-last"]]

		copy-cell last arguments
	]

	push: func [
		return: [cell!]
		/local cell [cell!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/push"]]

		cell: top
		top: top + 1
		if top >= a-end [
			print-line ["^/*** Error: arguments stack overflow!^/"]
			halt
		]
		cell
	]

	pop: func [
		positions [integer!]
	][
		top: top - positions
	]

	#if debug? = yes [
		dump: does [									;-- debug purpose only
			print-line "^/---- Argument stack ----"
			dump-memory
				as byte-ptr! bottom
				4
				(as-integer top + 1 - bottom) >> 4
			print-line ["arguments: " arguments]
			print-line ["top: " top]

			print-line "^/---- Call stack ----"
			dump-memory
				as byte-ptr! cbottom
				4
			(as-integer ctop + 1 - cbottom) >> 4

			print-line ["ctop: " ctop]
		]
	]
]

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

stack: context [										;-- call stack
	verbose: 0

	call!: alias struct! [
		header 	[integer!]								;-- cell header
		symbol	[integer!]								;-- index in symbol table
		spec	[node!]									;-- spec block (cleaned-up form)
		args	[red-value!]							;-- pointer to first argument in args stack
	]

	arg-stk:  block/make-in root 1024					;-- argument stack (should never be relocated)
	call-stk: block/make-in root 512					;-- call stack (should never be relocated)

	set-flag arg-stk/node flag-series-fixed or flag-series-nogc
	set-flag call-stk/node flag-series-fixed or flag-series-nogc

	;-- Shortcuts for stack buffers simpler and faster access
	;-- (stack buffers are not resizable with such approach
	;-- this can be made more flexible (but slower) if necessary
	;-- in the future)

	args-series:  GET_BUFFER(arg-stk)
	calls-series: GET_BUFFER(call-stk)

	a-end: as cell! (as byte-ptr! args-series)  + args-series/size
	c-end: as cell! (as byte-ptr! calls-series) + calls-series/size

	arguments:	args-series/tail
	bottom:  	args-series/offset
	top:	 	args-series/tail
	cbottom: 	calls-series/offset
	ctop:	 	calls-series/tail

	last-value: arguments

	reset: func [
		return:  [cell!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/reset"]]

		top: arguments									;-- overwrite last value
		last-value: arguments
		arguments
	]

	keep: func [
		return:  [cell!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/keep"]]

		top: arguments + 1								;-- keep last value in arguments slot
		last-value: arguments
		arguments
	]

	mark: func [
		fun		 [red-word!]
		/local
			call [call!]
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/mark"]]

		arguments: top

		if ctop = c-end [
			print-line ["^/*** Error: call stack overflow!^/"]
			halt
		]
		call: as call! ctop
		call/header: TYPE_STACK_CALL
		call/symbol: either null? fun [-1][fun/symbol]
		call/args: arguments
		ctop: ctop + 1

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind: func [
		/local
			s	   [series!]
			call  [call!]
			offset [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind"]]

		assert cbottom < ctop
		ctop: ctop - 1

		last-value: arguments							;-- for immediate use only!

		either ctop = cbottom [
			arguments: bottom
			top: bottom
		][
			call: as call! ctop
			top: call/args + 1

			call: call - 1
			arguments: call/args
		]

		#if debug? = yes [if verbose > 1 [dump]]
	]

	set-last: func [
		last	[red-value!]
		return: [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/set-last"]]

		copy-cell last arguments
	]

	push: func [
		return: [cell!]
		/local cell [cell!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/push"]]

		cell: top
		top: top + 1
		if top >= a-end [
			print-line ["^/*** Error: arguments stack overflow!^/"]
			halt
		]
		cell
	]

	pop: func [
		positions [integer!]
	][
		top: top - positions
	]

	#if debug? = yes [
		dump: does [									;-- debug purpose only
			print-line "^/---- Argument stack ----"
			dump-memory
				as byte-ptr! bottom
				4
				(as-integer top + 1 - bottom) >> 4
			print-line ["arguments: " arguments]
			print-line ["top: " top]

			print-line "^/---- Call stack ----"
			dump-memory
				as byte-ptr! cbottom
				4
			(as-integer ctop + 1 - cbottom) >> 4

			print-line ["ctop: " ctop]
		]
	]
]


TESTS: added test for issue #443

TESTS: added test for issue #443

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

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

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

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


FEAT: added predefined typesets values.

FEAT: added predefined typesets values.

Red [
	Title:   "Red base environment definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %boot.red
	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
	}
]

Red: true												;-- ultimate Truth ;-) (pre-defines Red word)

yes: on: true
no: off: false

tab:		 #"^-"
cr: 		 #"^M"
newline: lf: #"^/"
escape:      #"^["
slash: 		 #"/"
sp: space: 	 #" "
null: 		 #"^@"
crlf:		 "^M^/"
dot:		 #"."
comma:		 #","

pi: 3.141592653589793

internal!:		make typeset! [unset!]
number!:		make typeset! [integer! decimal!]
scalar!:		union number! make typeset! [char!]
any-word!:		make typeset! [word! set-word! get-word! lit-word! refinement! issue!]
any-path!:		make typeset! [path! set-path! get-path! lit-path!]
any-block!:		union any-path! make typeset! [block! paren!]
any-function!:	make typeset! [native! action! op! function! routine!]
any-object!:	make typeset! [object! error!]
any-string!:	make typeset! [string! url!]
series!:        union any-block! any-string!
immediate!:		union scalar! union any-word! make typeset! [none! logic! datatype! typeset!]
any-type!:		union series! union immediate! internal!


FIX: wrong test for testing multiple bits defined in a block.

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
	]

	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!]
	][
		s: GET_BUFFER(bits)
		if (s/size << 3) < index [s: expand-series s (index >> 3) + 1]
;zeroing buffer!!!
		as byte-ptr! s/offset
	]

	form-bytes: func [
		bits	[red-bitset!]
		buffer	[red-string!]
		part?	[logic!]
		part	[integer!]
		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
			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
	]

	process-range: func [
		bits 	[red-bitset!]
		lower	[integer!]
		upper	[integer!]
		op		[integer!]
		return: [integer!]
		/local
			pos	  [byte-ptr!]
			pbits [byte-ptr!]
			set?  [logic!]
	][
		switch op [
			OP_SET [
				pbits: bound-check bits upper
				while [lower <= upper][
					BS_SET_BIT(pbits lower)				;-- could be optimized by setting bytes directly
					lower: lower + 1
				]
			]
			OP_TEST [
				pbits: rs-head bits
				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 [
				pbits: rs-head bits
				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		[integer!]
		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!]
			test? [logic!]
			set?  [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

		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	 [BS_TEST_BIT(pbits cp set?)]
				OP_CLEAR [BS_CLEAR_BIT(pbits max)]
			]
			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		[integer!]
		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!]
	][
		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 [
					switch op [
						OP_SET   [
							pbits: bound-check bits max
							BS_SET_BIT(pbits max)
						]
						OP_TEST  [
							pbits: rs-head bits
							BS_TEST_BIT(pbits max test?)
							max: either test? [1][0]
						]
						OP_CLEAR [
							pbits: rs-head bits
							BS_CLEAR_BIT(pbits max)
						]
					]
				]
			]
			TYPE_STRING [
				if op = OP_SET [
					max: process-string as red-string! spec bits OP_MAX
					pbits: bound-check bits max
				]
				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!]
			s	 [series!]
	][
		#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
			size: size >> 3
			bits/node: alloc-bytes size
			s: GET_BUFFER(bits)
			s/tail: as cell! ((as byte-ptr! s/offset) + size)
		][
			size: process spec null OP_MAX no
			bits/node: alloc-bytes size
			process spec bits OP_SET no
		]
;zeroing buffer!!!
		bits
	]

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

		string/concatenate-literal buffer "make bitset! [#{"
		part: form-bytes bits buffer OPTION?(arg) part - 16
		string/concatenate-literal buffer "}]"
		part - 2
	]

	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
	]

	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
	]

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

		type: TYPE_OF(data)
		bool: as red-logic! data
		int:  as red-integer! data

		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
	]

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

	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!]
	][
		s: GET_BUFFER(bits)
		if (s/size << 3) < index [s: expand-series s (index >> 3) + 1]
;zeroing buffer!!!
		as byte-ptr! s/offset
	]

	form-bytes: func [
		bits	[red-bitset!]
		buffer	[red-string!]
		part?	[logic!]
		part	[integer!]
		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
			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
	]

	process-range: func [
		bits 	[red-bitset!]
		lower	[integer!]
		upper	[integer!]
		op		[integer!]
		return: [integer!]
		/local
			pos	  [byte-ptr!]
			pbits [byte-ptr!]
			set?  [logic!]
	][
		switch op [
			OP_SET [
				pbits: bound-check bits upper
				while [lower <= upper][
					BS_SET_BIT(pbits lower)				;-- could be optimized by setting bytes directly
					lower: lower + 1
				]
			]
			OP_TEST [
				pbits: rs-head bits
				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 [
				pbits: rs-head bits
				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		[integer!]
		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!]
			test? [logic!]
			set?  [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

		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	 [BS_TEST_BIT(pbits cp set?)]
				OP_CLEAR [BS_CLEAR_BIT(pbits max)]
			]
			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		[integer!]
		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!]
	][
		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 [
					switch op [
						OP_SET   [
							pbits: bound-check bits max
							BS_SET_BIT(pbits max)
						]
						OP_TEST  [
							pbits: rs-head bits
							BS_TEST_BIT(pbits max test?)
							max: either test? [1][0]
						]
						OP_CLEAR [
							pbits: rs-head bits
							BS_CLEAR_BIT(pbits max)
						]
					]
				]
			]
			TYPE_STRING [
				if op = OP_SET [
					max: process-string as red-string! spec bits OP_MAX
					pbits: bound-check bits max
				]
				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? max = 0][return 0]	;-- max > 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!]
			s	 [series!]
	][
		#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
			size: size >> 3
			bits/node: alloc-bytes size
			s: GET_BUFFER(bits)
			s/tail: as cell! ((as byte-ptr! s/offset) + size)
		][
			size: process spec null OP_MAX no
			bits/node: alloc-bytes size
			process spec bits OP_SET no
		]
;zeroing buffer!!!
		bits
	]

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

		string/concatenate-literal buffer "make bitset! [#{"
		part: form-bytes bits buffer OPTION?(arg) part - 16
		string/concatenate-literal buffer "}]"
		part - 2
	]

	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
	]

	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
	]

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

		type: TYPE_OF(data)
		bool: as red-logic! data
		int:  as red-integer! data

		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
	]

	init: does [
		datatype/register [
			TYPE_BITSET
			TYPE_VALUE
			"bitset!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			null			;get-path
			null			;set-path
			null			;compare
			;-- Scalar actions --
			null			;absolute
			null			;add
			null			;divide
			null			;multiply
			null			;negate
			null			;power
			null			;remainder
			null			;round
			null			;subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			null			;copy
			:find
			null			;head
			null			;head?
			null			;index?
			:insert
			null			;length?
			null			;next
			:pick
			: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: regression on SELF keyword definition after the merge.

Red/System [
	Title:   "Common datatypes utility functions"
	Author:  "Nenad Rakocevic"
	File: 	 %common.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
	}
]

names!: alias struct! [
	buffer	[c-string!]								;-- datatype name string
	size	[integer!]								;-- buffer size - 1 (not counting terminal `!`)
	word	[red-word!]								;-- datatype name as word! value
]

name-table:   declare names! 						;-- datatype names table
action-table: declare int-ptr!						;-- actions jump table

set-type: func [										;@@ convert to macro?
	cell [cell!]
	type [integer!]
][
	cell/header: cell/header and type-mask or type
]

alloc-at-tail: func [
	blk		[red-block!]
	return: [cell!]
][
	alloc-tail as series! blk/node/value
]

alloc-tail: func [
	s		 [series!]
	return:  [cell!]
	/local
		cell [red-value!]
][
	if (as byte-ptr! s/tail + 1) > ((as byte-ptr! s + 1) + s/size) [
		s: expand-series s 0
	]

	cell: s/tail
	;-- ensure that cell is within series upper boundary
	assert (as byte-ptr! cell) < ((as byte-ptr! s + 1) + s/size)

	s/tail: cell + 1									;-- move tail to next cell
	cell
]

alloc-tail-unit: func [
	s		 [series!]
	unit 	 [integer!]
	return:  [byte-ptr!]
	/local
		p	 [byte-ptr!]
][
	if ((as byte-ptr! s/tail) + unit) > ((as byte-ptr! s + 1) + s/size) [
		s: expand-series s 0
	]

	p: as byte-ptr! s/tail
	;-- ensure that cell is within series upper boundary
	assert p < ((as byte-ptr! s + 1) + s/size)

	s/tail: as cell! p + unit							;-- move tail to next unit slot
	p
]

copy-cell: func [
	src		[cell!]
	dst		[cell!]
	return: [red-value!]
][
	copy-memory											;@@ optimize for 16 bytes copying
		as byte-ptr! dst
		as byte-ptr! src
		size? cell!
	dst
]

words: context [
	spec:			-1
	body:			-1
	words:			-1
	logic!:			-1
	integer!:		-1
	repeat:			-1
	foreach:		-1
	map-each:		-1
	remove-each:	-1
	exit*:			-1
	return*:		-1
	self:			-1
	values:			-1

	any*:			-1
	break*:			-1
	copy:			-1
	end:			-1
	fail:			-1
	into:			-1
	opt:			-1
	not*:			-1
	quote:			-1
	reject:			-1
	set:			-1
	skip:			-1
	some:			-1
	thru:			-1
	to:				-1
	none:			-1
	pipe:			-1
	dash:			-1
	then:			-1
	if*:			-1
	remove:			-1
	while*:			-1
	insert:			-1
	only:			-1
	collect:		-1
	keep:			-1
	ahead:			-1

	_body:			as red-word! 0
	_windows:		as red-word! 0
	_syllable:		as red-word! 0
	_macosx:		as red-word! 0
	_linux:			as red-word! 0

	_push:			as red-word! 0
	_pop:			as red-word! 0
	_fetch:			as red-word! 0
	_match:			as red-word! 0
	_iterate:		as red-word! 0
	_paren:			as red-word! 0
	_end:			as red-word! 0

	_on-parse-event: as red-word! 0

	build: does [
		spec:			symbol/make "spec"
		body:			symbol/make "body"
		words:			symbol/make "words"
		logic!:			symbol/make "logic!"
		integer!:		symbol/make "integer!"
		exit*:			symbol/make "exit"
		return*:		symbol/make "return"

		windows:		symbol/make "Windows"
		syllable:		symbol/make "Syllable"
		macosx:			symbol/make "MacOSX"
		linux:			symbol/make "Linux"

		repeat:			symbol/make "repeat"
		foreach:		symbol/make "foreach"
		map-each:		symbol/make "map-each"
		remove-each:	symbol/make "remove-each"

		any*:			symbol/make "any"
		break*:			symbol/make "break"
		copy:			symbol/make "copy"
		end:			symbol/make "end"
		fail:			symbol/make "fail"
		into:			symbol/make "into"
		opt:			symbol/make "opt"
		not*:			symbol/make "not"
		quote:			symbol/make "quote"
		reject:			symbol/make "reject"
		set:			symbol/make "set"
		skip:			symbol/make "skip"
		some:			symbol/make "some"
		thru:			symbol/make "thru"
		to:				symbol/make "to"
		none:			symbol/make "none"
		pipe:			symbol/make "|"
		dash:			symbol/make "-"
		then:			symbol/make "then"
		if*:			symbol/make "if"
		remove:			symbol/make "remove"
		while*:			symbol/make "while"
		insert:			symbol/make "insert"
		only:			symbol/make "only"
		collect:		symbol/make "collect"
		keep:			symbol/make "keep"
		ahead:			symbol/make "ahead"

		self:			symbol/make "self"
		values:			symbol/make "values"

		_body:			_context/add-global body
		_windows:		_context/add-global windows
		_syllable:		_context/add-global syllable
		_macosx:		_context/add-global macosx
		_linux:			_context/add-global linux

		_push:			word/load "push"
		_pop:			word/load "pop"
		_fetch:			word/load "fetch"
		_match:			word/load "match"
		_iterate:		word/load "iterate"
		_paren:			word/load "paren"
		_end:			_context/add-global end

		_on-parse-event: word/load "on-parse-event"
	]
]

refinements: context [
	local: 		as red-refinement! 0
	extern: 	as red-refinement! 0

	build: does [
		local:	refinement/load "local"
		extern:	refinement/load "extern"
	]
]

Red/System [
	Title:   "Common datatypes utility functions"
	Author:  "Nenad Rakocevic"
	File: 	 %common.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
	}
]

names!: alias struct! [
	buffer	[c-string!]								;-- datatype name string
	size	[integer!]								;-- buffer size - 1 (not counting terminal `!`)
	word	[red-word!]								;-- datatype name as word! value
]

name-table:   declare names! 						;-- datatype names table
action-table: declare int-ptr!						;-- actions jump table

set-type: func [										;@@ convert to macro?
	cell [cell!]
	type [integer!]
][
	cell/header: cell/header and type-mask or type
]

alloc-at-tail: func [
	blk		[red-block!]
	return: [cell!]
][
	alloc-tail as series! blk/node/value
]

alloc-tail: func [
	s		 [series!]
	return:  [cell!]
	/local
		cell [red-value!]
][
	if (as byte-ptr! s/tail + 1) > ((as byte-ptr! s + 1) + s/size) [
		s: expand-series s 0
	]

	cell: s/tail
	;-- ensure that cell is within series upper boundary
	assert (as byte-ptr! cell) < ((as byte-ptr! s + 1) + s/size)

	s/tail: cell + 1									;-- move tail to next cell
	cell
]

alloc-tail-unit: func [
	s		 [series!]
	unit 	 [integer!]
	return:  [byte-ptr!]
	/local
		p	 [byte-ptr!]
][
	if ((as byte-ptr! s/tail) + unit) > ((as byte-ptr! s + 1) + s/size) [
		s: expand-series s 0
	]

	p: as byte-ptr! s/tail
	;-- ensure that cell is within series upper boundary
	assert p < ((as byte-ptr! s + 1) + s/size)

	s/tail: as cell! p + unit							;-- move tail to next unit slot
	p
]

copy-cell: func [
	src		[cell!]
	dst		[cell!]
	return: [red-value!]
][
	copy-memory											;@@ optimize for 16 bytes copying
		as byte-ptr! dst
		as byte-ptr! src
		size? cell!
	dst
]

words: context [

	spec:			-1
	body:			-1
	words:			-1
	logic!:			-1
	integer!:		-1
	repeat:			-1
	foreach:		-1
	map-each:		-1
	remove-each:	-1
	exit*:			-1
	return*:		-1
	self:			-1
	values:			-1

	any*:			-1
	break*:			-1
	copy:			-1
	end:			-1
	fail:			-1
	into:			-1
	opt:			-1
	not*:			-1
	quote:			-1
	reject:			-1
	set:			-1
	skip:			-1
	some:			-1
	thru:			-1
	to:				-1
	none:			-1
	pipe:			-1
	dash:			-1
	then:			-1
	if*:			-1
	remove:			-1
	while*:			-1
	insert:			-1
	only:			-1
	collect:		-1
	keep:			-1
	ahead:			-1

	_body:			as red-word! 0
	_windows:		as red-word! 0
	_syllable:		as red-word! 0
	_macosx:		as red-word! 0
	_linux:			as red-word! 0
	_self:			as red-word! 0
	_values:		as red-word! 0

	_push:			as red-word! 0
	_pop:			as red-word! 0
	_fetch:			as red-word! 0
	_match:			as red-word! 0
	_iterate:		as red-word! 0
	_paren:			as red-word! 0
	_end:			as red-word! 0

	_on-parse-event: as red-word! 0

	build: does [
		spec:			symbol/make "spec"
		body:			symbol/make "body"
		words:			symbol/make "words"
		logic!:			symbol/make "logic!"
		integer!:		symbol/make "integer!"
		exit*:			symbol/make "exit"
		return*:		symbol/make "return"

		windows:		symbol/make "Windows"
		syllable:		symbol/make "Syllable"
		macosx:			symbol/make "MacOSX"
		linux:			symbol/make "Linux"

		repeat:			symbol/make "repeat"
		foreach:		symbol/make "foreach"
		map-each:		symbol/make "map-each"
		remove-each:	symbol/make "remove-each"

		any*:			symbol/make "any"
		break*:			symbol/make "break"
		copy:			symbol/make "copy"
		end:			symbol/make "end"
		fail:			symbol/make "fail"
		into:			symbol/make "into"
		opt:			symbol/make "opt"
		not*:			symbol/make "not"
		quote:			symbol/make "quote"
		reject:			symbol/make "reject"
		set:			symbol/make "set"
		skip:			symbol/make "skip"
		some:			symbol/make "some"
		thru:			symbol/make "thru"
		to:				symbol/make "to"
		none:			symbol/make "none"
		pipe:			symbol/make "|"
		dash:			symbol/make "-"
		then:			symbol/make "then"
		if*:			symbol/make "if"
		remove:			symbol/make "remove"
		while*:			symbol/make "while"
		insert:			symbol/make "insert"
		only:			symbol/make "only"
		collect:		symbol/make "collect"
		keep:			symbol/make "keep"
		ahead:			symbol/make "ahead"

		_body:			_context/add-global body
		_windows:		_context/add-global windows
		_syllable:		_context/add-global syllable
		_macosx:		_context/add-global macosx
		_linux:			_context/add-global linux

		_self:			word/load "self"
		_values:		word/load "values"
		_push:			word/load "push"
		_pop:			word/load "pop"
		_fetch:			word/load "fetch"
		_match:			word/load "match"
		_iterate:		word/load "iterate"
		_paren:			word/load "paren"
		_end:			_context/add-global end

		_on-parse-event: word/load "on-parse-event"
	]
]

refinements: context [
	local: 		as red-refinement! 0
	extern: 	as red-refinement! 0

	build: does [
		local:	refinement/load "local"
		extern:	refinement/load "extern"
	]
]