FIX: removed unused argument in EVAL calls.

Red/System [
	Title:   "Red native functions"
	Author:  "Nenad Rakocevic"
	File: 	 %natives.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 RETURN_NONE [
	stack/reset
	none/push-last
	exit
]

#define RETURN_UNSET [
	stack/reset
	unset/push-last
]

natives: context [
	verbose: 0
	lf?: 	 no											;-- used to print or not an ending newline

	table: as int-ptr! allocate NATIVES_NB * size? integer!
	top: 0

	register: func [
		[variadic]
		count	   [integer!]
		list	   [int-ptr!]
		/local
			offset [integer!]
	][
		offset: 0

		until [
			table/top: list/value
			top: top + 1
			assert top < NATIVES_NB
			list: list + 1
			count: count - 1
			zero? count
		]
	]

	;--- Natives ----

	if*: does [
		either logic/false? [
			RETURN_NONE
		][
			interpreter/eval as red-block! stack/arguments + 1
		]
	]

	unless*: does [
		either logic/false? [
			interpreter/eval as red-block! stack/arguments + 1
		][
			RETURN_NONE
		]
	]

	either*: func [
		/local offset [integer!]
	][
		offset: either logic/true? [1][2]
		interpreter/eval as red-block! stack/arguments + offset
	]

	any*: func [
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head as red-block! stack/arguments
		tail:  block/rs-tail as red-block! stack/arguments

		while [value < tail][
			value: interpreter/eval-next value tail no
			if logic/true? [exit]
		]
		RETURN_NONE
	]

	all*: func [
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head as red-block! stack/arguments
		tail:  block/rs-tail as red-block! stack/arguments

		while [value < tail][
			value: interpreter/eval-next value tail no
			if logic/false? [RETURN_NONE]
		]
	]

	while*:	func [
		/local
			cond [red-block!]
			body [red-block!]
	][
		cond: as red-block! stack/arguments
		body: as red-block! stack/arguments + 1

		stack/mark-native words/_body
		while [
			interpreter/eval cond
			logic/true?
		][
			stack/reset
			interpreter/eval body
		]
		stack/unwind
		RETURN_UNSET
	]

	until*: func [
		/local
			body [red-block!]
	][
		body: as red-block! stack/arguments

		stack/mark-native words/_body
		until [
			stack/reset
			interpreter/eval body
			logic/true?
		]
		stack/unwind-last
	]

	loop*: func [
		/local
			body [red-block!]
			i	 [integer!]
	][
		i: integer/get*
		unless positive? i [RETURN_NONE]				;-- if counter <= 0, no loops

		body: as red-block! stack/arguments + 1

		stack/mark-native words/_body
		until [
			stack/reset
			interpreter/eval body
			i: i - 1
			zero? i
		]
		stack/unwind-last
	]

	repeat*: func [
		/local
			w	   [red-word!]
			body   [red-block!]
			count  [red-integer!]
			cnt	   [integer!]
			i	   [integer!]
	][
		w: 	   as red-word!    stack/arguments
		count: as red-integer! stack/arguments + 1
		body:  as red-block!   stack/arguments + 2

		i: integer/get as red-value! count
		unless positive? i [RETURN_NONE]				;-- if counter <= 0, no loops

		count/value: 1

		stack/mark-native words/_body
		until [
			stack/reset
			_context/set w as red-value! count
			interpreter/eval body
			count/value: count/value + 1
			i: i - 1
			zero? i
		]
		stack/unwind-last
	]

	foreach*: func [
		/local
			value [red-value!]
			body  [red-block!]
			size  [integer!]
	][
		value: stack/arguments
		body: as red-block! stack/arguments + 2

		stack/push stack/arguments + 1					;-- copy arguments to stack top in reverse order
		stack/push value								;-- (required by foreach-next)

		stack/mark-native words/_body

		either TYPE_OF(value) = TYPE_BLOCK [
			size: block/rs-length? as red-block! value

			while [foreach-next-block size][			;-- foreach [..]
				stack/reset
				interpreter/eval body
			]
		][
			while [foreach-next][						;-- foreach <word!>
				stack/reset
				interpreter/eval body
			]
		]
		stack/unwind-last
	]

	forall*: func [
		/local
			w 	   [red-word!]
			body   [red-block!]
			saved  [red-value!]
			series [red-series!]
	][
		w:    as red-word!  stack/arguments
		body: as red-block! stack/arguments + 1

		saved: word/get w							;-- save series (for resetting on end)
		w: word/push w								;-- word argument

		stack/mark-native words/_body
		while [
			loop? as red-series! _context/get w
		][
			stack/reset
			interpreter/eval body
			series: as red-series! _context/get w
			series/head: series/head + 1
		]
		stack/unwind-last
		_context/set w saved
	]

	func*:		does []
	function*:	does []
	does*:		does []
	has*:		does []
	exit*:		does []
	return*:	does []

	switch*: func [
		default? [integer!]								;@@ not implemented yet
		/local
			pos	 [red-value!]
			blk  [red-block!]
			end  [red-value!]
			s	 [series!]
	][
		blk: as red-block! stack/arguments + 1

		pos: actions/find
			as red-series! blk
			stack/arguments
			null
			no
			no
			no
			null
			null
			no
			no
			yes											;-- /tail
			no

		either TYPE_OF(blk) = TYPE_NONE [
			;TBD: add default block processing
			0
		][
			s: GET_BUFFER(blk)
			end: s/tail

			while [pos < end][							;-- find first following block
				if TYPE_OF(pos) = TYPE_BLOCK [
					stack/reset
					interpreter/eval as red-block! pos	;-- do the block
					exit								;-- early exit with last value on stack
				]
				pos: pos + 1
			]
		]
		RETURN_NONE
	]

	case*: func [
		all? 	  [integer!]							;@@ not implemented yet
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head as red-block! stack/arguments
		tail:  block/rs-tail as red-block! stack/arguments
		if value = tail [RETURN_NONE]

		while [value < tail][
			value: interpreter/eval-next value tail no	;-- eval condition
			either logic/true? [
				either TYPE_OF(value) = TYPE_BLOCK [	;-- if true, eval what follows it
					stack/reset
					interpreter/eval as red-block! value
				][
					value: interpreter/eval-next value tail no
				]
				exit									;-- early exit with last value on stack
			][
				value: value + 1						;-- single value only allowed for cases bodies
			]
		]
		RETURN_NONE
	]

	do*: does [
		interpreter/eval as red-block! stack/arguments
	]

	get*: func [
		any? [integer!]
	][
		stack/set-last _context/get as red-word! stack/arguments
	]

	set*: func [
		any? [integer!]
		/local
			w	  [red-word!]
			value [red-value!]
			blk	  [red-block!]
	][
		w: as red-word! stack/arguments
		value: stack/arguments + 1

		either TYPE_OF(w) = TYPE_BLOCK [
			blk: as red-block! w
			set-many blk value block/rs-length? blk
			stack/set-last value
		][
			stack/set-last _context/set w value
		]
	]

	print*: does [
		lf?: yes
		prin*
		lf?: no
	]

	prin*: func [
		/local
			arg		[red-value!]
			str		[red-string!]
			series	[series!]
			offset	[byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/prin"]]

		arg: stack/arguments

		either TYPE_OF(arg) = TYPE_STRING [
			str: as red-string! arg
		][
			actions/form* -1
			str: as red-string! stack/arguments + 1
			assert any [
				TYPE_OF(str) = TYPE_STRING
				TYPE_OF(str) = TYPE_SYMBOL					;-- symbol! and string! structs are overlapping
			]
		]
		series: GET_BUFFER(str)
		offset: (as byte-ptr! series/offset) + (str/head << (GET_UNIT(series) >> 1))

		either lf? [
			switch GET_UNIT(series) [
				Latin1 [platform/print-line-Latin1 as c-string! offset]
				UCS-2  [platform/print-line-UCS2 				offset]
				UCS-4  [platform/print-line-UCS4   as int-ptr!  offset]

				default [									;@@ replace by an assertion
					print-line ["Error: unknown string encoding: " GET_UNIT(series)]
				]
			]
		][
			switch GET_UNIT(series) [
				Latin1 [platform/print-Latin1 as c-string! offset]
				UCS-2  [platform/print-UCS2   			   offset]
				UCS-4  [platform/print-UCS4   as int-ptr!  offset]

				default [									;@@ replace by an assertion
					print-line ["Error: unknown string encoding: " GET_UNIT(series)]
				]
			]
		]
		stack/set-last unset-value
	]

	compare: func [
		op		   [integer!]
		return:    [red-logic!]
		/local
			args   [red-value!]
			result [red-logic!]
	][
		args: stack/arguments
		result: as red-logic! args
		result/value: actions/compare args args + 1 op
		result/header: TYPE_LOGIC
		result
	]

	equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/equal?"]]
		compare COMP_EQUAL
	]

	not-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not-equal?"]]
		compare COMP_NOT_EQUAL
	]

	strict-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/strict-equal?"]]
		compare COMP_STRICT_EQUAL
	]

	lesser?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser?"]]
		compare COMP_LESSER
	]

	greater?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater?"]]
		compare COMP_GREATER
	]

	lesser-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser-or-equal?"]]
		compare COMP_LESSER_EQUAL
	]

	greater-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater-or-equal?"]]
		compare COMP_GREATER_EQUAL
	]

	same?*: does []

	not*: func [
		/local bool [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not"]]

		bool: as red-logic! stack/arguments
		bool/value: logic/false?						;-- run test before modifying stack
		bool/header: TYPE_LOGIC
	]

	halt*: does [halt]

	type?*: func [
		word?	 [integer!]
		return:  [red-value!]
		/local
			dt	 [red-datatype!]
			w	 [red-word!]
			name [names!]
	][
		either negative? word? [
			dt: as red-datatype! stack/arguments		;-- overwrite argument
			dt/value: TYPE_OF(dt)						;-- extract type before overriding
			dt/header: TYPE_DATATYPE
			as red-value! dt
		][
			w: as red-word! stack/arguments				;-- overwrite argument
			name: name-table + TYPE_OF(w)				;-- point to the right datatype name record
			stack/set-last as red-value! name/word
		]
	]

	load*: func [
		/local
			str [red-string!]
			s	[series!]
	][
		str: as red-string! stack/arguments
		s: GET_BUFFER(str)
		tokenizer/scan as c-string! s/offset null	;@@ temporary limited to Latin-1
	]

	reduce*: func [
		into [integer!]
		/local
			value [red-value!]
			tail  [red-value!]
			blk	  [red-block!]
			arg	  [red-value!]
	][
		arg: stack/arguments
		if TYPE_OF(arg) <> TYPE_BLOCK [
			interpreter/eval-expression arg arg + 1 no no
			exit
		]

		value: block/rs-head as red-block! arg
		tail:  block/rs-tail as red-block! arg

		stack/mark-native words/_body

		blk: either negative? into [
			block/push-only* (as-integer tail - value) >> 4
		][
			as red-block! arg + into
		]

		while [value < tail][
			value: interpreter/eval-next value tail yes
			block/append*
			stack/keep									;-- preserve the reduced block on stack
		]
		stack/unwind-last
	]

	;--- Natives helper functions ---

	loop?: func [
		series     [red-series!]
		return:    [logic!]
		/local
			s	   [series!]
	][
		s: GET_BUFFER(series)

		either TYPE_OF(series) = TYPE_BLOCK [			;@@ replace with any-block?/any-string? check
			s/offset + series/head < s/tail
		][
			(as byte-ptr! s/offset)
				+ (series/head << (GET_UNIT(s) >> 1))
				< (as byte-ptr! s/tail)
		]
	]

	set-many: func [
		words [red-block!]
		value [red-value!]
		size  [integer!]
		/local
			v		[red-value!]
			blk		[red-block!]
			i		[integer!]
			block?	[logic!]
	][
		block?: TYPE_OF(value) = TYPE_BLOCK
		if block? [blk: as red-block! value]
		i: 1

		while [i <= size][
			v: either block? [block/pick blk i][value]
			_context/set
				as red-word! block/pick words i
				v
			i: i + 1
		]
	]

	foreach-next-block: func [
		size	[integer!]								;-- number of words in the block
		return: [logic!]
		/local
			series [red-series!]
			blk    [red-block!]
			result [logic!]
	][
		blk:    as red-block!  stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(blk) = TYPE_BLOCK

		set-many blk as red-value! series size
		result: loop? series
		series/head: series/head + size
		result
	]

	foreach-next: func [
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
			result [logic!]
	][
		word:   as red-word!   stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(word) = TYPE_WORD

		_context/set word actions/pick series 1
		result: loop? series
		series/head: series/head + 1
		result
	]

	forall-loop: func [									;@@ inline?
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: as red-word! stack/arguments - 1
		assert TYPE_OF(word) = TYPE_WORD

		series: as red-series! _context/get word
		loop? series
	]

	forall-next: func [									;@@ inline?
		/local
			series [red-series!]
	][
		series: as red-series! _context/get as red-word! stack/arguments - 1
		series/head: series/head + 1
	]

	forall-end: func [									;@@ inline?
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: 	as red-word!   stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(word) = TYPE_WORD

		_context/set word as red-value! series			;-- reset series to its initial offset
	]

	register [
		:if*
		:unless*
		:either*
		:any*
		:all*
		:while*
		:until*
		:loop*
		:repeat*
		:foreach*
		:forall*
		:func*
		:function*
		:does*
		:has*
		:exit*
		:return*
		:switch*
		:case*
		:do*
		:get*
		:set*
		:print*
		:prin*
		:equal?*
		:not-equal?*
		:strict-equal?*
		:lesser?*
		:greater?*
		:lesser-or-equal?*
		:greater-or-equal?*
		:same?*
		:not*
		:halt*
		:type?*
		:load*
		:reduce*
	]

]

