FIX: issue #558 (Can't iterate over path! & paren!)

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: declare int-ptr!
	top: 1

	buffer-blk: as red-block! 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

		if value = tail [RETURN_NONE]

		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/validate as red-block! stack/arguments
		_function/push
			as red-block! stack/arguments
			as red-block! stack/arguments + 1
			null
			0
		stack/set-last stack/top - 1
	]

	function*:	does [
		_function/collect-words
			as red-block! stack/arguments
			as red-block! stack/arguments + 1
		func*
	]

	does*: does [
		copy-cell stack/arguments stack/push*
		block/make-at as red-block! stack/arguments 1
		func*
	]

	has*: does [
		block/insert-value
			as red-block! stack/arguments
			as red-value! refinements/local
		func*
	]

	switch*: func [
		default? [integer!]
		/local
			pos	 [red-value!]
			blk  [red-block!]
			alt  [red-block!]
			end  [red-value!]
			s	 [series!]
	][
		blk: as red-block! stack/arguments + 1
		alt: as red-block! stack/arguments + 2

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

		either TYPE_OF(pos) = TYPE_NONE [
			either negative? default? [
				RETURN_NONE
			][
				interpreter/eval alt
				exit									;-- early exit with last value on stack
			]
		][
			s: GET_BUFFER(blk)
			end: s/tail

			while [pos < end][							;-- find first following block
				if TYPE_OF(pos) = TYPE_BLOCK [
					stack/reset
					pos: block/pick as red-series! pos 1 null
					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!]
		/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
				]
				if negative? all? [exit]				;-- early exit with last value on stack (unless /all)
			][
				value: value + 1						;-- single value only allowed for cases bodies
			]
		]
		RETURN_NONE
	]

	do*: func [
		/local
			arg [red-value!]
			str	[red-string!]
			s	[series!]
	][
		arg: stack/arguments
		switch TYPE_OF(arg) [
			TYPE_BLOCK [
				interpreter/eval as red-block! arg
			]
			TYPE_PATH [
				interpreter/eval-path arg arg arg + 1 no
				stack/set-last arg + 1
			]
			TYPE_STRING [
				str: as red-string! arg
				s: GET_BUFFER(str)
				tokenizer/scan as c-string! s/offset null	;@@ temporary limited to Latin-1
				do*
			]
			default [
				interpreter/eval-expression arg arg + 1 no no
			]
		]
	]

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

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

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

	print*: does [
		lf?: yes											;@@ get rid of this global state
		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 any [
			TYPE_OF(arg) = TYPE_STRING 						;@@ replace by ANY_STRING?
			TYPE_OF(arg) = TYPE_FILE
		][
			str: as red-string! arg
		][
			block/rs-clear buffer-blk
			stack/push as red-value! buffer-blk
			assert stack/top - 2 = stack/arguments			;-- check for correct stack layout

			if TYPE_OF(arg) = TYPE_BLOCK [reduce* 1]
			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 [
		header? [integer!]
		all?	[integer!]
		type?	[integer!]
		into 	[integer!]
		return: [red-value!]
		/local
			str [red-string!]
			dst [red-block!]
	][
		str: as red-string! stack/arguments
		dst: null

		if into >= 0 [
			dst: as red-block! stack/push stack/arguments + into
		]
		tokenizer/scan as c-string! string/rs-head str dst	;@@ temporary limited to Latin-1
		unless null? dst [stack/set-last as red-value! dst]

		blk: as red-block! stack/arguments
		if TYPE_OF(blk) = TYPE_BLOCK [
			if all [negative? all? 1 = block/rs-length? blk][
				stack/set-last block/pick as red-series! blk 1 null
			]
		]
		stack/arguments
	]

	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
	]

	stats*: func [
		show [integer!]
		info [integer!]
		/local
			blk [red-block!]
	][
		case [
			show >= 0 [
				;TBD
				integer/box memory/total
			]
			info >= 0 [
				blk: block/push* 5
				memory-info blk 2
				stack/set-last as red-value! blk
			]
			true [
				integer/box memory/total
			]
		]
	]

	bind*: func [
		copy [integer!]
		/local
			value [red-value!]
			ref	  [red-value!]
			fun	  [red-function!]
			word  [red-word!]
			ctx	  [red-context!]
	][
		value: stack/arguments
		ref: value + 1

		either any [
			TYPE_OF(ref) = TYPE_FUNCTION
			;TYPE_OF(ref) = TYPE_OBJECT
		][
			fun: as red-function! ref
			ctx: fun/ctx
		][
			word: as red-word! ref
			ctx: word/ctx
		]

		either TYPE_OF(value) = TYPE_BLOCK [
			either negative? copy [
				_context/bind as red-block! value ctx
			][
				stack/set-last
					as red-value! _context/bind
						block/clone as red-block! value yes
						ctx
			]
		][
			word: as red-word! value
			word/ctx: ctx
			word/index: _context/find-word ctx word/symbol
		]
	]

	parse*: func [
		over? [integer!]
		case? [integer!]
		;strict? [integer!]
		/local
			match? [logic!]
	][
		match?: parser/process
			as red-series! stack/arguments
			as red-block!  stack/arguments + 1
			as logic! over? + 1
			as logic! case? + 1
			;as logic! strict? + 1

		stack/set-last as red-value! logic/push match?
	]

	union*: func [
		cased	 [integer!]
		skip	 [integer!]
		/local
			set1	 [red-value!]
			skip-arg [red-value!]
			case?	 [logic!]
	][
		set1:	  stack/arguments
		skip-arg: set1 + skip
		case?:	  as logic! cased + 1

		switch TYPE_OF(set1) [
			;TYPE_BLOCK  [stack/set-last block/union set1 set2 case? skip-arg]
			;TYPE_STRING [stack/set-last string/union set1 set2 case? skip-arg]
			TYPE_BITSET [
				stack/set-last as red-value! bitset/union
					as red-bitset! set1
					as red-bitset! set1 + 1
					no
					null
				]
			default [
				print-line "*** Error: argument type not supported by UNION"
			]
		]
	]

	intersect*: does []

	unique*: does []

	difference*: does []

	;--- Natives helper functions ---

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

		type: TYPE_OF(series)
		either any [									;@@ replace with any-block?
			type = TYPE_BLOCK
			type = TYPE_PAREN
			type = TYPE_PATH
			type = TYPE_GET_PATH
			type = TYPE_SET_PATH
			type = TYPE_LIT_PATH
		][
			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 null][value]
			_context/set
				as red-word! block/pick words i null
				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_PAREN
			TYPE_OF(series) = TYPE_PATH
			TYPE_OF(series) = TYPE_GET_PATH
			TYPE_OF(series) = TYPE_SET_PATH
			TYPE_OF(series) = TYPE_LIT_PATH
			TYPE_OF(series) = TYPE_STRING
			TYPE_OF(series) = TYPE_FILE
		]
		assert TYPE_OF(blk) = TYPE_BLOCK

		result: loop? series
		if result [set-many blk as red-value! series size]
		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_PAREN
			TYPE_OF(series) = TYPE_PATH
			TYPE_OF(series) = TYPE_GET_PATH
			TYPE_OF(series) = TYPE_SET_PATH
			TYPE_OF(series) = TYPE_LIT_PATH
			TYPE_OF(series) = TYPE_STRING
			TYPE_OF(series) = TYPE_FILE
		]
		assert TYPE_OF(word) = TYPE_WORD

		result: loop? series
		if result [_context/set word actions/pick series 1 null]
		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_PAREN
			TYPE_OF(series) = TYPE_PATH
			TYPE_OF(series) = TYPE_GET_PATH
			TYPE_OF(series) = TYPE_SET_PATH
			TYPE_OF(series) = TYPE_LIT_PATH
			TYPE_OF(series) = TYPE_STRING
			TYPE_OF(series) = TYPE_FILE
		]
		assert TYPE_OF(word) = TYPE_WORD

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

	repeat-init*: func [
		cell  	[red-value!]
		return: [integer!]
		/local
			int [red-integer!]
	][
		copy-cell stack/arguments cell
		int: as red-integer! cell
		int/value										;-- overlapping /value field for integer! and char!
	]

	repeat-set: func [
		cell  [red-value!]
		value [integer!]
		/local
			int [red-integer!]
	][
		assert any [
			TYPE_OF(cell) = TYPE_INTEGER
			TYPE_OF(cell) = TYPE_CHAR
		]
		int: as red-integer! cell
		int/value: value								;-- overlapping /value field for integer! and char!
	]

	init: does [
		table: as int-ptr! allocate NATIVES_NB * size? integer!
		buffer-blk: block/make-in red/root 32			;-- block buffer for PRIN's reduce/into

		register [
			:if*
			:unless*
			:either*
			:any*
			:all*
			:while*
			:until*
			:loop*
			:repeat*
			:foreach*
			:forall*
			:func*
			:function*
			:does*
			:has*
			: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*
			:stats*
			:bind*
			:parse*
			:union*
			:intersect*
			:unique*
			:difference*
		]
	]

]

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: declare int-ptr!
	top: 1

	buffer-blk: as red-block! 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

		if value = tail [RETURN_NONE]

		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/validate as red-block! stack/arguments
		_function/push
			as red-block! stack/arguments
			as red-block! stack/arguments + 1
			null
			0
		stack/set-last stack/top - 1
	]

	function*:	does [
		_function/collect-words
			as red-block! stack/arguments
			as red-block! stack/arguments + 1
		func*
	]

	does*: does [
		copy-cell stack/arguments stack/push*
		block/make-at as red-block! stack/arguments 1
		func*
	]

	has*: does [
		block/insert-value
			as red-block! stack/arguments
			as red-value! refinements/local
		func*
	]

	switch*: func [
		default? [integer!]
		/local
			pos	 [red-value!]
			blk  [red-block!]
			alt  [red-block!]
			end  [red-value!]
			s	 [series!]
	][
		blk: as red-block! stack/arguments + 1
		alt: as red-block! stack/arguments + 2

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

		either TYPE_OF(pos) = TYPE_NONE [
			either negative? default? [
				RETURN_NONE
			][
				interpreter/eval alt
				exit									;-- early exit with last value on stack
			]
		][
			s: GET_BUFFER(blk)
			end: s/tail

			while [pos < end][							;-- find first following block
				if TYPE_OF(pos) = TYPE_BLOCK [
					stack/reset
					pos: block/pick as red-series! pos 1 null
					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!]
		/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
				]
				if negative? all? [exit]				;-- early exit with last value on stack (unless /all)
			][
				value: value + 1						;-- single value only allowed for cases bodies
			]
		]
		RETURN_NONE
	]

	do*: func [
		/local
			arg [red-value!]
			str	[red-string!]
			s	[series!]
	][
		arg: stack/arguments
		switch TYPE_OF(arg) [
			TYPE_BLOCK [
				interpreter/eval as red-block! arg
			]
			TYPE_PATH [
				interpreter/eval-path arg arg arg + 1 no
				stack/set-last arg + 1
			]
			TYPE_STRING [
				str: as red-string! arg
				s: GET_BUFFER(str)
				tokenizer/scan as c-string! s/offset null	;@@ temporary limited to Latin-1
				do*
			]
			default [
				interpreter/eval-expression arg arg + 1 no no
			]
		]
	]

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

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

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

	print*: does [
		lf?: yes											;@@ get rid of this global state
		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 any [
			TYPE_OF(arg) = TYPE_STRING 						;@@ replace by ANY_STRING?
			TYPE_OF(arg) = TYPE_FILE
		][
			str: as red-string! arg
		][
			block/rs-clear buffer-blk
			stack/push as red-value! buffer-blk
			assert stack/top - 2 = stack/arguments			;-- check for correct stack layout

			if TYPE_OF(arg) = TYPE_BLOCK [reduce* 1]
			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 [
		header? [integer!]
		all?	[integer!]
		type?	[integer!]
		into 	[integer!]
		return: [red-value!]
		/local
			str [red-string!]
			dst [red-block!]
	][
		str: as red-string! stack/arguments
		dst: null

		if into >= 0 [
			dst: as red-block! stack/push stack/arguments + into
		]
		tokenizer/scan as c-string! string/rs-head str dst	;@@ temporary limited to Latin-1
		unless null? dst [stack/set-last as red-value! dst]

		blk: as red-block! stack/arguments
		if TYPE_OF(blk) = TYPE_BLOCK [
			if all [negative? all? 1 = block/rs-length? blk][
				stack/set-last block/pick as red-series! blk 1 null
			]
		]
		stack/arguments
	]

	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
	]

	stats*: func [
		show [integer!]
		info [integer!]
		/local
			blk [red-block!]
	][
		case [
			show >= 0 [
				;TBD
				integer/box memory/total
			]
			info >= 0 [
				blk: block/push* 5
				memory-info blk 2
				stack/set-last as red-value! blk
			]
			true [
				integer/box memory/total
			]
		]
	]

	bind*: func [
		copy [integer!]
		/local
			value [red-value!]
			ref	  [red-value!]
			fun	  [red-function!]
			word  [red-word!]
			ctx	  [red-context!]
	][
		value: stack/arguments
		ref: value + 1

		either any [
			TYPE_OF(ref) = TYPE_FUNCTION
			;TYPE_OF(ref) = TYPE_OBJECT
		][
			fun: as red-function! ref
			ctx: fun/ctx
		][
			word: as red-word! ref
			ctx: word/ctx
		]

		either TYPE_OF(value) = TYPE_BLOCK [
			either negative? copy [
				_context/bind as red-block! value ctx
			][
				stack/set-last
					as red-value! _context/bind
						block/clone as red-block! value yes
						ctx
			]
		][
			word: as red-word! value
			word/ctx: ctx
			word/index: _context/find-word ctx word/symbol
		]
	]

	parse*: func [
		over? [integer!]
		case? [integer!]
		;strict? [integer!]
		/local
			match? [logic!]
	][
		match?: parser/process
			as red-series! stack/arguments
			as red-block!  stack/arguments + 1
			as logic! over? + 1
			as logic! case? + 1
			;as logic! strict? + 1

		stack/set-last as red-value! logic/push match?
	]

	union*: func [
		cased	 [integer!]
		skip	 [integer!]
		/local
			set1	 [red-value!]
			skip-arg [red-value!]
			case?	 [logic!]
	][
		set1:	  stack/arguments
		skip-arg: set1 + skip
		case?:	  as logic! cased + 1

		switch TYPE_OF(set1) [
			;TYPE_BLOCK  [stack/set-last block/union set1 set2 case? skip-arg]
			;TYPE_STRING [stack/set-last string/union set1 set2 case? skip-arg]
			TYPE_BITSET [
				stack/set-last as red-value! bitset/union
					as red-bitset! set1
					as red-bitset! set1 + 1
					no
					null
				]
			default [
				print-line "*** Error: argument type not supported by UNION"
			]
		]
	]

	intersect*: does []

	unique*: does []

	difference*: does []

	;--- 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 null][value]
			_context/set
				as red-word! block/pick words i null
				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
			TYPE_OF(series) = TYPE_FILE
		]
		assert TYPE_OF(blk) = TYPE_BLOCK

		result: loop? series
		if result [set-many blk as red-value! series size]
		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
			TYPE_OF(series) = TYPE_FILE
		]
		assert TYPE_OF(word) = TYPE_WORD

		result: loop? series
		if result [_context/set word actions/pick series 1 null]
		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
			TYPE_OF(series) = TYPE_FILE
		]
		assert TYPE_OF(word) = TYPE_WORD

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

	repeat-init*: func [
		cell  	[red-value!]
		return: [integer!]
		/local
			int [red-integer!]
	][
		copy-cell stack/arguments cell
		int: as red-integer! cell
		int/value										;-- overlapping /value field for integer! and char!
	]

	repeat-set: func [
		cell  [red-value!]
		value [integer!]
		/local
			int [red-integer!]
	][
		assert any [
			TYPE_OF(cell) = TYPE_INTEGER
			TYPE_OF(cell) = TYPE_CHAR
		]
		int: as red-integer! cell
		int/value: value								;-- overlapping /value field for integer! and char!
	]

	init: does [
		table: as int-ptr! allocate NATIVES_NB * size? integer!
		buffer-blk: block/make-in red/root 32			;-- block buffer for PRIN's reduce/into

		register [
			:if*
			:unless*
			:either*
			:any*
			:all*
			:while*
			:until*
			:loop*
			:repeat*
			:foreach*
			:forall*
			:func*
			:function*
			:does*
			:has*
			: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*
			:stats*
			:bind*
			:parse*
			:union*
			:intersect*
			:unique*
			:difference*
		]
	]

]


