FIX: nested integer! rules could lead to wrong results in some cases.

Red/System [
	Title:   "PARSE dialect interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %parse.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

parser: context [
	verbose: 0

	#define PARSE_PUSH_POSITIONS [
		p: as positions! ALLOC_TAIL(rules)
		p/header: TYPE_TRIPLE
		p/rule:	  (as-integer cmd - block/rs-head rule) >> 4	;-- save cmd position
		p/input:  input/head									;-- save input position
	]

	#define PARSE_SET_INPUT_LENGTH(word) [
		type: TYPE_OF(input)
		word: either any [				;TBD: replace with ANY_STRING?
			type = TYPE_STRING
			type = TYPE_FILE
		][
			if over? [skip-spaces as red-string! input]
			string/rs-length? as red-string! input
		][
			block/rs-length? input
		]
	]

	#enum states! [
		ST_PUSH_BLOCK
		ST_POP_BLOCK
		ST_PUSH_RULE
		ST_POP_RULE
		ST_CHECK_PENDING
		ST_DO_ACTION
		ST_NEXT_INPUT
		ST_NEXT_ACTION
		ST_MATCH
		ST_MATCH_RULE
		ST_FIND_ALTERN
		ST_WORD
		ST_END
		ST_EXIT
	]

	#enum rule-flags! [
		R_NONE:		 -1
		R_TO:		 -2
		R_THRU:		 -3
		R_COPY:		 -4
		R_SET:		 -5
		R_NOT:		 -6
	]

	triple!: alias struct! [
		header [integer!]
		min	   [integer!]
		max	   [integer!]
		state  [integer!]
	]

	positions!: alias struct! [
		header [integer!]
		rule   [integer!]
		input  [integer!]
		pad    [integer!]
	]

	#if debug? = yes [
		print-state: func [s [integer!]][
			print "state: "
			print-line switch s [
				ST_PUSH_BLOCK	 ["ST_PUSH_BLOCK"]
				ST_POP_BLOCK	 ["ST_POP_BLOCK"]
				ST_PUSH_RULE	 ["ST_PUSH_RULE"]
				ST_POP_RULE	 	 ["ST_POP_RULE"]
				ST_CHECK_PENDING ["ST_CHECK_PENDING"]
				ST_DO_ACTION	 ["ST_DO_ACTION"]
				ST_NEXT_INPUT	 ["ST_NEXT_INPUT"]
				ST_NEXT_ACTION	 ["ST_NEXT_ACTION"]
				ST_MATCH		 ["ST_MATCH"]
				ST_MATCH_RULE	 ["ST_MATCH_RULE"]
				ST_FIND_ALTERN	 ["ST_FIND_ALTERN"]
				ST_WORD			 ["ST_WORD"]
				ST_END			 ["ST_END"]
				ST_EXIT			 ["ST_EXIT"]
			]
		]
	]

	skip-spaces: func [
		str		[red-string!]
		return:	[logic!]
		/local
			s	 [series!]
			unit [integer!]
			p	 [byte-ptr!]
			p4	 [int-ptr!]
			tail [byte-ptr!]
			cnt	 [integer!]
			c    [byte!]
	][
		s:	  GET_BUFFER(str)
		unit: GET_UNIT(s)
		p:    string/rs-head str
		tail: string/rs-tail str
		cnt: 0

		while [p < tail][							;-- jump over whitespaces
			c: as-byte switch unit [
				Latin1 [as-integer p/value]
				UCS-2  [(as-integer p/2) << 8 + p/1]
				UCS-4  [p4: as int-ptr! p p4/value]
			]
			if all [c <> #" " c <> #"^-" c <> #"^/" c <> #"^M"][
				str/head: str/head + cnt
				return no
			]
			cnt: cnt + 1
			p: p + unit
		]
		unless zero? cnt [str/head: str/head + cnt]
		yes
	]

	advance: func [
		str		[red-string!]
		value	[red-value!]							;-- char! or string! value
		over?	[logic!]
		return:	[logic!]
		/local
			end? [logic!]
	][
		end?: either TYPE_OF(value) = TYPE_CHAR [
			string/rs-next str
		][
			assert TYPE_OF(value) = TYPE_STRING
			string/rs-skip str string/rs-length? as red-string! value
		]
		if over? [end?: skip-spaces str]
		end?
	]

	find-altern: func [									;-- search for next '| symbol
		rule	[red-block!]
		pos		[red-value!]
		return: [integer!]								;-- >= 0 found, -1 not found
		/local
			head  [red-value!]
			tail  [red-value!]
			value [red-value!]
			w	  [red-word!]
	][
		s: GET_BUFFER(rule)
		head:  s/offset + ((as-integer pos - s/offset) >> 4)
		tail:  s/tail
		value: head

		while [value < tail][
			if TYPE_OF(value) = TYPE_WORD [
				w: as red-word! value
				if w/symbol = words/pipe [
					return ((as-integer value - head) >> 4)
				]
			]
			value: value + 1
		]
		-1
	]

	adjust-input-index: func [
		input	[red-series!]
		pos		[positions!]
		base    [integer!]
		offset  [integer!]
		return: [logic!]
	][
		input/head: input/head + base + offset
		pos/input: either zero? input/head [0][input/head - base]
		yes
	]

	find-token?: func [									;-- optimized fast token lookup
		rules	[red-block!]							;-- (could be optimized even further)
		input	[red-series!]
		token	[red-value!]
		return: [logic!]
		/local
			pos	  [positions!]
			head  [red-value!]
			tail  [red-value!]
			value [red-value!]
			char  [red-char!]
			s	  [series!]
			p	  [byte-ptr!]
			phead [byte-ptr!]
			ptail [byte-ptr!]
			p4	  [int-ptr!]
			cp	  [integer!]
			size  [integer!]
			unit  [integer!]
			type  [integer!]
	][
		s: GET_BUFFER(rules)
		pos: as positions! s/tail - 2

		type: TYPE_OF(input)
		either any [									;TBD: replace with ANY_STRING + TYPE_BINARY
			type = TYPE_STRING
			type = TYPE_FILE
			type = TYPE_BINARY
		][
			switch TYPE_OF(token) [
				TYPE_STRING
				TYPE_FILE
				TYPE_BINARY [
					size: string/rs-length? as red-string! token
					if (string/rs-length? as red-string! input) < size [return no]

					s: GET_BUFFER(input)
					unit: (GET_UNIT(s) >> 1)

					until [
						if string/equal? as red-string! input as red-string! token COMP_EQUAL yes [
							return adjust-input-index input pos size 0
						]
						input/head: input/head + 1
						(as byte-ptr! s/offset) + (input/head + size << unit) = as byte-ptr! s/tail
					]
				]
				TYPE_CHAR [
					char: as red-char! token
					cp: char/value

					s: GET_BUFFER(input)
					unit: GET_UNIT(s)
					phead: (as byte-ptr! s/offset) + (input/head << (unit >> 1))
					ptail: as byte-ptr! s/tail
					p: phead

					switch unit [
						Latin1 [
							while [p < ptail][
								if p/value = as-byte cp [
									return adjust-input-index input pos 1 (as-integer p - phead)
								]
								p: p + 1
							]
						]
						UCS-2 [
							while [p < ptail][
								if (as-integer p/2) << 8 + p/1 = cp [
									return adjust-input-index input pos 1 ((as-integer p - phead) >> 1)
								]
								p: p + 2
							]
						]
						UCS-4 [
							p4: as int-ptr! p
							while [p4 < as int-ptr! ptail][
								if p4/value = cp [
									return adjust-input-index input pos 1 ((as-integer p4 - phead) >> 2)
								]
								p4: p4 + 1
							]
						]
					]
				]
				default [
					print-line "*** Parse Error: invalid literal value to match on string"
				]
			]
		][
			head:  block/rs-head input
			tail:  block/rs-tail input
			value: head

			while [value < tail][
				if actions/compare value token COMP_EQUAL [
					return adjust-input-index input pos 1 ((as-integer value - head) >> 4)
				]
				value: value + 1
			]
		]
		no
	]

	loop-token: func [
		input	[red-series!]
		token	[red-value!]
		min		[integer!]
		max		[integer!]
		counter [int-ptr!]
		over?	[logic!]
		return: [logic!]
		/local
			len	   [integer!]
			cnt	   [integer!]
			type   [integer!]
			match? [logic!]
			end?   [logic!]
	][
		PARSE_SET_INPUT_LENGTH(len)
		if len < min [return no]						;-- input too short

		either TYPE_OF(token)= TYPE_BITSET [
			--NOT_IMPLEMENTED--
		][												;-- fast literal matching loop
			cnt: 0
			either any [								;TBD: replace with ANY_STRING
				type = TYPE_STRING
				type = TYPE_FILE
			][
				until [									;-- ANY-STRING input matching
					match?: string/match? as red-string! input token COMP_EQUAL
					end?: all [match? advance as red-string! input token over?]	;-- consume matched input
					cnt: cnt + 1
					any [
						not match?
						end?
						all [max <> R_NONE cnt >= max]
					]
				]
			][
				until [									;-- ANY-BLOCK input matching
					match?:	actions/compare block/rs-head input token COMP_EQUAL	;@@ sub-optimal!!
					end?: all [match? block/rs-next input]	;-- consume matched input
					cnt: cnt + 1
					any [
						not match?
						end?
						all [max <> R_NONE cnt >= max]
					]
				]
			]
			unless match? [
				cnt: cnt - 1
				match?: either max = R_NONE [min <= cnt][all [min <= cnt cnt <= max]]
			]
			counter/value: cnt
		]
		match?
	]

	do-rule: func [
		job		[red-block!]
		rule	[red-block!]
		over?	[logic!]
		case?	[logic!]
		return: [logic!]
		/local
			input  [red-series!]
			new	   [red-series!]
			series [red-block!]
			rules  [red-block!]
			int	   [red-integer!]
			int2   [red-integer!]
			cmd	   [red-value!]
			tail   [red-value!]
			value  [red-value!]
			char   [red-char!]
			dt	   [red-datatype!]
			w	   [red-word!]
			t 	   [triple!]
			p	   [positions!]
			state  [integer!]
			type   [integer!]
			sym	   [integer!]
			min	   [integer!]
			max	   [integer!]
			s	   [series!]
			cnt	   [integer!]
			upper? [logic!]
			end?   [logic!]
			match? [logic!]
			below? [logic!]
			loop?  [logic!]
			pop?   [logic!]
	][
		int: as red-integer! block/rs-head job
		state:  int/value
		match?: yes
		end?:   no
		value:	null
		type:	-1
		min:	-1
		max:	-1
		cnt:	 0

		series: as red-block! int + 1
		rules:  as red-block! int + 2
		input:  as red-series! block/rs-head series

		cmd: (block/rs-head rule) - 1					;-- decrement to compensate for starting increment
		tail: block/rs-tail rule						;TBD: protect current rule block from changes

		until [
			#if debug? = yes [if verbose > 0 [print-state state]]

			switch state [
				ST_PUSH_BLOCK [
					none/rs-push rules
					PARSE_PUSH_POSITIONS
					block/rs-append rules as red-value! rule
					copy-cell value as red-value! rule
					cmd:  block/rs-head rule
					tail: block/rs-tail rule			;TBD: protect current rule block from changes
					value: cmd
					state: either cmd = tail [ST_POP_BLOCK][ST_DO_ACTION]
				]
				ST_POP_BLOCK [
					either zero? block/rs-length? rules [
						state: ST_END
					][
						loop?: no
						s: GET_BUFFER(rules)
						copy-cell s/tail - 1 as red-value! rule
						assert TYPE_OF(rule) = TYPE_BLOCK
						p: as positions! s/tail - 2
						cmd: (block/rs-head rule) + p/rule
						tail: block/rs-tail rule
						s/tail: s/tail - 3

						state: either zero? block/rs-length? rules [
							either match? [ST_NEXT_ACTION][ST_END]
						][
							value: s/tail - 1
							either TYPE_OF(value) = TYPE_INTEGER [ST_POP_RULE][ST_NEXT_ACTION]
						]
					]
				]
				ST_PUSH_RULE [
					either any [type = R_COPY type = R_SET][
						block/rs-append rules cmd
					][
						t: as triple! ALLOC_TAIL(rules)
						t/header: TYPE_TRIPLE
						t/min:	  min
						t/max:	  max
						t/state:  1
					]
					PARSE_PUSH_POSITIONS
					int: as red-integer! ALLOC_TAIL(rules)
					int/header: TYPE_INTEGER
					int/value: type
					state: ST_MATCH_RULE
				]
				ST_POP_RULE [
					s: GET_BUFFER(rules)
					value: s/tail - 1

					either any [
						s/offset + rules/head = s/tail	;-- rules stack empty already
						TYPE_OF(value) = TYPE_BLOCK
					][
						state: ST_NEXT_ACTION
					][
						pop?: yes
						p: as positions! s/tail - 2
						int: as red-integer! value
						switch int/value [
							R_COPY [
								if match? [
									w: as red-word!  s/tail - 3
									new: as red-series! value
									copy-cell as red-value! input as red-value! new
									new/head: p/input
									actions/copy new as red-value! input no null
									_context/set w as red-value! new
								]
							]
							R_SET [
								if match? [
									w: as red-word! p - 1
									type: TYPE_OF(input)
									either any [		;TBD: replace with ANY_STRING
										type = TYPE_STRING
										type = TYPE_FILE
									][
										char: as red-char! value
										char/header: TYPE_CHAR
										char/value: string/rs-abs-at as red-string! input p/input
									][
										value: block/rs-abs-at input p/input
									]
									_context/set w value
								]
							]
							R_TO
							R_THRU [
								either match? [
									if int/value = R_TO [
										input/head: p/input	;-- move input before the last match
										end?: no
									]
								][
									type: TYPE_OF(input)
									either any [		;TBD: replace with ANY_STRING?
										type = TYPE_STRING
										type = TYPE_FILE
									][
										string/rs-next as red-string! input
									][
										block/rs-next input
									]
									p/input: input/head	;-- refresh saved input head before new iteration
									cmd: (block/rs-head rule) + p/rule ;-- loop rule
									state: ST_NEXT_ACTION
									pop?: no
								]
							]
							R_NOT [
								match?: not match?
							]
							default [
								t: as triple! s/tail - 3
								cnt: t/state
								below?: cnt < t/min
								loop?: either t/max = R_NONE [match?][cnt < t/max]
								t/state: cnt + 1
								unless match? [match?: any [t/min <= cnt zero? t/min]]

								either any [end? not loop?][
									if all [match? below?][match?: no]
								][
									cmd: (block/rs-head rule) + p/rule ;-- loop rule
									state: ST_NEXT_ACTION
									pop?: no
								]
							]
						]
						if pop? [
							s/tail: s/tail - 3	;-- pop rule stack frame
							value:  s/tail - 1
							state:  ST_CHECK_PENDING
						]
					]
				]
				ST_CHECK_PENDING [
					state: either any [		;-- order of conditional expressions matters!
						zero? block/rs-length? rules
						TYPE_OF(value) <> TYPE_INTEGER
					][
						either match? [ST_NEXT_ACTION][ST_FIND_ALTERN]
					][
						ST_POP_RULE
					]
				]
				ST_DO_ACTION [
					type: TYPE_OF(value)				;-- value is used in this state instead of cmd
					switch type [						;-- allows to enter the state with cmd or :cmd (if word!)
						TYPE_WORD 	[
							if all [value <> cmd TYPE_OF(cmd) = TYPE_WORD][
								print-line "*** Parse Error: invalid word in rule"
								halt
							]
							state: ST_WORD
						]
						TYPE_BLOCK 	[
							state: ST_PUSH_BLOCK
						]
						TYPE_DATATYPE [
							dt: as red-datatype! value
							value: block/rs-head input
							match?: TYPE_OF(value) = dt/value
							state: either match? [ST_NEXT_INPUT][ST_FIND_ALTERN]
						]
						TYPE_BITSET [
							--NOT_IMPLEMENTED--
						]
						TYPE_SET_WORD [
							_context/set as red-word! value as red-value! input
							state: ST_NEXT_ACTION
						]
						TYPE_GET_WORD [
							new: as red-series! _context/get as red-word! value
							either all [
								TYPE_OF(new) = TYPE_OF(input)
								new/node = input/node
							][
								input/head: new/head
								state: ST_NEXT_ACTION
							][
								print-line "*** Parse Error: get-word refers to a different series!"
							]
						]
						TYPE_INTEGER [
							int:  as red-integer! value
							int2: as red-integer! cmd + 1
							if all [
								int2 < tail
								TYPE_OF(int2) = TYPE_WORD
							][
								int2: as red-integer! _context/get as red-word! cmd + 1
							]
							upper?: TYPE_OF(int2) = TYPE_INTEGER
							if any [
								int2 = tail
								all [upper?	int2 + 1 = tail]
								all [upper? int/value > int2/value]
							][
								print-line "*** Parse Error: invalid integer rule"
							]
							min:   int/value
							max:   either upper? [cmd: cmd + 1 int2/value][min]
							type:  1
							state: ST_PUSH_RULE

						]
						TYPE_PAREN [
							interpreter/eval as red-block! value
							state: ST_NEXT_ACTION
						]
						default [						;-- try to match a literal value
							state: ST_MATCH
						]
					]
				]
				ST_NEXT_INPUT [
					type: TYPE_OF(input)
					end?: either any [					;TBD: replace with ANY_STRING
						type = TYPE_STRING
						type = TYPE_FILE
					][
						string/rs-next as red-string! input
					][
						block/rs-next input
					]
					s: GET_BUFFER(rules)
					value: s/tail - 1
					state: ST_CHECK_PENDING
				]
				ST_NEXT_ACTION [
					if cmd < tail [cmd: cmd + 1]

					state: either cmd = tail [
						either zero? block/rs-length? rules [ST_END][ST_POP_BLOCK]
					][
						value: cmd
						ST_DO_ACTION
					]
				]
				ST_MATCH [
					either end? [
						state: ST_POP_BLOCK
					][
						type: TYPE_OF(input)
						end?: either any [				;TBD: replace with ANY_STRING?
							type = TYPE_STRING
							type = TYPE_FILE
						][
							match?: string/match? as red-string! input value COMP_EQUAL
							all [match? advance as red-string! input value over?]	;-- consume matched input
						][
							match?: actions/compare block/rs-head input value COMP_EQUAL
							all [match? block/rs-next input]				;-- consume matched input
						]
						s: GET_BUFFER(rules)
						value: s/tail - 1
						state:	ST_CHECK_PENDING
					]
				]
				ST_MATCH_RULE [
					if cmd < tail [cmd: cmd + 1]		;-- move after the rule prologue

					either all [cmd = tail][
						state: either zero? block/rs-length? rules [ST_END][ST_POP_BLOCK]
					][
						switch TYPE_OF(cmd) [
							TYPE_BLOCK [
								value: cmd
								state: ST_PUSH_BLOCK
							]
							TYPE_WORD [
								state: ST_WORD
							]
							TYPE_INTEGER [
								value: cmd
								state: ST_DO_ACTION
							]
							default [
								either min = R_NONE [
									either any [type = R_TO type = R_THRU][
										match?: find-token? rules input cmd
										state: ST_POP_RULE
									][
										value: cmd
										state: ST_DO_ACTION
									]
								][
									match?: loop-token input cmd min max :cnt over?

									s: GET_BUFFER(rules)
									s/tail: s/tail - 3		;-- pop rule stack frame
									value: s/tail - 1
									state: ST_CHECK_PENDING
								]
								PARSE_SET_INPUT_LENGTH(cnt)
								end?: zero? cnt
							]
						]
					]
				]
				ST_FIND_ALTERN [
					cnt: find-altern rule cmd

					state: either cnt >= 0 [
						cmd: cmd + cnt	;-- point rule head to alternative part
						ST_NEXT_ACTION
					][
						match?: no						;@@ useless line?
						ST_POP_BLOCK
					]
				]
				ST_WORD [
					w: as red-word! cmd
					sym: symbol/resolve w/symbol
					case [								;TBD: order the words by decreasing usage frequency
						sym = words/pipe [				;-- |
							state: ST_POP_BLOCK
						]
						sym = words/skip [				;-- SKIP
							match?: not end?
							state: ST_NEXT_INPUT
						]
						sym = words/any* [				;-- ANY
							min:   0
							max:   R_NONE
							type:  R_NONE
							state: ST_PUSH_RULE
						]
						sym = words/break* [			;-- BREAK
							match?: yes
							state: ST_POP_BLOCK
						]
						sym = words/copy [				;-- COPY
							cmd: cmd + 1
							if any [cmd = tail TYPE_OF(cmd) <> TYPE_WORD][
								print-line "*** Parse Error: invalid COPY rule"
							]
							type:  R_COPY
							state: ST_PUSH_RULE
						]
						sym = words/end [				;-- END
							PARSE_SET_INPUT_LENGTH(cnt)
							match?: zero? cnt
							state: ST_POP_RULE
						]
						sym = words/fail [				;-- FAIL
							match?: no
							state: ST_FIND_ALTERN
						]
						sym = words/into [				;-- INTO
							if TYPE_OF(input) <> TYPE_BLOCK [
								print-line "*** Parse Error: INTO can only be used on a block! value"
							]
							cmd: cmd + 1
							if any [
								cmd = tail
								TYPE_OF(cmd) <> TYPE_BLOCK
							][
								print-line "*** Parse Error: INTO invalid argument"
							]
							input: block/rs-append series as red-value! block/rs-head input
							value: cmd
							state: ST_PUSH_BLOCK
						]
						sym = words/opt [				;-- OPT
							min:   0
							max:   1
							type:  1
							state: ST_PUSH_RULE
						]
						sym = words/not* [				;-- NOT
							type:  R_NOT
							state: ST_PUSH_RULE
						]
						sym = words/quote [				;-- QUOTE
							cmd: cmd + 1
							if cmd = tail [
								print-line "*** Parse Error: missing QUOTE argument"
							]
							value: cmd
							state: ST_MATCH
						]
						sym = words/reject [			;-- REJECT
							match?: no
							state: ST_POP_BLOCK
						]
						sym = words/set [				;-- SET
							cmd: cmd + 1
							if any [cmd = tail TYPE_OF(cmd) <> TYPE_WORD][
								print-line "*** Parse Error: invalid COPY rule"
							]
							type:  R_SET
							state: ST_PUSH_RULE
						]
						sym = words/some [				;-- SOME
							min:   1
							max:   R_NONE
							type:  R_NONE
							state: ST_PUSH_RULE
						]
						sym = words/thru [				;-- THRU
							type:  R_THRU
							state: ST_PUSH_RULE
						]
						sym = words/to [				;-- TO
							type:  R_TO
							state: ST_PUSH_RULE
						]
						sym = words/none [				;-- NONE
							match?: yes
							state: ST_CHECK_PENDING
						]
						true [
							value: _context/get w
							state: ST_DO_ACTION
						]
					]
				]
				ST_END [
					if match? [match?: cmd = tail]

					PARSE_SET_INPUT_LENGTH(cnt)
					if any [
						cnt > 0
						1 < block/rs-length? series
					][
						match?: no
					]

					either 1 = block/rs-length? series [
						state: ST_EXIT
					][
						s: GET_BUFFER(series)
						input: as red-series! s/tail - 1
						s/tail: s/tail - 1
						state: ST_NEXT_ACTION
					]
				]
			]
			state = ST_EXIT
		]
		match?
	]

	process: func [
		input [red-series!]
		rule  [red-block!]
		over? [logic!]
		case? [logic!]
		;strict? [logic!]
		return: [logic!]
		/local
			job    [red-block!]
			series [red-block!]
	][
		job: block/push* 3
		integer/load-in job ST_NEXT_ACTION			;-- pos 1: state
		series: block/make-in job 8					;-- pos 2: input stack block @@TBD: alloc statically
		block/make-in job 32						;-- pos 3: rule stack block  @@TBD: alloc statically

		input: block/rs-append series as red-value! input	;-- input now points to the series stack entry

		if all [
			over?
			any [									;TBD: replace with ANY_STRING
				TYPE_OF(input) = TYPE_STRING
				TYPE_OF(input) = TYPE_FILE
			]
		][
			skip-spaces as red-string! input
		]

		do-rule job rule over? case?
	]
]