Red/System [
	Title:   "Red native functions"
	Author:  "Nenad Rakocevic"
	File: 	 %natives.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 RETURN_NONE [
	stack/reset
	none/push-last
	exit
]

#define RETURN_UNSET [
	stack/reset
	unset/push-last
]

natives: context [
	verbose: 0
	lf?: 	 no											;-- used to print or not an ending newline

	table: as int-ptr! allocate NATIVES_NB * size? integer!
	top: 0

	register: func [
		[variadic]
		count	   [integer!]
		list	   [int-ptr!]
		/local
			offset [integer!]
	][
		offset: 0

		until [
			table/top: list/value
			top: top + 1
			assert top < NATIVES_NB
			list: list + 1
			count: count - 1
			zero? count
		]
	]

	;--- Natives ----

	if*: does [
		either logic/false? [
			RETURN_NONE
		][
			interpreter/eval as red-block! stack/arguments + 1 no
		]
	]

	unless*: does [
		either logic/false? [
			interpreter/eval as red-block! stack/arguments + 1 no
		][
			RETURN_NONE
		]
	]

	either*: func [
		/local offset [integer!]
	][
		offset: either logic/true? [1][2]
		interpreter/eval as red-block! stack/arguments + offset no
	]

	any*: func [
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head as red-block! stack/arguments
		tail:  block/rs-tail as red-block! stack/arguments

		while [value < tail][
			value: interpreter/eval-next value tail no
			if logic/true? [exit]
		]
		RETURN_NONE
	]

	all*: func [
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head as red-block! stack/arguments
		tail:  block/rs-tail as red-block! stack/arguments

		while [value < tail][
			value: interpreter/eval-next value tail no
			if logic/false? [RETURN_NONE]
		]
	]

	while*:	func [
		/local
			cond [red-block!]
			body [red-block!]
	][
		cond: as red-block! stack/arguments
		body: as red-block! stack/arguments + 1

		stack/mark-native words/_body
		while [
			interpreter/eval cond
			logic/true?
		][
			stack/reset
			interpreter/eval body
		]
		stack/unwind
		RETURN_UNSET
	]

	until*: func [
		/local
			body [red-block!]
	][
		body: as red-block! stack/arguments

		stack/mark-native words/_body
		until [
			stack/reset
			interpreter/eval body
			logic/true?
		]
		stack/unwind-last
	]

	loop*: func [
		/local
			body [red-block!]
			i	 [integer!]
	][
		i: integer/get*
		unless positive? i [RETURN_NONE]				;-- if counter <= 0, no loops

		body: as red-block! stack/arguments + 1

		stack/mark-native words/_body
		until [
			stack/reset
			interpreter/eval body
			i: i - 1
			zero? i
		]
		stack/unwind-last
	]

	repeat*: func [
		/local
			w	   [red-word!]
			body   [red-block!]
			count  [red-integer!]
			cnt	   [integer!]
			i	   [integer!]
	][
		w: 	   as red-word!    stack/arguments
		count: as red-integer! stack/arguments + 1
		body:  as red-block!   stack/arguments + 2

		i: integer/get as red-value! count
		unless positive? i [RETURN_NONE]				;-- if counter <= 0, no loops

		count/value: 1

		stack/mark-native words/_body
		until [
			stack/reset
			_context/set w as red-value! count
			interpreter/eval body
			count/value: count/value + 1
			i: i - 1
			zero? i
		]
		stack/unwind-last
	]

	foreach*: func [
		/local
			value [red-value!]
			body  [red-block!]
			size  [integer!]
	][
		value: stack/arguments
		body: as red-block! stack/arguments + 2

		stack/push stack/arguments + 1					;-- copy arguments to stack top in reverse order
		stack/push value								;-- (required by foreach-next)

		stack/mark-native words/_body

		either TYPE_OF(value) = TYPE_BLOCK [
			size: block/rs-length? as red-block! value

			while [foreach-next-block size][			;-- foreach [..]
				stack/reset
				interpreter/eval body
			]
		][
			while [foreach-next][						;-- foreach <word!>
				stack/reset
				interpreter/eval body
			]
		]
		stack/unwind-last
	]

	forall*: func [
		/local
			w 	   [red-word!]
			body   [red-block!]
			saved  [red-value!]
			series [red-series!]
	][
		w:    as red-word!  stack/arguments
		body: as red-block! stack/arguments + 1

		saved: word/get w							;-- save series (for resetting on end)
		w: word/push w								;-- word argument

		stack/mark-native words/_body
		while [
			loop? as red-series! _context/get w
		][
			stack/reset
			interpreter/eval body
			series: as red-series! _context/get w
			series/head: series/head + 1
		]
		stack/unwind-last
		_context/set w saved
	]

	func*:		does []
	function*:	does []
	does*:		does []
	has*:		does []
	exit*:		does []
	return*:	does []

	switch*: func [
		default? [integer!]								;@@ not implemented yet
		/local
			pos	 [red-value!]
			blk  [red-block!]
			end  [red-value!]
			s	 [series!]
	][
		blk: as red-block! stack/arguments + 1

		pos: actions/find
			as red-series! blk
			stack/arguments
			null
			no
			no
			no
			null
			null
			no
			no
			yes											;-- /tail
			no

		either TYPE_OF(blk) = TYPE_NONE [
			;TBD: add default block processing
			0
		][
			s: GET_BUFFER(blk)
			end: s/tail

			while [pos < end][							;-- find first following block
				if TYPE_OF(pos) = TYPE_BLOCK [
					stack/reset
					interpreter/eval as red-block! pos	;-- do the block
					exit								;-- early exit with last value on stack
				]
				pos: pos + 1
			]
		]
		RETURN_NONE
	]

	case*: func [
		all? 	  [integer!]							;@@ not implemented yet
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head as red-block! stack/arguments
		tail:  block/rs-tail as red-block! stack/arguments
		if value = tail [RETURN_NONE]

		while [value < tail][
			value: interpreter/eval-next value tail no	;-- eval condition
			either logic/true? [
				either TYPE_OF(value) = TYPE_BLOCK [	;-- if true, eval what follows it
					stack/reset
					interpreter/eval as red-block! value
				][
					value: interpreter/eval-next value tail no
				]
				exit									;-- early exit with last value on stack
			][
				value: value + 1						;-- single value only allowed for cases bodies
			]
		]
		RETURN_NONE
	]

	do*: does [
		interpreter/eval as red-block! stack/arguments no
	]

	get*: func [
		any? [integer!]
	][
		stack/set-last _context/get as red-word! stack/arguments
	]

	set*: func [
		any? [integer!]
		/local
			w	  [red-word!]
			value [red-value!]
			blk	  [red-block!]
	][
		w: as red-word! stack/arguments
		value: stack/arguments + 1

		either TYPE_OF(w) = TYPE_BLOCK [
			blk: as red-block! w
			set-many blk value block/rs-length? blk
			stack/set-last value
		][
			stack/set-last _context/set w value
		]
	]

	print*: does [
		lf?: yes
		prin*
		lf?: no
	]

	prin*: func [
		/local
			arg		[red-value!]
			str		[red-string!]
			series	[series!]
			offset	[byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/prin"]]

		arg: stack/arguments

		either TYPE_OF(arg) = TYPE_STRING [
			str: as red-string! arg
		][
			actions/form* -1
			str: as red-string! stack/arguments + 1
			assert any [
				TYPE_OF(str) = TYPE_STRING
				TYPE_OF(str) = TYPE_SYMBOL					;-- symbol! and string! structs are overlapping
			]
		]
		series: GET_BUFFER(str)
		offset: (as byte-ptr! series/offset) + (str/head << (GET_UNIT(series) >> 1))

		either lf? [
			switch GET_UNIT(series) [
				Latin1 [platform/print-line-Latin1 as c-string! offset]
				UCS-2  [platform/print-line-UCS2 				offset]
				UCS-4  [platform/print-line-UCS4   as int-ptr!  offset]

				default [									;@@ replace by an assertion
					print-line ["Error: unknown string encoding: " GET_UNIT(series)]
				]
			]
		][
			switch GET_UNIT(series) [
				Latin1 [platform/print-Latin1 as c-string! offset]
				UCS-2  [platform/print-UCS2   			   offset]
				UCS-4  [platform/print-UCS4   as int-ptr!  offset]

				default [									;@@ replace by an assertion
					print-line ["Error: unknown string encoding: " GET_UNIT(series)]
				]
			]
		]
		stack/set-last unset-value
	]

	compare: func [
		op		   [integer!]
		return:    [red-logic!]
		/local
			args   [red-value!]
			result [red-logic!]
	][
		args: stack/arguments
		result: as red-logic! args
		result/value: actions/compare args args + 1 op
		result/header: TYPE_LOGIC
		result
	]

	equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/equal?"]]
		compare COMP_EQUAL
	]

	not-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not-equal?"]]
		compare COMP_NOT_EQUAL
	]

	strict-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/strict-equal?"]]
		compare COMP_STRICT_EQUAL
	]

	lesser?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser?"]]
		compare COMP_LESSER
	]

	greater?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater?"]]
		compare COMP_GREATER
	]

	lesser-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser-or-equal?"]]
		compare COMP_LESSER_EQUAL
	]

	greater-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater-or-equal?"]]
		compare COMP_GREATER_EQUAL
	]

	same?*: does []

	not*: func [
		/local bool [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not"]]

		bool: as red-logic! stack/arguments
		bool/value: logic/false?						;-- run test before modifying stack
		bool/header: TYPE_LOGIC
	]

	halt*: does [halt]

	type?*: func [
		word?	 [integer!]
		return:  [red-value!]
		/local
			dt	 [red-datatype!]
			w	 [red-word!]
			name [names!]
	][
		either negative? word? [
			dt: as red-datatype! stack/arguments		;-- overwrite argument
			dt/value: TYPE_OF(dt)						;-- extract type before overriding
			dt/header: TYPE_DATATYPE
			as red-value! dt
		][
			w: as red-word! stack/arguments				;-- overwrite argument
			name: name-table + TYPE_OF(w)				;-- point to the right datatype name record
			stack/set-last as red-value! name/word
		]
	]

	load*: func [
		/local
			str [red-string!]
			s	[series!]
	][
		str: as red-string! stack/arguments
		s: GET_BUFFER(str)
		tokenizer/scan as c-string! s/offset null	;@@ temporary limited to Latin-1
	]

	reduce*: func [
		into [integer!]
		/local
			value [red-value!]
			tail  [red-value!]
			blk	  [red-block!]
			arg	  [red-value!]
	][
		arg: stack/arguments
		if TYPE_OF(arg) <> TYPE_BLOCK [
			interpreter/eval-expression arg arg + 1 no no
			exit
		]

		value: block/rs-head as red-block! arg
		tail:  block/rs-tail as red-block! arg

		stack/mark-native words/_body

		blk: either negative? into [
			block/push-only* (as-integer tail - value) >> 4
		][
			as red-block! arg + into
		]

		while [value < tail][
			value: interpreter/eval-next value tail yes
			block/append*
			stack/keep									;-- preserve the reduced block on stack
		]
		stack/unwind-last
	]

	;--- Natives helper functions ---

	loop?: func [
		series     [red-series!]
		return:    [logic!]
		/local
			s	   [series!]
	][
		s: GET_BUFFER(series)

		either TYPE_OF(series) = TYPE_BLOCK [			;@@ replace with any-block?/any-string? check
			s/offset + series/head < s/tail
		][
			(as byte-ptr! s/offset)
				+ (series/head << (GET_UNIT(s) >> 1))
				< (as byte-ptr! s/tail)
		]
	]

	set-many: func [
		words [red-block!]
		value [red-value!]
		size  [integer!]
		/local
			v		[red-value!]
			blk		[red-block!]
			i		[integer!]
			block?	[logic!]
	][
		block?: TYPE_OF(value) = TYPE_BLOCK
		if block? [blk: as red-block! value]
		i: 1

		while [i <= size][
			v: either block? [block/pick blk i][value]
			_context/set
				as red-word! block/pick words i
				v
			i: i + 1
		]
	]

	foreach-next-block: func [
		size	[integer!]								;-- number of words in the block
		return: [logic!]
		/local
			series [red-series!]
			blk    [red-block!]
			result [logic!]
	][
		blk:    as red-block!  stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(blk) = TYPE_BLOCK

		set-many blk as red-value! series size
		result: loop? series
		series/head: series/head + size
		result
	]

	foreach-next: func [
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
			result [logic!]
	][
		word:   as red-word!   stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(word) = TYPE_WORD

		_context/set word actions/pick series 1
		result: loop? series
		series/head: series/head + 1
		result
	]

	forall-loop: func [									;@@ inline?
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: as red-word! stack/arguments - 1
		assert TYPE_OF(word) = TYPE_WORD

		series: as red-series! _context/get word
		loop? series
	]

	forall-next: func [									;@@ inline?
		/local
			series [red-series!]
	][
		series: as red-series! _context/get as red-word! stack/arguments - 1
		series/head: series/head + 1
	]

	forall-end: func [									;@@ inline?
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: 	as red-word!   stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(word) = TYPE_WORD

		_context/set word as red-value! series			;-- reset series to its initial offset
	]

	register [
		:if*
		:unless*
		:either*
		:any*
		:all*
		:while*
		:until*
		:loop*
		:repeat*
		:foreach*
		:forall*
		:func*
		:function*
		:does*
		:has*
		:exit*
		:return*
		:switch*
		:case*
		:do*
		:get*
		:set*
		:print*
		:prin*
		:equal?*
		:not-equal?*
		:strict-equal?*
		:lesser?*
		:greater?*
		:lesser-or-equal?*
		:greater-or-equal?*
		:same?*
		:not*
		:halt*
		:type?*
		:load*
		:reduce*
	]

]