TESTS: added tests to serialization-test.reds

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

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

~~~start-file~~~ "serialization"

blk: [
	1 #[none] #[true] #[false] #"c" "red" Red a/b 'a/b :a/b a/b: (1 + 2)
	[a] [[[]]] [[[a]]] [c [d [b] e] f] :w 'w w: /w :word 'word word: /word
]

molded: {[1 none true false #"c" "red" Red a/b 'a/b :a/b a/b: (1 + 2) [a] [[[]]] [[[a]]] [c [d [b] e] f] :w 'w w: /w :word 'word word: /word]}
formed: {1 none true false c red Red a/b 'a/b :a/b a/b: 1 + 2 a a c d b e f w w w w word word word word}

===start-group=== "Basic MOLD tests"

	--test-- "mold-1"
	--assert "[]" = mold []

	--test-- "mold-2"
	--assert "" = mold/only []

	--test-- "mold-3"
	--assert "[1 2 3]" = mold [1 2 3]

	--test-- "mold-4"
	--assert "1 2 3" = mold/only [1 2 3]

	--test-- "mold-5"
	--assert molded = mold blk

	--test-- "mold-6"
		repeat i 132 [
			--assert (copy/part molded i) = mold/part blk i
		]

	--test-- "mold-7"
	--assert "[a [b] c]" = mold [a [b] c]

===end-group===

===start-group=== "Basic FORM tests"

	--test-- "form-1"
	--assert "" = form []

	--test-- "form-2"
	--assert "1 2 3" = form [1 2 3]

	--test-- "form-3"
	--assert formed	= form blk

	--test-- "form-4"
	repeat i 132 [
		--assert (copy/part formed i) = form/part blk i
	]

	--test-- "form-5"
	--assert "a a" = form [[""] [a] [] [a] [[[]]]]

===end-group===

===start-group=== "mold strings"
	--test-- "mold-string-1"
	--assert {"abcde"} = mold {abcde}

	--test-- "mold-string-2"
	--assert {"^^(3A7)^^(3B1)^^(1FD6)^^(3C1)^^(3B5), ^^(3BA)^^(3CC)^^(3C3)^^(3BC)^^(3B5)"} = mold/all "Χαῖρε, κόσμε"

	--test-- "mold-string3 #issue 498"
	--assert {{""}} = mold mold {}

	--test-- "mold-string4"
	--assert {"abcde"} = mold "abcde"

	--test-- "mold-string5"
	--assert {"abc^^(2710)def"} = mold/all "abc✐def"

	--test-- "mold-string6"
	--assert {"abc^^(10000)def"} = mold/all "abc^(010000)def"

	--test-- "mold-string6"
		--assert {"目录1"} = mold "目录1"

===end-group===

===start-group=== "logic"

	--test-- "mold-logic1"
	--assert "true" = mold true
	--assert "false" = mold false
	--assert "none" = mold none

===end-group===

===start-group=== "block"

	--test-- "mold-block1"
	--assert "[a b c d e]" = mold [a b c d e]
	--assert "[b c d e]" = mold next [a b c d e]
	--assert "[c d e]" = mold at [a b c d e ] 3
	--assert "[]" = mold tail [a b c d e]

===end-group===

===start-group=== "integer"

	--test-- "mold-integer1"
	--assert "1" = mold 1
	--assert "-1" = mold FFFFFFFFh
	--assert "2147483647" = mold 7FFFFFFFh
	--assert "-2147483648" = mold 80000000h
	--assert "0" = mold 00h

===end-group===

===start-group=== "file"

	--test-- "mold-file1"
		--assert "%目录1" = mold %目录1

	--test-- "mold-file2"
		--assert "%目录1" = mold/all %目录1

===end-group===

===start-group=== "mold/only"
	--test-- "mold/only-1 issue #458"
	--assert "a [b] c" = mold/only [a [b] c]
	--test-- "mold/only-2"
	--assert {"a"} = mold/only "a"
	--test-- "mold/only-3"
		a: 1
		b: 2
		c: 3
	--assert {3} = mold/only (a (b) c)
	--test-- "mold/only-4"
	--assert "a" = mold/only [a]
	--test-- "mold/only-5"
	--assert "a [b] c [d [e] f] g" = mold/only [a [b] c [d [e] f] g]
===end-group===

===start-group=== "mold/all"
	--test-- "mold/all-1"
		--assert  {"^^(76EE)^^(5F55)1"} = mold/all "目录1"
===end-group===

~~~end-file~~~

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

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

~~~start-file~~~ "serialization"

blk: [
	1 #[none] #[true] #[false] #"c" "red" Red a/b 'a/b :a/b a/b: (1 + 2)
	[a] [[[]]] [[[a]]] [c [d [b] e] f] :w 'w w: /w :word 'word word: /word
]

molded: {[1 none true false #"c" "red" Red a/b 'a/b :a/b a/b: (1 + 2) [a] [[[]]] [[[a]]] [c [d [b] e] f] :w 'w w: /w :word 'word word: /word]}
formed: {1 none true false c red Red a/b 'a/b :a/b a/b: 1 + 2 a a c d b e f w w w w word word word word}

===start-group=== "Basic MOLD tests"

	--test-- "mold-1"
	--assert "[]" = mold []

	--test-- "mold-2"
	--assert "" = mold/only []

	--test-- "mold-3"
	--assert "[1 2 3]" = mold [1 2 3]

	--test-- "mold-4"
	--assert "1 2 3" = mold/only [1 2 3]

	--test-- "mold-5"
	--assert molded = mold blk

	--test-- "mold-6"
		repeat i 132 [
			--assert (copy/part molded i) = mold/part blk i
		]

	--test-- "mold-7"
	--assert "[a [b] c]" = mold [a [b] c]

===end-group===

===start-group=== "Basic FORM tests"

	--test-- "form-1"
	--assert "" = form []

	--test-- "form-2"
	--assert "1 2 3" = form [1 2 3]

	--test-- "form-3"
	--assert formed	= form blk

	--test-- "form-4"
	repeat i 132 [
		--assert (copy/part formed i) = form/part blk i
	]

	--test-- "form-5"
	--assert "a a" = form [[""] [a] [] [a] [[[]]]]

===end-group===

===start-group=== "mold strings"
	--test-- "mold-string-1"
	--assert {"abcde"} = mold {abcde}

	--test-- "mold-string-2"
	--assert {"^^(3A7)^^(3B1)^^(1FD6)^^(3C1)^^(3B5), ^^(3BA)^^(3CC)^^(3C3)^^(3BC)^^(3B5)"} = mold/all "Χαῖρε, κόσμε"

	--test-- "mold-string3 #issue 498"
	--assert {{""}} = mold mold {}

	--test-- "mold-string4"
	--assert {"abcde"} = mold "abcde"

	--test-- "mold-string5"
	--assert {"abc^^(2710)def"} = mold/all "abc✐def"

	--test-- "mold-string6"
	--assert {"abc^^(10000)def"} = mold/all "abc^(010000)def"
===end-group===

===start-group=== "logic"

	--test-- "mold-logic1"
	--assert "true" = mold true
	--assert "false" = mold false
	--assert "none" = mold none

===end-group===

===start-group=== "block"

	--test-- "mold-block1"
	--assert "[a b c d e]" = mold [a b c d e]
	--assert "[b c d e]" = mold next [a b c d e]
	--assert "[c d e]" = mold at [a b c d e ] 3
	--assert "[]" = mold tail [a b c d e]

===end-group===

===start-group=== "integer"

	--test-- "mold-integer1"
	--assert "1" = mold 1
	--assert "-1" = mold FFFFFFFFh
	--assert "2147483647" = mold 7FFFFFFFh
	--assert "-2147483648" = mold 80000000h
	--assert "0" = mold 00h

===end-group===

===start-group=== "mold/only"
	--test-- "mold/only-1 issue #458"
	--assert "a [b] c" = mold/only [a [b] c]
	--test-- "mold/only-2"
	--assert {"a"} = mold/only "a"
	--test-- "mold/only-3"
		a: 1
		b: 2
		c: 3
	--assert {3} = mold/only (a (b) c)
	--test-- "mold/only-4"
	--assert "a" = mold/only [a]
	--test-- "mold/only-5"
	--assert "a [b] c [d [e] f] g" = mold/only [a [b] c [d [e] f] g]
===end-group===

~~~end-file~~~


FIX: issue #745 (PRINT can't output unicode string on Windows XP)

Red/System [
	Title:   "Red runtime win32 API imported functions definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %win32.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/red-system/runtime/BSL-License.txt
	}
]

#define VA_COMMIT_RESERVE	3000h						;-- MEM_COMMIT | MEM_RESERVE
#define VA_PAGE_RW			04h							;-- PAGE_READWRITE
#define VA_PAGE_RWX			40h							;-- PAGE_EXECUTE_READWRITE

#define _O_TEXT        	 	4000h  						;-- file mode is text (translated)
#define _O_BINARY       	8000h  						;-- file mode is binary (untranslated)
#define _O_WTEXT        	00010000h 					;-- file mode is UTF16 (translated)
#define _O_U16TEXT      	00020000h 					;-- file mode is UTF16 no BOM (translated)
#define _O_U8TEXT       	00040000h 					;-- file mode is UTF8  no BOM (translated)

platform: context [

	#enum file-descriptors! [
		fd-stdout: 1									;@@ hardcoded, safe?
		fd-stderr: 2									;@@ hardcoded, safe?
	]

	page-size: 4096

	#import [
		LIBC-file cdecl [
			;putwchar: "putwchar" [
			;	wchar		[integer!]					;-- wchar is 16-bit on Windows
			;]
			wprintf: "wprintf" [
				[variadic]
				return: 	[integer!]
			]
			_setmode: "_setmode" [
				handle		[integer!]
				mode		[integer!]
				return:		[integer!]
			]
			;_open_osfhandle: "_open_osfhandle" [
			;	handle		[integer!]
			;	flags		[integer!]
			;	return:		[integer!]
			;]
		]
		"kernel32.dll" stdcall [
			VirtualAlloc: "VirtualAlloc" [
				address		[byte-ptr!]
				size		[integer!]
				type		[integer!]
				protection	[integer!]
				return:		[int-ptr!]
			]
			VirtualFree: "VirtualFree" [
				address 	[int-ptr!]
				size		[integer!]
				return:		[integer!]
			]
			WriteConsole: 	 "WriteConsoleW" [
				consoleOutput	[integer!]
				buffer			[byte-ptr!]
				charsToWrite	[integer!]
				numberOfChars	[int-ptr!]
				_reserved		[int-ptr!]
				return:			[integer!]
			]
		]
	]

	;-------------------------------------------
	;-- Allocate paged virtual memory region from OS
	;-------------------------------------------
	allocate-virtual: func [
		size 	[integer!]								;-- allocated size in bytes (page size multiple)
		exec? 	[logic!]								;-- TRUE => executable region
		return: [int-ptr!]								;-- allocated memory region pointer
		/local ptr prot
	][
		prot: either exec? [VA_PAGE_RWX][VA_PAGE_RW]

		ptr: VirtualAlloc
			null
			size
			VA_COMMIT_RESERVE
			prot

		if ptr = null [
			raise-error RED_ERR_VMEM_OUT_OF_MEMORY 0
		]
		ptr
	]

	;-------------------------------------------
	;-- Free paged virtual memory region from OS
	;-------------------------------------------
	free-virtual: func [
		ptr [int-ptr!]									;-- address of memory region to release
	][
		if negative? VirtualFree ptr ptr/value [
			raise-error RED_ERR_VMEM_RELEASE_FAILED as-integer ptr
		]
	]

	;-------------------------------------------
	;-- putwchar use WriteConsoleW internal
	;-------------------------------------------
	putwchar: func [
		wchar	[integer!]								;-- wchar is 16-bit on Windows
		return:	[integer!]
		/local
			n	[integer!]
	][
		n: 0
		WriteConsole stdout (as byte-ptr! :wchar) 1 :n null
	]

	;-------------------------------------------
	;-- Print a UCS-4 string to console
	;-------------------------------------------
	print-UCS4: func [
		str    [int-ptr!]								;-- zero-terminated UCS-4 string
		/local
			cp [integer!]								;-- codepoint
	][
		assert str <> null

		while [cp: str/value not zero? cp][
			either str/value > FFFFh [
				cp: cp - 00010000h						;-- encode surrogate pair
				putwchar cp >> 10 + D800h				;-- emit lead
				putwchar cp and 03FFh + DC00h			;-- emit trail
			][
				putwchar cp								;-- UCS-2 codepoint
			]
			str: str + 1
		]
	]

	;-------------------------------------------
	;-- Print a UCS-4 string to console
	;-------------------------------------------
	print-line-UCS4: func [
		str    [int-ptr!]								;-- zero-terminated UCS-4 string
		/local
			cp [integer!]								;-- codepoint
	][
		assert str <> null
		print-UCS4 str									;@@ throw an error on failure
		putwchar 10										;-- newline
	]

	;-------------------------------------------
	;-- Print a UCS-2 string to console
	;-------------------------------------------
	print-UCS2: func [
		str 	[byte-ptr!]								;-- zero-terminated UCS-2 string
		/local
			p	[byte-ptr!]
			cp	[integer!]
	][
		assert str <> null
		p: str
		while [p/1 <> null-byte][
			cp: (as-integer p/2) << 8 + p/1
			putwchar cp
			p: p + 2
		]
	]

	;-------------------------------------------
	;-- Print a UCS-2 string with newline to console
	;-------------------------------------------
	print-line-UCS2: func [
		str 	[byte-ptr!]								;-- zero-terminated UCS-2 string
	][
		assert str <> null
		print-UCS2 str									;@@ throw an error on failure
		putwchar 10										;-- newline
	]

	;-------------------------------------------
	;-- Print a Latin-1 string to console
	;-------------------------------------------
	print-Latin1: func [
		str 	[c-string!]								;-- zero-terminated Latin-1 string
		/local
			cp [integer!]								;-- codepoint
	][
		assert str <> null

		while [cp: as-integer str/1 not zero? cp][
			putwchar cp
			str: str + 1
		]
	]

	;-------------------------------------------
	;-- Print a Latin-1 string with newline to console
	;-------------------------------------------
	print-line-Latin1: func [
		str [c-string!]									;-- zero-terminated Latin-1 string
	][
		assert str <> null
		print-Latin1 str
		putwchar 10										;-- newline
	]

	;-------------------------------------------
	;-- Red/System Unicode replacement printing functions
	;-------------------------------------------

	prin*: func [s [c-string!] return: [c-string!] /local p][
		p: s
		while [p/1 <> null-byte][
			putwchar as-integer p/1
			p: p + 1
		]
		s
	]

	prin-int*: func [i [integer!] return: [integer!]][
		wprintf ["%^(00)i^(00)^(00)" i]								;-- UTF-16 literal string
		i
	]

	prin-hex*: func [i [integer!] return: [integer!]][
		wprintf ["%^(00)0^(00)8^(00)X^(00)^(00)" i]					;-- UTF-16 literal string
		i
	]

	prin-float*: func [f [float!] return: [float!]][
		wprintf ["^(00)%^(00).^(00)1^(00)4^(00)g^(00)^(00)" f]		;-- UTF-16 literal string
		f
	]

	prin-float32*: func [f [float32!] return: [float32!]][
		wprintf ["^(00)%^(00).^(00)7^(00)g^(00)^(00)" as-float f]	;-- UTF-16 literal string
		f
	]

	;-------------------------------------------
	;-- Do platform-specific initialization tasks
	;-------------------------------------------
	init: does [
		#if unicode? = yes [
			_setmode fd-stdout _O_U16TEXT				;@@ throw an error on failure
			_setmode fd-stderr _O_U16TEXT				;@@ throw an error on failure
		]
	]
]

Red/System [
	Title:   "Red runtime win32 API imported functions definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %win32.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/red-system/runtime/BSL-License.txt
	}
]

#define VA_COMMIT_RESERVE	3000h						;-- MEM_COMMIT | MEM_RESERVE
#define VA_PAGE_RW			04h							;-- PAGE_READWRITE
#define VA_PAGE_RWX			40h							;-- PAGE_EXECUTE_READWRITE

#define _O_TEXT        	 	4000h  						;-- file mode is text (translated)
#define _O_BINARY       	8000h  						;-- file mode is binary (untranslated)
#define _O_WTEXT        	00010000h 					;-- file mode is UTF16 (translated)
#define _O_U16TEXT      	00020000h 					;-- file mode is UTF16 no BOM (translated)
#define _O_U8TEXT       	00040000h 					;-- file mode is UTF8  no BOM (translated)

platform: context [

	#enum file-descriptors! [
		fd-stdout: 1									;@@ hardcoded, safe?
		fd-stderr: 2									;@@ hardcoded, safe?
	]

	page-size: 4096

	#import [
		LIBC-file cdecl [
			putwchar: "putwchar" [
				wchar		[integer!]					;-- wchar is 16-bit on Windows
			]
			wprintf: "wprintf" [
				[variadic]
				return: 	[integer!]
			]
			_setmode: "_setmode" [
				handle		[integer!]
				mode		[integer!]
				return:		[integer!]
			]
			;_open_osfhandle: "_open_osfhandle" [
			;	handle		[integer!]
			;	flags		[integer!]
			;	return:		[integer!]
			;]
		]
		"kernel32.dll" stdcall [
			VirtualAlloc: "VirtualAlloc" [
				address		[byte-ptr!]
				size		[integer!]
				type		[integer!]
				protection	[integer!]
				return:		[int-ptr!]
			]
			VirtualFree: "VirtualFree" [
				address 	[int-ptr!]
				size		[integer!]
				return:		[integer!]
			]
		]
	]

	;-------------------------------------------
	;-- Allocate paged virtual memory region from OS
	;-------------------------------------------
	allocate-virtual: func [
		size 	[integer!]								;-- allocated size in bytes (page size multiple)
		exec? 	[logic!]								;-- TRUE => executable region
		return: [int-ptr!]								;-- allocated memory region pointer
		/local ptr prot
	][
		prot: either exec? [VA_PAGE_RWX][VA_PAGE_RW]

		ptr: VirtualAlloc
			null
			size
			VA_COMMIT_RESERVE
			prot

		if ptr = null [
			raise-error RED_ERR_VMEM_OUT_OF_MEMORY 0
		]
		ptr
	]

	;-------------------------------------------
	;-- Free paged virtual memory region from OS
	;-------------------------------------------
	free-virtual: func [
		ptr [int-ptr!]									;-- address of memory region to release
	][
		if negative? VirtualFree ptr ptr/value [
			raise-error RED_ERR_VMEM_RELEASE_FAILED as-integer ptr
		]
	]

	;-------------------------------------------
	;-- Print a UCS-4 string to console
	;-------------------------------------------
	print-UCS4: func [
		str    [int-ptr!]								;-- zero-terminated UCS-4 string
		/local
			cp [integer!]								;-- codepoint
	][
		assert str <> null

		while [cp: str/value not zero? cp][
			either str/value > FFFFh [
				cp: cp - 00010000h						;-- encode surrogate pair
				putwchar cp >> 10 + D800h				;-- emit lead
				putwchar cp and 03FFh + DC00h			;-- emit trail
			][
				putwchar cp								;-- UCS-2 codepoint
			]
			str: str + 1
		]
	]

	;-------------------------------------------
	;-- Print a UCS-4 string to console
	;-------------------------------------------
	print-line-UCS4: func [
		str    [int-ptr!]								;-- zero-terminated UCS-4 string
		/local
			cp [integer!]								;-- codepoint
	][
		assert str <> null
		print-UCS4 str									;@@ throw an error on failure
		putwchar 10										;-- newline
	]

	;-------------------------------------------
	;-- Print a UCS-2 string to console
	;-------------------------------------------
	print-UCS2: func [
		str 	[byte-ptr!]								;-- zero-terminated UCS-2 string
		/local
			p	[byte-ptr!]
			cp	[integer!]
	][
		assert str <> null
		p: str
		while [p/1 <> null-byte][
			cp: (as-integer p/2) << 8 + p/1
			putwchar cp
			p: p + 2
		]
	]

	;-------------------------------------------
	;-- Print a UCS-2 string with newline to console
	;-------------------------------------------
	print-line-UCS2: func [
		str 	[byte-ptr!]								;-- zero-terminated UCS-2 string
	][
		assert str <> null
		print-UCS2 str									;@@ throw an error on failure
		putwchar 10										;-- newline
	]

	;-------------------------------------------
	;-- Print a Latin-1 string to console
	;-------------------------------------------
	print-Latin1: func [
		str 	[c-string!]								;-- zero-terminated Latin-1 string
		/local
			cp [integer!]								;-- codepoint
	][
		assert str <> null

		while [cp: as-integer str/1 not zero? cp][
			putwchar cp
			str: str + 1
		]
	]

	;-------------------------------------------
	;-- Print a Latin-1 string with newline to console
	;-------------------------------------------
	print-line-Latin1: func [
		str [c-string!]									;-- zero-terminated Latin-1 string
	][
		assert str <> null
		print-Latin1 str
		putwchar 10										;-- newline
	]

	;-------------------------------------------
	;-- Red/System Unicode replacement printing functions
	;-------------------------------------------

	prin*: func [s [c-string!] return: [c-string!] /local p][
		p: s
		while [p/1 <> null-byte][
			putwchar as-integer p/1
			p: p + 1
		]
		s
	]

	prin-int*: func [i [integer!] return: [integer!]][
		wprintf ["%^(00)i^(00)^(00)" i]								;-- UTF-16 literal string
		i
	]

	prin-hex*: func [i [integer!] return: [integer!]][
		wprintf ["%^(00)0^(00)8^(00)X^(00)^(00)" i]					;-- UTF-16 literal string
		i
	]

	prin-float*: func [f [float!] return: [float!]][
		wprintf ["^(00)%^(00).^(00)1^(00)4^(00)g^(00)^(00)" f]		;-- UTF-16 literal string
		f
	]

	prin-float32*: func [f [float32!] return: [float32!]][
		wprintf ["^(00)%^(00).^(00)7^(00)g^(00)^(00)" as-float f]	;-- UTF-16 literal string
		f
	]

	;-------------------------------------------
	;-- Do platform-specific initialization tasks
	;-------------------------------------------
	init: does [
		#if unicode? = yes [
			_setmode fd-stdout _O_U16TEXT				;@@ throw an error on failure
			_setmode fd-stderr _O_U16TEXT				;@@ throw an error on failure
		]
	]
]