Red/System [
	Title:   "PARSE dialect interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %parse.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

parser: context [
	verbose: 0

	#define PARSE_PUSH_POSITIONS [
		p: as positions! ALLOC_TAIL(rules)
		p/header: TYPE_TRIPLE
		p/rule:	  (as-integer cmd - block/rs-head rule) >> 4	;-- save cmd position
		p/input:  input/head									;-- save input position
	]

	#define PARSE_SET_INPUT_LENGTH(word) [
		type: TYPE_OF(input)
		word: either any [				;TBD: replace with ANY_STRING?
			type = TYPE_STRING
			type = TYPE_FILE
		][
			if over? [skip-spaces as red-string! input]
			string/rs-length? as red-string! input
		][
			block/rs-length? input
		]
	]

	#enum states! [
		ST_PUSH_BLOCK
		ST_POP_BLOCK
		ST_PUSH_RULE
		ST_POP_RULE
		ST_CHECK_PENDING
		ST_DO_ACTION
		ST_NEXT_INPUT
		ST_NEXT_ACTION
		ST_MATCH
		ST_MATCH_RULE
		ST_FIND_ALTERN
		ST_WORD
		ST_END
		ST_EXIT
	]

	#enum rule-flags! [
		R_NONE:		 -1
		R_TO:		 -2
		R_THRU:		 -3
		R_COPY:		 -4
		R_SET:		 -5
		R_NOT:		 -6
	]

	triple!: alias struct! [
		header [integer!]
		min	   [integer!]
		max	   [integer!]
		state  [integer!]
	]

	positions!: alias struct! [
		header [integer!]
		rule   [integer!]
		input  [integer!]
		pad    [integer!]
	]

	#if debug? = yes [
		print-state: func [s [integer!]][
			print "state: "
			print-line switch s [
				ST_PUSH_BLOCK	 ["ST_PUSH_BLOCK"]
				ST_POP_BLOCK	 ["ST_POP_BLOCK"]
				ST_PUSH_RULE	 ["ST_PUSH_RULE"]
				ST_POP_RULE	 	 ["ST_POP_RULE"]
				ST_CHECK_PENDING ["ST_CHECK_PENDING"]
				ST_DO_ACTION	 ["ST_DO_ACTION"]
				ST_NEXT_INPUT	 ["ST_NEXT_INPUT"]
				ST_NEXT_ACTION	 ["ST_NEXT_ACTION"]
				ST_MATCH		 ["ST_MATCH"]
				ST_MATCH_RULE	 ["ST_MATCH_RULE"]
				ST_FIND_ALTERN	 ["ST_FIND_ALTERN"]
				ST_WORD			 ["ST_WORD"]
				ST_END			 ["ST_END"]
				ST_EXIT			 ["ST_EXIT"]
			]
		]
	]

	skip-spaces: func [
		str		[red-string!]
		return:	[logic!]
		/local
			s	 [series!]
			unit [integer!]
			p	 [byte-ptr!]
			p4	 [int-ptr!]
			tail [byte-ptr!]
			cnt	 [integer!]
			c    [byte!]
	][
		s:	  GET_BUFFER(str)
		unit: GET_UNIT(s)
		p:    string/rs-head str
		tail: string/rs-tail str
		cnt: 0

		while [p < tail][							;-- jump over whitespaces
			c: as-byte switch unit [
				Latin1 [as-integer p/value]
				UCS-2  [(as-integer p/2) << 8 + p/1]
				UCS-4  [p4: as int-ptr! p p4/value]
			]
			if all [c <> #" " c <> #"^-" c <> #"^/" c <> #"^M"][
				str/head: str/head + cnt
				return no
			]
			cnt: cnt + 1
			p: p + unit
		]
		unless zero? cnt [str/head: str/head + cnt]
		yes
	]

	advance: func [
		str		[red-string!]
		value	[red-value!]							;-- char! or string! value
		over?	[logic!]
		return:	[logic!]
		/local
			end? [logic!]
	][
		end?: either TYPE_OF(value) = TYPE_CHAR [
			string/rs-next str
		][
			assert TYPE_OF(value) = TYPE_STRING
			string/rs-skip str string/rs-length? as red-string! value
		]
		if over? [end?: skip-spaces str]
		end?
	]

	find-altern: func [									;-- search for next '| symbol
		rule	[red-block!]
		pos		[red-value!]
		return: [integer!]								;-- >= 0 found, -1 not found
		/local
			head  [red-value!]
			tail  [red-value!]
			value [red-value!]
			w	  [red-word!]
	][
		s: GET_BUFFER(rule)
		head:  s/offset + ((as-integer pos - s/offset) >> 4)
		tail:  s/tail
		value: head

		while [value < tail][
			if TYPE_OF(value) = TYPE_WORD [
				w: as red-word! value
				if w/symbol = words/pipe [
					return ((as-integer value - head) >> 4)
				]
			]
			value: value + 1
		]
		-1
	]

	adjust-input-index: func [
		input	[red-series!]
		pos		[positions!]
		base    [integer!]
		offset  [integer!]
		return: [logic!]
	][
		input/head: input/head + base + offset
		pos/input: either zero? input/head [0][input/head - base]
		yes
	]

	find-token?: func [									;-- optimized fast token lookup
		rules	[red-block!]							;-- (could be optimized even further)
		input	[red-series!]
		token	[red-value!]
		return: [logic!]
		/local
			pos	  [positions!]
			head  [red-value!]
			tail  [red-value!]
			value [red-value!]
			char  [red-char!]
			s	  [series!]
			p	  [byte-ptr!]
			phead [byte-ptr!]
			ptail [byte-ptr!]
			p4	  [int-ptr!]
			cp	  [integer!]
			size  [integer!]
			unit  [integer!]
			type  [integer!]
	][
		s: GET_BUFFER(rules)
		pos: as positions! s/tail - 2

		type: TYPE_OF(input)
		either any [									;TBD: replace with ANY_STRING + TYPE_BINARY
			type = TYPE_STRING
			type = TYPE_FILE
			type = TYPE_BINARY
		][
			switch TYPE_OF(token) [
				TYPE_STRING
				TYPE_FILE
				TYPE_BINARY [
					size: string/rs-length? as red-string! token
					if (string/rs-length? as red-string! input) < size [return no]

					s: GET_BUFFER(input)
					unit: (GET_UNIT(s) >> 1)

					until [
						if string/equal? as red-string! input as red-string! token COMP_EQUAL yes [
							return adjust-input-index input pos size 0
						]
						input/head: input/head + 1
						(as byte-ptr! s/offset) + (input/head + size << unit) = as byte-ptr! s/tail
					]
				]
				TYPE_CHAR [
					char: as red-char! token
					cp: char/value

					s: GET_BUFFER(input)
					unit: GET_UNIT(s)
					phead: (as byte-ptr! s/offset) + (input/head << (unit >> 1))
					ptail: as byte-ptr! s/tail
					p: phead

					switch unit [
						Latin1 [
							while [p < ptail][
								if p/value = as-byte cp [
									return adjust-input-index input pos 1 (as-integer p - phead)
								]
								p: p + 1
							]
						]
						UCS-2 [
							while [p < ptail][
								if (as-integer p/2) << 8 + p/1 = cp [
									return adjust-input-index input pos 1 ((as-integer p - phead) >> 1)
								]
								p: p + 2
							]
						]
						UCS-4 [
							p4: as int-ptr! p
							while [p4 < as int-ptr! ptail][
								if p4/value = cp [
									return adjust-input-index input pos 1 ((as-integer p4 - phead) >> 2)
								]
								p4: p4 + 1
							]
						]
					]
				]
				default [
					print-line "*** Parse Error: invalid literal value to match on string"
				]
			]
		][
			head:  block/rs-head input
			tail:  block/rs-tail input
			value: head

			while [value < tail][
				if actions/compare value token COMP_EQUAL [
					return adjust-input-index input pos 1 ((as-integer value - head) >> 4)
				]
				value: value + 1
			]
		]
		no
	]

	loop-token: func [
		input	[red-series!]
		token	[red-value!]
		min		[integer!]
		max		[integer!]
		counter [int-ptr!]
		over?	[logic!]
		return: [logic!]
		/local
			len	   [integer!]
			cnt	   [integer!]
			type   [integer!]
			match? [logic!]
			end?   [logic!]
	][
		PARSE_SET_INPUT_LENGTH(len)
		if len < min [return no]						;-- input too short

		either TYPE_OF(token)= TYPE_BITSET [
			--NOT_IMPLEMENTED--
		][												;-- fast literal matching loop
			cnt: 0
			either any [								;TBD: replace with ANY_STRING
				type = TYPE_STRING
				type = TYPE_FILE
			][
				until [									;-- ANY-STRING input matching
					match?: string/match? as red-string! input token COMP_EQUAL
					end?: all [match? advance as red-string! input token over?]	;-- consume matched input
					cnt: cnt + 1
					any [
						not match?
						end?
						all [max <> R_NONE cnt >= max]
					]
				]
			][
				until [									;-- ANY-BLOCK input matching
					match?:	actions/compare block/rs-head input token COMP_EQUAL	;@@ sub-optimal!!
					end?: all [match? block/rs-next input]	;-- consume matched input
					cnt: cnt + 1
					any [
						not match?
						end?
						all [max <> R_NONE cnt >= max]
					]
				]
			]
			unless match? [
				cnt: cnt - 1
				match?: either max = R_NONE [min <= cnt][all [min <= cnt cnt <= max]]
			]
			counter/value: cnt
		]
		match?
	]

	do-rule: func [
		job		[red-block!]
		rule	[red-block!]
		over?	[logic!]
		case?	[logic!]
		return: [logic!]
		/local
			input  [red-series!]
			new	   [red-series!]
			series [red-block!]
			rules  [red-block!]
			int	   [red-integer!]
			int2   [red-integer!]
			cmd	   [red-value!]
			tail   [red-value!]
			value  [red-value!]
			char   [red-char!]
			dt	   [red-datatype!]
			w	   [red-word!]
			t 	   [triple!]
			p	   [positions!]
			state  [integer!]
			type   [integer!]
			sym	   [integer!]
			min	   [integer!]
			max	   [integer!]
			s	   [series!]
			cnt	   [integer!]
			upper? [logic!]
			end?   [logic!]
			match? [logic!]
			below? [logic!]
			loop?  [logic!]
			pop?   [logic!]
	][
		int: as red-integer! block/rs-head job
		state:  int/value
		match?: yes
		end?:   no
		value:	null
		type:	-1
		min:	-1
		max:	-1
		cnt:	 0

		series: as red-block! int + 1
		rules:  as red-block! int + 2
		input:  as red-series! block/rs-head series

		cmd: (block/rs-head rule) - 1					;-- decrement to compensate for starting increment
		tail: block/rs-tail rule						;TBD: protect current rule block from changes

		until [
			#if debug? = yes [if verbose > 0 [print-state state]]

			switch state [
				ST_PUSH_BLOCK [
					none/rs-push rules
					PARSE_PUSH_POSITIONS
					block/rs-append rules as red-value! rule
					copy-cell value as red-value! rule
					cmd:  block/rs-head rule
					tail: block/rs-tail rule			;TBD: protect current rule block from changes
					value: cmd
					state: either cmd = tail [ST_POP_BLOCK][ST_DO_ACTION]
				]
				ST_POP_BLOCK [
					either zero? block/rs-length? rules [
						state: ST_END
					][
						loop?: no
						s: GET_BUFFER(rules)
						copy-cell s/tail - 1 as red-value! rule
						assert TYPE_OF(rule) = TYPE_BLOCK
						p: as positions! s/tail - 2
						cmd: (block/rs-head rule) + p/rule
						tail: block/rs-tail rule
						s/tail: s/tail - 3

						state: either zero? block/rs-length? rules [
							either match? [ST_NEXT_ACTION][ST_END]
						][
							value: s/tail - 1
							either TYPE_OF(value) = TYPE_INTEGER [ST_POP_RULE][ST_NEXT_ACTION]
						]
					]
				]
				ST_PUSH_RULE [
					either any [type = R_COPY type = R_SET][
						block/rs-append rules cmd
					][
						t: as triple! ALLOC_TAIL(rules)
						t/header: TYPE_TRIPLE
						t/min:	  min
						t/max:	  max
						t/state:  1
					]
					PARSE_PUSH_POSITIONS
					int: as red-integer! ALLOC_TAIL(rules)
					int/header: TYPE_INTEGER
					int/value: type
					state: ST_MATCH_RULE
				]
				ST_POP_RULE [
					s: GET_BUFFER(rules)
					value: s/tail - 1

					either any [
						s/offset + rules/head = s/tail	;-- rules stack empty already
						TYPE_OF(value) = TYPE_BLOCK
					][
						state: ST_NEXT_ACTION
					][
						pop?: yes
						p: as positions! s/tail - 2
						int: as red-integer! value
						switch int/value [
							R_COPY [
								if match? [
									w: as red-word!  s/tail - 3
									new: as red-series! value
									copy-cell as red-value! input as red-value! new
									new/head: p/input
									actions/copy new as red-value! input no null
									_context/set w as red-value! new
								]
							]
							R_SET [
								if match? [
									w: as red-word! p - 1
									type: TYPE_OF(input)
									either any [		;TBD: replace with ANY_STRING
										type = TYPE_STRING
										type = TYPE_FILE
									][
										char: as red-char! value
										char/header: TYPE_CHAR
										char/value: string/rs-abs-at as red-string! input p/input
									][
										value: block/rs-abs-at input p/input
									]
									_context/set w value
								]
							]
							R_TO
							R_THRU [
								either match? [
									if int/value = R_TO [
										input/head: p/input	;-- move input before the last match
										end?: no
									]
								][
									type: TYPE_OF(input)
									either any [		;TBD: replace with ANY_STRING?
										type = TYPE_STRING
										type = TYPE_FILE
									][
										string/rs-next as red-string! input
									][
										block/rs-next input
									]
									p/input: input/head	;-- refresh saved input head before new iteration
									cmd: (block/rs-head rule) + p/rule ;-- loop rule
									state: ST_NEXT_ACTION
									pop?: no
								]
							]
							R_NOT [
								match?: not match?
							]
							default [
								t: as triple! s/tail - 3
								cnt: t/state
								below?: cnt < t/min
								loop?: either t/max = R_NONE [match?][cnt < t/max]
								t/state: cnt + 1
								unless match? [match?: any [t/min <= cnt zero? t/min]]

								either any [end? not loop?][
									if all [match? below?][match?: no]
								][
									cmd: (block/rs-head rule) + p/rule ;-- loop rule
									state: ST_NEXT_ACTION
									pop?: no
								]
							]
						]
						if pop? [
							s/tail: s/tail - 3	;-- pop rule stack frame
							value:  s/tail - 1
							state:  ST_CHECK_PENDING
						]
					]
				]
				ST_CHECK_PENDING [
					state: either any [		;-- order of conditional expressions matters!
						zero? block/rs-length? rules
						TYPE_OF(value) <> TYPE_INTEGER
					][
						either match? [ST_NEXT_ACTION][ST_FIND_ALTERN]
					][
						ST_POP_RULE
					]
				]
				ST_DO_ACTION [
					type: TYPE_OF(value)				;-- value is used in this state instead of cmd
					switch type [						;-- allows to enter the state with cmd or :cmd (if word!)
						TYPE_WORD 	[
							if all [value <> cmd TYPE_OF(cmd) = TYPE_WORD][
								print-line "*** Parse Error: invalid word in rule"
								halt
							]
							state: ST_WORD
						]
						TYPE_BLOCK 	[
							state: ST_PUSH_BLOCK
						]
						TYPE_DATATYPE [
							dt: as red-datatype! value
							value: block/rs-head input
							match?: TYPE_OF(value) = dt/value
							state: either match? [ST_NEXT_INPUT][ST_FIND_ALTERN]
						]
						TYPE_BITSET [
							--NOT_IMPLEMENTED--
						]
						TYPE_SET_WORD [
							_context/set as red-word! value as red-value! input
							state: ST_NEXT_ACTION
						]
						TYPE_GET_WORD [
							new: as red-series! _context/get as red-word! value
							either all [
								TYPE_OF(new) = TYPE_OF(input)
								new/node = input/node
							][
								input/head: new/head
								state: ST_NEXT_ACTION
							][
								print-line "*** Parse Error: get-word refers to a different series!"
							]
						]
						TYPE_INTEGER [
							int:  as red-integer! value
							int2: as red-integer! cmd + 1
							if all [
								int2 < tail
								TYPE_OF(int2) = TYPE_WORD
							][
								int2: as red-integer! _context/get as red-word! cmd + 1
							]
							upper?: TYPE_OF(int2) = TYPE_INTEGER
							if any [
								int2 = tail
								all [upper?	int2 + 1 = tail]
								all [upper? int/value > int2/value]
							][
								print-line "*** Parse Error: invalid integer rule"
							]
							min:   int/value
							max:   either upper? [cmd: cmd + 1 int2/value][min]
							type:  1
							state: ST_PUSH_RULE

						]
						TYPE_PAREN [
							interpreter/eval as red-block! value
							state: ST_NEXT_ACTION
						]
						default [						;-- try to match a literal value
							state: ST_MATCH
						]
					]
				]
				ST_NEXT_INPUT [
					type: TYPE_OF(input)
					end?: either any [					;TBD: replace with ANY_STRING
						type = TYPE_STRING
						type = TYPE_FILE
					][
						string/rs-next as red-string! input
					][
						block/rs-next input
					]
					s: GET_BUFFER(rules)
					value: s/tail - 1
					state: ST_CHECK_PENDING
				]
				ST_NEXT_ACTION [
					if cmd < tail [cmd: cmd + 1]

					state: either cmd = tail [
						either zero? block/rs-length? rules [ST_END][ST_POP_BLOCK]
					][
						value: cmd
						ST_DO_ACTION
					]
				]
				ST_MATCH [
					either end? [
						state: ST_POP_BLOCK
					][
						type: TYPE_OF(input)
						end?: either any [				;TBD: replace with ANY_STRING?
							type = TYPE_STRING
							type = TYPE_FILE
						][
							match?: string/match? as red-string! input value COMP_EQUAL
							all [match? advance as red-string! input value over?]	;-- consume matched input
						][
							match?: actions/compare block/rs-head input value COMP_EQUAL
							all [match? block/rs-next input]				;-- consume matched input
						]
						s: GET_BUFFER(rules)
						value: s/tail - 1
						state:	ST_CHECK_PENDING
					]
				]
				ST_MATCH_RULE [
					if cmd < tail [cmd: cmd + 1]		;-- move after the rule prologue

					either all [cmd = tail][
						state: either zero? block/rs-length? rules [ST_END][ST_POP_BLOCK]
					][
						switch TYPE_OF(cmd) [
							TYPE_BLOCK [
								value: cmd
								state: ST_PUSH_BLOCK
							]
							TYPE_WORD [
								state: ST_WORD
							]
							default [
								either min = R_NONE [
									either any [type = R_TO type = R_THRU][
										match?: find-token? rules input cmd
										state: ST_POP_RULE
									][
										value: cmd
										state: ST_DO_ACTION
									]
								][
									match?: loop-token input cmd min max :cnt over?

									s: GET_BUFFER(rules)
									s/tail: s/tail - 3		;-- pop rule stack frame
									value: s/tail - 1
									state: ST_CHECK_PENDING
								]
								PARSE_SET_INPUT_LENGTH(cnt)
								end?: zero? cnt
							]
						]
					]
				]
				ST_FIND_ALTERN [
					cnt: find-altern rule cmd

					state: either cnt >= 0 [
						cmd: cmd + cnt	;-- point rule head to alternative part
						ST_NEXT_ACTION
					][
						match?: no						;@@ useless line?
						ST_POP_BLOCK
					]
				]
				ST_WORD [
					w: as red-word! cmd
					sym: symbol/resolve w/symbol
					case [								;TBD: order the words by decreasing usage frequency
						sym = words/pipe [				;-- |
							state: ST_POP_BLOCK
						]
						sym = words/skip [				;-- SKIP
							match?: not end?
							state: ST_NEXT_INPUT
						]
						sym = words/any* [				;-- ANY
							min:   0
							max:   R_NONE
							type:  R_NONE
							state: ST_PUSH_RULE
						]
						sym = words/break* [			;-- BREAK
							match?: yes
							state: ST_POP_BLOCK
						]
						sym = words/copy [				;-- COPY
							cmd: cmd + 1
							if any [cmd = tail TYPE_OF(cmd) <> TYPE_WORD][
								print-line "*** Parse Error: invalid COPY rule"
							]
							type:  R_COPY
							state: ST_PUSH_RULE
						]
						sym = words/end [				;-- END
							PARSE_SET_INPUT_LENGTH(cnt)
							match?: zero? cnt
							state: ST_POP_RULE
						]
						sym = words/fail [				;-- FAIL
							match?: no
							state: ST_FIND_ALTERN
						]
						sym = words/into [				;-- INTO
							if TYPE_OF(input) <> TYPE_BLOCK [
								print-line "*** Parse Error: INTO can only be used on a block! value"
							]
							cmd: cmd + 1
							if any [
								cmd = tail
								TYPE_OF(cmd) <> TYPE_BLOCK
							][
								print-line "*** Parse Error: INTO invalid argument"
							]
							input: block/rs-append series as red-value! block/rs-head input
							value: cmd
							state: ST_PUSH_BLOCK
						]
						sym = words/opt [				;-- OPT
							min:   0
							max:   1
							type:  1
							state: ST_PUSH_RULE
						]
						sym = words/not* [				;-- NOT
							type:  R_NOT
							state: ST_PUSH_RULE
						]
						sym = words/quote [				;-- QUOTE
							cmd: cmd + 1
							if cmd = tail [
								print-line "*** Parse Error: missing QUOTE argument"
							]
							value: cmd
							state: ST_MATCH
						]
						sym = words/reject [			;-- REJECT
							match?: no
							state: ST_POP_BLOCK
						]
						sym = words/set [				;-- SET
							cmd: cmd + 1
							if any [cmd = tail TYPE_OF(cmd) <> TYPE_WORD][
								print-line "*** Parse Error: invalid COPY rule"
							]
							type:  R_SET
							state: ST_PUSH_RULE
						]
						sym = words/some [				;-- SOME
							min:   1
							max:   R_NONE
							type:  R_NONE
							state: ST_PUSH_RULE
						]
						sym = words/thru [				;-- THRU
							type:  R_THRU
							state: ST_PUSH_RULE
						]
						sym = words/to [				;-- TO
							type:  R_TO
							state: ST_PUSH_RULE
						]
						sym = words/none [				;-- NONE
							match?: yes
							state: ST_CHECK_PENDING
						]
						true [
							value: _context/get w
							state: ST_DO_ACTION
						]
					]
				]
				ST_END [
					if match? [match?: cmd = tail]

					PARSE_SET_INPUT_LENGTH(cnt)
					if any [
						cnt > 0
						1 < block/rs-length? series
					][
						match?: no
					]

					either 1 = block/rs-length? series [
						state: ST_EXIT
					][
						s: GET_BUFFER(series)
						input: as red-series! s/tail - 1
						s/tail: s/tail - 1
						state: ST_NEXT_ACTION
					]
				]
			]
			state = ST_EXIT
		]
		match?
	]

	process: func [
		input [red-series!]
		rule  [red-block!]
		over? [logic!]
		case? [logic!]
		;strict? [logic!]
		return: [logic!]
		/local
			job    [red-block!]
			series [red-block!]
	][
		job: block/push* 3
		integer/load-in job ST_NEXT_ACTION			;-- pos 1: state
		series: block/make-in job 8					;-- pos 2: input stack block @@TBD: alloc statically
		block/make-in job 32						;-- pos 3: rule stack block  @@TBD: alloc statically

		input: block/rs-append series as red-value! input	;-- input now points to the series stack entry

		if all [
			over?
			any [									;TBD: replace with ANY_STRING
				TYPE_OF(input) = TYPE_STRING
				TYPE_OF(input) = TYPE_FILE
			]
		][
			skip-spaces as red-string! input
		]

		do-rule job rule over? case?
	]
]