FEAT: dump-hex4 now requires a pointer! [integer!] as argument (closer to use-cases).

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

__line-record!: alias struct! [				;-- debug lines records associating code addresses and source lines
	address [byte-ptr!]						;-- native code pointer
	line	[integer!]						;-- source line number
	file	[integer!]						;-- source file name c-string offset (from first record)
]

__debug-lines: declare __line-record!		;-- pointer to first debug-lines record (set at link-time)

;-------------------------------------------
;-- Calculate line number for a runtime error and print it (internal function).
;-------------------------------------------
__print-debug-line: func [
	address [byte-ptr!]						;-- memory address where the runtime error happened
	/local base records
][
	records: __debug-lines
	base: as byte-ptr! records

	while [records/address < address][		;-- search for the closest record
		records: records + 1
	]
	if records/address > address [			;-- if not an exact match, use the closest lower record
		records: records - 1
	]
	print [
		lf "*** in file: " as-c-string base + records/file
		lf "*** at line: " records/line
		lf
	]
]

;-------------------------------------------
;-- Print an integer as hex number on screen, limited to n characters
;-------------------------------------------
prin-hex-chars: func [
	i [integer!]							;-- input integer to print
	n [integer!]							;-- max number of characters to print (right-aligned)
	return: [integer!]						;-- return the input integer (pass-thru)
	/local s c d ret
][
	s: "00000000"
	if zero? i [
		s: "00000000"
		print s + (8 - n)
		return i
	]
	c: 8
	ret: i
	until [
		d: i // 16
		if d > 9 [d: d + 7]					;-- 7 = (#"A" - 1) - #"9"
		s/c: #"0" + d
		i: i >>> 4
		c: c - 1
		zero? c								;-- iterate on all 8 bytes to overwrite previous values
	]
	prin s + (8 - n)
	ret
]

;-------------------------------------------
;-- Dump memory on screen in hex format
;-------------------------------------------
dump-memory: func [
	address	[byte-ptr!]						;-- memory address where the dump starts
	unit	[integer!]						;-- size of memory chunks to print in hex format (1 or 4 bytes)
	return: [byte-ptr!]						;-- return the pointer (pass-thru)
	/local offset ascii i byte int-ptr data-ptr
][
	assert any [unit = 1 unit = 4]

	print ["^/Hex dump from: " address "h^/" lf]

	offset: 0
	ascii: "                "

	data-ptr: address
	until [
		print [address ": "]
		i: 0
		until [
			i: i + 1

			if unit = 1 [
				prin-hex-chars as-integer address/value 2
				address: address + 1
				print either i = 8 ["  "][" "]
			]
			if all [unit = 4 zero? (i // 4)][
				int-ptr: as int-ptr! address
				prin-hex int-ptr/value
				address: address + 4
				print either i = 8 ["  "][" "]
			]

			byte: data-ptr/value
			ascii/i: either byte < as-byte 32 [
				either byte = null-byte [#"."][#"^(FE)"]
			][
				byte
			]

			data-ptr: data-ptr + 1
			i = 16
		]
		print [space ascii lf]
		offset: offset + 16
		offset = 128
	]
	address
]

;-------------------------------------------
;-- Dump memory on screen in hex format as array of bytes (handy wrapper on dump-hex)
;-------------------------------------------
dump-hex: func [
	address	[byte-ptr!]						;-- memory address where the dump starts
	return: [byte-ptr!]						;-- return the pointer (pass-thru)
][
	dump-memory address 1
]

;-------------------------------------------
;-- Dump memory on screen in hex format as array of 32-bit integers (handy wrapper on dump-hex)
;-------------------------------------------
dump-hex4: func [
	address	[int-ptr!]						;-- memory address where the dump starts
	return: [int-ptr!]						;-- return the pointer (pass-thru)
][
	as int-ptr! dump-memory as byte-ptr! address 4
]

;-------------------------------------------
;-- Show FPU all internal options and exception masks
;-------------------------------------------
show-fpu-info: func [/local value][
	#switch target [
		IA-32 [
			print-wide [
				"FPU type:"
				switch system/fpu/type [
					FPU_TYPE_X87 ["x87"]
					FPU_TYPE_SSE ["SSE"]
					default 	 ["unknown"]
				]
				lf
			]
			print-wide [
				"- control word:" as byte-ptr! system/fpu/control-word
				lf
			]
			print-wide [
				"- rounding    :"
				switch system/fpu/option/rounding [
					FPU_X87_ROUNDING_NEAREST ["nearest"]
					FPU_X87_ROUNDING_DOWN	 ["toward -INF"]
					FPU_X87_ROUNDING_UP		 ["toward +INF"]
					FPU_X87_ROUNDING_ZERO	 ["toward zero"]
				]
				lf
			]
			print-wide [
				"- precision   :"
				switch system/fpu/option/precision [
					FPU_X87_PRECISION_SINGLE	 ["single (32-bit)"]
					FPU_X87_PRECISION_DOUBLE	 ["double (64-bit)"]
					FPU_X87_PRECISION_DOUBLE_EXT ["double extended (80-bit)"]
				]
				lf
			]
			print-line "- raise exceptions for:"
			print-wide ["    - precision  :" either system/fpu/mask/precision   ["no"]["yes"] lf]
			print-wide ["    - underflow  :" either system/fpu/mask/underflow   ["no"]["yes"] lf]
			print-wide ["    - overflow   :" either system/fpu/mask/overflow    ["no"]["yes"] lf]
			print-wide ["    - zero-divide:" either system/fpu/mask/zero-divide ["no"]["yes"] lf]
			print-wide ["    - denormal   :" either system/fpu/mask/denormal    ["no"]["yes"] lf]
			print-wide ["    - invalid-op :" either system/fpu/mask/invalid-op  ["no"]["yes"] lf]
		]
		ARM [
			value: switch system/fpu/type [
				FPU_TYPE_VFP ["VFP"]
				default 	 ["unknown"]
			]
			print-wide ["FPU type:" value lf]
		]
	]
]

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

__line-record!: alias struct! [				;-- debug lines records associating code addresses and source lines
	address [byte-ptr!]						;-- native code pointer
	line	[integer!]						;-- source line number
	file	[integer!]						;-- source file name c-string offset (from first record)
]

__debug-lines: declare __line-record!		;-- pointer to first debug-lines record (set at link-time)

;-------------------------------------------
;-- Calculate line number for a runtime error and print it (internal function).
;-------------------------------------------
__print-debug-line: func [
	address [byte-ptr!]						;-- memory address where the runtime error happened
	/local base records
][
	records: __debug-lines
	base: as byte-ptr! records

	while [records/address < address][		;-- search for the closest record
		records: records + 1
	]
	if records/address > address [			;-- if not an exact match, use the closest lower record
		records: records - 1
	]
	print [
		lf "*** in file: " as-c-string base + records/file
		lf "*** at line: " records/line
		lf
	]
]

;-------------------------------------------
;-- Print an integer as hex number on screen, limited to n characters
;-------------------------------------------
prin-hex-chars: func [
	i [integer!]							;-- input integer to print
	n [integer!]							;-- max number of characters to print (right-aligned)
	return: [integer!]						;-- return the input integer (pass-thru)
	/local s c d ret
][
	s: "00000000"
	if zero? i [
		s: "00000000"
		print s + (8 - n)
		return i
	]
	c: 8
	ret: i
	until [
		d: i // 16
		if d > 9 [d: d + 7]					;-- 7 = (#"A" - 1) - #"9"
		s/c: #"0" + d
		i: i >>> 4
		c: c - 1
		zero? c								;-- iterate on all 8 bytes to overwrite previous values
	]
	prin s + (8 - n)
	ret
]

;-------------------------------------------
;-- Dump memory on screen in hex format
;-------------------------------------------
dump-memory: func [
	address	[byte-ptr!]						;-- memory address where the dump starts
	unit	[integer!]						;-- size of memory chunks to print in hex format (1 or 4 bytes)
	return: [byte-ptr!]						;-- return the pointer (pass-thru)
	/local offset ascii i byte int-ptr data-ptr
][
	assert any [unit = 1 unit = 4]

	print ["^/Hex dump from: " address "h^/" lf]

	offset: 0
	ascii: "                "

	data-ptr: address
	until [
		print [address ": "]
		i: 0
		until [
			i: i + 1

			if unit = 1 [
				prin-hex-chars as-integer address/value 2
				address: address + 1
				print either i = 8 ["  "][" "]
			]
			if all [unit = 4 zero? (i // 4)][
				int-ptr: as int-ptr! address
				prin-hex int-ptr/value
				address: address + 4
				print either i = 8 ["  "][" "]
			]

			byte: data-ptr/value
			ascii/i: either byte < as-byte 32 [
				either byte = null-byte [#"."][#"^(FE)"]
			][
				byte
			]

			data-ptr: data-ptr + 1
			i = 16
		]
		print [space ascii lf]
		offset: offset + 16
		offset = 128
	]
	address
]

;-------------------------------------------
;-- Dump memory on screen in hex format as array of bytes (handy wrapper on dump-hex)
;-------------------------------------------
dump-hex: func [
	address	[byte-ptr!]						;-- memory address where the dump starts
	return: [byte-ptr!]						;-- return the pointer (pass-thru)
][
	dump-memory address 1
]

;-------------------------------------------
;-- Dump memory on screen in hex format as array of 32-bit integers (handy wrapper on dump-hex)
;-------------------------------------------
dump-hex4: func [
	address	[byte-ptr!]						;-- memory address where the dump starts
	return: [byte-ptr!]						;-- return the pointer (pass-thru)
][
	dump-memory address 4
]

;-------------------------------------------
;-- Show FPU all internal options and exception masks
;-------------------------------------------
show-fpu-info: func [/local value][
	#switch target [
		IA-32 [
			print-wide [
				"FPU type:"
				switch system/fpu/type [
					FPU_TYPE_X87 ["x87"]
					FPU_TYPE_SSE ["SSE"]
					default 	 ["unknown"]
				]
				lf
			]
			print-wide [
				"- control word:" as byte-ptr! system/fpu/control-word
				lf
			]
			print-wide [
				"- rounding    :"
				switch system/fpu/option/rounding [
					FPU_X87_ROUNDING_NEAREST ["nearest"]
					FPU_X87_ROUNDING_DOWN	 ["toward -INF"]
					FPU_X87_ROUNDING_UP		 ["toward +INF"]
					FPU_X87_ROUNDING_ZERO	 ["toward zero"]
				]
				lf
			]
			print-wide [
				"- precision   :"
				switch system/fpu/option/precision [
					FPU_X87_PRECISION_SINGLE	 ["single (32-bit)"]
					FPU_X87_PRECISION_DOUBLE	 ["double (64-bit)"]
					FPU_X87_PRECISION_DOUBLE_EXT ["double extended (80-bit)"]
				]
				lf
			]
			print-line "- raise exceptions for:"
			print-wide ["    - precision  :" either system/fpu/mask/precision   ["no"]["yes"] lf]
			print-wide ["    - underflow  :" either system/fpu/mask/underflow   ["no"]["yes"] lf]
			print-wide ["    - overflow   :" either system/fpu/mask/overflow    ["no"]["yes"] lf]
			print-wide ["    - zero-divide:" either system/fpu/mask/zero-divide ["no"]["yes"] lf]
			print-wide ["    - denormal   :" either system/fpu/mask/denormal    ["no"]["yes"] lf]
			print-wide ["    - invalid-op :" either system/fpu/mask/invalid-op  ["no"]["yes"] lf]
		]
		ARM [
			value: switch system/fpu/type [
				FPU_TYPE_VFP ["VFP"]
				default 	 ["unknown"]
			]
			print-wide ["FPU type:" value lf]
		]
	]
]


FEAT: added COPY action support to bitset! datatype.

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-zeroed s (index >> 3) + 1]
		as byte-ptr! s/offset
	]

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

	match?: func [										;-- called from PARSE
		pbits	[byte-ptr!]
		index	[integer!]								;-- 0-based
		case?	[logic!]
		return: [logic!]
		/local
			match? [logic!]
	][													;-- no out of bound index checking!
		BS_TEST_BIT(pbits index match?)

		if all [not case? not match?][
			either all [65 <= index index <= 90][		;-- try with lowercasing
				index: index + 32
				BS_TEST_BIT(pbits index match?)
			][
				if all [97 <= index index <= 122][		;-- try with uppercasing
					index: index - 32
					BS_TEST_BIT(pbits index match?)
				]
			]
		]
		match?
	]

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

		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
	]

	union: func [
		set1	[red-bitset!]
		set2	[red-bitset!]
		case?	[logic!]
		skip	[red-value!]
		return: [red-bitset!]
		/local
			s1	  [series!]
			s2	  [series!]
			s	  [series!]
			node  [node!]
			p	  [byte-ptr!]
			p1	  [byte-ptr!]
			p2	  [byte-ptr!]
			tail  [byte-ptr!]
			same? [logic!]
	][
		s1: GET_BUFFER(set1)
		s2: GET_BUFFER(set2)

		if s1/size > s2/size [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
		s/tail: as red-value! (p + s/size)
		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: either same? [
				p1/value or p2/value					;-- OR s1 with part(s2)
			][
				p1/value xor p2/value					;-- XOR s1 with part(s2)
			]
			p:  p  + 1
			p1: p1 + 1
			p2: p2 + 1
			p1 = tail
		]
		tail: as byte-ptr! s2/tail
		if p2 < tail [copy-memory p p2 as-integer tail - p2] ;-- just copy remaining of s2

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

	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)

		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 virtual-bit? bits upper [return as-integer not?]
				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 virtual-bit? bits upper [return as-integer not?]
				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!]
			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 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!]
			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)
					switch op [
						OP_SET   [
							pbits: bound-check bits max
							BS_SET_BIT(pbits max)
						]
						OP_TEST  [
							if virtual-bit? bits max [return as-integer not?]
							pbits: rs-head bits
							BS_TEST_BIT(pbits max test?)
							max: as-integer test?
						]
						OP_CLEAR [
							if virtual-bit? bits max [return as-integer not?]
							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!]
			blk	 [red-block!]
			w	 [red-word!]
			s	 [series!]
			not? [logic!]
	][
		#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 size

			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
			]

			size: process spec null OP_MAX no			;-- 1st pass: determine size
			bits/node: alloc-bytes-zeroed size
			process spec bits OP_SET no					;-- 2nd pass: set bits

			if not? [
				s: GET_BUFFER(bits)
				s/flags: s/flags or flag-bitset-not
				blk/head: blk/head - 1					;-- restore series argument head
				invert-bytes s
			]
		]
		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
	]

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

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

	copy: func [
		bits	 [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)
		bits: as red-bitset! stack/push*
		bits/header: TYPE_BITSET
		bits/node:	 copy-series s
		bits
	]

	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!]
			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]
		][
			either not? [OP_SET][OP_CLEAR]
		][
			either not? [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~
			:complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			:copy
			:find
			null			;head
			null			;head?
			null			;index?
			: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-zeroed s (index >> 3) + 1]
		as byte-ptr! s/offset
	]

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

	match?: func [										;-- called from PARSE
		pbits	[byte-ptr!]
		index	[integer!]								;-- 0-based
		case?	[logic!]
		return: [logic!]
		/local
			match? [logic!]
	][													;-- no out of bound index checking!
		BS_TEST_BIT(pbits index match?)

		if all [not case? not match?][
			either all [65 <= index index <= 90][		;-- try with lowercasing
				index: index + 32
				BS_TEST_BIT(pbits index match?)
			][
				if all [97 <= index index <= 122][		;-- try with uppercasing
					index: index - 32
					BS_TEST_BIT(pbits index match?)
				]
			]
		]
		match?
	]

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

		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
	]

	union: func [
		set1	[red-bitset!]
		set2	[red-bitset!]
		case?	[logic!]
		skip	[red-value!]
		return: [red-bitset!]
		/local
			s1	  [series!]
			s2	  [series!]
			s	  [series!]
			node  [node!]
			p	  [byte-ptr!]
			p1	  [byte-ptr!]
			p2	  [byte-ptr!]
			tail  [byte-ptr!]
			same? [logic!]
	][
		s1: GET_BUFFER(set1)
		s2: GET_BUFFER(set2)

		if s1/size > s2/size [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
		s/tail: as red-value! (p + s/size)
		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: either same? [
				p1/value or p2/value					;-- OR s1 with part(s2)
			][
				p1/value xor p2/value					;-- XOR s1 with part(s2)
			]
			p:  p  + 1
			p1: p1 + 1
			p2: p2 + 1
			p1 = tail
		]
		tail: as byte-ptr! s2/tail
		if p2 < tail [copy-memory p p2 as-integer tail - p2] ;-- just copy remaining of s2

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

	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)

		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 virtual-bit? bits upper [return as-integer not?]
				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 virtual-bit? bits upper [return as-integer not?]
				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!]
			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 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!]
			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)
					switch op [
						OP_SET   [
							pbits: bound-check bits max
							BS_SET_BIT(pbits max)
						]
						OP_TEST  [
							if virtual-bit? bits max [return as-integer not?]
							pbits: rs-head bits
							BS_TEST_BIT(pbits max test?)
							max: as-integer test?
						]
						OP_CLEAR [
							if virtual-bit? bits max [return as-integer not?]
							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!]
			blk	 [red-block!]
			w	 [red-word!]
			s	 [series!]
			not? [logic!]
	][
		#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 size

			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
			]

			size: process spec null OP_MAX no			;-- 1st pass: determine size
			bits/node: alloc-bytes-zeroed size
			process spec bits OP_SET no					;-- 2nd pass: set bits

			if not? [
				s: GET_BUFFER(bits)
				s/flags: s/flags or flag-bitset-not
				blk/head: blk/head - 1					;-- restore series argument head
				invert-bytes s
			]
		]
		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
	]

	complement: func [
		bits	[red-bitset!]
		return:	[red-value!]
		/local
			s	 [series!]
			new  [series!]
			node [node!]
	][
		s: GET_BUFFER(bits)
		node: copy-series s
		new: as series! node/value
		new/flags: new/flags xor flag-bitset-not
		invert-bytes new

		bits: as red-bitset! stack/push*
		bits/header: TYPE_BITSET
		bits/node:	 node
		as red-value! bits
	]

	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!]
			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]
		][
			either not? [OP_SET][OP_CLEAR]
		][
			either not? [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~
			: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
		]
	]
]