FIX: minor correction to BSD.reds

FIX: minor correction to BSD.reds

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

#define SYSCALL_MMAP		197
#define SYSCALL_MUNMAP		73

#define SA_SIGINFO  		0040h
#define SA_RESTART   		0002h

sigaction!: alias struct! [
;	handler		[integer!]					;-- Warning: compiled as C union on most UNIX
	sigaction	[integer!]					;-- Warning: compiled as union on most UNIX
	mask		[integer!]					;-- bit array
	flags		[integer!]
]

siginfo!: alias struct! [
	signal		[integer!]
	error		[integer!]
	code		[integer!]
	pid			[integer!]
	uid			[integer!]
	status		[integer!]
	address		[integer!]					;-- this field is a C union, dependent on signal
	;... remaining fields skipped
]

#import [									;-- mandatory C bindings
	LIBC-file cdecl [
		sigaction: "sigaction" [
			signum	[integer!]
			action	[sigaction!]
			oldact	[sigaction!]
			return: [integer!]
		]
	]
]

stdin:  0
stdout: 1
stderr: 2

#if use-natives? = yes [
	prin: func [s [c-string!] return: [integer!]][
		write stdout s length? s
	]
]

;-- Catching runtime errors --

;; sources:
;;	http://fxr.watson.org/fxr/source/sys/signal.h?v=FREEBSD82
;;  http://fxr.watson.org/fxr/source/sys/signal.h?v=NETBSD5
;;	http://fxr.watson.org/fxr/source/sys/signal.h?v=OPENBSD
;;  http://fxr.watson.org/fxr/source/bsd/sys/signal.h?v=xnu-1456.1.26;im=excerpts