FEAT: modifying win32 print functions to use buffer which improves output to console significantly (as originaly it's printing chars one by one)

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)

#define GENERIC_WRITE		40000000h
#define GENERIC_READ 		80000000h
#define FILE_SHARE_READ		00000001h
#define FILE_SHARE_WRITE	00000002h
#define OPEN_EXISTING		00000003h

#define WEOF				FFFFh

platform: context [

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

	page-size: 4096
	confd: -2

	buffer: allocate  1024
	pbuffer: buffer ;this stores buffer's head position

	#import [
		LIBC-file cdecl [
			;putwchar: "putwchar" [
			;	wchar		[integer!]					;-- wchar is 16-bit on Windows
			;]
			wprintf: "wprintf" [
				[variadic]
				return: 	[integer!]
			]
			fflush: "fflush" [
				fd			[integer!]
				return:		[integer!]
			]
			_setmode: "_setmode" [
				handle		[integer!]
				mode		[integer!]
				return:		[integer!]
			]
			_get_osfhandle: "_get_osfhandle" [
				fd			[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!]
			]
			WriteFile: "WriteFile" [
				handle			[integer!]
				buffer			[c-string!]
				len				[integer!]
				written			[int-ptr!]
				overlapped		[integer!]
				return:			[integer!]
			]
			GetConsoleMode:	"GetConsoleMode" [
				handle			[integer!]
				mode			[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
		]
	]

	;-------------------------------------------
	;-- Initialize console ouput handle
	;-------------------------------------------
	init-console-out: func [][
		confd: simple-io/CreateFile
					"CONOUT$"
					GENERIC_WRITE
					FILE_SHARE_READ or FILE_SHARE_WRITE
					null
					OPEN_EXISTING
					0
					null
	]

	;-------------------------------------------
	;-- putwchar use windows api internal
	;-------------------------------------------
	putwchar: func [
		wchar	[integer!]								;-- wchar is 16-bit on Windows
		return:	[integer!]
		/local
			n	[integer!]
			cr	[integer!]
			con	[integer!]
	][
		n: 0
		cr: as integer! #"^M"

		con: GetConsoleMode _get_osfhandle fd-stdout :n		;-- test if output is a console
		either con > 0 [									;-- output to console
			if confd = -2 [init-console-out]
			if confd = -1 [return WEOF]
			WriteConsole confd (as byte-ptr! :wchar) 1 :n null
		][													;-- output to redirection file
			if wchar = as integer! #"^/" [					;-- convert lf to crlf
				WriteFile _get_osfhandle fd-stdout (as c-string! :cr) 2 :n 0
			]
			WriteFile _get_osfhandle fd-stdout (as c-string! :wchar) 2 :n 0
		]
		wchar
	]

	;-------------------------------------------
	;-- putbuffer use windows api internal
	;-------------------------------------------
	putbuffer: func [
		chars [integer!]
		return: [integer!]
		/local
			n	[integer!]
			con	[integer!]
	][
		n: 0
		con: GetConsoleMode _get_osfhandle fd-stdout :n		;-- test if output is a console
		either con > 0 [									;-- output to console
			if confd = -2 [init-console-out]
			if confd = -1 [return WEOF]
			WriteConsole confd pbuffer chars :n null
		][													;-- output to redirection file
			WriteFile _get_osfhandle fd-stdout as c-string! pbuffer 2 * chars :n 0
		]
		buffer: pbuffer
		chars
	]
	;-------------------------------------------
	;-- 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
			b1    [byte!]
			b2    [byte!]
			chars [integer!]
	][
		assert str <> null
		chars: 0
		while [
			b1: str/1
			b2: str/2
			((as-integer b2) << 8 + b1) <> 0
		][
			buffer/1: b1
			buffer/2: b2
			chars: chars + 1
			buffer: buffer + 2
			str: str + 2
			if chars = 512 [  ; if the buffer has 1024 bytes, it has room for 512 chars
				putbuffer chars
				chars: 0
			]
		]
		putbuffer chars
	]

	;-------------------------------------------
	;-- 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
		buffer/1: #"^M"
		buffer/2: null-byte
		buffer/3: #"^/"
		buffer/4: null-byte
		putbuffer 2 									;-- newline
	]

	;-------------------------------------------
	;-- Print a Latin-1 string to console
	;-------------------------------------------
	print-Latin1: func [
		str 	[c-string!]								;-- zero-terminated Latin-1 string
		/local
			cp    [byte!]							    ;-- codepoint
			chars [integer!]							;-- mumber of used chars in buffer
	][
		assert str <> null
		chars: 0
		while [cp: str/1  cp <> null-byte][
			buffer/1: cp
			buffer/2: null-byte ;this should be always 0 in Latin1
			str: str + 1
			chars: chars + 1
			buffer: buffer + 2
			if chars = 512 [  ; if the buffer has 1024 bytes, it has room for 512 chars
				putbuffer chars
				chars: 0
			]
		]
		putbuffer chars
	]

	;-------------------------------------------
	;-- 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
		buffer/1: #"^M"
		buffer/2: null-byte
		buffer/3: #"^/"
		buffer/4: null-byte
		putbuffer 2 									;-- 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
		fflush null													;-- flush all streams
		i
	]

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

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

	prin-float32*: func [f [float32!] return: [float32!]][
		wprintf ["%^(00).^(00)7^(00)g^(00)^(00)" as-float f]	;-- UTF-16 literal string
		fflush null
		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)