cleanup

cleanup

Red [url: https://adventofcode.com/2018/day/1]

input: load %../../resources/2018/day01

; part 1
probe sum input ; 470

; part 2
result: 0
list: make hash! [0]
duplicate: false

until [
  foreach freq input [
    result: result + freq
    either find list result [
      duplicate: true break
    ][
      append list result
    ]
  ]
  duplicate
]

probe result ; 790

Red [url: https://adventofcode.com/2018/day/1]

input: load %../../resources/2018/day01

; part 1
probe sum input ; 470

; part 2
result: 0
list: make hash! [0]
duplicate: false

until [
  foreach freq input [
    result: result + to integer! freq
    either find list result [
      duplicate: true break
    ][
      append list result
    ]
  ]
  duplicate
]

probe result ; 790


FEAT: minor code improvement after #272 bugfix.

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

natives: context [
	verbose: 0

	lf?: no												;-- used to print or not an ending newline

	print*: does [
		lf?: yes
		prin*
		lf?: no
	]

	prin*: func [
		/local
			arg		[red-value!]
			str		[red-string!]
			series	[series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/prin"]]

		arg: stack/arguments

		either TYPE_OF(arg) = TYPE_STRING [
			str: as red-string! arg
		][
			actions/form*
			str: as red-string! arg + 1
			assert any [
				TYPE_OF(str) = TYPE_STRING
				TYPE_OF(str) = TYPE_SYMBOL					;-- symbol! and string! structs are overlapping
			]
		]
		series: GET_BUFFER(str)

		either lf? [
			switch GET_UNIT(series) [
				Latin1 [platform/print-line-Latin1 as c-string! series/offset]
				UCS-2  [platform/print-line-UCS2   as byte-ptr! series/offset]
				UCS-4  [platform/print-line-UCS4   as int-ptr!  series/offset]

				default [
					print-line ["Error: unknown string encoding:" GET_UNIT(series)]
				]
			]
		][
			switch GET_UNIT(series) [
				Latin1 [platform/print-Latin1 as c-string! series/offset]
				UCS-2  [platform/print-UCS2   as byte-ptr! series/offset]
				UCS-4  [platform/print-UCS4   as int-ptr!  series/offset]

				default [
					print-line ["Error: unknown string encoding:" GET_UNIT(series)]
				]
			]
		]
		stack/set-last unset-value
	]

	compare: func [
		op		   [integer!]
		reverse	   [logic!]
		return:    [red-logic!]
		/local
			args   [red-value!]
			result [red-logic!]
	][
		args: stack/arguments
		result: as red-logic! args
		res: actions/compare args args + 1 op
		result/value: either reverse [not res][res]
		result/header: TYPE_LOGIC
		result
	]

	equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/equal?"]]
		compare COMP_EQUAL no
	]

	not-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not-equal?"]]
		compare COMP_EQUAL yes
	]

	strict-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/strict-equal?"]]
		compare COMP_STRICT_EQUAL no
	]

	lesser?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser?"]]
		compare COMP_LESSER no
	]

	greater?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater?"]]
		compare COMP_GREATER no
	]

	lesser-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser-or-equal?"]]
		compare COMP_LESSER_EQUAL no
	]

	greater-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater-or-equal?"]]
		compare COMP_GREATER_EQUAL no
	]

	not*: func [
		/local bool [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not"]]

		bool: as red-logic! stack/arguments
		bool/value: logic/false?						;-- run test before modifyin stack
		bool/header: TYPE_LOGIC
	]

	;--- Natives helper functions ---

	loop?: func [
		series     [red-series!]
		return:    [logic!]
		/local
			s	   [series!]
	][
		s: GET_BUFFER(series)

		either TYPE_OF(series) = TYPE_BLOCK [			;@@ replace with any-block?/any-string? check
			s/offset + series/head < s/tail
		][
			(as byte-ptr! s/offset)
				+ (series/head << (GET_UNIT(s) >> 1))
				< (as byte-ptr! s/tail)
		]
	]

	foreach-next: func [
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
			result [logic!]
	][
		series: as red-series! stack/arguments - 1
		word:   as red-word!   stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(word) = TYPE_WORD

		stack/mark exec/_pick							;@@ replace it with direct calls
		copy-cell as red-value! series stack/push
		integer/push 1
		actions/pick*
		stack/unwind

		_context/set word stack/last-value
		result: loop? series
		series/head: series/head + 1
		result
	]

	forall-loop: func [									;@@ inline?
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: as red-word! stack/arguments - 2
		assert TYPE_OF(word) = TYPE_WORD

		series: as red-series! _context/get word
		loop? series
	]

	forall-next: func [									;@@ inline?
		/local
			series [red-series!]
	][
		series: as red-series! _context/get as red-word! stack/arguments - 2
		series/head: series/head + 1
	]

	forall-end: func [									;@@ inline?
		/local
			series [red-series!]
			word   [red-word!]
	][
		series: as red-series! stack/arguments - 1
		word: as red-word! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(word) = TYPE_WORD

		_context/set word as red-value! series			;-- reset series to its initial offset
	]

]

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