#define	SIGILL		 4						;-- Illegal instruction
#define SIGBUS		10						;-- Bus access error
#define	SIGFPE		 8						;-- Floating point error
#define	SIGSEGV		11						;-- Segmentation violation

#switch OS [								;@@ also CPU-dependent
	MacOSX [
		_mcontext!: alias struct! [
			trapno		[integer!]			;-- _STRUCT_X86_EXCEPTION_STATE32 inlined
			err			[integer!]
			faultvaddr	[integer!]
			eax			[integer!]			;-- _STRUCT_X86_THREAD_STATE32 inlined
			ebx			[integer!]
			ecx			[integer!]
			edx			[integer!]
			edi			[integer!]
			esi			[integer!]
			ebp			[integer!]
			esp			[integer!]
			ss			[integer!]
			eflags		[integer!]
			eip			[integer!]
			cs			[integer!]
			ds			[integer!]
			es			[integer!]
			fs			[integer!]
			gs			[integer!]
			;... _STRUCT_X86_FLOAT_STATE32 skipped
		]

		_ucontext!: alias struct! [
			onstack		[integer!]
			sigmask		[integer!]
			ss_sp		[byte-ptr!]			;-- stack_t struct inlined
			ss_size		[integer!]
			ss_flags	[integer!]
			link		[_ucontext!]
			mcsize		[integer!]
			mcontext	[_mcontext!]
		]
	]
	#default [								;-- FreeBSD definition
		_mcontext!: alias struct! [
			onstack		[integer!]
			gs			[integer!]
			fs			[integer!]
			es			[integer!]
			ds			[integer!]
			edi			[integer!]
			esi			[integer!]
			ebp			[integer!]
			isp			[integer!]
			ebx			[integer!]
			edx			[integer!]
			ecx			[integer!]
			eax			[integer!]
			trapno		[integer!]
			err			[integer!]
			eip			[integer!]
			cs			[integer!]
			eflags		[integer!]
			esp			[integer!]
			ss			[integer!]
			mc_len		[integer!]
			fpformat	[integer!]
			ownedfp		[integer!]
			;... remaining fields skipped
		]
		_ucontext!: alias struct! [
			sigmask0	[integer!]			;-- __sigset defined as an array of 4 uint32
			sigmask1	[integer!]
			sigmask2	[integer!]
			sigmask3	[integer!]
			mcontext	[_mcontext!]
			link		[_ucontext!]
			ss_sp		[byte-ptr!]			;-- stack_t struct inlined
			ss_size		[integer!]
			ss_flags	[integer!]
			flags		[integer!]
			;... remaining fields skipped
		]
	]
]

