FIX: may run into infinite loop.

FIX: may run into infinite loop.

Red/System [
	Title:   "Float! datatype runtime functions"
	Author:  "Nenad Rakocevic, Oldes"
	File: 	 %decimal.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 DBL_EPSILON		2.2204460492503131E-16

float: context [
	verbose: 0

	uint64!: alias struct! [int1 [byte-ptr!] int2 [byte-ptr!]]
	int64!:  alias struct! [int1 [integer!] int2 [integer!]]

	DOUBLE_MAX: 0.0
	+INF: 0.0											;-- rebol can't load INF, NaN
	QNaN: 0.0

	double-int-union: as int64! :DOUBLE_MAX				;-- set to largest number
	double-int-union/int2: 7FEFFFFFh
	double-int-union/int1: FFFFFFFFh

	double-int-union: as int64! :+INF
	double-int-union/int2: 7FF00000h

	double-int-union: as int64! :QNaN					;-- smallest quiet NaN
	double-int-union/int2: 7FF80000h

	abs: func [
		value	[float!]
		return: [float!]
		/local
			n	[int-ptr!]
	][
		n: (as int-ptr! :value) + 1
		n/value: n/value and 7FFFFFFFh
		value
	]

	get*: func [										;-- unboxing float value from stack
		return: [float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		assert TYPE_OF(fl) = TYPE_FLOAT
		fl/value
	]

	get-any*: func [									;-- special get* variant for SWITCH
		return: [float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		either TYPE_OF(fl) = TYPE_FLOAT [fl/value][0.0] ;-- accept NONE values
	]

	get: func [											;-- unboxing float value
		value	[red-value!]
		return: [float!]
		/local
			fl [red-float!]
	][
		assert TYPE_OF(value) = TYPE_FLOAT
		fl: as red-float! value
		fl/value
	]

	box: func [
		value	[float!]
		return: [red-float!]
		/local
			int [red-float!]
	][
		fl: as red-float! stack/arguments
		fl/header: TYPE_FLOAT
		fl/value: value
		fl
	]

	to-integer: func [
		number 	[float!]
		return:	[integer!]
		/local
			f	[float!]
			d	[int-ptr!]
	][
		;-- Based on this method: http://stackoverflow.com/a/429812/494472
		;-- A bit more explanation: http://lolengine.net/blog/2011/3/20/understanding-fast-float-integer-conversions
		f: number + 6755399441055744.0
		d: as int-ptr! :f
		d/value
	]

	form-float: func [
		f 		[float!]
		return: [c-string!]
		/local
			s	[c-string!]
			s0	[c-string!]
			p0	[c-string!]
			p	[c-string!]
			p1	[c-string!]
			dot? [logic!]
			d	[int64!]
			w0	[integer!]
	][
		d: as int64! :f
		w0: d/int2												;@@ Use little endian. Watch out big endian !

		if w0 and 7FF00000h = 7FF00000h [
			if all [
				zero? d/int1									;@@ Use little endian. Watch out big endian !
				zero? (w0 and 000FFFFFh)
			][
				return either 0 = (w0 and 80000000h) ["1.#INF"]["-1.#INF"]
			]
			return "1.#NaN"
		]

		s: "0000000000000000000000000000000"					;-- 32 bytes wide, big enough.
		s/17: #"0"
		s/18: #"0"
		sprintf [s "%.16g" f]

		p:  null
		p1: null
		s0: s
		until [
			dot?: no
			until [
				if s/1 = #"." [dot?: yes]
				if s/1 = #"e" [
					p: s
					until [
						s: s + 1
						s/1 > #"0"
					]
					p1: s
				]
				s: s + 1
				s/1 = #"^@"
			]

			if all [											;-- correct number if needed
				p <> null										;-- has "E" notation
				(as-integer p - s0) > 16						;-- the number of digits = 16
			][
				p0: either s0/1 = #"-" [s0 + 1][s0]
				if any [										;-- correct '01' or '99' pattern
					all [p0/17 = #"1" p0/16 = #"0"]
					all [p0/17 = #"9" p0/16 = #"9"]
				][
					s: "00000000000000000000000"				;-- 24 bytes
					sprintf [s "%.14g" f]
					if 10 > length? s [s0: s]					;-- length? "-x.xE-xxx" = 9
				]
			]
			s0 <> s
		]

		if p1 <> null [											;-- remove #"+" and leading zero
			p0: p
			either p/2 = #"-" [p: p + 2][p: p + 1]
			move-memory as byte-ptr! p as byte-ptr! p1 as-integer s - p1
			s: p + as-integer s - p1
			s/1: #"^@"
			p: p0
		]
		unless dot? [											;-- added tailing ".0"
			either p = null [
				p: s
			][
				move-memory as byte-ptr! p + 2 as byte-ptr! p as-integer s - p
			]
			p/1: #"."
			p/2: #"0"
			s/3: #"^@"
		]
		s0
	]

	do-math: func [
		type	  [integer!]
		return:	  [red-float!]
		/local
			left  [red-float!]
			right [red-float!]
			int   [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/do-math"]]

		left:  as red-float! stack/arguments
		right: as red-float! left + 1

		assert any [									;@@ replace by typeset check when possible
			TYPE_OF(left) = TYPE_INTEGER
			TYPE_OF(left) = TYPE_FLOAT
		]
		assert any [
			TYPE_OF(right) = TYPE_INTEGER
			TYPE_OF(right) = TYPE_CHAR
			TYPE_OF(right) = TYPE_FLOAT
		]

		if TYPE_OF(left) <> TYPE_FLOAT [
			int: as red-integer! left
			left/header: TYPE_FLOAT
			left/value: integer/to-float int/value
		]
		if TYPE_OF(right) <> TYPE_FLOAT [
			int: as red-integer! right
			right/value: integer/to-float int/value
		]

		left/value: switch type [
			OP_ADD [left/value + right/value]
			OP_SUB [left/value - right/value]
			OP_MUL [left/value * right/value]
			OP_DIV [left/value / right/value]
			OP_REM [left/value % right/value]
			default [print-line "*** Math Error: float don't support BITWISE OP!" left/value]
		]
		left
	]

	load-in: func [
		blk	  	[red-block!]
		value 	[float!]
		/local
			fl [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/load-in"]]

		fl: as red-float! ALLOC_TAIL(blk)
		fl/header: TYPE_FLOAT
		fl/value: value
	]

	push64: func [
		high	[integer!]
		low		[integer!]
		return: [red-float!]
		/local
			cell [cell!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/push64"]]

		cell: stack/push*
		cell/header: TYPE_FLOAT
		cell/data2: low
		cell/data3: high
		as red-float! cell
	]

	push: func [
		value	[float!]
		return: [red-float!]
		/local
			fl [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/push"]]

		fl: as red-float! stack/push*
		fl/header: TYPE_FLOAT
		fl/value: value
		fl
	]

	;-- Actions --

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

		switch TYPE_OF(spec) [
			TYPE_FLOAT [
				as red-float! spec
			]
			default [
				--NOT_IMPLEMENTED--
				as red-float! spec					;@@ just for making it compilable
			]
		]
	]

	random: func [
		f		[red-float!]
		seed?	[logic!]
		secure? [logic!]
		only?   [logic!]
		return: [red-float!]
		/local
			t	[float!]
			s	[float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/random"]]

		either seed? [
			_random/srand to-integer f/value
			f/header: TYPE_UNSET
		][
			s: (integer/to-float _random/rand) / 2147483647.0
			if s < 0.0 [s: 0.0 - s]
			f/value: s * f/value
		]
		f
	]

	to: func [
		type	[red-datatype!]
		spec	[red-float!]
		return: [red-value!]
		/local
			int [red-integer!]
			buf [red-string!]
			f	[float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "to/random"]]

		f: spec/value
		switch type/value [
			TYPE_INTEGER [
				int: as red-integer! type
				int/header: TYPE_INTEGER
				int/value: to-integer either f < 0.0 [f + 0.4999999999999999][f - 0.4999999999999999]
			]
			TYPE_STRING [
				buf: string/rs-make-at as cell! type 1			;-- 16 bits string
				string/concatenate-literal buf form-float f
			]
			default [
				print-line "** Script error: Invalid argument for TO float!"
				type/header: TYPE_UNSET
			]
		]
		as red-value! type
	]

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

		formed: form-float fl/value
		string/concatenate-literal buffer formed
		part - length? formed							;@@ optimize by removing length?
	]

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

		form fl buffer arg part
	]

	NaN?: func [
		value	[float!]
		return: [logic!]
		/local
			n	[int-ptr!]
			m	[int-ptr!]
	][
		m: as int-ptr! :value
		n: m + 1
		either n/value and 7FF00000h = 7FF00000h [		;-- the exponent bits are all ones
			either any [								;-- the fraction bits are not entirely zeros
				m/value <> 0
				n/value and 000FFFFFh <> 0
			] [true][false]
		][false]
	]

	;@@ using 64bit integer will simplify it significantly.
	;-- returns false if either number is (or both are) NAN.
	;-- treats really large numbers as almost equal to infinity.
	;-- thinks +0.0 and -0.0 are 0 DLP's apart.
	;-- Max ULP: 4 (enough for ordinary use)
	;-- Ref: https://github.com/svn2github/googletest/blob/master/include/gtest/internal/gtest-internal.h
	;--      https://github.com/rebol/rebol/blob/master/src/core/t-decimal.c
	almost-equal: func [
		left	[float!]
		right	[float!]
		return: [logic!]
		/local
			a	 [uint64!]
			b	 [uint64!]
			lo1  [byte-ptr!]
			lo2  [byte-ptr!]
			hi1  [byte-ptr!]
			hi2  [byte-ptr!]
			diff [byte-ptr!]
	][
		if left = right [return true]					;-- for NaN, also raise error in default mode
		if any [NaN? left NaN? right] [return false]

		a: as uint64! :left
		b: as uint64! :right
		lo1: a/int1
		lo2: b/int1
		hi1: a/int2
		hi2: b/int2

		either (as-integer hi1) < 0 [
			hi1: as byte-ptr! (not as-integer hi1)
			lo1: as byte-ptr! (not as-integer lo1)
			either (as-integer lo1) = -1 [hi1: hi1 + 1 lo1: null][lo1: lo1 + 1]
		][
			hi1: as byte-ptr! (as-integer hi1) or 80000000h
		]

		either (as-integer hi2) < 0 [
			hi2: as byte-ptr! (not as-integer hi2)
			lo2: as byte-ptr! (not as-integer lo2)
			either (as-integer lo2) = -1 [hi2: hi2 + 1 lo2: null][lo2: lo2 + 1]
		][
			hi2: as byte-ptr! (as-integer hi2) or 80000000h
		]

		diff: either hi1 > hi2 [hi1 - hi2][hi2 - hi1]
		if diff > (as byte-ptr! 1) [return false]

		case [
			hi1 = hi2 [
				diff: either lo1 < lo2 [lo2 - lo1][lo1 - lo2]
			]
			hi1 > hi2 [
				either lo1 >= lo2 [return false][
					diff: (as byte-ptr! -1) - lo2 + lo1 + 1
				]
			]
			hi2 > hi1 [
				either lo2 >= lo1 [return false][
					diff: (as byte-ptr! -1) - lo1 + lo2 + 1
				]
			]
		]

		diff <= (as byte-ptr! 4)
	]

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

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_CHAR
			TYPE_INTEGER [
				int: as red-integer! value2
				right: integer/to-float int/value
			]
			TYPE_FLOAT [right: value2/value]
			default [RETURN_COMPARE_OTHER]
		]
		switch op [
			COMP_EQUAL 			[res: almost-equal left right]
			COMP_NOT_EQUAL 		[res: not almost-equal left right]
			COMP_STRICT_EQUAL	[res: all [TYPE_OF(value2) = TYPE_FLOAT left = right]]
			COMP_LESSER			[res: left <  right]
			COMP_LESSER_EQUAL	[res: left <= right]
			COMP_GREATER		[res: left >  right]
			COMP_GREATER_EQUAL	[res: left >= right]
		]
		res
	]

	complement: func [
		fl		[red-float!]
		return:	[red-value!]
	][
		--NOT_IMPLEMENTED--
		;fl/value: not fl/value
		as red-value! fl
	]

	absolute: func [
		return: [red-float!]
		/local
			f	  [red-float!]
			value [float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/absolute"]]

		f: as red-float! stack/arguments
		f/value: abs f/value
		f 											;-- re-use argument slot for return value
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/subtract"]]
		as red-value! do-math OP_SUB
	]

	remainder: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/remainder"]]
		as red-value! do-math OP_REM
	]

	negate: func [
		return: [red-float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		fl/value: 0.0 - fl/value
		fl 											;-- re-use argument slot for return value
	]

	power: func [
		return:	 [red-float!]
		/local
			base [red-float!]
			exp  [red-float!]
			int	 [red-integer!]
	][
		base: as red-float! stack/arguments
		exp: base + 1
		if TYPE_OF(exp) = TYPE_INTEGER [
			int: as red-integer! exp
			exp/value: integer/to-float int/value
		]
		base/value: float-power base/value exp/value
		base
	]

	even?: func [
		int		[red-float!]
		return: [logic!]
	][
		;requires conversion to integer
		;not as-logic float/value and 1
		--NOT_IMPLEMENTED--
		false
	]

	odd?: func [
		int		[red-integer!]
		return: [logic!]
	][
		;requires conversion to integer
		;as-logic int/value and 1
		--NOT_IMPLEMENTED--
		false
	]

	#define FLOAT_TRUNC(x) [d: floor float/abs x either x < 0.0 [0.0 - d][d]]
	#define FLOAT_AWAY(x)  [d: ceil float/abs x  either x < 0.0 [0.0 - d][d]]

	round: func [
		value		[red-value!]
		scale		[red-float!]
		_even?		[logic!]
		down?		[logic!]
		half-down?	[logic!]
		floor?		[logic!]
		ceil?		[logic!]
		half-ceil?	[logic!]
		return:		[red-value!]
		/local
			int		[red-integer!]
			f		[red-float!]
			dec		[float!]
			sc		[float!]
			r		[float!]
			d		[float!]
			e		[integer!]
			v		[logic!]
	][
		e: 0
		f: as red-float! value
		dec: f/value
		sc: 1.0
		if OPTION?(scale) [
			if TYPE_OF(scale) = TYPE_INTEGER [
				int: as red-integer! value
				int/value: to-integer dec
				int/header: TYPE_INTEGER
				return integer/round value as red-integer! scale _even? down? half-down? floor? ceil? half-ceil?
			]
			sc: abs scale/value
		]

		if sc = 0.0 [
			print-line "*** Math Error: float overflow on ROUND"
			value/header: TYPE_UNSET
			return value
		]

		if sc < ldexp abs dec -53 [return value]		;-- is scale negligible?

		v: sc >= 1.0
		dec: either v [dec / sc][
			r: frexp sc :e
			either e <= -1022 [
				sc: r
				dec: ldexp dec e
			][e: 0]
			sc: 1.0 / sc
			dec * sc
		]

		d: abs dec
		r: 0.5 + floor d
		dec: case [
			down?		[FLOAT_TRUNC(dec)]
			floor?		[floor dec		 ]
			ceil?		[ceil dec		 ]
			r < d		[FLOAT_AWAY(dec) ]
			r > d		[FLOAT_TRUNC(dec)]
			_even?		[either d % 2.0 < 1.0 [FLOAT_TRUNC(dec)][FLOAT_AWAY(dec)]]
			half-down?	[FLOAT_TRUNC(dec)]
			half-ceil?	[ceil dec		 ]
			true		[FLOAT_AWAY(dec) ]
		]

		f/value: either v [
			dec: dec * sc
			if DOUBLE_MAX = abs dec [
				print-line "*** Math Error: float overflow on ROUND"
				value/header: TYPE_UNSET
			]
			dec
		][
			ldexp dec / sc e
		]
		value
	]

	init: does [
		datatype/register [
			TYPE_FLOAT
			TYPE_VALUE
			"float!"
			;-- General actions --
			:make
			:random
			null			;reflect
			:to
			:form
			:mold
			null			;eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			:absolute
			:add
			:divide
			:multiply
			:negate
			:power
			:remainder
			:round
			:subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			null			;copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]

Red/System [
	Title:   "Float! datatype runtime functions"
	Author:  "Nenad Rakocevic, Oldes"
	File: 	 %decimal.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 DBL_EPSILON		2.2204460492503131E-16

float: context [
	verbose: 0

	uint64!: alias struct! [int1 [byte-ptr!] int2 [byte-ptr!]]
	int64!:  alias struct! [int1 [integer!] int2 [integer!]]

	DOUBLE_MAX: 0.0
	+INF: 0.0											;-- rebol can't load INF, NaN
	QNaN: 0.0

	double-int-union: as int64! :DOUBLE_MAX				;-- set to largest number
	double-int-union/int2: 7FEFFFFFh
	double-int-union/int1: FFFFFFFFh

	double-int-union: as int64! :+INF
	double-int-union/int2: 7FF00000h

	double-int-union: as int64! :QNaN					;-- smallest quiet NaN
	double-int-union/int2: 7FF80000h

	abs: func [
		value	[float!]
		return: [float!]
		/local
			n	[int-ptr!]
	][
		n: (as int-ptr! :value) + 1
		n/value: n/value and 7FFFFFFFh
		value
	]

	get*: func [										;-- unboxing float value from stack
		return: [float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		assert TYPE_OF(fl) = TYPE_FLOAT
		fl/value
	]

	get-any*: func [									;-- special get* variant for SWITCH
		return: [float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		either TYPE_OF(fl) = TYPE_FLOAT [fl/value][0.0] ;-- accept NONE values
	]

	get: func [											;-- unboxing float value
		value	[red-value!]
		return: [float!]
		/local
			fl [red-float!]
	][
		assert TYPE_OF(value) = TYPE_FLOAT
		fl: as red-float! value
		fl/value
	]

	box: func [
		value	[float!]
		return: [red-float!]
		/local
			int [red-float!]
	][
		fl: as red-float! stack/arguments
		fl/header: TYPE_FLOAT
		fl/value: value
		fl
	]

	to-integer: func [
		number 	[float!]
		return:	[integer!]
		/local
			f	[float!]
			d	[int-ptr!]
	][
		;-- Based on this method: http://stackoverflow.com/a/429812/494472
		;-- A bit more explanation: http://lolengine.net/blog/2011/3/20/understanding-fast-float-integer-conversions
		f: number + 6755399441055744.0
		d: as int-ptr! :f
		d/value
	]

	form-float: func [
		f 		[float!]
		return: [c-string!]
		/local
			s	[c-string!]
			s0	[c-string!]
			p0	[c-string!]
			p	[c-string!]
			p1	[c-string!]
			dot? [logic!]
			d	[int64!]
			w0	[integer!]
	][
		d: as int64! :f
		w0: d/int2												;@@ Use little endian. Watch out big endian !

		if w0 and 7FF00000h = 7FF00000h [
			if all [
				zero? d/int1									;@@ Use little endian. Watch out big endian !
				zero? (w0 and 000FFFFFh)
			][
				return either 0 = (w0 and 80000000h) ["1.#INF"]["-1.#INF"]
			]
			return "1.#NaN"
		]

		s: "0000000000000000000000000000000"					;-- 32 bytes wide, big enough.
		s/17: #"0"
		s/18: #"0"
		sprintf [s "%.16g" f]

		p:  null
		p1: null
		s0: s
		until [
			dot?: no
			until [
				if s/1 = #"." [dot?: yes]
				if s/1 = #"e" [
					p: s
					until [
						s: s + 1
						s/1 > #"0"
					]
					p1: s
				]
				s: s + 1
				s/1 = #"^@"
			]

			if all [											;-- correct number if needed
				p <> null										;-- has "E" notation
				(as-integer p - s0) > 16						;-- the number of digits = 16
			][
				s: either s0/1 = #"-" [s0 + 1][s0]
				if any [										;-- correct '01' or '99' pattern
					all [s/17 = #"1" s/16 = #"0"]
					all [s/17 = #"9" s/16 = #"9"]
				][
					s: "00000000000000000000000"				;-- 24 bytes
					sprintf [s "%.14g" f]
					either 10 > length? s [						;-- length? "-x.xE-xxx" = 9
						s0: s
					][
						return s0
					]
				]
			]
			s0 <> s
		]

		if p1 <> null [											;-- remove #"+" and leading zero
			p0: p
			either p/2 = #"-" [p: p + 2][p: p + 1]
			move-memory as byte-ptr! p as byte-ptr! p1 as-integer s - p1
			s: p + as-integer s - p1
			s/1: #"^@"
			p: p0
		]
		unless dot? [											;-- added tailing ".0"
			either p = null [
				p: s
			][
				move-memory as byte-ptr! p + 2 as byte-ptr! p as-integer s - p
			]
			p/1: #"."
			p/2: #"0"
			s/3: #"^@"
		]
		s0
	]

	do-math: func [
		type	  [integer!]
		return:	  [red-float!]
		/local
			left  [red-float!]
			right [red-float!]
			int   [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/do-math"]]

		left:  as red-float! stack/arguments
		right: as red-float! left + 1

		assert any [									;@@ replace by typeset check when possible
			TYPE_OF(left) = TYPE_INTEGER
			TYPE_OF(left) = TYPE_FLOAT
		]
		assert any [
			TYPE_OF(right) = TYPE_INTEGER
			TYPE_OF(right) = TYPE_CHAR
			TYPE_OF(right) = TYPE_FLOAT
		]

		if TYPE_OF(left) <> TYPE_FLOAT [
			int: as red-integer! left
			left/header: TYPE_FLOAT
			left/value: integer/to-float int/value
		]
		if TYPE_OF(right) <> TYPE_FLOAT [
			int: as red-integer! right
			right/value: integer/to-float int/value
		]

		left/value: switch type [
			OP_ADD [left/value + right/value]
			OP_SUB [left/value - right/value]
			OP_MUL [left/value * right/value]
			OP_DIV [left/value / right/value]
			OP_REM [left/value % right/value]
			default [print-line "*** Math Error: float don't support BITWISE OP!" left/value]
		]
		left
	]

	load-in: func [
		blk	  	[red-block!]
		value 	[float!]
		/local
			fl [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/load-in"]]

		fl: as red-float! ALLOC_TAIL(blk)
		fl/header: TYPE_FLOAT
		fl/value: value
	]

	push64: func [
		high	[integer!]
		low		[integer!]
		return: [red-float!]
		/local
			cell [cell!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/push64"]]

		cell: stack/push*
		cell/header: TYPE_FLOAT
		cell/data2: low
		cell/data3: high
		as red-float! cell
	]

	push: func [
		value	[float!]
		return: [red-float!]
		/local
			fl [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/push"]]

		fl: as red-float! stack/push*
		fl/header: TYPE_FLOAT
		fl/value: value
		fl
	]

	;-- Actions --

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

		switch TYPE_OF(spec) [
			TYPE_FLOAT [
				as red-float! spec
			]
			default [
				--NOT_IMPLEMENTED--
				as red-float! spec					;@@ just for making it compilable
			]
		]
	]

	random: func [
		f		[red-float!]
		seed?	[logic!]
		secure? [logic!]
		only?   [logic!]
		return: [red-float!]
		/local
			t	[float!]
			s	[float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/random"]]

		either seed? [
			_random/srand to-integer f/value
			f/header: TYPE_UNSET
		][
			s: (integer/to-float _random/rand) / 2147483647.0
			if s < 0.0 [s: 0.0 - s]
			f/value: s * f/value
		]
		f
	]

	to: func [
		type	[red-datatype!]
		spec	[red-float!]
		return: [red-value!]
		/local
			int [red-integer!]
			buf [red-string!]
			f	[float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "to/random"]]

		f: spec/value
		switch type/value [
			TYPE_INTEGER [
				int: as red-integer! type
				int/header: TYPE_INTEGER
				int/value: to-integer either f < 0.0 [f + 0.4999999999999999][f - 0.4999999999999999]
			]
			TYPE_STRING [
				buf: string/rs-make-at as cell! type 1			;-- 16 bits string
				string/concatenate-literal buf form-float f
			]
			default [
				print-line "** Script error: Invalid argument for TO float!"
				type/header: TYPE_UNSET
			]
		]
		as red-value! type
	]

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

		formed: form-float fl/value
		string/concatenate-literal buffer formed
		part - length? formed							;@@ optimize by removing length?
	]

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

		form fl buffer arg part
	]

	NaN?: func [
		value	[float!]
		return: [logic!]
		/local
			n	[int-ptr!]
			m	[int-ptr!]
	][
		m: as int-ptr! :value
		n: m + 1
		either n/value and 7FF00000h = 7FF00000h [		;-- the exponent bits are all ones
			either any [								;-- the fraction bits are not entirely zeros
				m/value <> 0
				n/value and 000FFFFFh <> 0
			] [true][false]
		][false]
	]

	;@@ using 64bit integer will simplify it significantly.
	;-- returns false if either number is (or both are) NAN.
	;-- treats really large numbers as almost equal to infinity.
	;-- thinks +0.0 and -0.0 are 0 DLP's apart.
	;-- Max ULP: 4 (enough for ordinary use)
	;-- Ref: https://github.com/svn2github/googletest/blob/master/include/gtest/internal/gtest-internal.h
	;--      https://github.com/rebol/rebol/blob/master/src/core/t-decimal.c
	almost-equal: func [
		left	[float!]
		right	[float!]
		return: [logic!]
		/local
			a	 [uint64!]
			b	 [uint64!]
			lo1  [byte-ptr!]
			lo2  [byte-ptr!]
			hi1  [byte-ptr!]
			hi2  [byte-ptr!]
			diff [byte-ptr!]
	][
		if left = right [return true]					;-- for NaN, also raise error in default mode
		if any [NaN? left NaN? right] [return false]

		a: as uint64! :left
		b: as uint64! :right
		lo1: a/int1
		lo2: b/int1
		hi1: a/int2
		hi2: b/int2

		either (as-integer hi1) < 0 [
			hi1: as byte-ptr! (not as-integer hi1)
			lo1: as byte-ptr! (not as-integer lo1)
			either (as-integer lo1) = -1 [hi1: hi1 + 1 lo1: null][lo1: lo1 + 1]
		][
			hi1: as byte-ptr! (as-integer hi1) or 80000000h
		]

		either (as-integer hi2) < 0 [
			hi2: as byte-ptr! (not as-integer hi2)
			lo2: as byte-ptr! (not as-integer lo2)
			either (as-integer lo2) = -1 [hi2: hi2 + 1 lo2: null][lo2: lo2 + 1]
		][
			hi2: as byte-ptr! (as-integer hi2) or 80000000h
		]

		diff: either hi1 > hi2 [hi1 - hi2][hi2 - hi1]
		if diff > (as byte-ptr! 1) [return false]

		case [
			hi1 = hi2 [
				diff: either lo1 < lo2 [lo2 - lo1][lo1 - lo2]
			]
			hi1 > hi2 [
				either lo1 >= lo2 [return false][
					diff: (as byte-ptr! -1) - lo2 + lo1 + 1
				]
			]
			hi2 > hi1 [
				either lo2 >= lo1 [return false][
					diff: (as byte-ptr! -1) - lo1 + lo2 + 1
				]
			]
		]

		diff <= (as byte-ptr! 4)
	]

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

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_CHAR
			TYPE_INTEGER [
				int: as red-integer! value2
				right: integer/to-float int/value
			]
			TYPE_FLOAT [right: value2/value]
			default [RETURN_COMPARE_OTHER]
		]
		switch op [
			COMP_EQUAL 			[res: almost-equal left right]
			COMP_NOT_EQUAL 		[res: not almost-equal left right]
			COMP_STRICT_EQUAL	[res: all [TYPE_OF(value2) = TYPE_FLOAT left = right]]
			COMP_LESSER			[res: left <  right]
			COMP_LESSER_EQUAL	[res: left <= right]
			COMP_GREATER		[res: left >  right]
			COMP_GREATER_EQUAL	[res: left >= right]
		]
		res
	]

	complement: func [
		fl		[red-float!]
		return:	[red-value!]
	][
		--NOT_IMPLEMENTED--
		;fl/value: not fl/value
		as red-value! fl
	]

	absolute: func [
		return: [red-float!]
		/local
			f	  [red-float!]
			value [float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/absolute"]]

		f: as red-float! stack/arguments
		f/value: abs f/value
		f 											;-- re-use argument slot for return value
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/subtract"]]
		as red-value! do-math OP_SUB
	]

	remainder: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/remainder"]]
		as red-value! do-math OP_REM
	]

	negate: func [
		return: [red-float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		fl/value: 0.0 - fl/value
		fl 											;-- re-use argument slot for return value
	]

	power: func [
		return:	 [red-float!]
		/local
			base [red-float!]
			exp  [red-float!]
			int	 [red-integer!]
	][
		base: as red-float! stack/arguments
		exp: base + 1
		if TYPE_OF(exp) = TYPE_INTEGER [
			int: as red-integer! exp
			exp/value: integer/to-float int/value
		]
		base/value: float-power base/value exp/value
		base
	]

	even?: func [
		int		[red-float!]
		return: [logic!]
	][
		;requires conversion to integer
		;not as-logic float/value and 1
		--NOT_IMPLEMENTED--
		false
	]

	odd?: func [
		int		[red-integer!]
		return: [logic!]
	][
		;requires conversion to integer
		;as-logic int/value and 1
		--NOT_IMPLEMENTED--
		false
	]

	#define FLOAT_TRUNC(x) [d: floor float/abs x either x < 0.0 [0.0 - d][d]]
	#define FLOAT_AWAY(x)  [d: ceil float/abs x  either x < 0.0 [0.0 - d][d]]

	round: func [
		value		[red-value!]
		scale		[red-float!]
		_even?		[logic!]
		down?		[logic!]
		half-down?	[logic!]
		floor?		[logic!]
		ceil?		[logic!]
		half-ceil?	[logic!]
		return:		[red-value!]
		/local
			int		[red-integer!]
			f		[red-float!]
			dec		[float!]
			sc		[float!]
			r		[float!]
			d		[float!]
			e		[integer!]
			v		[logic!]
	][
		e: 0
		f: as red-float! value
		dec: f/value
		sc: 1.0
		if OPTION?(scale) [
			if TYPE_OF(scale) = TYPE_INTEGER [
				int: as red-integer! value
				int/value: to-integer dec
				int/header: TYPE_INTEGER
				return integer/round value as red-integer! scale _even? down? half-down? floor? ceil? half-ceil?
			]
			sc: abs scale/value
		]

		if sc = 0.0 [
			print-line "*** Math Error: float overflow on ROUND"
			value/header: TYPE_UNSET
			return value
		]

		if sc < ldexp abs dec -53 [return value]		;-- is scale negligible?

		v: sc >= 1.0
		dec: either v [dec / sc][
			r: frexp sc :e
			either e <= -1022 [
				sc: r
				dec: ldexp dec e
			][e: 0]
			sc: 1.0 / sc
			dec * sc
		]

		d: abs dec
		r: 0.5 + floor d
		dec: case [
			down?		[FLOAT_TRUNC(dec)]
			floor?		[floor dec		 ]
			ceil?		[ceil dec		 ]
			r < d		[FLOAT_AWAY(dec) ]
			r > d		[FLOAT_TRUNC(dec)]
			_even?		[either d % 2.0 < 1.0 [FLOAT_TRUNC(dec)][FLOAT_AWAY(dec)]]
			half-down?	[FLOAT_TRUNC(dec)]
			half-ceil?	[ceil dec		 ]
			true		[FLOAT_AWAY(dec) ]
		]

		f/value: either v [
			dec: dec * sc
			if DOUBLE_MAX = abs dec [
				print-line "*** Math Error: float overflow on ROUND"
				value/header: TYPE_UNSET
			]
			dec
		][
			ldexp dec / sc e
		]
		value
	]

	init: does [
		datatype/register [
			TYPE_FLOAT
			TYPE_VALUE
			"float!"
			;-- General actions --
			:make
			:random
			null			;reflect
			:to
			:form
			:mold
			null			;eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			:absolute
			:add
			:divide
			:multiply
			:negate
			:power
			:remainder
			:round
			:subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			null			;copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]


FIX: crash when random tuple which contains zero

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

tuple: context [
	verbose: 0

	push: func [
		size	[integer!]
		arr1	[integer!]
		arr2	[integer!]
		arr3	[integer!]
		return: [red-tuple!]
		/local
			tp	 [red-tuple!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/push"]]

		tp: as red-tuple! stack/push*
		tp/header: TYPE_TUPLE or (size << 19)
		tp/array1: arr1
		tp/array2: arr2
		tp/array3: arr3
		tp
	]

	do-math: func [
		type	  [integer!]
		return:	  [red-tuple!]
		/local
			left  [red-tuple!]
			right [red-tuple!]
			int   [red-integer!]
			fl    [red-float!]
			tp1   [byte-ptr!]
			tp2   [byte-ptr!]
			size  [integer!]
			size1 [integer!]
			size2 [integer!]
			v	  [integer!]
			v1	  [integer!]
			n	  [integer!]
			f1	  [float!]
			f2	  [float!]
			swap? [logic!]
			float? [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/do-math"]]

		left:  as red-tuple! stack/arguments
		right: as red-tuple! left + 1

		swap?: no
		if TYPE_OF(left) <> TYPE_TUPLE [
			int: as red-integer! left
			left: right
			right: as red-tuple! int
			swap?: yes
		]

		float?: no
		size2: 0
		switch TYPE_OF(right) [
			TYPE_TUPLE [
				tp2: (as byte-ptr! right) + 4
				size2: TUPLE_SIZE(right)
			]
			TYPE_INTEGER [
				int: as red-integer! right
				v: int/value
			]
			TYPE_FLOAT
			TYPE_PERCENT [
				float?: yes
				fl: as red-float! right
				f2: fl/value
			]
			default [
				fire [TO_ERROR(script invalid-type) datatype/push TYPE_OF(right)]
			]
		]

		tp1: (as byte-ptr! left) + 4
		size1: TUPLE_SIZE(left)
		n: 0
		either float? [
			until [
				n: n + 1
				f1: integer/to-float as-integer tp1/n
				f1: switch type [
					OP_ADD [f1 + f2]
					OP_SUB [f1 - f2]
					OP_MUL [f1 * f2]
					OP_DIV
					OP_REM [
						if 0.0 = f2 [fire [TO_ERROR(math zero-divide)]]
						either type = OP_DIV [f1 / f2][f1 % f2]
					]
					default [ERR_EXPECT_ARGUMENT((TYPE_OF(right)) 2) 0.0]
				]
				v1: float/to-integer either f1 < 0.0 [f1 + 0.4999999999999999][f1 - 0.4999999999999999]
				either v1 > 255 [v1: 255][if negative? v1 [v1: 0]]
				tp1/n: as byte! v1
				n = size1
			]
		][
			size: either size1 < size2 [
				tp1/1: as byte! size2
				size2
			][size1]
			until [
				n: n + 1
				if positive? size2 [
					v: either n <= size2 [as-integer tp2/n][0]
				]
				v1: either n <= size1 [as-integer tp1/n][0]
				v1: switch type [
					OP_ADD [v1 + v]
					OP_SUB [v1 - v]
					OP_MUL [v1 * v]
					OP_AND [v1 and v]
					OP_OR  [v1 or v]
					OP_XOR [v1 xor v]
					OP_REM [
						either zero? v [
							fire [TO_ERROR(math zero-divide)]
							0								;-- pass the compiler's type-checking
						][v1 % v]
					]
					OP_DIV [
						either zero? v [
							fire [TO_ERROR(math zero-divide)]
							0								;-- pass the compiler's type-checking
						][v1 / v]
					]
				]
				either v1 > 255 [v1: 255][if negative? v1 [v1: 0]]
				tp1/n: as byte! v1
				n = size
			]
		]
		if swap? [copy-cell as cell! left stack/arguments]
		left
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-tuple!]
		/local
			blk   [red-block!]
			tuple [red-tuple!]
			tp    [byte-ptr!]
			n	  [integer!]
			i	  [integer!]
			s	  [series!]
			int   [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/make"]]

		switch TYPE_OF(spec) [
			TYPE_TUPLE [
				as red-tuple! spec
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				tuple: as red-tuple! stack/push*
				tuple/header: TYPE_TUPLE
				tp: (as byte-ptr! tuple) + 4
				n: block/rs-length? blk
				if n > 12 [
					fire [TO_ERROR(script bad-make-arg) proto spec]
				]
				tuple/header: TYPE_TUPLE or either n > 2 [n << 19][3 << 19]
				s: GET_BUFFER(blk)
				int: as red-integer! s/offset + blk/head
				i: 0
				while [i < n][
					i: i + 1
					if any [
						int/value > 255
						int/value < 0
					][fire [TO_ERROR(script bad-make-arg) proto spec]]
					tp/i: as byte! int/value
					int: int + 1
				]
				while [i < 3][i: i + 1 tp/i: null-byte]
				tuple
			]
			default [
				fire [TO_ERROR(script bad-make-arg) proto spec]
				null
			]
		]
	]

	random: func [
		tp		[red-tuple!]
		seed?	[logic!]
		secure? [logic!]
		only?   [logic!]
		return: [red-value!]
		/local
			value [red-value!]
			array [byte-ptr!]
			n	  [integer!]
			size  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/random"]]

		either seed? [
			value: as red-value! tp
			_random/srand value/data1 xor value/data2 xor value/data3
			tp/header: TYPE_UNSET
		][
			array: (as byte-ptr! tp) + 4
			size: TUPLE_SIZE(tp)
			n: 0
			until [
				n: n + 1
				array/n: as-byte _random/rand % ((as-integer array/n) + 1)
				n = size
			]
		]
		as red-value! tp
	]

	form: func [
		tp		   [red-tuple!]
		buffer	   [red-string!]
		arg		   [red-value!]
		part 	   [integer!]
		return:    [integer!]
		/local
			formed [c-string!]
			value  [byte-ptr!]
			n	   [integer!]
			size   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/form"]]

		value: (as byte-ptr! tp) + 4
		size: TUPLE_SIZE(tp)

		n: 0
		until [
			n: n + 1
			formed: integer/form-signed as-integer value/n
			string/concatenate-literal buffer formed
			unless n = size [
				part: part - 1
				string/append-char GET_BUFFER(buffer) as-integer #"."
			]
			part: part - system/words/length? formed	;@@ optimize by removing length?
			n = size
		]
		part
	]

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

		form tp buffer arg part
	]

	eval-path: func [
		parent	[red-tuple!]							;-- implicit type casting
		element	[red-value!]
		value	[red-value!]
		path	[red-value!]
		case?	[logic!]
		return:	[red-value!]
		/local
			int  [red-integer!]
			type [integer!]
	][
		type: TYPE_OF(element)
		either type = TYPE_INTEGER [
			int: as red-integer! element
			either value <> null [
				poke parent int/value value null
				value
			][
				pick parent int/value null
			]
		][
			fire [TO_ERROR(script invalid-type) datatype/push TYPE_OF(element)]
			null
		]
	]

	compare: func [
		tp1		[red-tuple!]							;-- first operand
		tp2		[red-tuple!]							;-- second operand
		op		[integer!]								;-- type of comparison
		return: [integer!]
		/local
			p1	 [byte-ptr!]
			p2	 [byte-ptr!]
			i	 [integer!]
			sz   [integer!]
			sz1  [integer!]
			sz2  [integer!]
			v1	 [integer!]
			v2	 [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/compare"]]

		if TYPE_OF(tp2) <> TYPE_TUPLE [RETURN_COMPARE_OTHER]
		p1: (as byte-ptr! tp1) + 4
		p2: (as byte-ptr! tp2) + 4
		sz1: TUPLE_SIZE(tp1)
		sz2: TUPLE_SIZE(tp2)
		sz: either sz1 > sz2 [sz1][sz2]

		i: 0
		until [
			i: i + 1
			v1: either i > sz1 [0][as-integer p1/i]
			v2: either i > sz2 [0][as-integer p2/i]
			if v1 <> v2 [return SIGN_COMPARE_RESULT(v1 v2)]
			i = sz
		]
		0
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "tuple/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "tuple/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "tuple/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "tuple/subtract"]]
		as red-value! do-math OP_SUB
	]

	remainder: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "tuple/remainder"]]
		as red-value! do-math OP_REM
	]

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

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

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

	length?: func [
		tp		[red-tuple!]
		return: [integer!]
		/local
			value  [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/length?"]]

		TUPLE_SIZE(tp)
	]

	pick: func [
		tp		[red-tuple!]
		index	[integer!]
		boxed	[red-value!]
		return:	[red-value!]
		/local
			value	[byte-ptr!]
			size	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/pick"]]

		value: (as byte-ptr! tp) + 4
		size: TUPLE_SIZE(tp)

		either any [
			index <= 0
			index > size
		][
			fire [TO_ERROR(script out-of-range) boxed]
			null
		][
			as red-value! integer/box as-integer value/index
		]
	]

	poke: func [
		tp		[red-tuple!]
		index	[integer!]
		data	[red-value!]
		boxed	[red-value!]
		return:	[red-value!]
		/local
			value [byte-ptr!]
			size  [integer!]
			int   [red-integer!]
			v	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/poke"]]

		value: (as byte-ptr! tp) + 4
		size: TUPLE_SIZE(tp)

		either any [
			index <= 0
			index > size
		][
			fire [TO_ERROR(script out-of-range) boxed]
		][
			int: as red-integer! data
			v: int/value
			either v > 255 [v: 255][if negative? v [v: 0]]
			value/index: as byte! v
		]
		as red-value! data
	]

	reverse: func [
		tuple	 [red-tuple!]
		part-arg [red-value!]
		return:	 [red-value!]
		/local
			int  [red-integer!]
			part [integer!]
			tmp  [byte!]
			size [integer!]
			n	 [integer!]
			m	 [integer!]
			tp   [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/reverse"]]

		tp: (as byte-ptr! tuple) + 4
		size: TUPLE_SIZE(tuple)
		part: size
		if OPTION?(part-arg) [
			either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				part: int/value
				if negative? part [
					fire [TO_ERROR(script out-of-range) int]
				]
			][
				ERR_INVALID_REFINEMENT_ARG(refinements/_part part-arg)
			]
		]

		if part < size [size: part]
		n: 1
		while [n < size] [
			tmp: tp/n
			tp/n: tp/size
			tp/size: tmp
			n: n + 1
			size: size - 1
		]
		as red-value! tuple
	]

	init: does [
		datatype/register [
			TYPE_TUPLE
			TYPE_VALUE
			"tuple!"
			;-- General actions --
			:make
			:random
			null			;reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			null			;absolute
			:add
			:divide
			:multiply
			null			;negate
			null			;power
			:remainder
			null			;round
			:subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			:and~
			null			;complement
			:or~
			:xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			null			;copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			:length?
			null			;next
			:pick
			:poke
			null			;remove
			: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:   "Tuple! datatype runtime functions"
	Author:  "Qingtian Xie"
	File: 	 %tuple.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
]

tuple: context [
	verbose: 0

	push: func [
		size	[integer!]
		arr1	[integer!]
		arr2	[integer!]
		arr3	[integer!]
		return: [red-tuple!]
		/local
			tp	 [red-tuple!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/push"]]

		tp: as red-tuple! stack/push*
		tp/header: TYPE_TUPLE or (size << 19)
		tp/array1: arr1
		tp/array2: arr2
		tp/array3: arr3
		tp
	]

	do-math: func [
		type	  [integer!]
		return:	  [red-tuple!]
		/local
			left  [red-tuple!]
			right [red-tuple!]
			int   [red-integer!]
			fl    [red-float!]
			tp1   [byte-ptr!]
			tp2   [byte-ptr!]
			size  [integer!]
			size1 [integer!]
			size2 [integer!]
			v	  [integer!]
			v1	  [integer!]
			n	  [integer!]
			f1	  [float!]
			f2	  [float!]
			swap? [logic!]
			float? [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/do-math"]]

		left:  as red-tuple! stack/arguments
		right: as red-tuple! left + 1

		swap?: no
		if TYPE_OF(left) <> TYPE_TUPLE [
			int: as red-integer! left
			left: right
			right: as red-tuple! int
			swap?: yes
		]

		float?: no
		size2: 0
		switch TYPE_OF(right) [
			TYPE_TUPLE [
				tp2: (as byte-ptr! right) + 4
				size2: TUPLE_SIZE(right)
			]
			TYPE_INTEGER [
				int: as red-integer! right
				v: int/value
			]
			TYPE_FLOAT
			TYPE_PERCENT [
				float?: yes
				fl: as red-float! right
				f2: fl/value
			]
			default [
				fire [TO_ERROR(script invalid-type) datatype/push TYPE_OF(right)]
			]
		]

		tp1: (as byte-ptr! left) + 4
		size1: TUPLE_SIZE(left)
		n: 0
		either float? [
			until [
				n: n + 1
				f1: integer/to-float as-integer tp1/n
				f1: switch type [
					OP_ADD [f1 + f2]
					OP_SUB [f1 - f2]
					OP_MUL [f1 * f2]
					OP_DIV
					OP_REM [
						if 0.0 = f2 [fire [TO_ERROR(math zero-divide)]]
						either type = OP_DIV [f1 / f2][f1 % f2]
					]
					default [ERR_EXPECT_ARGUMENT((TYPE_OF(right)) 2) 0.0]
				]
				v1: float/to-integer either f1 < 0.0 [f1 + 0.4999999999999999][f1 - 0.4999999999999999]
				either v1 > 255 [v1: 255][if negative? v1 [v1: 0]]
				tp1/n: as byte! v1
				n = size1
			]
		][
			size: either size1 < size2 [
				tp1/1: as byte! size2
				size2
			][size1]
			until [
				n: n + 1
				if positive? size2 [
					v: either n <= size2 [as-integer tp2/n][0]
				]
				v1: either n <= size1 [as-integer tp1/n][0]
				v1: switch type [
					OP_ADD [v1 + v]
					OP_SUB [v1 - v]
					OP_MUL [v1 * v]
					OP_AND [v1 and v]
					OP_OR  [v1 or v]
					OP_XOR [v1 xor v]
					OP_REM [
						either zero? v [
							fire [TO_ERROR(math zero-divide)]
							0								;-- pass the compiler's type-checking
						][v1 % v]
					]
					OP_DIV [
						either zero? v [
							fire [TO_ERROR(math zero-divide)]
							0								;-- pass the compiler's type-checking
						][v1 / v]
					]
				]
				either v1 > 255 [v1: 255][if negative? v1 [v1: 0]]
				tp1/n: as byte! v1
				n = size
			]
		]
		if swap? [copy-cell as cell! left stack/arguments]
		left
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-tuple!]
		/local
			blk   [red-block!]
			tuple [red-tuple!]
			tp    [byte-ptr!]
			n	  [integer!]
			i	  [integer!]
			s	  [series!]
			int   [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/make"]]

		switch TYPE_OF(spec) [
			TYPE_TUPLE [
				as red-tuple! spec
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				tuple: as red-tuple! stack/push*
				tuple/header: TYPE_TUPLE
				tp: (as byte-ptr! tuple) + 4
				n: block/rs-length? blk
				if n > 12 [
					fire [TO_ERROR(script bad-make-arg) proto spec]
				]
				tuple/header: TYPE_TUPLE or either n > 2 [n << 19][3 << 19]
				s: GET_BUFFER(blk)
				int: as red-integer! s/offset + blk/head
				i: 0
				while [i < n][
					i: i + 1
					if any [
						int/value > 255
						int/value < 0
					][fire [TO_ERROR(script bad-make-arg) proto spec]]
					tp/i: as byte! int/value
					int: int + 1
				]
				while [i < 3][i: i + 1 tp/i: null-byte]
				tuple
			]
			default [
				fire [TO_ERROR(script bad-make-arg) proto spec]
				null
			]
		]
	]

	random: func [
		tp		[red-tuple!]
		seed?	[logic!]
		secure? [logic!]
		only?   [logic!]
		return: [red-value!]
		/local
			value [red-value!]
			array [byte-ptr!]
			n	  [integer!]
			size  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/random"]]

		either seed? [
			value: as red-value! tp
			_random/srand value/data1 xor value/data2 xor value/data3
			tp/header: TYPE_UNSET
		][
			array: (as byte-ptr! tp) + 4
			size: TUPLE_SIZE(tp)
			n: 0
			until [
				n: n + 1
				array/n: as-byte _random/rand % array/n + 1
				n = size
			]
		]
		as red-value! tp
	]

	form: func [
		tp		   [red-tuple!]
		buffer	   [red-string!]
		arg		   [red-value!]
		part 	   [integer!]
		return:    [integer!]
		/local
			formed [c-string!]
			value  [byte-ptr!]
			n	   [integer!]
			size   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/form"]]

		value: (as byte-ptr! tp) + 4
		size: TUPLE_SIZE(tp)

		n: 0
		until [
			n: n + 1
			formed: integer/form-signed as-integer value/n
			string/concatenate-literal buffer formed
			unless n = size [
				part: part - 1
				string/append-char GET_BUFFER(buffer) as-integer #"."
			]
			part: part - system/words/length? formed	;@@ optimize by removing length?
			n = size
		]
		part
	]

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

		form tp buffer arg part
	]

	eval-path: func [
		parent	[red-tuple!]							;-- implicit type casting
		element	[red-value!]
		value	[red-value!]
		path	[red-value!]
		case?	[logic!]
		return:	[red-value!]
		/local
			int  [red-integer!]
			type [integer!]
	][
		type: TYPE_OF(element)
		either type = TYPE_INTEGER [
			int: as red-integer! element
			either value <> null [
				poke parent int/value value null
				value
			][
				pick parent int/value null
			]
		][
			fire [TO_ERROR(script invalid-type) datatype/push TYPE_OF(element)]
			null
		]
	]

	compare: func [
		tp1		[red-tuple!]							;-- first operand
		tp2		[red-tuple!]							;-- second operand
		op		[integer!]								;-- type of comparison
		return: [integer!]
		/local
			p1	 [byte-ptr!]
			p2	 [byte-ptr!]
			i	 [integer!]
			sz   [integer!]
			sz1  [integer!]
			sz2  [integer!]
			v1	 [integer!]
			v2	 [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/compare"]]

		if TYPE_OF(tp2) <> TYPE_TUPLE [RETURN_COMPARE_OTHER]
		p1: (as byte-ptr! tp1) + 4
		p2: (as byte-ptr! tp2) + 4
		sz1: TUPLE_SIZE(tp1)
		sz2: TUPLE_SIZE(tp2)
		sz: either sz1 > sz2 [sz1][sz2]

		i: 0
		until [
			i: i + 1
			v1: either i > sz1 [0][as-integer p1/i]
			v2: either i > sz2 [0][as-integer p2/i]
			if v1 <> v2 [return SIGN_COMPARE_RESULT(v1 v2)]
			i = sz
		]
		0
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "tuple/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "tuple/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "tuple/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "tuple/subtract"]]
		as red-value! do-math OP_SUB
	]

	remainder: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "tuple/remainder"]]
		as red-value! do-math OP_REM
	]

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

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

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

	length?: func [
		tp		[red-tuple!]
		return: [integer!]
		/local
			value  [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/length?"]]

		TUPLE_SIZE(tp)
	]

	pick: func [
		tp		[red-tuple!]
		index	[integer!]
		boxed	[red-value!]
		return:	[red-value!]
		/local
			value	[byte-ptr!]
			size	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/pick"]]

		value: (as byte-ptr! tp) + 4
		size: TUPLE_SIZE(tp)

		either any [
			index <= 0
			index > size
		][
			fire [TO_ERROR(script out-of-range) boxed]
			null
		][
			as red-value! integer/box as-integer value/index
		]
	]

	poke: func [
		tp		[red-tuple!]
		index	[integer!]
		data	[red-value!]
		boxed	[red-value!]
		return:	[red-value!]
		/local
			value [byte-ptr!]
			size  [integer!]
			int   [red-integer!]
			v	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/poke"]]

		value: (as byte-ptr! tp) + 4
		size: TUPLE_SIZE(tp)

		either any [
			index <= 0
			index > size
		][
			fire [TO_ERROR(script out-of-range) boxed]
		][
			int: as red-integer! data
			v: int/value
			either v > 255 [v: 255][if negative? v [v: 0]]
			value/index: as byte! v
		]
		as red-value! data
	]

	reverse: func [
		tuple	 [red-tuple!]
		part-arg [red-value!]
		return:	 [red-value!]
		/local
			int  [red-integer!]
			part [integer!]
			tmp  [byte!]
			size [integer!]
			n	 [integer!]
			m	 [integer!]
			tp   [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "tuple/reverse"]]

		tp: (as byte-ptr! tuple) + 4
		size: TUPLE_SIZE(tuple)
		part: size
		if OPTION?(part-arg) [
			either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				part: int/value
				if negative? part [
					fire [TO_ERROR(script out-of-range) int]
				]
			][
				ERR_INVALID_REFINEMENT_ARG(refinements/_part part-arg)
			]
		]

		if part < size [size: part]
		n: 1
		while [n < size] [
			tmp: tp/n
			tp/n: tp/size
			tp/size: tmp
			n: n + 1
			size: size - 1
		]
		as red-value! tuple
	]

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


TESTS: added pointer and nesting tests to namepace tests

Red/System [
	Title:   "Red/System null test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %namespace-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~~~ "namespace"

    nmsp1: context [
      i: 123
      f: 1.23
      f32: as float32! 2.46
      l: true
      s: "my string"
      fn: func [pi [pointer! [integer!]] return: [integer!]] [pi/value: 789 789]
      fn2: func [
        i [integer!]
        return: [integer!]
      ][ 2 * i]
      st: declare struct! [
        a [integer!]
        b [integer!]
      ]
    ]

    i: 987
	ctx: context [
		i: 123
		j: "test"
		foo: func [return: [integer!]][
			i: i + 1
			i
		]
		--test-- "in-ns1"
		--assert 124 = foo
	]

===start-group=== "basic"

  --test-- "ns1"
  --assert 123 = nmsp1/i
  --test-- "ns2"
  --assert 1.23 = nmsp1/f
  --test-- "ns3"
  --assert (as float32! 2.46) = nmsp1/f32
  --test-- "ns4"
  --assert nmsp1/l
  --test-- "ns5"
  --assert nmsp1/s/1 = #"m"
  --assert nmsp1/s/2 = #"y"
  --assert nmsp1/s/3 = #" "
  --assert nmsp1/s/4 = #"s"
  --assert nmsp1/s/5 = #"t"
  --assert nmsp1/s/6 = #"r"
  --assert nmsp1/s/7 = #"i"
  --assert nmsp1/s/8 = #"n"
  --assert nmsp1/s/9 = #"g"
  --test-- "ns6"
    nmsp1/s: "hello"
  --assert 5 = length? nmsp1/s
  --test-- "ns7"
    ns1-b-i: 0
  --assert 789 = nmsp1/fn :ns1-b-i
  --test-- "ns8"
    ns1-b-i: 4
  --assert 8 = nmsp1/fn2 ns1-b-i
  --test-- "ns9"
    nmsp1/st/a: 1
  --assert nmsp1/st/a = 1
  --test-- "ns10"
  --assert ctx/j/1 = #"t"
  --test-- "ns11"
  --assert ctx/foo = 125
  --test-- "ns12"
    ctx/i: ctx/i + 1
  --assert ctx/i = 126
  --assert i = 987

===end-group===

===start-group=== "hiding"
    i: 321
    f: 3.21
    f32: as float32! 6.42
    l: false
    s: "not my string"
    fn: func [pi [pointer! [integer!]]] [pi/value: 987]
    fn2: func[
        i [integer!]
        return: [integer!]
      ][ 3 * i]
    st: declare struct! [
        a [integer!]
        b [integer!]
    ]

  --test-- "nmh1"
    nmsp1/i: 789
  --assert i = 321
  --test-- "nmh2"
    nmsp1/f: 7.89
  --assert f = 3.21
  --test-- "nmh3"
    nmsp1/f32: as float32! 7.89
  --assert nmsp1/f32 = as float32! 7.89
  --test-- "nmh4"
    nmsp1/s: "str"
  --assert 13 = length? s
  --test-- "nmh5"
    nmh5-i: 1
    nmsp1/fn :nmh5-i
  --assert 789 = nmh5-i
  --test-- "nmh6"
    nmh6-i: 1
    fn :nmh6-i
  --assert 987 = nmh6-i
  --test-- "nmh7"
    nmh7-i: 2
  --assert 4 = nmsp1/fn2 nmh7-i
  --assert 6 = fn2 nmh7-i
  --test-- "nmh8"
    st/a: 1
    st/b: 2
    nmsp1/st/a: 100
    nmsp1/st/b: 200
  --assert 1 = st/a
  --assert 2 = st/b

===end-group===

===start-group=== "initialisation"
    nmsp2: context [
      i: 2
      j: 3
      k: 0
      s: "12345"
      st: declare struct! [
        a [integer!]
        b [c-string!]
        c [float!]
        d [integer!]
      ]

      k: i * j
      s/1: #"h"
      s/2: #"e"
      s/3: #"l"
      s/4: #"l"
      s/5: #"o"
      st/a: 1
      st/b: "hello"
      st/c: 12345.678
      st/d: 1
      until [
        i: i * j
        j: j - 1
        j < 1
      ]
    ]
  --test-- "nmi1"
  --assert nmsp2/i = 12
  --test-- "nmi2"
  --assert nmsp2/j = 0
  --test-- "nmi3"
  --assert nmsp2/k = 6
  --test-- "nmi4"
  --assert nmsp2/s/1 = #"h"
  --assert nmsp2/s/2 = #"e"
  --assert nmsp2/s/3 = #"l"
  --assert nmsp2/s/4 = #"l"
  --assert nmsp2/s/5 = #"o"
  --test-- "nmi5"
  --assert nmsp2/st/a = 1
  --test-- "nmi6"
  --assert nmsp2/st/b/1 = #"h"
  --assert nmsp2/st/b/2 = #"e"
  --assert nmsp2/st/b/3 = #"l"
  --assert nmsp2/st/b/4 = #"l"
  --assert nmsp2/st/b/5 = #"o"
  --test-- "nmi7"
  --assert nmsp2/st/c = 12345.678
  --test-- "nmi8"
  --assert nmsp2/st/d = 1

===end-group===

===start-group=== "multiple"
    nmspa: context [
      i: 1
    ]
    nmspb: context [
      i: 2
    ]
    nmspc: context [
      i: 3
    ]
    nmspd: context [
      i: 4
    ]
    nmspe: context [
      i: 5
    ]
    nmspf: context [
      i: 6
    ]
    nmspg: context [
      i: 7
    ]
    nmsph: context [
      i: 8
    ]
    nmspi: context [
      i: 9
    ]
    nmspj: context [
      i: 10
    ]
    nmspk: context [
      i: 11
    ]
  --test-- "nmm1"
  --assert nmspa/i = 1
  --assert nmspb/i = 2
  --assert nmspc/i = 3
  --assert nmspd/i = 4
  --assert nmspe/i = 5
  --assert nmspf/i = 6
  --assert nmspg/i = 7
  --assert nmsph/i = 8
  --assert nmspi/i = 9
  --assert nmspj/i = 10
  --assert nmspk/i = 11

===end-group===

===start-group=== "global access"
  --test-- "nmga1"
    i2: 0
    j: 3
    nmsp3: context [
      i: 2
      k: i * j
      i2: 4
    ]
  --assert nmsp3/k = 6
  --assert nmsp3/i2 = 4
  --assert i2 = 0
  --test-- "nmga2"
      j3: 1
    nmsp4: context [
      i3: 2
      k3: i3 * j3
      i4: 4
    ]
    i4: 0
    j3: 3
  --assert nmsp4/k3 = 2
  --assert i4 = 0
===end-group===

===start-group=== "pointers"
  --test-- "nmp1"
    i: 12345
    nmsp5: context [
      pi: declare pointer! [integer!]
    ]
    nmsp5/pi: :i
  --assert nmsp5/pi/value = 12345
  --test-- "nmp2"
    pi: declare pointer! [integer!]
    nmsp6: context [
      i: 12345
    ]
    pi: :nmsp6/i
  --assert pi/value = 12345
===end-group===

===start-group=== "nesting"
  --test-- "nmm1"
    nmsp7: context! [
      i: 0
      nmsp7-1 context! [
        i: 1
        j: i * nmsp7/i
        nmsp7-2 context! [
          i: 2
          j: i * nmsp7/i
          k: i * nmsp7-1/i
          nmsp7-3 context! [
            i: 3
            j: i * nmsp7/i
            k: i * nmsp7-1/i
            l: i * nmsp7-2/i
          ]
        ]
      ]
    ]
  --assert nmsp7/i = 0
  --assert nmsp7/nmsp7-1/i = 1
  --assert nmsp7/nmsp7-1/j = 0
  --assert nmsp7/nmsp7-1/nmsp7-2/i = 2
  --assert nmsp7/nmsp7-1/nmsp7-2/j = 0
  --assert nmsp7/nmsp7-1/nmsp7-2/k = 2
  --assert nmsp7/nmsp7-1/nmsp7-2/nmsp7-3/i = 3
  --assert nmsp7/nmsp7-1/nmsp7-2/nmsp7-3/j = 0
  --assert nmsp7/nmsp7-1/nmsp7-2/nmsp7-3/k = 3
  --assert nmsp7/nmsp7-1/nmsp7-2/nmsp7-3/l = 6
===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System null test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %namespace-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~~~ "namespace"

    nmsp1: context [
      i: 123
      f: 1.23
      f32: as float32! 2.46
      l: true
      s: "my string"
      fn: func [pi [pointer! [integer!]] return: [integer!]] [pi/value: 789 789]
      fn2: func [
        i [integer!]
        return: [integer!]
      ][ 2 * i]
      st: declare struct! [
        a [integer!]
        b [integer!]
      ]
    ]

    i: 987
	ctx: context [
		i: 123
		j: "test"
		foo: func [return: [integer!]][
			i: i + 1
			i
		]
		--test-- "in-ns1"
		--assert 124 = foo
	]

===start-group=== "basic"

  --test-- "ns1"
  --assert 123 = nmsp1/i
  --test-- "ns2"
  --assert 1.23 = nmsp1/f
  --test-- "ns3"
  --assert (as float32! 2.46) = nmsp1/f32
  --test-- "ns4"
  --assert nmsp1/l
  --test-- "ns5"
  --assert nmsp1/s/1 = #"m"
  --assert nmsp1/s/2 = #"y"
  --assert nmsp1/s/3 = #" "
  --assert nmsp1/s/4 = #"s"
  --assert nmsp1/s/5 = #"t"
  --assert nmsp1/s/6 = #"r"
  --assert nmsp1/s/7 = #"i"
  --assert nmsp1/s/8 = #"n"
  --assert nmsp1/s/9 = #"g"
  --test-- "ns6"
    nmsp1/s: "hello"
  --assert 5 = length? nmsp1/s
  --test-- "ns7"
    ns1-b-i: 0
  --assert 789 = nmsp1/fn :ns1-b-i
  --test-- "ns8"
    ns1-b-i: 4
  --assert 8 = nmsp1/fn2 ns1-b-i
  --test-- "ns9"
    nmsp1/st/a: 1
  --assert nmsp1/st/a = 1
  --test-- "ns10"
  --assert ctx/j/1 = #"t"
  --test-- "ns11"
  --assert ctx/foo = 125
  --test-- "ns12"
    ctx/i: ctx/i + 1
  --assert ctx/i = 126
  --assert i = 987

===end-group===

===start-group=== "hiding"
    i: 321
    f: 3.21
    f32: as float32! 6.42
    l: false
    s: "not my string"
    fn: func [pi [pointer! [integer!]]] [pi/value: 987]
    fn2: func[
        i [integer!]
        return: [integer!]
      ][ 3 * i]
    st: declare struct! [
        a [integer!]
        b [integer!]
    ]

  --test-- "nmh1"
    nmsp1/i: 789
  --assert i = 321
  --test-- "nmh2"
    nmsp1/f: 7.89
  --assert f = 3.21
  --test-- "nmh3"
    nmsp1/f32: as float32! 7.89
  --assert nmsp1/f32 = as float32! 7.89
  --test-- "nmh4"
    nmsp1/s: "str"
  --assert 13 = length? s
  --test-- "nmh5"
    nmh5-i: 1
    nmsp1/fn :nmh5-i
  --assert 789 = nmh5-i
  --test-- "nmh6"
    nmh6-i: 1
    fn :nmh6-i
  --assert 987 = nmh6-i
  --test-- "nmh7"
    nmh7-i: 2
  --assert 4 = nmsp1/fn2 nmh7-i
  --assert 6 = fn2 nmh7-i
  --test-- "nmh8"
    st/a: 1
    st/b: 2
    nmsp1/st/a: 100
    nmsp1/st/b: 200
  --assert 1 = st/a
  --assert 2 = st/b

===end-group===

===start-group=== "initialisation"
    nmsp2: context [
      i: 2
      j: 3
      k: 0
      s: "12345"
      st: declare struct! [
        a [integer!]
        b [c-string!]
        c [float!]
        d [integer!]
      ]

      k: i * j
      s/1: #"h"
      s/2: #"e"
      s/3: #"l"
      s/4: #"l"
      s/5: #"o"
      st/a: 1
      st/b: "hello"
      st/c: 12345.678
      st/d: 1
      until [
        i: i * j
        j: j - 1
        j < 1
      ]
    ]
  --test-- "nmi1"
  --assert nmsp2/i = 12
  --test-- "nmi2"
  --assert nmsp2/j = 0
  --test-- "nmi3"
  --assert nmsp2/k = 6
  --test-- "nmi4"
  --assert nmsp2/s/1 = #"h"
  --assert nmsp2/s/2 = #"e"
  --assert nmsp2/s/3 = #"l"
  --assert nmsp2/s/4 = #"l"
  --assert nmsp2/s/5 = #"o"
  --test-- "nmi5"
  --assert nmsp2/st/a = 1
  --test-- "nmi6"
  --assert nmsp2/st/b/1 = #"h"
  --assert nmsp2/st/b/2 = #"e"
  --assert nmsp2/st/b/3 = #"l"
  --assert nmsp2/st/b/4 = #"l"
  --assert nmsp2/st/b/5 = #"o"
  --test-- "nmi7"
  --assert nmsp2/st/c = 12345.678
  --test-- "nmi8"
  --assert nmsp2/st/d = 1

===end-group===

===start-group=== "multiple"
    nmspa: context [
      i: 1
    ]
    nmspb: context [
      i: 2
    ]
    nmspc: context [
      i: 3
    ]
    nmspd: context [
      i: 4
    ]
    nmspe: context [
      i: 5
    ]
    nmspf: context [
      i: 6
    ]
    nmspg: context [
      i: 7
    ]
    nmsph: context [
      i: 8
    ]
    nmspi: context [
      i: 9
    ]
    nmspj: context [
      i: 10
    ]
    nmspk: context [
      i: 11
    ]
  --test-- "nmm1"
  --assert nmspa/i = 1
  --assert nmspb/i = 2
  --assert nmspc/i = 3
  --assert nmspd/i = 4
  --assert nmspe/i = 5
  --assert nmspf/i = 6
  --assert nmspg/i = 7
  --assert nmsph/i = 8
  --assert nmspi/i = 9
  --assert nmspj/i = 10
  --assert nmspk/i = 11

===end-group===

===start-group=== "global access"
  --test-- "nmga1"
    i2: 0
    j: 3
    nmsp3: context [
      i: 2
      k: i * j
      i2: 4
    ]
  --assert nmsp3/k = 6
  --assert nmsp3/i2 = 4
  --assert i2 = 0
  --test-- "nmga2"
      j3: 1
    nmsp4: context [
      i3: 2
      k3: i3 * j3
      i4: 4
    ]
    i4: 0
    j3: 3
  --assert nmsp4/k3 = 2
  --assert i4 = 0
===end-group===

~~~end-file~~~