#define GENERIC_WRITE		40000000h
#define GENERIC_READ 		80000000h
#define FILE_SHARE_READ		00000001h
#define FILE_SHARE_WRITE	00000002h
#define OPEN_EXISTING		00000003h

#define WEOF				FFFFh

platform: context [

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

	page-size: 4096
	confd: -2

	#import [
		LIBC-file cdecl [
			;putwchar: "putwchar" [
			;	wchar		[integer!]					;-- wchar is 16-bit on Windows
			;]
			wprintf: "wprintf" [
				[variadic]
				return: 	[integer!]
			]
			fflush: "fflush" [
				fd			[integer!]
				return:		[integer!]
			]
			_setmode: "_setmode" [
				handle		[integer!]
				mode		[integer!]
				return:		[integer!]
			]
			_get_osfhandle: "_get_osfhandle" [
				fd			[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!]
			]
			WriteFile: "WriteFile" [
				handle			[integer!]
				buffer			[c-string!]
				len				[integer!]
				written			[int-ptr!]
				overlapped		[integer!]
				return:			[integer!]
			]
			GetConsoleMode:	"GetConsoleMode" [
				handle			[integer!]
				mode			[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
		]
	]

	;-------------------------------------------
	;-- Initialize console ouput handle
	;-------------------------------------------
	init-console-out: func [][
		confd: simple-io/CreateFile
					"CONOUT$"
					GENERIC_WRITE
					FILE_SHARE_READ or FILE_SHARE_WRITE
					null
					OPEN_EXISTING
					0
					null
	]

	;-------------------------------------------
	;-- putwchar use windows api internal
	;-------------------------------------------
	putwchar: func [
		wchar	[integer!]								;-- wchar is 16-bit on Windows
		return:	[integer!]
		/local
			n	[integer!]
			cr	[integer!]
			con	[integer!]
	][
		n: 0
		cr: as integer! #"^M"

		con: GetConsoleMode _get_osfhandle fd-stdout :n		;-- test if output is a console
		either con > 0 [									;-- output to console
			if confd = -2 [init-console-out]
			if confd = -1 [return WEOF]
			WriteConsole confd (as byte-ptr! :wchar) 1 :n null
		][													;-- output to redirection file
			if wchar = as integer! #"^/" [					;-- convert lf to crlf
				WriteFile _get_osfhandle fd-stdout (as c-string! :cr) 2 :n 0
			]
			WriteFile _get_osfhandle fd-stdout (as c-string! :wchar) 2 :n 0
		]
		wchar
	]

	;-------------------------------------------
	;-- 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 [
			cp: (as-integer p/2) << 8 + p/1
			cp <> 0
		][
			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
		fflush null													;-- flush all streams
		i
	]

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

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

	prin-float32*: func [f [float32!] return: [float32!]][
		wprintf ["%^(00).^(00)7^(00)g^(00)^(00)" as-float f]	;-- UTF-16 literal string
		fflush null
		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
		]
	]
]