***-on-signal: func [
	[cdecl]
	signal	[integer!]
	info	[siginfo!]
	ctx		[_ucontext!]
	/local code error
][
	error: 99								;-- default unknown error
	code: info/code

	error: switch signal [
		SIGILL [
			switch code [
				1 [17]						;-- illegal opcode
				2 [25]						;-- illegal trap
				3 [15]						;-- privileged opcode
				4 [23]						;-- illegal operand
				5 [24]						;-- illegal addressing mode
				6 [31]						;-- privileged register
				7 [26]						;-- coprocessor error
				8 [19]						;-- internal stack error
			]
		]
		SIGBUS [
			switch code [
				1 [2]						;-- invalid address alignment
				2 [1]						;-- non-existant physical address
				3 [28]						;-- object specific hardware error
				4 [29]						;-- hardware memory error consumed (action required)
				5 [30]						;-- hardware memory error consumed (action optional)
			]
		]
		SIGFPE [
			switch code [
				1 [7]						;-- floating point divide by zero
				2 [10]						;-- floating point overflow
				3 [12]						;-- floating point underflow
				4 [8]						;-- floating point inexact result
				5 [9]						;-- floating point invalid operation
				6 [5]						;-- subscript out of range
				7 [13]						;-- integer divide by zero
				8 [14]						;-- integer overflow
			]
		]
		SIGSEGV [
			switch code [
				1 [1]						;-- address not mapped to object
				2 [16]						;-- invalid permissions for mapped object
			]
		]
	]

	***-on-quit error ctx/mcontext/eip
]

