FIX: stack bad layout when REDUCE is used with /into option from interpreter.

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 [					;-- pass-thru for non block! values
			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! stack/push 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
	]

	compose-block: func [
		blk		[red-block!]
		deep?	[logic!]
		only?	[logic!]
		into	[red-block!]
		root?	[logic!]
		return: [red-block!]
		/local
			value  [red-value!]
			tail   [red-value!]
			new	   [red-block!]
			result [red-value!]
	][
		value: block/rs-head blk
		tail:  block/rs-tail blk

		new: either all [root? OPTION?(into)][
			into
		][
			block/push-only* (as-integer tail - value) >> 4
		]
		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_BLOCK [
					blk: either deep? [
						compose-block as red-block! value deep? only? into no
					][
						as red-block! value
					]
					copy-cell as red-value! blk ALLOC_TAIL(new)
				]
				TYPE_PAREN [
					blk: as red-block! value
					unless zero? block/rs-length? blk [
						interpreter/eval blk
						result: stack/arguments
						blk: as red-block! result

						unless any [
							TYPE_OF(result) = TYPE_UNSET
							all [
								not only?
								TYPE_OF(result) = TYPE_BLOCK
								zero? block/rs-length? blk
							]
						][
							either any [
								only?
								TYPE_OF(result) <> TYPE_BLOCK
							][
								copy-cell result ALLOC_TAIL(new)
							][
								block/rs-append-block new as red-block! result
							]
						]
					]
				]
				default [
					copy-cell value ALLOC_TAIL(new)
				]
			]
			value: value + 1
		]
		new
	]

	compose*: func [
		deep [integer!]
		only [integer!]
		into [integer!]
	][
		arg: stack/arguments
		if TYPE_OF(arg) <> TYPE_BLOCK [					;-- pass-thru for non block! values
			interpreter/eval-expression arg arg + 1 no no
			exit
		]
		stack/set-last
			as red-value! compose-block
				as red-block! arg
				as logic! deep + 1
				as logic! only + 1
				as red-block! stack/arguments + into
				yes
	]

	;--- 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*
		:compose*
	]

]

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 [					;-- pass-thru for non block! values
			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
	]

	compose-block: func [
		blk		[red-block!]
		deep?	[logic!]
		only?	[logic!]
		into	[red-block!]
		root?	[logic!]
		return: [red-block!]
		/local
			value  [red-value!]
			tail   [red-value!]
			new	   [red-block!]
			result [red-value!]
	][
		value: block/rs-head blk
		tail:  block/rs-tail blk

		new: either all [root? OPTION?(into)][
			into
		][
			block/push-only* (as-integer tail - value) >> 4
		]
		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_BLOCK [
					blk: either deep? [
						compose-block as red-block! value deep? only? into no
					][
						as red-block! value
					]
					copy-cell as red-value! blk ALLOC_TAIL(new)
				]
				TYPE_PAREN [
					blk: as red-block! value
					unless zero? block/rs-length? blk [
						interpreter/eval blk
						result: stack/arguments
						blk: as red-block! result

						unless any [
							TYPE_OF(result) = TYPE_UNSET
							all [
								not only?
								TYPE_OF(result) = TYPE_BLOCK
								zero? block/rs-length? blk
							]
						][
							either any [
								only?
								TYPE_OF(result) <> TYPE_BLOCK
							][
								copy-cell result ALLOC_TAIL(new)
							][
								block/rs-append-block new as red-block! result
							]
						]
					]
				]
				default [
					copy-cell value ALLOC_TAIL(new)
				]
			]
			value: value + 1
		]
		new
	]

	compose*: func [
		deep [integer!]
		only [integer!]
		into [integer!]
	][
		arg: stack/arguments
		if TYPE_OF(arg) <> TYPE_BLOCK [					;-- pass-thru for non block! values
			interpreter/eval-expression arg arg + 1 no no
			exit
		]
		stack/set-last
			as red-value! compose-block
				as red-block! arg
				as logic! deep + 1
				as logic! only + 1
				as red-block! stack/arguments + into
				yes
	]

	;--- 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*
		:compose*
	]

]


TESTS: moved type-casting inside SWITCH statement, so that values are stored as float32! and not float64! values.