natives: context [
	verbose: 0

	lf?: no												;-- used to print or not an ending newline

	print*: does [
		lf?: yes
		prin*
		lf?: no
	]

	prin*: func [
		/local
			arg		[red-value!]
			str		[red-string!]
			series	[series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/prin"]]

		arg: stack/arguments

		either TYPE_OF(arg) = TYPE_STRING [
			str: as red-string! arg
		][
			actions/form*
			str: as red-string! arg + 1
			assert any [
				TYPE_OF(str) = TYPE_STRING
				TYPE_OF(str) = TYPE_SYMBOL					;-- symbol! and string! structs are overlapping
			]
		]
		series: GET_BUFFER(str)

		either lf? [
			switch GET_UNIT(series) [
				Latin1 [platform/print-line-Latin1 as c-string! series/offset]
				UCS-2  [platform/print-line-UCS2   as byte-ptr! series/offset]
				UCS-4  [platform/print-line-UCS4   as int-ptr!  series/offset]

				default [
					print-line ["Error: unknown string encoding:" GET_UNIT(series)]
				]
			]
		][
			switch GET_UNIT(series) [
				Latin1 [platform/print-Latin1 as c-string! series/offset]
				UCS-2  [platform/print-UCS2   as byte-ptr! series/offset]
				UCS-4  [platform/print-UCS4   as int-ptr!  series/offset]

				default [
					print-line ["Error: unknown string encoding:" GET_UNIT(series)]
				]
			]
		]
		stack/set-last unset-value
	]

	compare: func [
		op		   [integer!]
		reverse	   [logic!]
		return:    [red-logic!]
		/local
			args   [red-value!]
			result [red-logic!]
	][
		args: stack/arguments
		result: as red-logic! args
		res: actions/compare args args + 1 op
		result/value: either reverse [not res][res]
		result/header: TYPE_LOGIC
		result
	]

	equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/equal?"]]
		compare COMP_EQUAL no
	]

	not-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not-equal?"]]
		compare COMP_EQUAL yes
	]

	strict-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/strict-equal?"]]
		compare COMP_STRICT_EQUAL no
	]

	lesser?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser?"]]
		compare COMP_LESSER no
	]

	greater?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater?"]]
		compare COMP_GREATER no
	]

	lesser-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser-or-equal?"]]
		compare COMP_LESSER_EQUAL no
	]

	greater-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater-or-equal?"]]
		compare COMP_GREATER_EQUAL no
	]

	not*: func [
		/local bool [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not"]]

		bool: as red-logic! stack/arguments
		bool/value: logic/false?						;-- run test before modifyin stack
		bool/header: TYPE_LOGIC
	]

	;--- Natives helper functions ---

	loop?: func [
		series     [red-series!]
		return:    [logic!]
		/local
			s	   [series!]
			result [logic!]
	][
		s: GET_BUFFER(series)

		either TYPE_OF(series) = TYPE_BLOCK [			;@@ replace with any-block?/any-string? check
			result: s/offset + series/head < s/tail
		][
			result: (as byte-ptr! s/offset)
				+ (series/head << (GET_UNIT(s) >> 1))
				< (as byte-ptr! s/tail)
		]
		result
	]

	foreach-next: func [
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
			result [logic!]
	][
		series: as red-series! stack/arguments - 1
		word:   as red-word!   stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(word) = TYPE_WORD

		stack/mark exec/_pick							;@@ replace it with direct calls
		copy-cell as red-value! series stack/push
		integer/push 1
		actions/pick*
		stack/unwind

		_context/set word stack/last-value
		result: loop? series
		series/head: series/head + 1
		result
	]

	forall-loop: func [									;@@ inline?
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: as red-word! stack/arguments - 2
		assert TYPE_OF(word) = TYPE_WORD

		series: as red-series! _context/get word
		loop? series
	]

	forall-next: func [									;@@ inline?
		/local
			series [red-series!]
	][
		series: as red-series! _context/get as red-word! stack/arguments - 2
		series/head: series/head + 1
	]

	forall-end: func [									;@@ inline?
		/local
			series [red-series!]
			word   [red-word!]
	][
		series: as red-series! stack/arguments - 1
		word: as red-word! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(word) = TYPE_WORD

		_context/set word as red-value! series			;-- reset series to its initial offset
	]

]