__sigaction-options: declare sigaction!

__sigaction-options/sigaction: 	as-integer :***-on-signal
__sigaction-options/mask: 		0
__sigaction-options/flags: 		SA_SIGINFO ;or SA_RESTART

sigaction SIGILL  __sigaction-options as sigaction! 0
sigaction SIGBUS  __sigaction-options as sigaction! 0
sigaction SIGFPE  __sigaction-options as sigaction! 0
sigaction SIGSEGV __sigaction-options as sigaction! 0

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

#define SYSCALL_MMAP		197
#define SYSCALL_MUNMAP		73

#define SA_SIGINFO  		0040h
#define SA_RESTART   		0002h

sigaction!: alias struct! [
;	handler		[integer!]					;-- Warning: compiled as C union on most UNIX
	sigaction	[integer!]					;-- Warning: compiled as union on most UNIX
	mask		[integer!]					;-- bit array
	flags		[integer!]
]

siginfo!: alias struct! [
	signal		[integer!]
	error		[integer!]
	code		[integer!]
	pid			[integer!]
	uid			[integer!]
	status		[integer!]
	address		[integer!]					;-- this field is a C union, dependent on signal
	;... remaining fields skipped
]

#import [									;-- mandatory C bindings
	LIBC-file cdecl [
		sigaction: "sigaction" [
			signum	[integer!]
			action	[sigaction!]
			oldact	[sigaction!]
			return: [integer!]
		]
	]
]