Red/System [
	Title:   "Red/System integer! datatype tests"
	Author:  "Peter W A Wood"
	File: 	 %float32-test.reds
	Version: 0.1.0
	Rights:  "Copyright (C) 2012 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~~~ "float32"

===start-group=== "float32 assignment"
  --test-- "float32-1"
    f: as float32! 100.0
  --assert f = as float32! 100.0
  --test-- "float32-2"
    f: as float32! 1.222090944E+33
  --assert f = as float32! 1.222090944E+33
  --test-- "float32-3"
    f: as float32! 9.99999E-45
  --assert f = as float32! 9.99999E-45
  --test-- "float32-4"
    f: as float32! 1.0
    f1: f
  --assert f1 = as float32! 1.0
===end-group===

===start-group=== "float32 function arguments"
    ff: func [
      fff     [float32!]
      ffg     [float32!]
      return: [integer!]
      /local
      ffl [float32!]
    ][
       ffl: fff
       if ffl <> fff [return 1]
       ffl: ffg
       if ffl <> ffg [return 2]
       1
    ]

  --test-- "float32-func-args-1"
  --assert 1 = ff as float32! 1.0 as float32! 2.0

  --test-- "float32-func-args-2"
  --assert 1 = ff as float32! 1.222090944E+33 as float32! 9.99999E-45

===end-group===

===start-group=== "float32 function return"

    ff1: func [
      ff1i      [integer!]
      return:   [float32!]
    ][
      switch ff1i [
        1 [as float32! 1.0]							; TBD: document that constraint somewhere
        2 [as float32! 1.222090944E+33]
        3 [as float32! 9.99999E-45]
      ]
    ]
  --test-- "float32 return 1"
  --assert (as float32! 1.0) = ff1 1
  --test-- "float32 return 2"
  --assert (as float32! 1.222090944E+33) = ff1 2
  --test-- "float32 return 3"
  --assert (as float32! 9.99999E-45) = ff1 3

===end-group===

===start-group=== "float32 struct!"

  --test-- "float32-struct-1"
    sf1: declare struct! [
      a   [float32!]
    ]
  --assert (as float32! 0.0) = sf1/a

  --test-- "float32-struct-2"
    sf2: declare struct! [
      a   [float32!]
    ]
    sf1/a: as float32! 1.222090944E+33
  --assert (as float32! 1.222090944E+33) = sf1/a

    sf3: declare struct! [
      a   [float32!]
      b   [float32!]
    ]

  --test-- "float32-struct-3"
    sf3/a: as float32! 1.222090944E+33
    sf3/b: as float32! 9.99999E-45

  --assert (as float32! 1.222090944E+33) = sf3/a
  --assert (as float32! 9.99999E-45) = sf3/b

  --test-- "float32-struct-4"
    sf4: declare struct! [
      c   [byte!]
      a   [float32!]
      l   [logic!]
      b   [float32!]
    ]
    sf4/a: as float32! 1.222090944E+33
    sf4/b: as float32! 9.99999E-45
  --assert (as float32! 1.222090944E+33) = sf4/a
  --assert (as float32! 9.99999E-45) = sf4/b

===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System integer! datatype tests"
	Author:  "Peter W A Wood"
	File: 	 %float32-test.reds
	Version: 0.1.0
	Rights:  "Copyright (C) 2012 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~~~ "float32"

===start-group=== "float32 assignment"
  --test-- "float32-1"
    f: as float32! 100.0
  --assert f = as float32! 100.0
  --test-- "float32-2"
    f: as float32! 1.222090944E+33
  --assert f = as float32! 1.222090944E+33
  --test-- "float32-3"
    f: as float32! 9.99999E-45
  --assert f = as float32! 9.99999E-45
  --test-- "float32-4"
    f: as float32! 1.0
    f1: f
  --assert f1 = as float32! 1.0
===end-group===

===start-group=== "float32 function arguments"
    ff: func [
      fff     [float32!]
      ffg     [float32!]
      return: [integer!]
      /local
      ffl [float32!]
    ][
       ffl: fff
       if ffl <> fff [return 1]
       ffl: ffg
       if ffl <> ffg [return 2]
       1
    ]

  --test-- "float32-func-args-1"
  --assert 1 = ff as float32! 1.0 as float32! 2.0

  --test-- "float32-func-args-2"
  --assert 1 = ff as float32! 1.222090944E+33 as float32! 9.99999E-45

===end-group===

===start-group=== "float32 function return"

    ff1: func [
      ff1i      [integer!]
      return:   [float32!]
    ][
      as float32! switch ff1i [
        1 [1.0]
        2 [1.222090944E+33]
        3 [9.99999E-45]
      ]
    ]
  --test-- "float32 return 1"
  --assert (as float32! 1.0) = ff1 1
  --test-- "float32 return 2"
  --assert (as float32! 1.222090944E+33) = ff1 2
  --test-- "float32 return 3"
  --assert (as float32! 9.99999E-45) = ff1 3

===end-group===

===start-group=== "float32 struct!"

  --test-- "float32-struct-1"
    sf1: declare struct! [
      a   [float32!]
    ]
  --assert (as float32! 0.0) = sf1/a

  --test-- "float32-struct-2"
    sf2: declare struct! [
      a   [float32!]
    ]
    sf1/a: as float32! 1.222090944E+33
  --assert (as float32! 1.222090944E+33) = sf1/a

    sf3: declare struct! [
      a   [float32!]
      b   [float32!]
    ]

  --test-- "float32-struct-3"
    sf3/a: as float32! 1.222090944E+33
    sf3/b: as float32! 9.99999E-45

  --assert (as float32! 1.222090944E+33) = sf3/a
  --assert (as float32! 9.99999E-45) = sf3/b

  --test-- "float32-struct-4"
    sf4: declare struct! [
      c   [byte!]
      a   [float32!]
      l   [logic!]
      b   [float32!]
    ]
    sf4/a: as float32! 1.222090944E+33
    sf4/b: as float32! 9.99999E-45
  --assert (as float32! 1.222090944E+33) = sf4/a
  --assert (as float32! 9.99999E-45) = sf4/b

===end-group===

~~~end-file~~~