TESTS: added a simple regression test for issue #253

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

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

~~~start-file~~~ "alias"

  --test-- "alias-1"
    a1-str!: alias struct! [i [integer!]]
    a1-s: declare a1-str!
    a1-s/i: 123
  --assert a1-s/i = 123

  --test-- "alias-2"
    a2-str!: alias struct! [i [integer!]]
    a2-s: declare a2-str!
    a2-s/i: 123
    a2-str2!: alias struct! [a [a2-str!] b [a2-str!]]
    a2-s2: declare a2-str2!
    a2-s2/b: a2-s
    a2-s2/b/i: 987
  --assert a2-S/i = 987

  --test-- "alias-3"
    a3-alias!: alias struct! [s [c-string!]]
    a3-struct: declare a3-alias!
    a3-struct/s: "abcde"
    a3-struct-1: declare a3-alias!
    a3-struct-1/s: "fghij"
  --assert a3-struct/s/1 = #"a"
  --assert a3-struct/s/2 = #"b"
  --assert a3-struct/s/3 = #"c"
  --assert a3-struct/s/4 = #"d"
  --assert a3-struct/s/5 = #"e"
  --assert a3-struct-1/s/1 = #"f"
  --assert a3-struct-1/s/2 = #"g"
  --assert a3-struct-1/s/3 = #"h"
  --assert a3-struct-1/s/4 = #"i"
  --assert a3-struct-1/s/5 = #"j"

  --test-- "alias-4"
    a4-alias!: alias struct! [a [integer!] b [integer!]]
    a4-struct: declare a4-alias!
    a4-struct/a: 1
    a4-struct/b: 2
    a4-struct-1: declare a4-alias!
    a4-struct-1/a: 3
    a4-struct-1/b: 4
  --assert a4-struct/a = 1
  --assert a4-struct/b = 2
  --assert a4-struct-1/a = 3
  --assert a4-struct-1/b = 4

  --test-- "alias-5"
      a5-alias!: alias struct! [a [integer!] b [integer!]]
      a5-struc: declare a5-alias!
      a5-pointer: declare pointer! [integer!]
      a5-struc/a: 1
      a5-struc/b: 2
      a5-pointer: as [pointer! [integer!]] a5-struc
      a5-struc: as a5-alias! a5-pointer
   --assert a5-struc/a = 1
   --assert a5-struc/b = 2

     --test-- "alias-6"
    a6-alias!: alias struct! [a [byte!] b [byte!]]
    a6-struct: declare struct! [
      s1 [a6-alias!]
      s2 [a6-alias!]
    ]
    a6-struct/s1: declare a6-alias!
    a6-struct/s1/a: #"a"
    a6-struct/s1/b: #"b"
    a6-struct/s2: declare a6-alias!
    a6-struct/s2/a: #"x"                  ;; this assignment seems to be causing
    a6-struct/s2/b: #"y"                  ;;  memory to be over-written
  --assert a6-struct/s1/a = #"a"
  --assert a6-struct/s1/b = #"b"
  --assert a6-struct/s2/a = #"x"
  --assert a6-struct/s2/b = #"y"

  --test-- "alias-7"						;-- regression test from issue #235
	a!: alias struct! [a [byte!]]
	--assert system/alias/a! = system/alias/a!