FEAT: adds missing RANDOM action in pair! datatype.

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

pair: context [
	verbose: 0

	do-math: func [
		type	  [integer!]
		return:	  [red-pair!]
		/local
			left  [red-pair!]
			right [red-pair!]
			int	  [red-integer!]
			x	  [integer!]
			y	  [integer!]
	][
		left: as red-pair! stack/arguments
		right: left + 1

		assert TYPE_OF(left) = TYPE_PAIR
		assert any [
			TYPE_OF(right) = TYPE_PAIR
			TYPE_OF(right) = TYPE_INTEGER
		]

		switch TYPE_OF(right) [
			TYPE_PAIR 	 [
				x: right/x
				y: right/y
			]
			TYPE_INTEGER [
				int: as red-integer! right
				x: int/value
				y: x
			]
			default [
				print-line "*** Math Error: unsupported right operand for pair operation"
			]
		]

		switch type [
			OP_ADD [left/x: left/x + x  left/y: left/y + y]
			OP_SUB [left/x: left/x - x  left/y: left/y - y]
			OP_MUL [left/x: left/x * x  left/y: left/y * y]
			OP_DIV [left/x: left/x / x  left/y: left/y / y]
			OP_REM [left/x: left/x % x  left/y: left/y % y]
			OP_AND [left/x: left/x and x  left/y: left/y and y]
			OP_OR  [left/x: left/x or  x  left/y: left/y or  y]
			OP_XOR [left/x: left/x xor x  left/y: left/y xor y]
		]
		left
	]

	make-in: func [
		parent 	[red-block!]
		x 		[integer!]
		y 		[integer!]
		/local
			pair [red-pair!]
	][
		#if debug? = yes [if verbose > 0 [print-line "pair/make-in"]]

		pair: as red-pair! ALLOC_TAIL(parent)
		pair/header: TYPE_PAIR
		pair/x: x
		pair/y: y
	]

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

		pair: as red-pair! stack/push*
		pair/header: TYPE_PAIR
		pair/x: value
		pair/y: value2
		pair
	]

	;-- Actions --

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

		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				int: as red-integer! spec
				push int/value int/value
			]
			default [
				int: as red-integer! block/rs-head as red-block! spec
				int2: int + 1
				if any [
					2 <> block/rs-length? as red-block! spec
					TYPE_OF(int)  <> TYPE_INTEGER
					TYPE_OF(int2) <> TYPE_INTEGER
				][
					print-line "*** MAKE Error: pair expects a block with two integers"
				]
				push int/value int2/value
			]
		]
	]

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

		either seed? [
			_random/srand pair/x xor pair/y
			pair/header: TYPE_UNSET
		][
			n: _random/rand % pair/x + 1
			pair/x: either negative? pair/x [0 - n][n]
			n: _random/rand % pair/y + 1
			pair/y: either negative? pair/y [0 - n][n]
		]
		as red-value! pair
	]

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

		formed: integer/form-signed pair/x
		string/concatenate-literal buffer formed
		part: part - length? formed						;@@ optimize by removing length?

		string/append-char GET_BUFFER(buffer) as-integer #"x"

		formed: integer/form-signed pair/y
		string/concatenate-literal buffer formed
		part - 1 - length? formed						;@@ optimize by removing length?
	]

	mold: func [
		pair	[red-pair!]
		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 "pair/mold"]]

		form pair buffer arg part
	]

	eval-path: func [
		parent	[red-pair!]								;-- implicit type casting
		element	[red-value!]
		value	[red-value!]
		path	[red-value!]
		case?	[logic!]
		return:	[red-value!]
		/local
			int	 [red-integer!]
			w	 [red-word!]
			axis [integer!]
	][
		switch TYPE_OF(element) [
			TYPE_INTEGER [
				int: as red-integer! element
				axis: int/value
				if all [axis <> 1 axis <> 2][
					fire [TO_ERROR(script invalid-path) stack/arguments element]
				]
			]
			TYPE_WORD [
				w: as red-word! element
				axis: symbol/resolve w/symbol
				if all [axis <> words/x axis <> words/y][
					fire [TO_ERROR(script invalid-path) stack/arguments element]
				]
				axis: either axis = words/x [1][2]
			]
			default [
				fire [TO_ERROR(script invalid-path) stack/arguments element]
			]
		]
		either value <> null [
			int: as red-integer! stack/arguments
			either axis = 1 [parent/x: int/value][parent/y: int/value]
			as red-value! int
		][
			integer/push either axis = 1 [parent/x][parent/y]
		]
	]

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

		diff: left/y - right/y
		if zero? diff [diff: left/x - right/x]
		SIGN_COMPARE_RESULT(diff 0)
	]

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

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

		pair: as red-pair! stack/arguments
		pair/x: integer/abs pair/x
		pair/y: integer/abs pair/y
		pair
	]

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

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

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

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

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

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

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

	negate: func [
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/value: 0 - int/value
		int 											;-- re-use argument slot for return value
	]

	pick: func [
		pair	[red-pair!]
		index	[integer!]
		boxed	[red-value!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "pair/pick"]]

		if all [index <> 1 index <> 2][fire [TO_ERROR(script out-of-range) boxed]]
		as red-value! integer/push either index = 1 [pair/x][pair/y]
	]

	reverse: func [
		pair	[red-pair!]
		part	[red-value!]
		return:	[red-value!]
		/local
			tmp [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "pair/reverse"]]

		tmp: pair/x
		pair/x: pair/y
		pair/y: tmp
		as red-value! pair
	]

	init: does [
		datatype/register [
			TYPE_PAIR
			TYPE_VALUE
			"pair!"
			;-- General actions --
			:make
			:random
			null			;reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			:absolute
			:add
			:divide
			:multiply
			: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
			null			;length?
			null			;next
			:pick
			null			;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:   "Pair! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %pair.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
	}
]