stdin:  0
stdout: 1
stderr: 2

#if use-natives? = yes [
	prin: func [s [c-string!] return: [integer!]][
		write stdout s length? s
	]
]

;-- Catching runtime errors --

;; sources:
;;	http://fxr.watson.org/fxr/source/sys/signal.h?v=FREEBSD82
;;  http://fxr.watson.org/fxr/source/sys/signal.h?v=NETBSD5
;;	http://fxr.watson.org/fxr/source/sys/signal.h?v=OPENBSD
;;  http://fxr.watson.org/fxr/source/bsd/sys/signal.h?v=xnu-1456.1.26;im=excerpts

#define	SIGILL		 4						;-- Illegal instruction
#define SIGBUS		10						;-- Bus access error
#define	SIGFPE		 8						;-- Floating point error
#define	SIGSEGV		11						;-- Segmentation violation

#switch OS [								;@@ also CPU-dependent
	MacOSX [
		_mcontext!: alias struct! [
			trapno		[integer!]			;-- _STRUCT_X86_EXCEPTION_STATE32 inlined
			err			[integer!]
			faultvaddr	[integer!]
			eax			[integer!]			;-- _STRUCT_X86_THREAD_STATE32 inlined
			ebx			[integer!]
			ecx			[integer!]
			edx			[integer!]
			edi			[integer!]
			esi			[integer!]
			ebp			[integer!]
			esp			[integer!]
			ss			[integer!]
			eflags		[integer!]
			eip			[integer!]
			cs			[integer!]
			ds			[integer!]
			es			[integer!]
			fs			[integer!]
			gs			[integer!]
			;... _STRUCT_X86_FLOAT_STATE32 skipped
		]

		_ucontext!: alias struct! [
			onstack		[integer!]
			sigmask		[integer!]
			ss_sp		[byte-ptr!]			;-- stack_t struct inlined
			ss_size		[integer!]
			ss_flags	[integer!]
			link		[_ucontext!]
			mcsize		[integer!]
			mcontext	[_mcontext!]
		]
	]
	#default [								;-- FreeBSD definition
		_mcontext!: alias struct! [
			onstack		[integer!]
			gs			[integer!]
			fs			[integer!]
			es			[integer!]
			ds			[integer!]
			edi			[integer!]
			esi			[integer!]
			ebp			[integer!]
			isp			[integer!]
			ebx			[integer!]
			edx			[integer!]
			ecx			[integer!]
			eax			[integer!]
			trapno		[integer!]
			err			[integer!]
			eip			[integer!]
			cs			[integer!]
			eflags		[integer!]
			esp			[integer!]
			ss			[integer!]
			mc_len		[integer!]
			fpformat	[integer!]
			ownedfp		[integer!]
			;... remaining fields skipped
		]
		_ucontext!: alias struct! [
			sigmask0	[integer!]			;-- __sigset defined as an array of 4 uint32
			sigmask1	[integer!]
			sigmask2	[integer!]
			sigmask3	[integer!]
			mcontext	[_mcontext!]
			link		[_ucontext!]
			ss_sp		[byte-ptr!]			;-- stack_t struct inlined
			ss_size		[integer!]
			ss_flags	[integer!]
			flags		[integer!]
			;... remaining fields skipped
		]
	]
]