~~~end-file~~~

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

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

~~~start-file~~~ "alias"

  --test-- "alias-1"
    a1-str!: alias struct! [i [integer!]]
    a1-s: declare a1-str!
    a1-s/i: 123
  --assert a1-s/i = 123

  --test-- "alias-2"
    a2-str!: alias struct! [i [integer!]]
    a2-s: declare a2-str!
    a2-s/i: 123
    a2-str2!: alias struct! [a [a2-str!] b [a2-str!]]
    a2-s2: declare a2-str2!
    a2-s2/b: a2-s
    a2-s2/b/i: 987
  --assert a2-S/i = 987

  --test-- "alias-3"
    a3-alias!: alias struct! [s [c-string!]]
    a3-struct: declare a3-alias!
    a3-struct/s: "abcde"
    a3-struct-1: declare a3-alias!
    a3-struct-1/s: "fghij"
  --assert a3-struct/s/1 = #"a"
  --assert a3-struct/s/2 = #"b"
  --assert a3-struct/s/3 = #"c"
  --assert a3-struct/s/4 = #"d"
  --assert a3-struct/s/5 = #"e"
  --assert a3-struct-1/s/1 = #"f"
  --assert a3-struct-1/s/2 = #"g"
  --assert a3-struct-1/s/3 = #"h"
  --assert a3-struct-1/s/4 = #"i"
  --assert a3-struct-1/s/5 = #"j"

  --test-- "alias-4"
    a4-alias!: alias struct! [a [integer!] b [integer!]]
    a4-struct: declare a4-alias!
    a4-struct/a: 1
    a4-struct/b: 2
    a4-struct-1: declare a4-alias!
    a4-struct-1/a: 3
    a4-struct-1/b: 4
  --assert a4-struct/a = 1
  --assert a4-struct/b = 2
  --assert a4-struct-1/a = 3
  --assert a4-struct-1/b = 4

  --test-- "alias-5"
      a5-alias!: alias struct! [a [integer!] b [integer!]]
      a5-struc: declare a5-alias!
      a5-pointer: declare pointer! [integer!]
      a5-struc/a: 1
      a5-struc/b: 2
      a5-pointer: as [pointer! [integer!]] a5-struc
      a5-struc: as a5-alias! a5-pointer
   --assert a5-struc/a = 1
   --assert a5-struc/b = 2

     --test-- "alias-6"
    a6-alias!: alias struct! [a [byte!] b [byte!]]
    a6-struct: declare struct! [
      s1 [a6-alias!]
      s2 [a6-alias!]
    ]
    a6-struct/s1: declare a6-alias!
    a6-struct/s1/a: #"a"
    a6-struct/s1/b: #"b"
    a6-struct/s2: declare a6-alias!
    a6-struct/s2/a: #"x"                  ;; this assignment seems to be causing
    a6-struct/s2/b: #"y"                  ;;  memory to be over-written
  --assert a6-struct/s1/a = #"a"
  --assert a6-struct/s1/b = #"b"
  --assert a6-struct/s2/a = #"x"
  --assert a6-struct/s2/b = #"y"

~~~end-file~~~