pair: context [
	verbose: 0

	do-math: func [
		type	  [integer!]
		return:	  [red-pair!]
		/local
			left  [red-pair!]
			right [red-pair!]
			int	  [red-integer!]
			x	  [integer!]
			y	  [integer!]
	][
		left: as red-pair! stack/arguments
		right: left + 1

		assert TYPE_OF(left) = TYPE_PAIR
		assert any [
			TYPE_OF(right) = TYPE_PAIR
			TYPE_OF(right) = TYPE_INTEGER
		]

		switch TYPE_OF(right) [
			TYPE_PAIR 	 [
				x: right/x
				y: right/y
			]
			TYPE_INTEGER [
				int: as red-integer! right
				x: int/value
				y: x
			]
			default [
				print-line "*** Math Error: unsupported right operand for pair operation"
			]
		]

		switch type [
			OP_ADD [left/x: left/x + x  left/y: left/y + y]
			OP_SUB [left/x: left/x - x  left/y: left/y - y]
			OP_MUL [left/x: left/x * x  left/y: left/y * y]
			OP_DIV [left/x: left/x / x  left/y: left/y / y]
			OP_REM [left/x: left/x % x  left/y: left/y % y]
			OP_AND [left/x: left/x and x  left/y: left/y and y]
			OP_OR  [left/x: left/x or  x  left/y: left/y or  y]
			OP_XOR [left/x: left/x xor x  left/y: left/y xor y]
		]
		left
	]

	make-in: func [
		parent 	[red-block!]
		x 		[integer!]
		y 		[integer!]
		/local
			pair [red-pair!]
	][
		#if debug? = yes [if verbose > 0 [print-line "pair/make-in"]]

		pair: as red-pair! ALLOC_TAIL(parent)
		pair/header: TYPE_PAIR
		pair/x: x
		pair/y: y
	]

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

		pair: as red-pair! stack/push*
		pair/header: TYPE_PAIR
		pair/x: value
		pair/y: value2
		pair
	]

	;-- Actions --

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

		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				int: as red-integer! spec
				push int/value int/value
			]
			default [
				int: as red-integer! block/rs-head as red-block! spec
				int2: int + 1
				if any [
					2 <> block/rs-length? as red-block! spec
					TYPE_OF(int)  <> TYPE_INTEGER
					TYPE_OF(int2) <> TYPE_INTEGER
				][
					print-line "*** MAKE Error: pair expects a block with two integers"
				]
				push int/value int2/value
			]
		]
	]

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

		formed: integer/form-signed pair/x
		string/concatenate-literal buffer formed
		part: part - length? formed						;@@ optimize by removing length?

		string/append-char GET_BUFFER(buffer) as-integer #"x"

		formed: integer/form-signed pair/y
		string/concatenate-literal buffer formed
		part - 1 - length? formed						;@@ optimize by removing length?
	]

	mold: func [
		pair	[red-pair!]
		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 "pair/mold"]]

		form pair buffer arg part
	]

	eval-path: func [
		parent	[red-pair!]								;-- implicit type casting
		element	[red-value!]
		value	[red-value!]
		path	[red-value!]
		case?	[logic!]
		return:	[red-value!]
		/local
			int	 [red-integer!]
			w	 [red-word!]
			axis [integer!]
	][
		switch TYPE_OF(element) [
			TYPE_INTEGER [
				int: as red-integer! element
				axis: int/value
				if all [axis <> 1 axis <> 2][
					fire [TO_ERROR(script invalid-path) stack/arguments element]
				]
			]
			TYPE_WORD [
				w: as red-word! element
				axis: symbol/resolve w/symbol
				if all [axis <> words/x axis <> words/y][
					fire [TO_ERROR(script invalid-path) stack/arguments element]
				]
				axis: either axis = words/x [1][2]
			]
			default [
				fire [TO_ERROR(script invalid-path) stack/arguments element]
			]
		]
		either value <> null [
			int: as red-integer! stack/arguments
			either axis = 1 [parent/x: int/value][parent/y: int/value]
			as red-value! int
		][
			integer/push either axis = 1 [parent/x][parent/y]
		]
	]

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

		diff: left/y - right/y
		if zero? diff [diff: left/x - right/x]
		SIGN_COMPARE_RESULT(diff 0)
	]

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

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

		pair: as red-pair! stack/arguments
		pair/x: integer/abs pair/x
		pair/y: integer/abs pair/y
		pair
	]

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

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

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

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

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

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

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

	negate: func [
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/value: 0 - int/value
		int 											;-- re-use argument slot for return value
	]

	pick: func [
		pair	[red-pair!]
		index	[integer!]
		boxed	[red-value!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "pair/pick"]]

		if all [index <> 1 index <> 2][fire [TO_ERROR(script out-of-range) boxed]]
		as red-value! integer/push either index = 1 [pair/x][pair/y]
	]

	reverse: func [
		pair	[red-pair!]
		part	[red-value!]
		return:	[red-value!]
		/local
			tmp [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "pair/reverse"]]

		tmp: pair/x
		pair/x: pair/y
		pair/y: tmp
		as red-value! pair
	]

	init: does [
		datatype/register [
			TYPE_PAIR
			TYPE_VALUE
			"pair!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			:absolute
			:add
			:divide
			:multiply
			: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
			null			;length?
			null			;next
			:pick
			null			;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: reverted commenting an infix function test, this one is valid.

Red/System [
	Title:   "Red/System null test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %namespace-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.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
  --test-- "ns13"
    ns13i: 1
    ns13i-nsp: context [
      ns13i: 2
      get-ns13i: func [return: [integer!]] [ns13i]
    ]
  --assert 2 = ns13i-nsp/get-ns13i

===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-- "nsm1"
  --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-- "nmp3"
    nmsp6a: context [
      i: 67890
      get-addr-i: func [
        return: [pointer! [integer!]]
      ][
        :i
      ]
    ]
    pinmp3: declare pointer! [integer!]
    pinmp3: nmsp6a/get-addr-i
  --assert 67890 = pinmp3/value

===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/nmsp7-1/i
          nmsp7-3: context [
            i: 3
            j: i * nmsp7/i
            k: i * nmsp7/nmsp7-1/i
            l: i * nmsp7/nmsp7-1/nmsp7-2/i
          ]
          --assert i = 2
          --assert j = 0
          --assert k = 2
		  --assert nmsp7/i = 0
		  --assert nmsp7/nmsp7-1/i = 1
		  --assert nmsp7/nmsp7-1/j = 0
        ]
        --assert i = 1
        --assert j = 0
        --assert nmsp7/i = 0
      ]
      --assert i = 0
    ]
  --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

  --test-- "nmm2"
	  red: context [
		c: context [set: func [return: [integer!]][1] ]
		w: context [d: func [return: [integer!]][c/set] ]
	  ]
  --assert red/w/d = 1