***-on-signal: func [
	[cdecl]
	signal	[integer!]
	info	[siginfo!]
	ctx		[_ucontext!]
	/local code error
][
	error: 99								;-- default unknown error
	code: info/code

	error: switch signal [
		SIGILL [
			switch code [
				1 [17]						;-- illegal opcode
				2 [25]						;-- illegal trap
				3 [15]						;-- privileged opcode
				4 [23]						;-- illegal operand
				5 [24]						;-- illegal addressing mode
				6 [31]						;-- privileged register
				7 [26]						;-- coprocessor error
				8 [19]						;-- internal stack error
			]
		]
		SIGBUS [
			switch code [
				1 [2]						;-- invalid address alignment
				2 [1]						;-- non-existant physical address
				3 [28]						;-- object specific hardware error
				4 [29]						;-- hardware memory error consumed (action required)
				5 [30]						;-- hardware memory error consumed (action optional)
			]
		]
		SIGFPE [
			switch code [
				1 [7]						;-- floating point divide by zero
				2 [10]						;-- floating point overflow
				3 [12]						;-- floating point underflow
				4 [8]						;-- floating point inexact result
				5 [9]						;-- floating point invalid operation
				6 [5]						;-- subscript out of range
				7 [13]						;-- integer divide by zero
				8 [14]						;-- integer overflow
		]
		SIGSEGV [
			switch code [
				1 [1]						;-- address not mapped to object
				2 [16]						;-- invalid permissions for mapped object
			]
		]
	]

	***-on-quit error ctx/mcontext/eip
]

__sigaction-options: declare sigaction!

__sigaction-options/sigaction: 	as-integer :***-on-signal
__sigaction-options/mask: 		0
__sigaction-options/flags: 		SA_SIGINFO ;or SA_RESTART

sigaction SIGILL  __sigaction-options as sigaction! 0
sigaction SIGBUS  __sigaction-options as sigaction! 0
sigaction SIGFPE  __sigaction-options as sigaction! 0
sigaction SIGSEGV __sigaction-options as sigaction! 0