FIX: issue #1120 (missing "(" crash interpreter)

This commit just fix minor error display issues, this ticket's issue was fixed by previous commits.

Red [
	Title:   "Red runtime lexer"
	Author:  "Nenad Rakocevic"
	File: 	 %lexer.red
	Tabs:	 4
	Rights:  "Copyright (C) 2014 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
	}
]

system/lexer: context [

	make-number: routine [
		start  [string!]
		end	   [string!]
		float? [logic!]
		/local
			c	 [integer!]
			n	 [integer!]
			m	 [integer!]
			len  [integer!]
			p	 [byte-ptr!]
			neg? [logic!]
	][
		if float? [
			make-float start end							;-- decimal! escape path
			exit
		]
		str:  GET_BUFFER(start)
		unit: GET_UNIT(str)
		p:	  string/rs-head start
		len:  end/head - start/head
		neg?: no

		c: string/get-char p unit
		if any [
			c = as-integer #"+"
			c = as-integer #"-"
		][
			neg?: c = as-integer #"-"
			p: p + unit
			len: len - 1
		]
		n: 0
		until [
			c: (string/get-char p unit) - #"0"
			if c >= 0 [									;-- skip #"'"
				m: n * 10
				if m < n [SET_RETURN(none-value) exit]	;-- return NONE on overflow
				n: m

				if all [n = 2147483640 c = 8][
					integer/box 80000000h				;-- special exit trap for -2147483648
					exit
				]

				m: n + c
				if m < n [SET_RETURN(none-value) exit]	;-- return NONE on overflow
				n: m
			]
			p: p + unit
			len: len - 1
			zero? len
		]
		integer/box either neg? [0 - n][n]
	]

	make-float: routine [
		start [string!]
		end	  [string!]
		/local
			str  [series!]
			cp	 [integer!]
			unit [integer!]
			p	 [byte-ptr!]
			tail [byte-ptr!]
			cur	 [byte-ptr!]
			s0	 [byte-ptr!]
			byte [byte!]
	][
		str:  GET_BUFFER(start)
		unit: GET_UNIT(str)
		p:	  string/rs-head start
		tail: p + ((end/head - start/head) << (unit >> 1))
		cur:  p
		s0:   cur

		until [											;-- convert to ascii string
			cp: string/get-char p unit
			if cp <> as-integer #"'" [					;-- skip #"'"
				if cp = as-integer #"," [cp: as-integer #"."]
				cur/1: as-byte cp
				cur: cur + 1
			]
			p: p + unit
			p = tail
		]
		byte: cur/1										;-- store last byte
		cur/1: #"^@"									;-- replace the byte with null so to-float can use it as end of input
		float/box string/to-float s0
		cur/1: byte										;-- revert the byte back
	]

	make-hexa: routine [
		start	[string!]
		end		[string!]
		return: [integer!]
		/local
			s	  [series!]
			unit  [integer!]
			p	  [byte-ptr!]
			head  [byte-ptr!]
			p4	  [int-ptr!]
			n	  [integer!]
			power [integer!]
			cp	  [byte!]
	][
		s: GET_BUFFER(start)
		unit: GET_UNIT(s)

		p: (string/rs-head end) - unit
		head: string/rs-head start

		n: 0
		power: 0
		while [p >= head][
			cp: switch unit [
				Latin1 [p/value]
				UCS-2  [as-byte ((as-integer p/2) << 8 + p/1)]
				UCS-4  [p4: as int-ptr! p as-byte p4/value]
			]
			if cp <> #"0" [
				case [
					all [#"0" <= cp cp <= #"9"][cp: cp - #"0"]
					all [#"A" <= cp cp <= #"F"][cp: cp - #"A" + 10]
					all [#"a" <= cp cp <= #"f"][cp: cp - #"a" + 10]
				]
				n: n + ((as-integer cp) << power)
			]
			power: power + 4
			p: p - unit
		]
		n
	]

	make-char: routine [
		start	[string!]
		end		[string!]
		/local
			n	  [integer!]
			value [red-value!]
	][
		n: make-hexa start end
		value: as red-value! integer/box n
		set-type value TYPE_CHAR
	]

	push-path: routine [
		stack [block!]
		type  [datatype!]
		/local
			path [red-path!]
	][
		path: as red-path! block/make-at as red-block! ALLOC_TAIL(stack) 4
		path/header: switch type/value [
			TYPE_GET_WORD [TYPE_GET_PATH]
			TYPE_LIT_WORD [TYPE_LIT_PATH]
			default [TYPE_PATH]
		]
	]

	set-path: routine [
		stack [block!]
		/local
			path [red-path!]
	][
		path: as red-path! block/pick stack 1 null
		set-type as red-value! path TYPE_SET_PATH
	]

	make-word: routine [
		src   [string!]
		type  [datatype!]
	][
		set-type
			as red-value! word/box (symbol/make-alt src) ;-- word/box puts it in stack/arguments
			type/value
	]

	to-word: func [
		stack [block!]
		src   [string!]
		type  [datatype!]
	][
		store stack make-word src type
	]

	pop: function [stack [block!]][
		value: last stack
		remove back tail stack

		either any [1 < length? stack head? stack/1][
			append/only last stack :value
		][
			pos: back tail stack						;-- root storage and offset-ed series (/into option)
			pos/1: insert/only last stack :value
		]
	]

	store: function [stack [block!] value][
		either any [1 < length? stack head? stack/1][
			append last stack value
		][
			pos: back tail stack						;-- root storage and offset-ed series (/into option)
			pos/1: insert last stack value
		]
	]

	transcode: function [
		src	[string!]
		dst	[block! none!]
		/part
			length [integer! string!]
		return: [block!]
		/local
			new s e c hex pos value cnt type process
			digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
			not-file-char not-str-char not-mstr-char caret-char
			non-printable-char integer-end ws-ASCII ws-U+2k control-char
	][
		cs:		[- - - - - - - - - - - - - - - -]		;-- memoized bitsets
		stack:	clear []
		count?:	yes										;-- if TRUE, lines counter is enabled
		line: 	1

		append/only stack any [dst make block! 4]

		make-string: [
			new: make type (index? e) - index? s
			parse/case copy/part s e [					;@@ add /part option to parse!
				any [
					escaped-char (append new value)
					| #"^^"								;-- trash single caret chars
					| set c skip (append new c)
				]
			]
			new
		]

		make-file: [
			new: make type (index? e) - index? s
			append new dehex copy/part s e
			new
		]

		if cs/1 = '- [
			cs/1:  charset "0123465798"					;-- digit
			cs/2:  charset "ABCDEF"						;-- hexa-upper
			cs/3:  charset "abcdef"						;-- hexa-lower
			cs/4:  union cs/1 cs/2						;-- hexa
			cs/5:  union cs/4 cs/3						;-- hexa-char
			cs/6:  charset {/\^^,[](){}"#%$@:;}			;-- not-word-char
			cs/7:  union union cs/6 cs/1 charset {'}	;-- not-word-1st
			cs/8:  charset {[](){}"@:;}					;-- not-file-char
			cs/9:  #"^""								;-- not-str-char
			cs/10: #"}"									;-- not-mstr-char
			cs/11: charset [#"^(40)" - #"^(5F)"]		;-- caret-char
			cs/12: charset [#"^(00)" - #"^(1F)"]		;-- non-printable-char
			cs/13: charset {^{"[]);}					;-- integer-end
			cs/14: charset " ^-^M"						;-- ws-ASCII, ASCII common whitespaces
			cs/15: charset [#"^(2000)" - #"^(200A)"]	;-- ws-U+2k, Unicode spaces in the U+2000-U+200A range
			cs/16: charset [#"^(00)" - #"^(1F)"] 		;-- ASCII control characters

		]
		set [
			digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
			not-file-char not-str-char not-mstr-char caret-char
			non-printable-char integer-end ws-ASCII ws-U+2k control-char
		] cs

		;-- Whitespaces list from: http://en.wikipedia.org/wiki/Whitespace_character
		ws: [
			pos: #"^/" (
				if count? [
					line: line + 1
					;append/only lines to block! stack/tail?
				]
			)
			| ws-ASCII									;-- only the common whitespaces are matched
			| #"^(0085)"								;-- U+0085 (Newline)
			| #"^(00A0)"								;-- U+00A0 (No-break space)
			| #"^(1680)"								;-- U+1680 (Ogham space mark)
			| #"^(180E)"								;-- U+180E (Mongolian vowel separator)
			| ws-U+2k									;-- U+2000-U+200A range
			| #"^(2028)"								;-- U+2028 (Line separator)
			| #"^(2029)"								;-- U+2029 (Paragraph separator)
			| #"^(202F)"								;-- U+202F (Narrow no-break space)
			| #"^(205F)"								;-- U+205F (Medium mathematical space)
			| #"^(3000)"								;-- U+3000 (Ideographic space)
		]

		newline-char: [
			#"^/"
			| #"^(0085)"								;-- U+0085 (Newline)
			| #"^(2028)"								;-- U+2028 (Line separator)
			| #"^(2029)"								;-- U+2029 (Paragraph separator)
		]

		counted-newline: [pos: #"^/" (line: line + 1)]

		ws-no-count: [(count?: no) ws (count?: yes)]

		escaped-char: [
			"^^(" [
				[										;-- special case first
					"null" 	 (value: #"^(00)")
					| "back" (value: #"^(08)")
					| "tab"  (value: #"^(09)")
					| "line" (value: #"^(0A)")
					| "page" (value: #"^(0C)")
					| "esc"  (value: #"^(1B)")
					| "del"	 (value: #"^(7F)")
				]
				| pos: [1 6 hexa-char] e: (				;-- Unicode values allowed up to 10FFFFh
					value: make-char pos e
				)
			] #")"
			| #"^^" [
				[
					#"/" 	(value: #"^/")
					| #"-"	(value: #"^-")
					| #"?" 	(value: #"^(del)")			;@@FIXME
					| #"^^" (value: #"^^")				;-- caret escaping case
					| #"{"	(value: #"{")
					| #"}"	(value: #"}")
					| #"^""	(value: #"^"")
				]
				| pos: caret-char (value: pos/1 - 64)
			]
		]

		char-rule: [
			{#"} s: [
				 escaped-char
				| ahead [non-printable-char | not-str-char] break
				| skip (value: s/1)
			] {"}
		]

		line-string: [
			{"} s: any [
				{^^"}
				| ahead [#"^"" | newline-char] break
				| escaped-char
				| skip
			]
			e: {"}
		]

		nested-curly-braces: [
			(cnt: 1)
			any [
				counted-newline
				| "^^{"
				| "^^}"
				| #"{" (cnt: cnt + 1)
				| e: #"}" if (zero? cnt: cnt - 1) break
				| escaped-char
				| skip
			]
		]

		multiline-string: [
			#"{" s: nested-curly-braces (
				unless zero? cnt [cause-error 'syntax 'invalid [string! mold s]]
			)
		]

		string-rule: [(type: string!) line-string | multiline-string]

		file-rule: [
			#"%" [
				line-string (process: make-string type: file!)
				| s: any [ahead [not-file-char | ws-no-count] break | skip] e:
				  (process: make-file type: file!)
			]
		]

		url-rule: [
			#":" not [integer-end | ws-no-count | end]
			any [#"@" | #":" | ahead [not-file-char | ws-no-count] break | skip] e:
			(type: url! store stack do make-file)
		]

		symbol-rule: [
			some [ahead [not-word-char | ws-no-count | control-char] break | skip] e:
		]

		begin-symbol-rule: [							;-- 1st char in symbols is restricted
			[not ahead [not-word-1st | ws-no-count | control-char]]
			symbol-rule
		]

		path-rule: [
			ahead slash (								;-- path detection barrier
				push-path stack type					;-- create empty path
				to-word stack copy/part s e word!		;-- push 1st path element
			)
			some [
				slash
				s: [
					integer-number-rule			(store stack make-number s e no)
					| begin-symbol-rule			(to-word stack copy/part s e word!)
					| paren-rule
					| #":" s: begin-symbol-rule	(to-word stack copy/part s e get-word!)
					;@@ add more datatypes here
					| (cause-error 'syntax 'invalid [path! trim/tail copy back s])
					  reject
				]
				opt [#":" (set-path back tail stack)]
			] (pop stack)
		]

		word-rule: 	[
			#"%" ws-no-count (to-word stack "%" word!)	;-- special case for remainder op!
			| s: begin-symbol-rule (type: word!) [
					url-rule
					| path-rule							;-- path matched
					| opt [#":" (type: set-word!)]
					  (if type [to-word stack copy/part s e type])	;-- word or set-word matched
			  ]
		]

		get-word-rule: [
			#":" (type: get-word!) s: begin-symbol-rule [
				path-rule (type: get-path!)
				| (to-word stack copy/part s e type)	;-- get-word matched
			]
		]

		lit-word-rule: [
			#"'" (type: lit-word!) s: begin-symbol-rule [
				path-rule (type: lit-path!)				;-- path matched
				| (to-word stack copy/part s e type)	;-- lit-word matched
			]
		]

		issue-rule: [
			#"#" (type: issue!) s: symbol-rule
			(to-word stack copy/part s e type)
		]

		refinement-rule: [
			slash [
				some slash (type: word!) e:				;--  ///... case
				| ahead [not-word-char | ws-no-count | control-char] (type: word!) e: ;-- / case
				| symbol-rule (type: refinement! s: next s)
			]
			(to-word stack copy/part s e type)
		]

		hexa-rule: [2 8 hexa e: #"h"]

		integer-number-rule: [
			opt [#"-" | #"+"] digit any [digit | #"'" digit] e:
		]

		integer-rule: [
			float-special								;-- escape path for NaN, INFs
			| integer-number-rule
			  opt [float-number-rule | float-exp-rule e: (type: float!)]
			  ahead [integer-end | ws-no-count | end]
		]

		float-special: [
			s: opt [#"-"] "1.#" [
				[[#"N" | #"n"] [#"a" | #"A"] [#"N" | #"n"]]
				| [[#"I" | #"i"] [#"N" | #"n"] [#"F" | #"f"]]
			] e: (type: float!)
		]

		float-exp-rule: [[#"e" | #"E"] opt [#"-" | #"+"] 1 3 digit]

		float-number-rule: [
			[dot | comma] digit any [digit | #"'" digit]
			opt float-exp-rule e: (type: float!)
		]

		float-rule: [
			opt [#"-" | #"+"] float-number-rule
			ahead [integer-end | ws-no-count | end]
		]

		block-rule: [
			#"[" (append/only stack make block! 4)
			any-value
			#"]" (pop stack)
		]

		paren-rule: [
			#"(" (append/only stack make paren! 4)
			any-value
			#")" (pop stack)
		]

		escaped-rule: [
			"#[" pos: any ws [
				  "true"  			(value: true)
				| "false" 			(value: false)
				| [
					"none!"			(value: none!)
					| "logic!"		(value: logic!)
					| "block!"		(value: block!)
					| "integer!"	(value: integer!)
					| "word!"		(value: word!)
					| "set-word!"	(value: set-word!)
					| "get-word!"	(value: get-word!)
					| "lit-word!"	(value: lit-word!)
					| "refinement!"	(value: refinement!)
					;| "binary!"	(value: binary!)
					| "string!"		(value: string!)
					| "char!"		(value: char!)
					| "bitset!"		(value: bitset!)
					| "path!"		(value: path!)
					| "set-path!"	(value: set-path!)
					| "lit-path!"	(value: lit-path!)
					| "get-path!"	(value: get-path!)
					| "native!"		(value: native!)
					| "action!"		(value: action!)
					| "op!"			(value: op!)
					| "issue!"		(value: issue!)
					| "paren!"		(value: paren!)
					| "function!"	(value: function!)
					| "routine!"	(value: routine!)
				]
				| "none" 			(value: none)
			] pos: any ws #"]"
		]

		comment-rule: [#";" [to lf | to end]]

		wrong-delimiters: [
			pos: [
				  #"]" (value: #"[") | #")" (value: #"(")
				| #"[" (value: #"]") | #"(" (value: #")")
			] :pos
			(cause-error 'syntax 'missing [trim/all copy skip pos -3 value])
		]

		literal-value: [
			pos: (e: none) s: [
				comment-rule
				| escaped-rule		(store stack value)
				| integer-rule		if (value: make-number s e type = float!) (store stack value)
				| float-rule		if (value: make-float s e) (store stack value)
				| hexa-rule			(store stack make-hexa s e)
				| word-rule
				| lit-word-rule
				| get-word-rule
				| refinement-rule
				| file-rule			(store stack value: do process)
				| char-rule			(store stack value)
				| issue-rule
				| block-rule
				| paren-rule
				| string-rule		(store stack do make-string)
				;| binary-rule	  	(stack/push load-binary s e)
			]
		]

		any-value: [pos: any [literal-value | ws]]

		red-rules: [any-value opt wrong-delimiters]

		unless either part [
			parse/case/part src red-rules length
		][
			parse/case src red-rules
		][
			cause-error 'syntax 'invalid ['value copy/part pos 20]
		]
		stack/1
	]
]

Red [
	Title:   "Red runtime lexer"
	Author:  "Nenad Rakocevic"
	File: 	 %lexer.red
	Tabs:	 4
	Rights:  "Copyright (C) 2014 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
	}
]

system/lexer: context [

	make-number: routine [
		start  [string!]
		end	   [string!]
		float? [logic!]
		/local
			c	 [integer!]
			n	 [integer!]
			m	 [integer!]
			len  [integer!]
			p	 [byte-ptr!]
			neg? [logic!]
	][
		if float? [
			make-float start end							;-- decimal! escape path
			exit
		]
		str:  GET_BUFFER(start)
		unit: GET_UNIT(str)
		p:	  string/rs-head start
		len:  end/head - start/head
		neg?: no

		c: string/get-char p unit
		if any [
			c = as-integer #"+"
			c = as-integer #"-"
		][
			neg?: c = as-integer #"-"
			p: p + unit
			len: len - 1
		]
		n: 0
		until [
			c: (string/get-char p unit) - #"0"
			if c >= 0 [									;-- skip #"'"
				m: n * 10
				if m < n [SET_RETURN(none-value) exit]	;-- return NONE on overflow
				n: m

				if all [n = 2147483640 c = 8][
					integer/box 80000000h				;-- special exit trap for -2147483648
					exit
				]

				m: n + c
				if m < n [SET_RETURN(none-value) exit]	;-- return NONE on overflow
				n: m
			]
			p: p + unit
			len: len - 1
			zero? len
		]
		integer/box either neg? [0 - n][n]
	]

	make-float: routine [
		start [string!]
		end	  [string!]
		/local
			str  [series!]
			cp	 [integer!]
			unit [integer!]
			p	 [byte-ptr!]
			tail [byte-ptr!]
			cur	 [byte-ptr!]
			s0	 [byte-ptr!]
			byte [byte!]
	][
		str:  GET_BUFFER(start)
		unit: GET_UNIT(str)
		p:	  string/rs-head start
		tail: p + ((end/head - start/head) << (unit >> 1))
		cur:  p
		s0:   cur

		until [											;-- convert to ascii string
			cp: string/get-char p unit
			if cp <> as-integer #"'" [					;-- skip #"'"
				if cp = as-integer #"," [cp: as-integer #"."]
				cur/1: as-byte cp
				cur: cur + 1
			]
			p: p + unit
			p = tail
		]
		byte: cur/1										;-- store last byte
		cur/1: #"^@"									;-- replace the byte with null so to-float can use it as end of input
		float/box string/to-float s0
		cur/1: byte										;-- revert the byte back
	]

	make-hexa: routine [
		start	[string!]
		end		[string!]
		return: [integer!]
		/local
			s	  [series!]
			unit  [integer!]
			p	  [byte-ptr!]
			head  [byte-ptr!]
			p4	  [int-ptr!]
			n	  [integer!]
			power [integer!]
			cp	  [byte!]
	][
		s: GET_BUFFER(start)
		unit: GET_UNIT(s)

		p: (string/rs-head end) - unit
		head: string/rs-head start

		n: 0
		power: 0
		while [p >= head][
			cp: switch unit [
				Latin1 [p/value]
				UCS-2  [as-byte ((as-integer p/2) << 8 + p/1)]
				UCS-4  [p4: as int-ptr! p as-byte p4/value]
			]
			if cp <> #"0" [
				case [
					all [#"0" <= cp cp <= #"9"][cp: cp - #"0"]
					all [#"A" <= cp cp <= #"F"][cp: cp - #"A" + 10]
					all [#"a" <= cp cp <= #"f"][cp: cp - #"a" + 10]
				]
				n: n + ((as-integer cp) << power)
			]
			power: power + 4
			p: p - unit
		]
		n
	]

	make-char: routine [
		start	[string!]
		end		[string!]
		/local
			n	  [integer!]
			value [red-value!]
	][
		n: make-hexa start end
		value: as red-value! integer/box n
		set-type value TYPE_CHAR
	]

	push-path: routine [
		stack [block!]
		type  [datatype!]
		/local
			path [red-path!]
	][
		path: as red-path! block/make-at as red-block! ALLOC_TAIL(stack) 4
		path/header: switch type/value [
			TYPE_GET_WORD [TYPE_GET_PATH]
			TYPE_LIT_WORD [TYPE_LIT_PATH]
			default [TYPE_PATH]
		]
	]

	set-path: routine [
		stack [block!]
		/local
			path [red-path!]
	][
		path: as red-path! block/pick stack 1 null
		set-type as red-value! path TYPE_SET_PATH
	]

	make-word: routine [
		src   [string!]
		type  [datatype!]
	][
		set-type
			as red-value! word/box (symbol/make-alt src) ;-- word/box puts it in stack/arguments
			type/value
	]

	to-word: func [
		stack [block!]
		src   [string!]
		type  [datatype!]
	][
		store stack make-word src type
	]

	pop: function [stack [block!]][
		value: last stack
		remove back tail stack

		either any [1 < length? stack head? stack/1][
			append/only last stack :value
		][
			pos: back tail stack						;-- root storage and offset-ed series (/into option)
			pos/1: insert/only last stack :value
		]
	]

	store: function [stack [block!] value][
		either any [1 < length? stack head? stack/1][
			append last stack value
		][
			pos: back tail stack						;-- root storage and offset-ed series (/into option)
			pos/1: insert last stack value
		]
	]

	transcode: function [
		src	[string!]
		dst	[block! none!]
		/part
			length [integer! string!]
		return: [block!]
		/local
			new s e c hex pos value cnt type process
			digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
			not-file-char not-str-char not-mstr-char caret-char
			non-printable-char integer-end ws-ASCII ws-U+2k control-char
	][
		cs:		[- - - - - - - - - - - - - - - -]		;-- memoized bitsets
		stack:	clear []
		count?:	yes										;-- if TRUE, lines counter is enabled
		line: 	1

		append/only stack any [dst make block! 4]

		make-string: [
			new: make type (index? e) - index? s
			parse/case copy/part s e [					;@@ add /part option to parse!
				any [
					escaped-char (append new value)
					| #"^^"								;-- trash single caret chars
					| set c skip (append new c)
				]
			]
			new
		]

		make-file: [
			new: make type (index? e) - index? s
			append new dehex copy/part s e
			new
		]

		if cs/1 = '- [
			cs/1:  charset "0123465798"					;-- digit
			cs/2:  charset "ABCDEF"						;-- hexa-upper
			cs/3:  charset "abcdef"						;-- hexa-lower
			cs/4:  union cs/1 cs/2						;-- hexa
			cs/5:  union cs/4 cs/3						;-- hexa-char
			cs/6:  charset {/\^^,[](){}"#%$@:;}			;-- not-word-char
			cs/7:  union union cs/6 cs/1 charset {'}	;-- not-word-1st
			cs/8:  charset {[](){}"@:;}					;-- not-file-char
			cs/9:  #"^""								;-- not-str-char
			cs/10: #"}"									;-- not-mstr-char
			cs/11: charset [#"^(40)" - #"^(5F)"]		;-- caret-char
			cs/12: charset [#"^(00)" - #"^(1F)"]		;-- non-printable-char
			cs/13: charset {^{"[]);}					;-- integer-end
			cs/14: charset " ^-^M"						;-- ws-ASCII, ASCII common whitespaces
			cs/15: charset [#"^(2000)" - #"^(200A)"]	;-- ws-U+2k, Unicode spaces in the U+2000-U+200A range
			cs/16: charset [#"^(00)" - #"^(1F)"] 		;-- ASCII control characters

		]
		set [
			digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
			not-file-char not-str-char not-mstr-char caret-char
			non-printable-char integer-end ws-ASCII ws-U+2k control-char
		] cs

		;-- Whitespaces list from: http://en.wikipedia.org/wiki/Whitespace_character
		ws: [
			pos: #"^/" (
				if count? [
					line: line + 1
					;append/only lines to block! stack/tail?
				]
			)
			| ws-ASCII									;-- only the common whitespaces are matched
			| #"^(0085)"								;-- U+0085 (Newline)
			| #"^(00A0)"								;-- U+00A0 (No-break space)
			| #"^(1680)"								;-- U+1680 (Ogham space mark)
			| #"^(180E)"								;-- U+180E (Mongolian vowel separator)
			| ws-U+2k									;-- U+2000-U+200A range
			| #"^(2028)"								;-- U+2028 (Line separator)
			| #"^(2029)"								;-- U+2029 (Paragraph separator)
			| #"^(202F)"								;-- U+202F (Narrow no-break space)
			| #"^(205F)"								;-- U+205F (Medium mathematical space)
			| #"^(3000)"								;-- U+3000 (Ideographic space)
		]

		newline-char: [
			#"^/"
			| #"^(0085)"								;-- U+0085 (Newline)
			| #"^(2028)"								;-- U+2028 (Line separator)
			| #"^(2029)"								;-- U+2029 (Paragraph separator)
		]

		counted-newline: [pos: #"^/" (line: line + 1)]

		ws-no-count: [(count?: no) ws (count?: yes)]

		escaped-char: [
			"^^(" [
				[										;-- special case first
					"null" 	 (value: #"^(00)")
					| "back" (value: #"^(08)")
					| "tab"  (value: #"^(09)")
					| "line" (value: #"^(0A)")
					| "page" (value: #"^(0C)")
					| "esc"  (value: #"^(1B)")
					| "del"	 (value: #"^(7F)")
				]
				| pos: [1 6 hexa-char] e: (				;-- Unicode values allowed up to 10FFFFh
					value: make-char pos e
				)
			] #")"
			| #"^^" [
				[
					#"/" 	(value: #"^/")
					| #"-"	(value: #"^-")
					| #"?" 	(value: #"^(del)")			;@@FIXME
					| #"^^" (value: #"^^")				;-- caret escaping case
					| #"{"	(value: #"{")
					| #"}"	(value: #"}")
					| #"^""	(value: #"^"")
				]
				| pos: caret-char (value: pos/1 - 64)
			]
		]

		char-rule: [
			{#"} s: [
				 escaped-char
				| ahead [non-printable-char | not-str-char] break
				| skip (value: s/1)
			] {"}
		]

		line-string: [
			{"} s: any [
				{^^"}
				| ahead [#"^"" | newline-char] break
				| escaped-char
				| skip
			]
			e: {"}
		]

		nested-curly-braces: [
			(cnt: 1)
			any [
				counted-newline
				| "^^{"
				| "^^}"
				| #"{" (cnt: cnt + 1)
				| e: #"}" if (zero? cnt: cnt - 1) break
				| escaped-char
				| skip
			]
		]

		multiline-string: [
			#"{" s: nested-curly-braces (
				unless zero? cnt [cause-error 'syntax 'invalid [string! mold s]]
			)
		]

		string-rule: [(type: string!) line-string | multiline-string]

		file-rule: [
			#"%" [
				line-string (process: make-string type: file!)
				| s: any [ahead [not-file-char | ws-no-count] break | skip] e:
				  (process: make-file type: file!)
			]
		]

		url-rule: [
			#":" not [integer-end | ws-no-count | end]
			any [#"@" | #":" | ahead [not-file-char | ws-no-count] break | skip] e:
			(type: url! store stack do make-file)
		]

		symbol-rule: [
			some [ahead [not-word-char | ws-no-count | control-char] break | skip] e:
		]

		begin-symbol-rule: [							;-- 1st char in symbols is restricted
			[not ahead [not-word-1st | ws-no-count | control-char]]
			symbol-rule
		]

		path-rule: [
			ahead slash (								;-- path detection barrier
				push-path stack type					;-- create empty path
				to-word stack copy/part s e word!		;-- push 1st path element
			)
			some [
				slash
				s: [
					integer-number-rule			(store stack make-number s e no)
					| begin-symbol-rule			(to-word stack copy/part s e word!)
					| paren-rule
					| #":" s: begin-symbol-rule	(to-word stack copy/part s e get-word!)
					;@@ add more datatypes here
					| (cause-error 'syntax 'invalid [path! trim/tail back s])
					  reject
				]
				opt [#":" (set-path back tail stack)]
			] (pop stack)
		]

		word-rule: 	[
			#"%" ws-no-count (to-word stack "%" word!)	;-- special case for remainder op!
			| s: begin-symbol-rule (type: word!) [
					url-rule
					| path-rule							;-- path matched
					| opt [#":" (type: set-word!)]
					  (if type [to-word stack copy/part s e type])	;-- word or set-word matched
			  ]
		]

		get-word-rule: [
			#":" (type: get-word!) s: begin-symbol-rule [
				path-rule (type: get-path!)
				| (to-word stack copy/part s e type)	;-- get-word matched
			]
		]

		lit-word-rule: [
			#"'" (type: lit-word!) s: begin-symbol-rule [
				path-rule (type: lit-path!)				;-- path matched
				| (to-word stack copy/part s e type)	;-- lit-word matched
			]
		]

		issue-rule: [
			#"#" (type: issue!) s: symbol-rule
			(to-word stack copy/part s e type)
		]

		refinement-rule: [
			slash [
				some slash (type: word!) e:				;--  ///... case
				| ahead [not-word-char | ws-no-count | control-char] (type: word!) e: ;-- / case
				| symbol-rule (type: refinement! s: next s)
			]
			(to-word stack copy/part s e type)
		]

		hexa-rule: [2 8 hexa e: #"h"]

		integer-number-rule: [
			opt [#"-" | #"+"] digit any [digit | #"'" digit] e:
		]

		integer-rule: [
			float-special								;-- escape path for NaN, INFs
			| integer-number-rule
			  opt [float-number-rule | float-exp-rule e: (type: float!)]
			  ahead [integer-end | ws-no-count | end]
		]

		float-special: [
			s: opt [#"-"] "1.#" [
				[[#"N" | #"n"] [#"a" | #"A"] [#"N" | #"n"]]
				| [[#"I" | #"i"] [#"N" | #"n"] [#"F" | #"f"]]
			] e: (type: float!)
		]

		float-exp-rule: [[#"e" | #"E"] opt [#"-" | #"+"] 1 3 digit]

		float-number-rule: [
			[dot | comma] digit any [digit | #"'" digit]
			opt float-exp-rule e: (type: float!)
		]

		float-rule: [
			opt [#"-" | #"+"] float-number-rule
			ahead [integer-end | ws-no-count | end]
		]

		block-rule: [
			#"[" (append/only stack make block! 4)
			any-value
			#"]" (pop stack)
		]

		paren-rule: [
			#"(" (append/only stack make paren! 4)
			any-value
			#")" (pop stack)
		]

		escaped-rule: [
			"#[" pos: any ws [
				  "true"  			(value: true)
				| "false" 			(value: false)
				| [
					"none!"			(value: none!)
					| "logic!"		(value: logic!)
					| "block!"		(value: block!)
					| "integer!"	(value: integer!)
					| "word!"		(value: word!)
					| "set-word!"	(value: set-word!)
					| "get-word!"	(value: get-word!)
					| "lit-word!"	(value: lit-word!)
					| "refinement!"	(value: refinement!)
					;| "binary!"	(value: binary!)
					| "string!"		(value: string!)
					| "char!"		(value: char!)
					| "bitset!"		(value: bitset!)
					| "path!"		(value: path!)
					| "set-path!"	(value: set-path!)
					| "lit-path!"	(value: lit-path!)
					| "get-path!"	(value: get-path!)
					| "native!"		(value: native!)
					| "action!"		(value: action!)
					| "op!"			(value: op!)
					| "issue!"		(value: issue!)
					| "paren!"		(value: paren!)
					| "function!"	(value: function!)
					| "routine!"	(value: routine!)
				]
				| "none" 			(value: none)
			] pos: any ws #"]"
		]

		comment-rule: [#";" [to lf | to end]]

		wrong-delimiters: [
			pos: [
				  #"]" (value: #"[") | #")" (value: #"(")
				| #"[" (value: #"]") | #"(" (value: #")")
			] :pos
			(cause-error 'syntax 'missing [value pos])
		]

		literal-value: [
			pos: (e: none) s: [
				comment-rule
				| escaped-rule		(store stack value)
				| integer-rule		if (value: make-number s e type = float!) (store stack value)
				| float-rule		if (value: make-float s e) (store stack value)
				| hexa-rule			(store stack make-hexa s e)
				| word-rule
				| lit-word-rule
				| get-word-rule
				| refinement-rule
				| file-rule			(store stack value: do process)
				| char-rule			(store stack value)
				| issue-rule
				| block-rule
				| paren-rule
				| string-rule		(store stack do make-string)
				;| binary-rule	  	(stack/push load-binary s e)
			]
		]

		any-value: [pos: any [literal-value | ws]]

		red-rules: [any-value opt wrong-delimiters]

		unless either part [
			parse/case/part src red-rules length
		][
			parse/case src red-rules
		][
			cause-error 'syntax 'invalid ['value copy/part pos 20]
		]
		stack/1
	]
]


FIX: issue #983 (Crash on SWITCH local object! path!)

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

stack: context [										;-- call stack
	verbose: 0

	dyn-info!: alias struct! [
		header [integer!]
		code   [integer!]
		count  [integer!]
		locals [integer!]
	]

	arg-stk:		declare red-block!					;-- argument stack (should never be relocated)
	call-stk:		declare red-block!					;-- call stack (should never be relocated)
	args-series:	declare series!
	calls-series:	declare series!
	a-end: 			declare red-value!
	c-end: 			declare int-ptr!
	arguments:		declare red-value!
	bottom:  		declare red-value!
	top:	 		declare red-value!
	cbottom: 		declare int-ptr!
	ctop:	 		declare int-ptr!

	acc-mode?: no										;-- YES: accumulate expressions on stack

	#define MARK_STACK(type) [
		func [
			fun [red-word!]
		][
			#if debug? = yes [if verbose > 0 [print-line "stack/mark"]]

			if ctop = c-end [
				print-line ["^/*** Error: call stack overflow!^/"]
				halt
			]
			ctop/1: type or (fun/symbol << 8)
			ctop/2: as-integer arguments
			arguments: top								;-- top of stack becomes frame base
			ctop: ctop + 2

			#if debug? = yes [if verbose > 1 [dump]]
		]
	]

	#define STACK_SET_FRAME [
		either ctop = cbottom [
			arguments: bottom
			top: bottom
		][
			top: arguments + 1							;-- keep last value on stack
			arguments: as red-value! ctop/2
		]
	]

	;-- header flags
	#enum flags! [
		FLAG_FUNCTION:	80000000h						;-- function! call
		FLAG_NATIVE:	40000000h						;-- native! or action! call
		FLAG_ROUTINE:	20000000h						;--	<reserved>
		FLAG_TRY:		10000000h						;--	TRY native
		FLAG_CATCH:		08000000h						;-- CATCH native
		FLAG_THROW_ATR:	04000000h						;-- Throw function attribut
		FLAG_CATCH_ATR:	02000000h						;--	Catch function attribut
		FLAG_EVAL:		01000000h						;-- Interpreter root frame
		FLAG_DYN_CALL:	11000000h						;-- Dynamic call (alternative stack mode)
	]

	init: does [
		arg-stk:  block/make-in root 1024
		call-stk: block/make-in root 512

		set-flag arg-stk/node flag-series-fixed or flag-series-nogc
		set-flag call-stk/node flag-series-fixed or flag-series-nogc

		;-- Shortcuts for stack buffers simpler and faster access
		;-- (stack buffers are not resizable with such approach
		;-- this can be made more flexible (but slower) if necessary
		;-- in the future)

		args-series:  GET_BUFFER(arg-stk)
		calls-series: GET_BUFFER(call-stk)

		a-end: as cell!    (as byte-ptr! args-series)  + args-series/size
		c-end: as int-ptr! (as byte-ptr! calls-series) + calls-series/size

		arguments:	args-series/tail
		bottom:  	args-series/offset
		top:	 	args-series/tail
		cbottom: 	as int-ptr! calls-series/offset
		ctop:	 	as int-ptr! calls-series/tail
	]

	check-call: does [
		if acc-mode? [check-dyn-call]
	]

	reset: func [
		return:  [cell!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/reset"]]

		either acc-mode? [check-dyn-call][top: arguments]
		arguments
	]

	keep: func [
		return:  [cell!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/keep"]]

		top: arguments + 1								;-- keep last value in arguments slot
		if acc-mode? [check-dyn-call]
		arguments
	]

	mark-native: MARK_STACK(FLAG_NATIVE)
	mark-func:	 MARK_STACK(FLAG_FUNCTION)
	mark-try:	 MARK_STACK(FLAG_TRY)
	mark-catch:	 MARK_STACK(FLAG_CATCH)
	mark-eval:	 MARK_STACK(FLAG_EVAL)
	mark-dyn:	 MARK_STACK(FLAG_DYN_CALL)

	revert: does [
		#if debug? = yes [if verbose > 0 [print-line "stack/revert"]]

		assert cbottom < ctop
		ctop: ctop - 2
		either ctop = cbottom [
			arguments: bottom
			top: bottom
		][
			top: arguments
			arguments: as red-value! ctop/2
		]

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind-part: does [
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind-part"]]

		assert cbottom < ctop
		ctop: ctop - 2
		either ctop = cbottom [
			arguments: bottom
		][
			arguments: as red-value! ctop/2
		]
		top: top - 1

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind: does [
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind"]]

		assert cbottom < ctop
		ctop: ctop - 2
		STACK_SET_FRAME
		if acc-mode? [check-dyn-call]

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind-last: func [
		return:  [red-value!]
		/local
			last [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind-last"]]

		last: arguments
		unwind
		copy-cell last arguments
	]

	unroll: func [
		flags	 [integer!]
		/local
			last [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/unroll"]]

		last: arguments
		assert cbottom < ctop
		until [
			ctop: ctop - 2
			any [
				flags and ctop/1 = flags
				ctop <= cbottom
			]
		]

		STACK_SET_FRAME
		ctop: ctop + 2									;-- ctop points past the current call frame
		copy-cell last as red-value! ctop/2
	]

	eval?: func [
		return: [logic!]
		/local
			cframe [int-ptr!]
	][
		cframe: ctop
		until [
			cframe: cframe - 2
			if FLAG_EVAL and cframe/1 = FLAG_EVAL [return yes]
			cframe <= cbottom
		]
		no
	]

	set-last: func [
		last	[red-value!]
		return: [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/set-last"]]

		copy-cell last arguments
	]

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

		cell: top
		top: top + 1
		if top >= a-end [
			print-line ["^/*** Error: arguments stack overflow!^/"]
			halt
		]
		cell
	]

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

		copy-cell value top
		push*
	]

	pop: func [
		positions [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/pop"]]

		top: top - positions
	]

	top-type?: func [
		return:  [integer!]
		/local
			value [red-value!]
	][
		value: top - 1
		TYPE_OF(value)
	]

	func?: func [
		return: [logic!]
		/local
			value [red-value!]
			type  [integer!]
	][
		value: top - 1
		type: TYPE_OF(value)
		any [											;@@ replace with ANY_FUNCTION?
			type = TYPE_FUNCTION
			type = TYPE_ROUTINE
		]
	]

	defer-call: func [
		name   [red-word!]
		code   [integer!]
		count  [integer!]
		octx [node!]
		/local
			info [dyn-info!]
	][
		;mark-native words/_anon
		integer/push as-integer octx					;-- store optional wrapping object pointer

		info: as dyn-info! push*
		info/header: TYPE_POINT
		info/code:   code								;-- store wrapping function pointer
		info/count:  count								;-- store caller's arity
		info/locals: -2									;-- store caller's locals count

		mark-dyn name									;-- open new frame
		acc-mode?: yes
		arguments/header: TYPE_VALUE					;-- use TYPE_VALUE to signal "no argument"
	]

	push-call: func [
		path [red-path!]
		idx  [integer!]
		code [integer!]
		octx [node!]
		/local
			fun		 [red-function!]
			p		 [red-path!]
			info	 [dyn-info!]
			counters [integer!]
	][
		;mark-native words/_anon
		fun: as red-function! top - 1

		assert any [
			TYPE_OF(fun) = TYPE_FUNCTION
			TYPE_OF(fun) = TYPE_ROUTINE
		]
		counters: _function/calc-arity path fun idx
		p: as red-path! copy-cell as red-value! path push*
		p/head: idx										;-- store path with function's index

		integer/push as-integer octx					;-- store optional wrapping object pointer

		info: as dyn-info! push*
		info/header: TYPE_POINT
		info/code:   code								;-- store wrapping function pointer
		info/count:  counters and FFFFh					;-- store caller's arity
		info/locals: counters >> 16						;-- store caller's locals count

		mark-dyn as red-word! block/rs-abs-at as red-block! path idx  ;-- open new frame
		acc-mode?: yes

		either zero? (counters and FFFFh) [
			arguments/header: TYPE_UNSET
			check-dyn-call								;-- short path to call with no arguments
		][
			arguments/header: TYPE_VALUE				;-- use TYPE_VALUE to signal "no argument"
		]
	]

	check-dyn-call: func [
		/local
			int		   [red-integer!]
			fun		   [red-function!]
			obj		   [red-object!]
			base	   [red-value!]
			last	   [red-value!]
			info	   [dyn-info!]
			ctx		   [node!]
			octx	   [node!]
			more	   [series!]
			p		   [int-ptr!]
			dyn?	   [logic!]
			new-frame? [logic!]
			code
	][
		p: ctop - 2
		if p < cbottom [exit]

		if all [
			FLAG_DYN_CALL and p/1 = FLAG_DYN_CALL
			TYPE_OF(arguments) <> TYPE_VALUE
		][
			info: as dyn-info! arguments - 1
			unless zero? info/count [info/count: info/count - 1]

			if zero? info/count [
				base: arguments
				either info/locals = -2 [
					fun: null
					new-frame?: no
				][
					ctx: null
					fun: as red-function! base - 4
					more: as series! fun/more/value
					int: as red-integer! more/offset + 4
					obj: as red-object! base - 5
					case [
						TYPE_OF(obj) = TYPE_OBJECT  [ctx: obj/ctx]
						TYPE_OF(int) = TYPE_INTEGER [ctx: as node! int/value]
					]

					new-frame?: info/locals = -1
					case [
						info/locals > 0 [_function/init-locals info/locals]
						new-frame?		[_function/lay-frame]
						true			[0]					;-- 0 locals case, do nothing
					]
				]

				code: as function! [octx [node!]] info/code
				int: as red-integer! base - 2
				octx: as node! int/value

				acc-mode?: no							;-- temporary disable accumulative mode
				unless null? fun [_function/call fun ctx] ;-- run the detected function
				unless zero? info/code [code octx]		;-- run wrapper code (stored as function)
				if new-frame? [unwind-last]				;-- close new frame created for handling refinements

				last: arguments
				unwind									;-- close frame opened in 'push-call
				either all [
					null? fun							;-- for defered calls only
					arguments + 3 < top					;-- check if not first argument of parent call?
				][
					top: top - 2						;-- adjust stack to right position for next argument
				][
					copy-cell last arguments			;-- unwind-last
				]

				;base: arguments
				;unwind
				;push base
				acc-mode?: yes

				p: ctop - 2								;-- decide to keep or not the accumulative mode on
				either p < cbottom [
					acc-mode?: no						;-- bottom of stack reached, switch back to normal
				][
					dyn?: FLAG_DYN_CALL and p/1 = FLAG_DYN_CALL
					either dyn? [check-dyn-call][acc-mode?: no] ;-- if another dyn call pending, keep the mode on
				]
			]
		]
	]

	#if debug? = yes [
		dump: does [									;-- debug purpose only
			print-line "^/---- Argument stack ----"
			dump-memory
				as byte-ptr! bottom
				4
				(as-integer top + 1 - bottom) >> 4
			print-line ["arguments: " arguments]
			print-line ["top: " top]

			print-line "^/---- Call stack ----"
			dump-memory
				as byte-ptr! cbottom
				4
				(as-integer ctop + 4 - cbottom) >> 4
			print-line ["ctop: " ctop]
		]
	]
]

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

stack: context [										;-- call stack
	verbose: 0

	dyn-info!: alias struct! [
		header [integer!]
		code   [integer!]
		count  [integer!]
		locals [integer!]
	]

	arg-stk:		declare red-block!					;-- argument stack (should never be relocated)
	call-stk:		declare red-block!					;-- call stack (should never be relocated)
	args-series:	declare series!
	calls-series:	declare series!
	a-end: 			declare red-value!
	c-end: 			declare int-ptr!
	arguments:		declare red-value!
	bottom:  		declare red-value!
	top:	 		declare red-value!
	cbottom: 		declare int-ptr!
	ctop:	 		declare int-ptr!

	acc-mode?: no										;-- YES: accumulate expressions on stack

	#define MARK_STACK(type) [
		func [
			fun [red-word!]
		][
			#if debug? = yes [if verbose > 0 [print-line "stack/mark"]]

			if ctop = c-end [
				print-line ["^/*** Error: call stack overflow!^/"]
				halt
			]
			ctop/1: type or (fun/symbol << 8)
			ctop/2: as-integer arguments
			arguments: top								;-- top of stack becomes frame base
			ctop: ctop + 2

			#if debug? = yes [if verbose > 1 [dump]]
		]
	]

	#define STACK_SET_FRAME [
		either ctop = cbottom [
			arguments: bottom
			top: bottom
		][
			top: arguments + 1							;-- keep last value on stack
			arguments: as red-value! ctop/2
		]
	]

	;-- header flags
	#enum flags! [
		FLAG_FUNCTION:	80000000h						;-- function! call
		FLAG_NATIVE:	40000000h						;-- native! or action! call
		FLAG_ROUTINE:	20000000h						;--	<reserved>
		FLAG_TRY:		10000000h						;--	TRY native
		FLAG_CATCH:		08000000h						;-- CATCH native
		FLAG_THROW_ATR:	04000000h						;-- Throw function attribut
		FLAG_CATCH_ATR:	02000000h						;--	Catch function attribut
		FLAG_EVAL:		01000000h						;-- Interpreter root frame
		FLAG_DYN_CALL:	11000000h						;-- Dynamic call (alternative stack mode)
	]

	init: does [
		arg-stk:  block/make-in root 1024
		call-stk: block/make-in root 512

		set-flag arg-stk/node flag-series-fixed or flag-series-nogc
		set-flag call-stk/node flag-series-fixed or flag-series-nogc

		;-- Shortcuts for stack buffers simpler and faster access
		;-- (stack buffers are not resizable with such approach
		;-- this can be made more flexible (but slower) if necessary
		;-- in the future)

		args-series:  GET_BUFFER(arg-stk)
		calls-series: GET_BUFFER(call-stk)

		a-end: as cell!    (as byte-ptr! args-series)  + args-series/size
		c-end: as int-ptr! (as byte-ptr! calls-series) + calls-series/size

		arguments:	args-series/tail
		bottom:  	args-series/offset
		top:	 	args-series/tail
		cbottom: 	as int-ptr! calls-series/offset
		ctop:	 	as int-ptr! calls-series/tail
	]

	check-call: does [
		if acc-mode? [check-dyn-call]
	]

	reset: func [
		return:  [cell!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/reset"]]

		either acc-mode? [check-dyn-call][top: arguments]
		arguments
	]

	keep: func [
		return:  [cell!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/keep"]]

		top: arguments + 1								;-- keep last value in arguments slot
		if acc-mode? [check-dyn-call]
		arguments
	]

	mark-native: MARK_STACK(FLAG_NATIVE)
	mark-func:	 MARK_STACK(FLAG_FUNCTION)
	mark-try:	 MARK_STACK(FLAG_TRY)
	mark-catch:	 MARK_STACK(FLAG_CATCH)
	mark-eval:	 MARK_STACK(FLAG_EVAL)
	mark-dyn:	 MARK_STACK(FLAG_DYN_CALL)

	revert: does [
		#if debug? = yes [if verbose > 0 [print-line "stack/revert"]]

		assert cbottom < ctop
		ctop: ctop - 2
		either ctop = cbottom [
			arguments: bottom
			top: bottom
		][
			top: arguments
			arguments: as red-value! ctop/2
		]

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind-part: does [
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind-part"]]

		assert cbottom < ctop
		ctop: ctop - 2
		either ctop = cbottom [
			arguments: bottom
		][
			arguments: as red-value! ctop/2
		]
		top: top - 1

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind: does [
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind"]]

		assert cbottom < ctop
		ctop: ctop - 2
		STACK_SET_FRAME
		if acc-mode? [check-dyn-call]

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind-last: func [
		return:  [red-value!]
		/local
			last [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind-last"]]

		last: arguments
		unwind
		copy-cell last arguments
	]

	unroll: func [
		flags	 [integer!]
		/local
			last [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/unroll"]]

		last: arguments
		assert cbottom < ctop
		until [
			ctop: ctop - 2
			any [
				flags and ctop/1 = flags
				ctop <= cbottom
			]
		]

		STACK_SET_FRAME
		ctop: ctop + 2									;-- ctop points past the current call frame
		copy-cell last as red-value! ctop/2
	]

	eval?: func [
		return: [logic!]
		/local
			cframe [int-ptr!]
	][
		cframe: ctop
		until [
			cframe: cframe - 2
			if FLAG_EVAL and cframe/1 = FLAG_EVAL [return yes]
			cframe <= cbottom
		]
		no
	]

	set-last: func [
		last	[red-value!]
		return: [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/set-last"]]

		copy-cell last arguments
	]

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

		cell: top
		top: top + 1
		if top >= a-end [
			print-line ["^/*** Error: arguments stack overflow!^/"]
			halt
		]
		cell
	]

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

		copy-cell value top
		push*
	]

	pop: func [
		positions [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/pop"]]

		top: top - positions
	]

	top-type?: func [
		return:  [integer!]
		/local
			value [red-value!]
	][
		value: top - 1
		TYPE_OF(value)
	]

	func?: func [
		return: [logic!]
		/local
			value [red-value!]
			type  [integer!]
	][
		value: top - 1
		type: TYPE_OF(value)
		any [											;@@ replace with ANY_FUNCTION?
			type = TYPE_FUNCTION
			type = TYPE_ROUTINE
		]
	]

	defer-call: func [
		name   [red-word!]
		code   [integer!]
		count  [integer!]
		octx [node!]
		/local
			info [dyn-info!]
	][
		;mark-native words/_anon
		integer/push as-integer octx					;-- store optional wrapping object pointer

		info: as dyn-info! push*
		info/header: TYPE_POINT
		info/code:   code								;-- store wrapping function pointer
		info/count:  count								;-- store caller's arity
		info/locals: -2									;-- store caller's locals count

		mark-dyn name									;-- open new frame
		acc-mode?: yes
		arguments/header: TYPE_VALUE					;-- use TYPE_VALUE to signal "no argument"
	]

	push-call: func [
		path [red-path!]
		idx  [integer!]
		code [integer!]
		octx [node!]
		/local
			fun		 [red-function!]
			p		 [red-path!]
			info	 [dyn-info!]
			counters [integer!]
	][
		;mark-native words/_anon
		fun: as red-function! top - 1

		assert any [
			TYPE_OF(fun) = TYPE_FUNCTION
			TYPE_OF(fun) = TYPE_ROUTINE
		]
		counters: _function/calc-arity path fun idx
		p: as red-path! copy-cell as red-value! path push*
		p/head: idx										;-- store path with function's index

		integer/push as-integer octx					;-- store optional wrapping object pointer

		info: as dyn-info! push*
		info/header: TYPE_POINT
		info/code:   code								;-- store wrapping function pointer
		info/count:  counters and FFFFh					;-- store caller's arity
		info/locals: counters >> 16						;-- store caller's locals count

		mark-dyn as red-word! block/rs-abs-at as red-block! path idx  ;-- open new frame
		acc-mode?: yes

		either zero? (counters and FFFFh) [
			arguments/header: TYPE_UNSET
			check-dyn-call								;-- short path to call with no arguments
		][
			arguments/header: TYPE_VALUE				;-- use TYPE_VALUE to signal "no argument"
		]
	]

	check-dyn-call: func [
		/local
			int		   [red-integer!]
			fun		   [red-function!]
			obj		   [red-object!]
			base	   [red-value!]
			info	   [dyn-info!]
			ctx		   [node!]
			octx	   [node!]
			more	   [series!]
			p		   [int-ptr!]
			dyn?	   [logic!]
			new-frame? [logic!]
			code
	][
		p: ctop - 2
		if p < cbottom [exit]

		if all [
			FLAG_DYN_CALL and p/1 = FLAG_DYN_CALL
			TYPE_OF(arguments) <> TYPE_VALUE
		][
			info: as dyn-info! arguments - 1
			unless zero? info/count [info/count: info/count - 1]

			if zero? info/count [
				base: arguments
				either info/locals = -2 [
					fun: null
					new-frame?: no
				][
					ctx: null
					fun: as red-function! base - 4
					more: as series! fun/more/value
					int: as red-integer! more/offset + 4
					obj: as red-object! base - 5
					case [
						TYPE_OF(obj) = TYPE_OBJECT  [ctx: obj/ctx]
						TYPE_OF(int) = TYPE_INTEGER [ctx: as node! int/value]
					]

					new-frame?: info/locals = -1
					case [
						info/locals > 0 [_function/init-locals info/locals]
						new-frame?		[_function/lay-frame]
						true			[0]					;-- 0 locals case, do nothing
					]
				]

				code: as function! [octx [node!]] info/code
				int: as red-integer! base - 2
				octx: as node! int/value

				acc-mode?: no							;-- temporary disable accumulative mode
				unless null? fun [_function/call fun ctx] ;-- run the detected function
				unless zero? info/code [code octx]		;-- run wrapper code (stored as function)
				if new-frame? [unwind-last]				;-- close new frame created for handling refinements
				unwind-last								;-- close frame opened in 'push-call

				;base: arguments
				;unwind
				;push base
				acc-mode?: yes

				p: ctop - 2								;-- decide to keep or not the accumulative mode on
				either p < cbottom [
					acc-mode?: no						;-- bottom of stack reached, switch back to normal
				][
					dyn?: FLAG_DYN_CALL and p/1 = FLAG_DYN_CALL
					either dyn? [check-dyn-call][acc-mode?: no] ;-- if another dyn call pending, keep the mode on
				]
			]
		]
	]

	#if debug? = yes [
		dump: does [									;-- debug purpose only
			print-line "^/---- Argument stack ----"
			dump-memory
				as byte-ptr! bottom
				4
				(as-integer top + 1 - bottom) >> 4
			print-line ["arguments: " arguments]
			print-line ["top: " top]

			print-line "^/---- Call stack ----"
			dump-memory
				as byte-ptr! cbottom
				4
				(as-integer ctop + 4 - cbottom) >> 4
			print-line ["ctop: " ctop]
		]
	]
]


FEAT: make integer/push returns the boxed value.

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

integer: context [
	verbose: 0

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

	get-any*: func [									;-- special get* variant for SWITCH
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		either TYPE_OF(int) = TYPE_INTEGER [int/value][0] ;-- accept NONE values
	]

	get: func [											;-- unboxing integer value
		value	[red-value!]
		return: [integer!]
		/local
			int [red-integer!]
	][
		assert TYPE_OF(value) = TYPE_INTEGER
		int: as red-integer! value
		int/value
	]

	box: func [
		value	[integer!]
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/header: TYPE_INTEGER
		int/value: value
		int
	]

	form-signed: func [									;@@ replace with sprintf() call?
		i 		[integer!]
		return: [c-string!]
		/local
			s	[c-string!]
			c 	[integer!]
			n 	[logic!]
	][
		s: "-0000000000"								;-- 11 bytes wide
		if zero? i [									;-- zero special case
			s/11: #"0"
			return s + 10
		]
		if i = -2147483648 [							;-- min integer special case
			return "-2147483648"
		]
		n: negative? i
		if n [i: negate i]
		c: 11
		while [i <> 0][
			s/c: #"0" + (i // 10)
			i: i / 10
			c: c - 1
		]
		if n [s/c: #"-" c: c - 1]
		s + c
	]

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

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

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

		left/value: switch type [
			OP_ADD [left/value + right/value]
			OP_SUB [left/value - right/value]
			OP_MUL [left/value * right/value]
			OP_DIV [left/value / right/value]
		]
		left
	]

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

		int: as red-integer! ALLOC_TAIL(blk)
		int/header: TYPE_INTEGER
		int/value: value
	]

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

		int: as red-integer! stack/push*
		int/header: TYPE_INTEGER
		int/value: value
		int
	]

	;-- Actions --

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

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

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

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

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

		form int buffer arg part
	]

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

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_INTEGER [
				right: value2/value
			]
			TYPE_CHAR [
				char: as red-char! value2				;@@ could be optimized as integer! and char!
				right: char/value						;@@ structures are overlapping exactly
			]
			default [RETURN_COMPARE_OTHER]
		]
		switch op [
			COMP_EQUAL 			[res: left = right]
			COMP_NOT_EQUAL 		[res: left <> right]
			COMP_STRICT_EQUAL	[res: all [TYPE_OF(value2) = TYPE_INTEGER left = right]]
			COMP_LESSER			[res: left <  right]
			COMP_LESSER_EQUAL	[res: left <= right]
			COMP_GREATER		[res: left >  right]
			COMP_GREATER_EQUAL	[res: left >= right]
		]
		res
	]

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

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

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

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

	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
	]

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

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

integer: context [
	verbose: 0

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

	get-any*: func [									;-- special get* variant for SWITCH
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		either TYPE_OF(int) = TYPE_INTEGER [int/value][0] ;-- accept NONE values
	]

	get: func [											;-- unboxing integer value
		value	[red-value!]
		return: [integer!]
		/local
			int [red-integer!]
	][
		assert TYPE_OF(value) = TYPE_INTEGER
		int: as red-integer! value
		int/value
	]

	box: func [
		value	[integer!]
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/header: TYPE_INTEGER
		int/value: value
		int
	]

	form-signed: func [									;@@ replace with sprintf() call?
		i 		[integer!]
		return: [c-string!]
		/local
			s	[c-string!]
			c 	[integer!]
			n 	[logic!]
	][
		s: "-0000000000"								;-- 11 bytes wide
		if zero? i [									;-- zero special case
			s/11: #"0"
			return s + 10
		]
		if i = -2147483648 [							;-- min integer special case
			return "-2147483648"
		]
		n: negative? i
		if n [i: negate i]
		c: 11
		while [i <> 0][
			s/c: #"0" + (i // 10)
			i: i / 10
			c: c - 1
		]
		if n [s/c: #"-" c: c - 1]
		s + c
	]

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

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

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

		left/value: switch type [
			OP_ADD [left/value + right/value]
			OP_SUB [left/value - right/value]
			OP_MUL [left/value * right/value]
			OP_DIV [left/value / right/value]
		]
		left
	]

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

		int: as red-integer! ALLOC_TAIL(blk)
		int/header: TYPE_INTEGER
		int/value: value
	]

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

		int: as red-integer! stack/push*
		int/header: TYPE_INTEGER
		int/value: value
	]

	;-- Actions --

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

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

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

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

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

		form int buffer arg part
	]

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

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_INTEGER [
				right: value2/value
			]
			TYPE_CHAR [
				char: as red-char! value2				;@@ could be optimized as integer! and char!
				right: char/value						;@@ structures are overlapping exactly
			]
			default [RETURN_COMPARE_OTHER]
		]
		switch op [
			COMP_EQUAL 			[res: left = right]
			COMP_NOT_EQUAL 		[res: left <> right]
			COMP_STRICT_EQUAL	[res: all [TYPE_OF(value2) = TYPE_INTEGER left = right]]
			COMP_LESSER			[res: left <  right]
			COMP_LESSER_EQUAL	[res: left <= right]
			COMP_GREATER		[res: left >  right]
			COMP_GREATER_EQUAL	[res: left >= right]
		]
		res
	]

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

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

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

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

	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
	]

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


TESTS: added vector select tests

TESTS: added vector select tests

Red [
	Title:   "Red series test script"
	Author:  "Peter W A Wood"
	File: 	 %vector-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/red/red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "vector"

===start-group=== "make"

	vector-make-test: func [
		name [string!]
		type [datatype!]
		spec [block!]
		len [integer!]
		test-value [char! float! integer!]
		/local
			vm-v
	][
		--test-- name
		vm-v: make vector! spec
		--assert len = length? vm-v
		foreach v vm-v [
			test-value: test-value + 1
			--assert test-value = v
			--assert type = type? v
		]
		--assert none = vm-v/0
		--assert none = vm-v/(len + 1)
	]

	--test-- "vector-make-1"
		vm1-v: make vector! 10
		--assert 10 = length? vm1-v
		foreach v vm1-v [
			--assert v = 0
			--assert integer! = type? v
		]
		--assert none = vm1-v/0
		--assert none = vm1-v/11

	vector-make-test "vector-make-2" integer! [1 2 3 4 5] 5 0

	vector-make-test "vector-make-3" char! [#"b" #"c" #"d" #"e"] 4 #"a"

	vector-make-test "vector-make-4" float! [1.0 2.0 3.0 4.0 5.0] 5 0.0

	vector-make-test "vector-make-5" integer! [integer! 8 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-6" integer! [integer! 16 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-7" integer! [integer! 32 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-8" float! [float! 64 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

	vector-make-test "vector-make-9" float! [float! 32 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

===end-group===

===start-group=== "vector-truncate"

	--test-- "vector-trunc-1"
		vt1-v: make vector! [char! 8 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt1-v #"^(0100)"
		--assert 4 = length? vt1-v
		--assert #"^(00)" = vt1-v/4
		--assert none = vt1-v/5

	--test-- "vector-trunc-2"
		vt2-v: make vector! [char! 16 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt2-v #"^(100100)"
		--assert 4 = length? vt2-v
		--assert #"^(0100)" = vt2-v/4
		--assert none = vt2-v/5

	--test-- "vector-trunc-3"
		vt3-v: make vector! [integer! 8 [0 1 2]]
		append vt3-v 256
		--assert 4 = length? vt3-v
		--assert 0 = vt3-v/4
		--assert none = vt3-v/5

	--test-- "vector-trunc-4"
		vt4-v: make vector! [integer! 16 [0 1 2]]
		append vt4-v 65536
		--assert 4 = length? vt4-v
		--assert 0 = vt4-v/4
		--assert none = vt4-v/5

	--test-- "vector-trunc-6"
		vt5-v: make vector! [float! 32 [0.0 1.0 2.0]]
		append vt5-v 1.23456789012345678901234567
		--assert 1.2345679 = round/to vt5-v/4 0.0000001

===end-group===

===start-group=== "vector path notation"

	--test-- "vector-path-1"
		vp1-v: [0 1 2 3 4]
		--assert none = vp1-v/0
		--assert 0 = vp1-v/1
		--assert 1 = vp1-v/2
		--assert 2 = vp1-v/3
		--assert 3 = vp1-v/4
		--assert 4 = vp1-v/5
		--assert none = vp1-v/6
		--assert none = vp1-v/-1

===end-group===

===start-group=== "vector navigation"

	--test-- "vector-navigation-1"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next vn-v
		--assert vn-v/1 = 1
		--assert vn-v/4 = 4

	--test-- "vector-navigation-2"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next next vn-v
		--assert vn-v/1 = 2
		--assert vn-v/3 = 4

	--test-- "vector-navigation-3"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next next next vn-v
		--assert vn-v/1 = 3
		--assert vn-v/2 = 4

	--test-- "vector-navigation-4"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next next next next vn-v
		--assert vn-v/1 = 4

	--test-- "vector-navigation-5"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: tail vn-v
		--assert vn-v/1 = none

	--test-- "vector-navigation-6"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: back tail vn-v
		--assert vn-v/1 = 4

	--test-- "vector-navigation-7"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: head tail vn-v
		--assert vn-v/1 = 0
		--assert vn-v/5 = 4

===end-group===

===start-group=== "vector comparison"

	--test-- "vector-comparison-1"
		--assert (make vector! [1 2 3 4]) = make vector! [1 2 3 4]

	--test-- "vector-comparison-2"
		--assert (make vector! [1 2 3 4]) <> make vector! [1 2 3 3]

	--test-- "vector-comparison-3"
		--assert (make vector! [1 2 3 4]) > make vector! [1 2 3 3]

	--test-- "vector-comparison-4"
		--assert (make vector! [1 2 3 3]) < make vector! [1 2 3 4]

	--test-- "vector-comparison-5"
		--assert (make vector! [1 2 3]) < make vector! [1 2 3 4]

	--test-- "vector-comparison-6"
		--assert equal? make vector! [1 2 3 4] make vector! [1 2 3 4]

	--test-- "vector-comparison-7"
		--assert not equal? make vector! [1 2 3 4]make vector! [1 2 3 3]

	--test-- "vector-comparison-8"
		--assert greater? make vector! [1 2 3 4] make vector! [1 2 3 3]

	--test-- "vector-comparison-9"
		--assert lesser? make vector! [1 2 3 3] make vector! [1 2 3 4]

	--test-- "vector-comparison-10"
		--assert lesser? make vector! [1 2 3] make vector! [1 2 3 4]

===end-group===

===start-group=== "vector ordinal"

	--test-- "vector-ordinal-1"
		--assert 1 = first make vector! [1 2 3 4]

	--test-- "vector-ordinal-2"
		--assert 2 = second make vector! [1 2 3 4]

	--test-- "vector-ordinal-3"
		--assert 3 = third make vector! [1 2 3 4]

	--test-- "vector-ordinal-4"
		--assert 4 = fourth make vector! [1 2 3 4]

	--test-- "vector-ordinal-5"
		--assert 5 = fifth make vector! [1 2 3 4 5]

	--test-- "vector-ordinal-6"
		--assert none = fifth make vector! [1 2 3 4]

	--test-- "vector-ordinal-7"
		--assert 4 = last make vector! [1 2 3 4]

	--test-- "vector-ordinal-8"
		--assert 2 = first next make vector! [1 2 3 4]

	--test-- "vector-ordinal-7"
		--assert 3 = second next make vector! [1 2 3 4]

===end-group===

===start-group=== "vector-clear"

		empty-vector: make vector! []

	--test-- "vector-clear-1"
		--assert empty-vector = clear make vector! [1 2 3 4]

	--test-- "vector-clear-2"
		vc2-v: make vector! [1 2 3 4]
		append vc2-v 5
		--assert empty-vector = clear vc2-v

===end-group===

===start-group=== "vector-copy"

	--test-- "vector-copy-1"
		vcp1-v1: make vector! [1 2 3 4]
		vcp1-v2: copy vcp1-v1
		vcp1-v1/1: 5
		vcp1-v1/2: 6
		vcp1-v1/3: 7
		vcp1-v1/4: 8
		--assert vcp1-v1 = make vector! [5 6 7 8]
		--assert vcp1-v2 = make vector! [1 2 3 4]

	--test-- "vector-copy-2"
		vcp2-v: make vector! [1 2 3 4 5 6 7 8 9]
			--assert (make vector! [1 2 3 4]) = copy/part vcp2-v 4

	--test-- "vector-copy-3"
		vcp3-v: make vector! [1 2 3 4 5 6 7 8 9]
			--assert (make vector! [3 4]) = copy/part next next vcp3-v 2

	--test-- "vector-copy-4"
		vcp4-v: make vector! [1 2 3 4 5 6 7 8 9]
			--assert (make vector! [8]) = copy/part back back tail vcp4-v 1

	--test-- "vector-copy-5"
		vcp5-v: make vector! [1 2]
			--assert (make vector! [1 2]) = copy/part vcp5-v 4

===end-group===

===start-group=== "vector poke"

	--test-- "vector-poke-1"
		vp1-v: make vector! [1 2]
		poke vp1-v 1 0
		--assert (make vector! [0 2]) = vp1-v

	--test-- "vector-poke-2"
		vp2-v: make vector! [1 2 3]
		poke vp2-v 3 0
		--assert (make vector! [1 2 0]) = vp2-v

	--test-- "vector-poke-3"
		vp3-v: make vector! [1 2 3]
		poke vp3-v 2 0
		--assert (make vector! [1 0 3]) = vp3-v

===end-group===

===start-group=== "vector remove"

	--test-- "vector-remove-1"
		--assert (make vector! [2 3]) = remove make vector! [1 2 3]

	--test-- "vector-remove-2"
		--assert (make vector! [3]) = remove next make vector! [1 2 3]

	--test-- "vector-remove-3"
		--assert (make vector! []) = remove tail make vector! [1 2 3]

	--test-- "vector-remove-4"
		--assert (make vector! []) = remove back tail make vector! [1 2 3]

	--test-- "vector-remove-5"
		--assert (make vector! [3]) = remove back back tail make vector! [1 2 3]

===end-group===

===start-group=== "vector reverse"

	--test-- "vector-reverse-1"
		--assert (make vector! [4 3 2 1]) = reverse make vector! [1 2 3 4]

	--test-- "vector-reverse-2"
		--assert (make vector! [1 4 3 2 ]) = head reverse next make vector! [1 2 3 4]

	--test-- "vector-reverse-2"
		--assert (make vector! [1 2 3 4]) = head reverse tail make vector! [1 2 3 4]

===end-group===

===start-group=== "vector take"

	--test-- "vector-take-1"
		vt1-v: make vector! [1 2 3 4]
		--assert 1 = take vt1-v
		--assert vt1-v = make vector! [2 3 4]

	--test-- "vector-take-2"
		vt2-v: make vector! [1 2 3 4]
		--assert 2 = take next vt2-v
		--assert vt2-v = make vector! [1 3 4]

	--test-- "vector-take-3"
		vt3-v: make vector! [1 2 3 4]
		--assert 4 = take/last vt3-v
		--assert vt3-v = make vector! [1 2 3]

	--test-- "vector-take-4"
		vt4-v: make vector! [1 2 3 4]
		--assert (make vector! [1 2]) = take/part vt4-v 2
		--assert vt4-v = make vector! [3 4]

	--test-- "vector-take-5"
		vt5-v: make vector! [1 2 3 4]
		--assert (make vector! [1 2]) = take/part vt5-v find vt5-v 3
		--assert vt5-v = make vector! [3 4]

===end-group===

===start-group=== "vector sort"

	--test-- "vector-sort-1"
		--assert (make vector! [1 2 3]) = sort make vector! [3 2 1]

	--test-- "vector-sort-2"
		--assert (make vector! [3 1 2]) = head sort next make vector! [3 2 1]

	--test-- "vector-sort-3"
		--assert (make vector! [3 2 1]) = head sort tail make vector! [3 2 1]

	--test-- "vector-sort-4"
		--assert (make vector! [#"c" #"à" #"é"]) = sort make vector! [#"é" #"à" #"c"]

===end-group===

===start-group=== "vector find"

	--test-- "vector-find-1"
		--assert none = find make vector! [1 2 3 4] "five"

	--test-- "vector-find-2"
		--assert none = find next make vector! [1 2 3 4] 1

	--test-- "vector-find-3"
		--assert 1 = first find make vector! [1 2 3 4] 1

	--test-- "vector-find-4"
		--assert none = find make vector! [1 2 3 4] 1.0

	--test-- "vector-find-5"
		--assert 1 = length? find make vector! [1 2 3 4] 4

	--test-- "vector-find-6"
		--assert none = find/part make vector! [1 2 3 4] 4 3

	--test-- "vector-find-7"
		--assert 3 = first find/part make vector! [1 2 3 4] 3 3
		--assert 4 = second find/part make vector! [1 2 3 4] 3 3
		--assert 2 = length? find/part make vector! [1 2 3 4] 3 3

	--test-- "vector-find-8"
		--assert #"a" = first find/case make vector! [ #"A" #"a" #"b" #"c"] #"a"
		--assert 3 = length? find/case make vector! [ #"A" #"a" #"b" #"c"] #"a"

	--test-- "vector-find-9"
		--assert #"a" = first find make vector! [ #"A" #"a" #"b" #"c"] #"a"

	--test-- "vector-find-10"
		--assert (make vector! [4 5 6]) = find/skip make vector! [1 4 4 4 5 6] 4 3

	--test-- "vector-find-11"
		--assert (make vector! [1]) = find/last make vector! [1 1 1 1 1] 1

	--test-- "vector-find-12"
		vf12-v: next next next make vector! [1 2 1 2 1 2]
		--assert (make vector! [2 1 2 1 2]) = find/reverse vf12-v 2

	--test-- "vector-find-13"
		--assert (make vector! [5 6]) = find/tail make vector! [1 2 3 4 5 6] 4

	--test-- "vector-find-14"
		--assert (make vector! [3 4]) = find/match next make vector! [1 2 3 4] 2

===end-group===

===start-group=== "vector select"

	--test-- "vector-select-1"
		--assert none = select make vector! [1 2 3 4] "five"

	--test-- "vector-select-2"
		--assert none = select next make vector! [1 2 3 4] 1

	--test-- "vector-select-3"
		--assert 2 = select make vector! [1 2 3 4] 1

	--test-- "vector-select-4"
		--assert none = select make vector! [1 2 3 4] 1.0

	--test-- "vector-select-5"
		--assert 4 = select make vector! [1 2 3 4] 3

	--test-- "vector-select-6"
		--assert none = select/part make vector! [1 2 3 4] 4 3

	--test-- "vector-select-7"
		--assert 4 = select/part make vector! [1 2 3 4] 3 3

	--test-- "vector-select-8"
		--assert #"b" = select/case make vector! [ #"A" #"a" #"b" #"c"] #"a"

	--test-- "vector-select-9"
		--assert #"b" = select make vector! [ #"A" #"a" #"b" #"c"] #"a"

	--test-- "vector-select-10"
		--assert 5 = select/skip make vector! [1 4 4 4 5 6] 4 3

	--test-- "vector-select-11"
		--assert 1 = select/last make vector! [1 2 3 4 1] 4

	--test-- "vector-select-12"
		vs12-v: next next next next make vector! [1 2 1 2 3 4]
		--assert 3 = select/reverse vs12-v 2

===end-group===

~~~end-file~~~

Red [
	Title:   "Red series test script"
	Author:  "Peter W A Wood"
	File: 	 %vector-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/red/red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "vector"

===start-group=== "make"

	vector-make-test: func [
		name [string!]
		type [datatype!]
		spec [block!]
		len [integer!]
		test-value [char! float! integer!]
		/local
			vm-v
	][
		--test-- name
		vm-v: make vector! spec
		--assert len = length? vm-v
		foreach v vm-v [
			test-value: test-value + 1
			--assert test-value = v
			--assert type = type? v
		]
		--assert none = vm-v/0
		--assert none = vm-v/(len + 1)
	]

	--test-- "vector-make-1"
		vm1-v: make vector! 10
		--assert 10 = length? vm1-v
		foreach v vm1-v [
			--assert v = 0
			--assert integer! = type? v
		]
		--assert none = vm1-v/0
		--assert none = vm1-v/11

	vector-make-test "vector-make-2" integer! [1 2 3 4 5] 5 0

	vector-make-test "vector-make-3" char! [#"b" #"c" #"d" #"e"] 4 #"a"

	vector-make-test "vector-make-4" float! [1.0 2.0 3.0 4.0 5.0] 5 0.0

	vector-make-test "vector-make-5" integer! [integer! 8 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-6" integer! [integer! 16 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-7" integer! [integer! 32 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-8" float! [float! 64 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

	vector-make-test "vector-make-9" float! [float! 32 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

===end-group===

===start-group=== "vector-truncate"

	--test-- "vector-trunc-1"
		vt1-v: make vector! [char! 8 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt1-v #"^(0100)"
		--assert 4 = length? vt1-v
		--assert #"^(00)" = vt1-v/4
		--assert none = vt1-v/5

	--test-- "vector-trunc-2"
		vt2-v: make vector! [char! 16 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt2-v #"^(100100)"
		--assert 4 = length? vt2-v
		--assert #"^(0100)" = vt2-v/4
		--assert none = vt2-v/5

	--test-- "vector-trunc-3"
		vt3-v: make vector! [integer! 8 [0 1 2]]
		append vt3-v 256
		--assert 4 = length? vt3-v
		--assert 0 = vt3-v/4
		--assert none = vt3-v/5

	--test-- "vector-trunc-4"
		vt4-v: make vector! [integer! 16 [0 1 2]]
		append vt4-v 65536
		--assert 4 = length? vt4-v
		--assert 0 = vt4-v/4
		--assert none = vt4-v/5

	--test-- "vector-trunc-6"
		vt5-v: make vector! [float! 32 [0.0 1.0 2.0]]
		append vt5-v 1.23456789012345678901234567
		--assert 1.2345679 = round/to vt5-v/4 0.0000001

===end-group===

===start-group=== "vector path notation"

	--test-- "vector-path-1"
		vp1-v: [0 1 2 3 4]
		--assert none = vp1-v/0
		--assert 0 = vp1-v/1
		--assert 1 = vp1-v/2
		--assert 2 = vp1-v/3
		--assert 3 = vp1-v/4
		--assert 4 = vp1-v/5
		--assert none = vp1-v/6
		--assert none = vp1-v/-1

===end-group===

===start-group=== "vector navigation"

	--test-- "vector-navigation-1"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next vn-v
		--assert vn-v/1 = 1
		--assert vn-v/4 = 4

	--test-- "vector-navigation-2"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next next vn-v
		--assert vn-v/1 = 2
		--assert vn-v/3 = 4

	--test-- "vector-navigation-3"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next next next vn-v
		--assert vn-v/1 = 3
		--assert vn-v/2 = 4

	--test-- "vector-navigation-4"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next next next next vn-v
		--assert vn-v/1 = 4

	--test-- "vector-navigation-5"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: tail vn-v
		--assert vn-v/1 = none

	--test-- "vector-navigation-6"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: back tail vn-v
		--assert vn-v/1 = 4

	--test-- "vector-navigation-7"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: head tail vn-v
		--assert vn-v/1 = 0
		--assert vn-v/5 = 4

===end-group===

===start-group=== "vector comparison"

	--test-- "vector-comparison-1"
		--assert (make vector! [1 2 3 4]) = make vector! [1 2 3 4]

	--test-- "vector-comparison-2"
		--assert (make vector! [1 2 3 4]) <> make vector! [1 2 3 3]

	--test-- "vector-comparison-3"
		--assert (make vector! [1 2 3 4]) > make vector! [1 2 3 3]

	--test-- "vector-comparison-4"
		--assert (make vector! [1 2 3 3]) < make vector! [1 2 3 4]

	--test-- "vector-comparison-5"
		--assert (make vector! [1 2 3]) < make vector! [1 2 3 4]

	--test-- "vector-comparison-6"
		--assert equal? make vector! [1 2 3 4] make vector! [1 2 3 4]

	--test-- "vector-comparison-7"
		--assert not equal? make vector! [1 2 3 4]make vector! [1 2 3 3]

	--test-- "vector-comparison-8"
		--assert greater? make vector! [1 2 3 4] make vector! [1 2 3 3]

	--test-- "vector-comparison-9"
		--assert lesser? make vector! [1 2 3 3] make vector! [1 2 3 4]

	--test-- "vector-comparison-10"
		--assert lesser? make vector! [1 2 3] make vector! [1 2 3 4]

===end-group===

===start-group=== "vector ordinal"

	--test-- "vector-ordinal-1"
		--assert 1 = first make vector! [1 2 3 4]

	--test-- "vector-ordinal-2"
		--assert 2 = second make vector! [1 2 3 4]

	--test-- "vector-ordinal-3"
		--assert 3 = third make vector! [1 2 3 4]

	--test-- "vector-ordinal-4"
		--assert 4 = fourth make vector! [1 2 3 4]

	--test-- "vector-ordinal-5"
		--assert 5 = fifth make vector! [1 2 3 4 5]

	--test-- "vector-ordinal-6"
		--assert none = fifth make vector! [1 2 3 4]

	--test-- "vector-ordinal-7"
		--assert 4 = last make vector! [1 2 3 4]

	--test-- "vector-ordinal-8"
		--assert 2 = first next make vector! [1 2 3 4]

	--test-- "vector-ordinal-7"
		--assert 3 = second next make vector! [1 2 3 4]

===end-group===

===start-group=== "vector-clear"

		empty-vector: make vector! []

	--test-- "vector-clear-1"
		--assert empty-vector = clear make vector! [1 2 3 4]

	--test-- "vector-clear-2"
		vc2-v: make vector! [1 2 3 4]
		append vc2-v 5
		--assert empty-vector = clear vc2-v

===end-group===

===start-group=== "vector-copy"

	--test-- "vector-copy-1"
		vcp1-v1: make vector! [1 2 3 4]
		vcp1-v2: copy vcp1-v1
		vcp1-v1/1: 5
		vcp1-v1/2: 6
		vcp1-v1/3: 7
		vcp1-v1/4: 8
		--assert vcp1-v1 = make vector! [5 6 7 8]
		--assert vcp1-v2 = make vector! [1 2 3 4]

	--test-- "vector-copy-2"
		vcp2-v: make vector! [1 2 3 4 5 6 7 8 9]
			--assert (make vector! [1 2 3 4]) = copy/part vcp2-v 4

	--test-- "vector-copy-3"
		vcp3-v: make vector! [1 2 3 4 5 6 7 8 9]
			--assert (make vector! [3 4]) = copy/part next next vcp3-v 2

	--test-- "vector-copy-4"
		vcp4-v: make vector! [1 2 3 4 5 6 7 8 9]
			--assert (make vector! [8]) = copy/part back back tail vcp4-v 1

	--test-- "vector-copy-5"
		vcp5-v: make vector! [1 2]
			--assert (make vector! [1 2]) = copy/part vcp5-v 4

===end-group===

===start-group=== "vector poke"

	--test-- "vector-poke-1"
		vp1-v: make vector! [1 2]
		poke vp1-v 1 0
		--assert (make vector! [0 2]) = vp1-v

	--test-- "vector-poke-2"
		vp2-v: make vector! [1 2 3]
		poke vp2-v 3 0
		--assert (make vector! [1 2 0]) = vp2-v

	--test-- "vector-poke-3"
		vp3-v: make vector! [1 2 3]
		poke vp3-v 2 0
		--assert (make vector! [1 0 3]) = vp3-v

===end-group===

===start-group=== "vector remove"

	--test-- "vector-remove-1"
		--assert (make vector! [2 3]) = remove make vector! [1 2 3]

	--test-- "vector-remove-2"
		--assert (make vector! [3]) = remove next make vector! [1 2 3]

	--test-- "vector-remove-3"
		--assert (make vector! []) = remove tail make vector! [1 2 3]

	--test-- "vector-remove-4"
		--assert (make vector! []) = remove back tail make vector! [1 2 3]

	--test-- "vector-remove-5"
		--assert (make vector! [3]) = remove back back tail make vector! [1 2 3]

===end-group===

===start-group=== "vector reverse"

	--test-- "vector-reverse-1"
		--assert (make vector! [4 3 2 1]) = reverse make vector! [1 2 3 4]

	--test-- "vector-reverse-2"
		--assert (make vector! [1 4 3 2 ]) = head reverse next make vector! [1 2 3 4]

	--test-- "vector-reverse-2"
		--assert (make vector! [1 2 3 4]) = head reverse tail make vector! [1 2 3 4]

===end-group===

===start-group=== "vector take"

	--test-- "vector-take-1"
		vt1-v: make vector! [1 2 3 4]
		--assert 1 = take vt1-v
		--assert vt1-v = make vector! [2 3 4]

	--test-- "vector-take-2"
		vt2-v: make vector! [1 2 3 4]
		--assert 2 = take next vt2-v
		--assert vt2-v = make vector! [1 3 4]

	--test-- "vector-take-3"
		vt3-v: make vector! [1 2 3 4]
		--assert 4 = take/last vt3-v
		--assert vt3-v = make vector! [1 2 3]

	--test-- "vector-take-4"
		vt4-v: make vector! [1 2 3 4]
		--assert (make vector! [1 2]) = take/part vt4-v 2
		--assert vt4-v = make vector! [3 4]

	--test-- "vector-take-5"
		vt5-v: make vector! [1 2 3 4]
		--assert (make vector! [1 2]) = take/part vt5-v find vt5-v 3
		--assert vt5-v = make vector! [3 4]

===end-group===

===start-group=== "vector sort"

	--test-- "vector-sort-1"
		--assert (make vector! [1 2 3]) = sort make vector! [3 2 1]

	--test-- "vector-sort-2"
		--assert (make vector! [3 1 2]) = head sort next make vector! [3 2 1]

	--test-- "vector-sort-3"
		--assert (make vector! [3 2 1]) = head sort tail make vector! [3 2 1]

	--test-- "vector-sort-4"
		--assert (make vector! [#"c" #"à" #"é"]) = sort make vector! [#"é" #"à" #"c"]

===end-group===

===start-group=== "vector find"

	--test-- "vector-find-1"
		--assert none = find make vector! [1 2 3 4] "five"

	--test-- "vector-find-2"
		--assert none = find next make vector! [1 2 3 4] 1

	--test-- "vector-find-3"
		--assert 1 = first find make vector! [1 2 3 4] 1

	--test-- "vector-find-4"
		--assert none = find make vector! [1 2 3 4] 1.0

	--test-- "vector-find-5"
		--assert 1 = length? find make vector! [1 2 3 4] 4

	--test-- "vector-find-6"
		--assert none = find/part make vector! [1 2 3 4] 4 3

	--test-- "vector-find-7"
		--assert 3 = first find/part make vector! [1 2 3 4] 3 3
		--assert 4 = second find/part make vector! [1 2 3 4] 3 3
		--assert 2 = length? find/part make vector! [1 2 3 4] 3 3

	--test-- "vector-find-8"
		--assert #"a" = first find/case make vector! [ #"A" #"a" #"b" #"c"] #"a"
		--assert 3 = length? find/case make vector! [ #"A" #"a" #"b" #"c"] #"a"

	--test-- "vector-find-9"
		--assert #"a" = first find make vector! [ #"A" #"a" #"b" #"c"] #"a"

	--test-- "vector-find-10"
		--assert (make vector! [4 5 6]) = find/skip make vector! [1 4 4 4 5 6] 4 3

	--test-- "vector-find-11"
		--assert (make vector! [1]) = find/last make vector! [1 1 1 1 1] 1

	--test-- "vector-find-12"
		vf12-v: next next next make vector! [1 2 1 2 1 2]
		--assert (make vector! [2 1 2 1 2]) = find/reverse vf12-v 2

	--test-- "vector-find-13"
		--assert (make vector! [5 6]) = find/tail make vector! [1 2 3 4 5 6] 4

	--test-- "vector-find-14"
		--assert (make vector! [3 4]) = find/match next make vector! [1 2 3 4] 2

===end-group===

~~~end-file~~~


FEAT: functions' bodies are now correctly rebound in new objects.

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

object: context [
	verbose: 0

	serialize: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent? [logic!]
		return: [integer!]
		/local
			syms	[series!]
			values	[series!]
			sym		[red-value!]
			s-tail	[red-value!]
			value	[red-value!]
	][
		syms:   as series! obj/symbols/value
		values: as series! obj/values/value

		sym:	syms/offset
		s-tail: syms/tail
		value: 	values/offset

		while [sym < s-tail][
			if indent? [
				string/concatenate-literal buffer "    "
				part: part - 4
			]

			part: word/mold as red-word! sym buffer no no flat? arg part
			string/concatenate-literal buffer ": "
			part: part - 2

			part: actions/mold value buffer only? all? flat? arg part

			if any [indent? sym + 1 < s-tail][			;-- no final LF when FORMed
				string/append-char GET_BUFFER(buffer) as-integer lf
				part: part - 1
			]
			sym: sym + 1
			value: value + 1
		]
		part
	]

	rebind: func [
		fun		[red-function!]
		ctx 	[red-context!]
		/local
			s	 [series!]
			more [red-value!]
	][
		s: as series! fun/more/value
		more: s/offset

		if TYPE_OF(more) = TYPE_NONE [
			print-line "*** Error: COPY stuck on missing function's body block"
			halt
		]
		_context/bind as red-block! more ctx
		_context/bind as red-block! more fun/ctx

		more: more + 2
		more/header: TYPE_UNSET			;-- invalidate compiled body
	]

	make-at: func [
		cell	[red-object!]
		slots	[integer!]
		return: [red-object!]
	][
		cell/header:  TYPE_OBJECT
		cell/symbols: alloc-cells slots
		cell/values:  alloc-cells slots
		cell
	]

	;-- Actions --

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

		obj: as red-object! ALLOC_TAIl(root)

		either TYPE_OF(proto) = TYPE_OBJECT [
			copy proto obj null yes null				;-- /deep
		][
			make-at obj 4								;-- arbitrary value
		]
		_context/collect-set-words as red-context! obj spec
		_context/bind spec as red-context! obj
		interpreter/eval spec
		obj
	]

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

		serialize obj buffer no no no arg part no
	]

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

		string/concatenate-literal buffer "make object! [^/"
		part: serialize obj buffer only? all? flat? arg part - 15 yes
		string/append-char GET_BUFFER(buffer) as-integer #"]"
		part - 1
	]

	eval-path: func [
		parent	[red-object!]							;-- implicit type casting
		element	[red-value!]
		set?	[logic!]
		return:	[red-value!]
		/local
			word [red-word!]
			ctx  [red-context!]
	][
		word: as red-word! element
		ctx:  as red-context! parent

		if word/ctx <> ctx [							;-- bind the word to object's context
			word/index: _context/find-word ctx word/symbol
			word/ctx: ctx
		]
		either set? [
			_context/set-in word stack/arguments ctx
			stack/arguments
		][
			_context/get-in word ctx
		]
	]

	copy: func [
		obj      [red-object!]
		new	  	 [red-object!]
		part-arg [red-value!]
		deep?	 [logic!]
		types	 [red-value!]
		return:	 [red-object!]
		/local
			value [red-value!]
			tail  [red-value!]
			src	  [series!]
			dst	  [series!]
			size  [integer!]
			slots [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/copy"]]

		if OPTION?(types) [--NOT_IMPLEMENTED--]

		if OPTION?(part-arg) [
			print-line "***Error: copy/part is not supported on objects"
			halt
		]

		src:	as series! obj/symbols/value
		size:   as-integer src/tail - src/offset
		slots:	size >> 4

		new: make-at new slots

		;-- process SYMBOLS
		dst: as series! new/symbols/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots
		_context/set-context-each as red-context! new dst

		;-- process VALUES
		src: as series! obj/values/value
		dst: as series! new/values/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots

		if deep? [
			value: dst/offset
			tail:  dst/tail

			while [value < tail][
				switch TYPE_OF(value) [					;@@ replace it with ANY_SERIES?()
					TYPE_BLOCK
					TYPE_PAREN
					TYPE_PATH
					TYPE_SET_PATH
					TYPE_GET_PATH
					TYPE_LIT_PATH
					TYPE_STRING
					TYPE_FILE [
						actions/copy value value null yes null ;-- overwrite the value
					]
					TYPE_FUNCTION [
						rebind as red-function! value as red-context! new
					]
					default [0]
				]
				value: value + 1
			]
		]

		new
	]

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

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

object: context [
	verbose: 0

	serialize: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent? [logic!]
		return: [integer!]
		/local
			syms	[series!]
			values	[series!]
			sym		[red-value!]
			s-tail	[red-value!]
			value	[red-value!]
	][
		syms:   as series! obj/symbols/value
		values: as series! obj/values/value

		sym:	syms/offset
		s-tail: syms/tail
		value: 	values/offset

		while [sym < s-tail][
			if indent? [
				string/concatenate-literal buffer "    "
				part: part - 4
			]

			part: word/mold as red-word! sym buffer no no flat? arg part
			string/concatenate-literal buffer ": "
			part: part - 2

			part: actions/mold value buffer only? all? flat? arg part

			if any [indent? sym + 1 < s-tail][			;-- no final LF when FORMed
				string/append-char GET_BUFFER(buffer) as-integer lf
				part: part - 1
			]
			sym: sym + 1
			value: value + 1
		]
		part
	]

	make-at: func [
		cell	[red-object!]
		slots	[integer!]
		return: [red-object!]
	][
		cell/header:  TYPE_OBJECT
		cell/symbols: alloc-cells slots
		cell/values:  alloc-cells slots
		cell
	]

	;-- Actions --

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

		obj: as red-object! ALLOC_TAIl(root)

		either TYPE_OF(proto) = TYPE_OBJECT [
			copy proto obj null yes null				;-- /deep
		][
			make-at obj 4								;-- arbitrary value
		]
		_context/collect-set-words as red-context! obj spec
		_context/bind spec as red-context! obj
		interpreter/eval spec
		obj
	]

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

		serialize obj buffer no no no arg part no
	]

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

		string/concatenate-literal buffer "make object! [^/"
		part: serialize obj buffer only? all? flat? arg part - 15 yes
		string/append-char GET_BUFFER(buffer) as-integer #"]"
		part - 1
	]

	eval-path: func [
		parent	[red-object!]							;-- implicit type casting
		element	[red-value!]
		set?	[logic!]
		return:	[red-value!]
		/local
			word [red-word!]
			ctx  [red-context!]
	][
		word: as red-word! element
		ctx:  as red-context! parent

		if word/ctx <> ctx [							;-- bind the word to object's context
			word/index: _context/find-word ctx word/symbol
			word/ctx: ctx
		]
		either set? [
			_context/set-in word stack/arguments ctx
			stack/arguments
		][
			_context/get-in word ctx
		]
	]

	copy: func [
		obj      [red-object!]
		new	  	 [red-object!]
		part-arg [red-value!]
		deep?	 [logic!]
		types	 [red-value!]
		return:	 [red-object!]
		/local
			value [red-value!]
			tail  [red-value!]
			src	  [series!]
			dst	  [series!]
			size  [integer!]
			slots [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/copy"]]

		if OPTION?(types) [--NOT_IMPLEMENTED--]

		if OPTION?(part-arg) [
			print-line "***Error: copy/part is not supported on objects"
			halt
		]

		src:	as series! obj/symbols/value
		size:   as-integer src/tail - src/offset
		slots:	size >> 4

		new: make-at new slots

		;-- process SYMBOLS
		dst: as series! new/symbols/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots
		_context/set-context-each as red-context! new dst

		;-- process VALUES
		src: as series! obj/values/value
		dst: as series! new/values/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots

		if deep? [
			value: dst/offset
			tail:  dst/tail

			while [value < tail][
				switch TYPE_OF(value) [					;@@ replace it with ANY_SERIES?()
					TYPE_BLOCK
					TYPE_PAREN
					TYPE_PATH
					TYPE_SET_PATH
					TYPE_GET_PATH
					TYPE_LIT_PATH
					TYPE_STRING
					TYPE_FILE [
						actions/copy value value null yes null ;-- overwrite the value
					]
					;TYPE_FUNCTION [

					;]
					default [0]
				]
				value: value + 1
			]
		]

		new
	]

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