===end-group===

===start-group=== "include"
  --test-- "nminc1"
    nmsp8: context [
      #include %namespace-test-include.reds
    ]
  --assert 54321 = nmsp8/i

===end-group===

===start-group=== "libs"
    nmsp-lib: context [
      #import [
        LIBM-file cdecl [
          abs-int: "abs" [
            i       [integer!]
            return: [integer!]
          ]
        ]
      ]
      #import [
        LIBC-file cdecl [
          strlen: "strlen" [
            str     [c-string!]
            return: [integer!]
          ]
        ]
      ]
    ]
  --test-- "nmlibs1"
  --assert 1 = nmsp-lib/abs-int -1
  --test-- "nmlibs2"
  --assert 11 = nmsp-lib/strlen "hello world"

===end-group===

===start-group=== "cross-reference"

	nmxr1: context [c: 789 fooo: func [][nmxr2/e: 123]]
	nmxr2: context [e: 456 f: nmxr1/c]

  --test-- "ns-cross-1"
	--assert nmxr2/e = 456
	nmxr1/fooo
	--assert nmxr2/e = 123

  --test-- "ns-cross-2"
	--assert nmxr2/f = 789

===end-group===

===start-group=== "with"
  --test-- "nsw1"
    nsw1-nsp: context [b: 123]
    with nsw1-nsp [
      --assert b = 123
    ]

  --test-- "nsw2"
    nsw2-nsp1: context [b: 123]
    nsw2-nsp2: context [b: 456]
    with [nsw2-nsp1 nsw2-nsp2] [
      --assert b = 456
      --assert nsw2-nsp1/b = 123
      --assert nsw2-nsp2/b = 456
    ]

  --test-- "nsw3"
    nsw3-nsp1: context [z: declare pointer! [integer!] fooo: func [][nsw3-nsp2/e: 123]]
    nsw3-nsp2: context [e: 456]

    with nsw3-nsp1 [
      c: 123
      z: null
    ]
	--assert nsw3-nsp1/z = null

	  e: -1
	  with [nsw3-nsp1 nsw3-nsp2][
	    fooo
	    --assert e = 123
	  ]
	--assert e = -1

	--test-- "nsw4"
    nsw4-nsp1: context [e: 456]
    nsw4-nsp2: context [fooo: func [][e: 123]]
    with [nsw4-nsp1 nsw4-nsp2] [
      fooo
      --assert e = 456
    ]

===end-group===

===start-group=== "System/Words"

  --test-- "nssw1"
    nssw1-a: 1
    nssw1-nmsp: context [
      nssw1-a: 2
      --assert 1 = system/words/nssw1-a
      --assert 2 = nssw1-a
      system/words/nssw1-a: 3
    ]
  --assert nssw1-a = 3

  --test-- "nssw2"
    nssw2-i: 1
    nssw2-nmsp: context [
      nssw2-i: 2
      pi: declare pointer! [integer!]
      pi: :nssw2-i
      --assert pi/value = 2
    ]
  --assert nssw2-i = 1

===end-group===

===start-group=== "context as local variable"

  --test-- "nscasv2"
    nsca2-f: function [
      return: [integer!]
      /local
        context
    ][
      context: 1
      context
    ]
  --assert nsca2-f = 1

===end-group===

===start-group=== "accessing alias from context"

  --test-- "nsaa2 - issue #238"
    nssa2-c: context [
      s!: alias struct! [val [integer!]]
      s: declare s!
      s/val: 200
    ]

    with nssa2-c [
      nssa2-f: function [
        p [s!]
        return: [integer!]
      ][
        p/val
      ]
    ]
  --assert 200 = nssa2-f nssa2-c/s

===end-group===

===start-group=== "inline functions in namespace"

    --test-- "ifin1 - issue 285"
      ifin-func: func [i [integer!] return: [integer!]][i]
      ifin-nsp: context [
        f: func [[infix] a [integer!] b [integer!] return: [integer!]][a + b]
        i: ifin-func 1 f 2
      ]
    --assert 3 = ifin-nsp/i

===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System null test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %namespace-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.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
  --test-- "ns13"
    ns13i: 1
    ns13i-nsp: context [
      ns13i: 2
      get-ns13i: func [return: [integer!]] [ns13i]
    ]
  --assert 2 = ns13i-nsp/get-ns13i

===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-- "nsm1"
  --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-- "nmp3"
    nmsp6a: context [
      i: 67890
      get-addr-i: func [
        return: [pointer! [integer!]]
      ][
        :i
      ]
    ]
    pinmp3: declare pointer! [integer!]
    pinmp3: nmsp6a/get-addr-i
  --assert 67890 = pinmp3/value

===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/nmsp7-1/i
          nmsp7-3: context [
            i: 3
            j: i * nmsp7/i
            k: i * nmsp7/nmsp7-1/i
            l: i * nmsp7/nmsp7-1/nmsp7-2/i
          ]
          --assert i = 2
          --assert j = 0
          --assert k = 2
		  --assert nmsp7/i = 0
		  --assert nmsp7/nmsp7-1/i = 1
		  --assert nmsp7/nmsp7-1/j = 0
        ]
        --assert i = 1
        --assert j = 0
        --assert nmsp7/i = 0
      ]
      --assert i = 0
    ]
  --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

  --test-- "nmm2"
	  red: context [
		c: context [set: func [return: [integer!]][1] ]
		w: context [d: func [return: [integer!]][c/set] ]
	  ]
  --assert red/w/d = 1

===end-group===

===start-group=== "include"
  --test-- "nminc1"
    nmsp8: context [
      #include %namespace-test-include.reds
    ]
  --assert 54321 = nmsp8/i

===end-group===

===start-group=== "libs"
    nmsp-lib: context [
      #import [
        LIBM-file cdecl [
          abs-int: "abs" [
            i       [integer!]
            return: [integer!]
          ]
        ]
      ]
      #import [
        LIBC-file cdecl [
          strlen: "strlen" [
            str     [c-string!]
            return: [integer!]
          ]
        ]
      ]
    ]
  --test-- "nmlibs1"
  --assert 1 = nmsp-lib/abs-int -1
  --test-- "nmlibs2"
  --assert 11 = nmsp-lib/strlen "hello world"

===end-group===

===start-group=== "cross-reference"

	nmxr1: context [c: 789 fooo: func [][nmxr2/e: 123]]
	nmxr2: context [e: 456 f: nmxr1/c]

  --test-- "ns-cross-1"
	--assert nmxr2/e = 456
	nmxr1/fooo
	--assert nmxr2/e = 123

  --test-- "ns-cross-2"
	--assert nmxr2/f = 789

===end-group===

===start-group=== "with"
  --test-- "nsw1"
    nsw1-nsp: context [b: 123]
    with nsw1-nsp [
      --assert b = 123
    ]

  --test-- "nsw2"
    nsw2-nsp1: context [b: 123]
    nsw2-nsp2: context [b: 456]
    with [nsw2-nsp1 nsw2-nsp2] [
      --assert b = 456
      --assert nsw2-nsp1/b = 123
      --assert nsw2-nsp2/b = 456
    ]

  --test-- "nsw3"
    nsw3-nsp1: context [z: declare pointer! [integer!] fooo: func [][nsw3-nsp2/e: 123]]
    nsw3-nsp2: context [e: 456]

    with nsw3-nsp1 [
      c: 123
      z: null
    ]
	--assert nsw3-nsp1/z = null

	  e: -1
	  with [nsw3-nsp1 nsw3-nsp2][
	    fooo
	    --assert e = 123
	  ]
	--assert e = -1

	--test-- "nsw4"
    nsw4-nsp1: context [e: 456]
    nsw4-nsp2: context [fooo: func [][e: 123]]
    with [nsw4-nsp1 nsw4-nsp2] [
      fooo
      --assert e = 456
    ]

===end-group===

===start-group=== "System/Words"

  --test-- "nssw1"
    nssw1-a: 1
    nssw1-nmsp: context [
      nssw1-a: 2
      --assert 1 = system/words/nssw1-a
      --assert 2 = nssw1-a
      system/words/nssw1-a: 3
    ]
  --assert nssw1-a = 3

  --test-- "nssw2"
    nssw2-i: 1
    nssw2-nmsp: context [
      nssw2-i: 2
      pi: declare pointer! [integer!]
      pi: :nssw2-i
      --assert pi/value = 2
    ]
  --assert nssw2-i = 1

===end-group===

===start-group=== "context as local variable"

  --test-- "nscasv2"
    nsca2-f: function [
      return: [integer!]
      /local
        context
    ][
      context: 1
      context
    ]
  --assert nsca2-f = 1

===end-group===

===start-group=== "accessing alias from context"

  --test-- "nsaa2 - issue #238"
    nssa2-c: context [
      s!: alias struct! [val [integer!]]
      s: declare s!
      s/val: 200
    ]

    with nssa2-c [
      nssa2-f: function [
        p [s!]
        return: [integer!]
      ][
        p/val
      ]
    ]
  --assert 200 = nssa2-f nssa2-c/s

===end-group===

===start-group=== "inline functions in namespace"

    ;--test-- "ifin1 - issue 285"
    ;  ifin-func: func [i [integer!] return: [integer!]][i]
    ;  ifin-nsp: context [
    ;    f: func [[infix] a [integer!] b [integer!] return: [integer!]][a + b]
    ;    i: ifin-func 1 f 2
    ;  ]
    ;--assert 3 = ifin-nsp/i

===end-group===

~~~end-file~~~