FIX: issue #429 (MOLD TAB incorrect).

FIX: issue #429 (MOLD TAB incorrect).

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

string: context [
	verbose: 0

	#define BRACES_THRESHOLD	50						;-- max string length for using " delimiter
	#define MAX_ESC_CHARS		60h

	escape-chars: allocate MAX_ESC_CHARS

	fill-table: func [
		/local
			c [byte!]
			i [integer!]
	][
		i: 0
		while [i <= as-integer #"@"][
			escape-chars/i: null-byte
			i: i + 1
		]

		escape-chars/9:  #"-"
		escape-chars/10: #"/"
		escape-chars/34: #"^""

		c: #"@"
		while [c <= #"_"][
			i: 1 + as-integer c
			escape-chars/i: c
			c: c + 1
		]
	]
	fill-table											;-- fill table on loading

	to-hex: func [
		cp		[integer!]								;-- codepoint <= 10FFFFh
		return: [c-string!]
		/local
			s [c-string!]
			h [c-string!]
			c [integer!]
			i [integer!]
	][
		assert cp <= 0010FFFFh

		s: "000000"
		h: "0123456789ABCDEF"

		if zero? cp [
			s/5: #"0"
			s/6: #"0"
			return s + 5
		]

		c: 6
		while [cp <> 0][
			i: cp and 15 + 1								;-- cp // 16 + 1
			s/c: h/i
			cp: cp >> 4
			c: c - 1
		]
		s + c
	]

	rs-length?: func [
		str	    [red-string!]
		return: [integer!]
	][
		get-length str
	]

	rs-head: func [
		str	    [red-string!]
		return: [byte-ptr!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(str)
		(as byte-ptr! s/offset) + (str/head << (GET_UNIT(s) >> 1))
	]

	rs-tail: func [
		str	    [red-string!]
		return: [byte-ptr!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(str)
		as byte-ptr! s/tail
	]

	get-position: func [
		base	   [integer!]
		return:	   [integer!]
		/local
			str	   [red-string!]
			index  [red-integer!]
			s	   [series!]
			offset [integer!]
			max	   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/get-position"]]

		str: as red-string! stack/arguments
		index: as red-integer! str + 1

		assert any [
			TYPE_OF(str) = TYPE_STRING					;@@ ANY_STRING?
			TYPE_OF(str) = TYPE_FILE
		]
		assert TYPE_OF(index) = TYPE_INTEGER

		s: GET_BUFFER(str)

		offset: str/head + index/value - base			;-- index is one-based
		if negative? offset [offset: 0]
		max: (as-integer s/tail - s/offset) >> (GET_UNIT(s) >> 1)
		if offset > max [offset: max]

		offset
	]

	rs-make-at: func [
		slot	[cell!]
		size 	[integer!]								;-- number of cells to pre-allocate
		return:	[red-string!]
		/local
			p	[node!]
			str	[red-string!]
	][
		p: alloc-series size 1 0
		set-type slot TYPE_STRING						;@@ decide to use or not 'set-type...
		str: as red-string! slot
		str/head: 0
		str/node: p
		str
	]

	get-length: func [
		str		   [red-string!]
		return:	   [integer!]
		/local
			s	   [series!]
			offset [integer!]
	][
		s: GET_BUFFER(str)
		offset: str/head
		if negative? offset [offset: 0]					;-- @@ beware of symbol/index leaking here...
		(as-integer s/tail - s/offset) >> (GET_UNIT(s) >> 1) - offset
	]

	add-terminal-NUL: func [
		p	   [byte-ptr!]
		unit   [integer!]
		/local
			p4 [int-ptr!]
	][
		switch unit [
			Latin1 [p/1: as-byte 0]
			UCS-2  [p/1: as-byte 0 p/2: as-byte 0]
			UCS-4  [p4: as int-ptr! p p4/1: 0]
		]
	]

	truncate-tail: func [
		s	    [series!]
		offset  [integer!]								;-- negative offset from tail
		return: [series!]
	][
		if zero? offset [return s]
		assert negative? offset

		s/tail: as cell! (as byte-ptr! s/tail) + (offset * GET_UNIT(s))
		add-terminal-NUL as byte-ptr! s/tail GET_UNIT(s)
		s
	]

	append-char: func [
		s		[series!]
		cp		[integer!]								;-- codepoint
		return: [series!]
		/local
			p	[byte-ptr!]
			p4	[int-ptr!]
	][
		switch GET_UNIT(s) [
			Latin1 [
				case [
					cp <= FFh [
						s/tail: as cell! (as byte-ptr! s/tail) + 1	;-- safe to increment here
						p: alloc-tail-unit s 1
						p/0: as-byte cp					;-- overwrite termination NUL character
						p/1: as-byte 0					;-- add it back at next position
						s: GET_BUFFER(s)				;-- refresh s pointer if relocated by alloc-tail-unit
						s/tail: as cell! p				;-- reset tail just before NUL
					]
					cp <= FFFFh [
						s: unicode/Latin1-to-UCS2 s
						s: append-char s cp
					]
					true [
						s: unicode/Latin1-to-UCS4 s
						s: append-char s cp
					]
				]
			]
			UCS-2 [
				either cp <= FFFFh [
					s/tail: as cell! (as byte-ptr! s/tail) + 2	;-- safe to increment here
					p: alloc-tail-unit s 2

					p/-1: as-byte (cp and FFh)			;-- overwrite termination NUL character
					p/0: as-byte (cp >> 8)
					p/1: as-byte 0						;-- add it back
					p/2: as-byte 0

					s: GET_BUFFER(s)					;-- refresh s pointer if relocated by alloc-tail-unit
					s/tail: as cell! p 					;-- reset tail just before NUL
				][
					s: unicode/UCS2-to-UCS4 s
					s: append-char s cp
				]
			]
			UCS-4 [
				s/tail: as cell! (as int-ptr! s/tail) + 1	;-- safe to increment here
				p4: as int-ptr! alloc-tail-unit s 4
				p4/0: cp								;-- overwrite termination NUL character
				p4/1: 0									;-- add it back
				s: GET_BUFFER(s)						;-- refresh s pointer if relocated by alloc-tail-unit
				s/tail: as cell! p4						;-- reset tail just before NUL
			]
		]
		s
	]

	poke-char: func [
		s		[series!]
		p		[byte-ptr!]								;-- target passed as pointer to favor the general code path
		cp		[integer!]								;-- codepoint
		return: [series!]
		/local
			p4	[int-ptr!]
	][
		switch GET_UNIT(s) [
			Latin1 [
				case [
					cp <= FFh [
						p/1: as-byte cp
					]
					cp <= FFFFh [
						p: (as byte-ptr! s - 1) - p		;-- calc index value
						s: unicode/Latin1-to-UCS2 s
						p: (as byte-ptr! s + 1) + ((as-integer p) << 1) ;-- calc the new position
						s: poke-char s p cp
					]
					true [
						p: (as byte-ptr! s - 1) - p		;-- calc index value
						s: unicode/Latin1-to-UCS4 s
						p: (as byte-ptr! s + 1) + ((as-integer p) << 2) ;-- calc the new position
						s: poke-char s p cp
					]
				]
			]
			UCS-2 [
				either cp <= FFFFh [
					p/1: as-byte (cp and FFh)
					p/2: as-byte (cp >> 8)
				][
					p: (as byte-ptr! s - 1) - p			;-- calc index value
					s: unicode/UCS2-to-UCS4 s
					p: (as byte-ptr! s + 1) + ((as-integer p) << 2) ;-- calc the new position
					s: poke-char s p cp
				]
			]
			UCS-4 [
				p4: as int-ptr! p
				p4/1: cp
			]
		]
		s
	]

	concatenate: func [									;-- append str2 to str1
		str1	  [red-string!]							;-- string! to extend
		str2	  [red-string!]							;-- string! to append to str1
		part	  [integer!]							;-- str2 characters to append, -1 means all
		keep?	  [logic!]								;-- do not change str2 encoding
		/local
			s1	  [series!]
			s2	  [series!]
			unit1 [integer!]
			unit2 [integer!]
			size  [integer!]
			size2 [integer!]
			p	  [byte-ptr!]
			limit [byte-ptr!]
			cp	  [integer!]
			h1	  [integer!]
			h2	  [integer!]
	][
		s1: GET_BUFFER(str1)
		s2: GET_BUFFER(str2)
		unit1: GET_UNIT(s1)
		unit2: GET_UNIT(s2)

		case [											;-- harmonize both encodings
			unit1 < unit2 [
				switch unit2 [
					UCS-2 [s1: unicode/Latin1-to-UCS2 s1]
					UCS-4 [
						s1: either unit1 = Latin1 [
							unicode/Latin1-to-UCS4 s1
						][
							unicode/UCS2-to-UCS4 s1
						]
					]
				]
				unit1: unit2
			]
			all [unit1 > unit2 not keep?][
				switch unit1 [
					UCS-2 [s2: unicode/Latin1-to-UCS2 s2]
					UCS-4 [
						s2: either unit2 = Latin1 [
							unicode/Latin1-to-UCS4 s2
						][
							unicode/UCS2-to-UCS4 s2
						]
					]
				]
			]
			true [true]									;@@ catch-all case to make compiler happy
		]

		h1: either TYPE_OF(str1) = TYPE_SYMBOL [0][str1/head << (unit2 >> 1)]	;-- make symbol! used as string! pass safely
		h2: either TYPE_OF(str2) = TYPE_SYMBOL [0][str2/head << (unit1 >> 1)]	;-- make symbol! used as string! pass safely

		size2: (as-integer s2/tail - s2/offset) - h2
		size:  (as-integer s1/tail - s1/offset) - h1 + size2
		if s1/size < size [s1: expand-series s1 size + unit1]	;-- account for terminal NUL

		if part >= 0 [
			part: part << (unit2 >> 1)
			if part < size2 [size2: part]				;-- optionally limit str2 characters to copy
		]

		either all [keep? unit1 <> unit2][
			p: (as byte-ptr! s1/offset) + h1
			limit: p + size2
			while [p < limit][
				either unit2 = UCS-2 [
					cp: (as-integer p/2) << 8 + p/1
					p: p + 2
				][
					cp: as-integer p/1
					p: p + 1
				]
				s1: append-char s1 cp
			]
		][
			p: as byte-ptr! s1/tail
			copy-memory	p (as byte-ptr! s2/offset) + h2 size2
			p: p + size2
		]
		add-terminal-NUL p unit1
		s1/tail: as cell! p								;-- reset tail just before NUL
	]

	concatenate-literal: func [
		str		  [red-string!]
		p		  [c-string!]							;-- Red/System literal string
		/local
			s	  [series!]
	][
		s: GET_BUFFER(str)
		assert p/1 <> null-byte							;-- assume no empty string passed

		until [
			s: append-char s as-integer p/1
			p: p + 1
			p/1 = null-byte
		]
	]

	concatenate-literal-part: func [
		str	   [red-string!]
		p	   [c-string!]								;-- Red/System literal string
		part   [integer!]								;-- number of bytes to append
		/local
			s	  [series!]
	][
		s: GET_BUFFER(str)
		assert p/1 <> null-byte							;-- assume no empty string passed
		assert positive? part

		until [
			s: append-char s as-integer p/1
			p: p + 1
			part: part - 1
			zero? part
		]
	]

	load-in: func [
		src		 [c-string!]							;-- UTF-8 source string buffer
		size	 [integer!]
		blk		 [red-block!]
		return:  [red-string!]
		/local
			str  [red-string!]
	][
		str: as red-string! ALLOC_TAIL(blk)
		str/header: TYPE_STRING							;-- implicit reset of all header flags
		str/head: 0
		str/node: unicode/load-utf8 src size
		str/cache: either size < 64 [src][null]			;-- cache only small strings (experimental)
		str
	]

	load: func [
		src		 [c-string!]							;-- UTF-8 source string buffer
		size	 [integer!]
		return:  [red-string!]
	][
		load-in src size root
	]

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

		copy-cell as red-value! str stack/push*
	]

	;-- Actions --

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

		size: 1
		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				int: as red-integer! spec
				size: int/value
			]
			default [--NOT_IMPLEMENTED--]
		]
		str: as red-string! stack/push*
		str/header: TYPE_STRING							;-- implicit reset of all header flags
		str/head: 	0
		str/node: 	alloc-bytes size					;-- alloc enough space for at least a Latin1 string
		str
	]

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

		limit: either OPTION?(arg) [
			int: as red-integer! arg
			int/value
		][-1]
		concatenate buffer str limit no
		part - get-length str
	]

	sniff-chars: func [
		p	  [byte-ptr!]
		tail  [byte-ptr!]
		unit  [integer!]
		curly [int-ptr!]
		quote [int-ptr!]
		nl	  [int-ptr!]
		/local
			cp [integer!]
			p4 [int-ptr!]
	][
		while [p < tail][
			cp: switch unit [
				Latin1 [as-integer p/value]
				UCS-2  [(as-integer p/2) << 8 + p/1]
				UCS-4  [p4: as int-ptr! p p4/value]
			]
			switch cp [
				#"{"    [if curly/value >= 0 [curly/value: curly/value + 1]]
				#"}"    [curly/value: curly/value - 1]
				#"^""   [quote/value: quote/value + 1]
				#"^/"   [nl/value: 	  nl/value + 1]
				default [0]
			]
			p: p + unit
		]
	]

	append-escaped-char: func [
		buffer	[red-string!]
		cp	    [integer!]
		/local
			idx [integer!]
	][
		idx: cp + 1
		case [
			any [cp > 7Fh cp = 1Eh][
				append-char GET_BUFFER(buffer) as-integer #"^^"
				append-char GET_BUFFER(buffer) as-integer #"("
				concatenate-literal buffer to-hex cp
				append-char GET_BUFFER(buffer) as-integer #")"
			]
			all [cp < MAX_ESC_CHARS escape-chars/idx <> null-byte][
				append-char GET_BUFFER(buffer) as-integer #"^^"
				append-char GET_BUFFER(buffer) as-integer escape-chars/idx
			]
			true [
				append-char GET_BUFFER(buffer) cp
			]
		]
	]

	mold: func [
		str		  [red-string!]
		buffer	  [red-string!]
		only?	  [logic!]
		all?	  [logic!]
		flat?	  [logic!]
		arg		  [red-value!]
		part	  [integer!]
		return:	  [integer!]
		/local
			int	   [red-integer!]
			limit  [integer!]
			s	   [series!]
			unit   [integer!]
			cp	   [integer!]
			p	   [byte-ptr!]
			p4	   [int-ptr!]
			head   [byte-ptr!]
			tail   [byte-ptr!]
			curly  [integer!]
			quote  [integer!]
			nl	   [integer!]
			open   [byte!]
			close  [byte!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/mold"]]

		limit: either OPTION?(arg) [
			int: as red-integer! arg
			int/value
		][0]

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

		tail: either zero? limit [						;@@ rework that part
			as byte-ptr! s/tail
		][
			p + (part << (unit >> 1))
		]
		if tail > as byte-ptr! s/tail [tail: as byte-ptr! s/tail]

		curly: 0
		quote: 0
		nl:    0
		sniff-chars p tail unit :curly :quote :nl

		either any [
			nl >= 3
			negative? curly
			positive? quote
			BRACES_THRESHOLD <= get-length str
		][
			open:  #"{"
			close: #"}"
		][
			open:  #"^""
			close: #"^""
		]

		append-char GET_BUFFER(buffer) as-integer open

		while [p < tail][
			cp: switch unit [
				Latin1 [as-integer p/value]
				UCS-2  [(as-integer p/2) << 8 + p/1]
				UCS-4  [p4: as int-ptr! p p4/value]
			]
			either open =  #"{" [
				switch cp [
					#"{" #"}" [
						append-char GET_BUFFER(buffer) as-integer #"^^"
						append-char GET_BUFFER(buffer) cp
					]
					#"^/" #"^"" [
						append-char GET_BUFFER(buffer) cp
					]
					default [
						append-escaped-char buffer cp
					]
				]
			][
				append-escaped-char buffer cp
			]
			p: p + unit
		]

		append-char GET_BUFFER(buffer) as-integer close
		part - ((as-integer tail - head) >> (unit >> 1)) - 2
	]

	compare: func [
		str1	  [red-string!]							;-- first operand
		str2	  [red-string!]							;-- second operand
		op		  [integer!]							;-- type of comparison
		return:	  [logic!]
		/local
			s1	  [series!]
			s2	  [series!]
			unit1 [integer!]
			unit2 [integer!]
			size1 [integer!]
			size2 [integer!]
			end	  [byte-ptr!]
			p1	  [byte-ptr!]
			p2	  [byte-ptr!]
			p4	  [int-ptr!]
			c1	  [integer!]
			c2	  [integer!]
			lax?  [logic!]
			res	  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/compare"]]

		if any [
			all [
				op = COMP_STRICT_EQUAL
				TYPE_OF(str2) <> TYPE_STRING
			]
			all [
				op <> COMP_STRICT_EQUAL
				TYPE_OF(str2) <> TYPE_STRING
				TYPE_OF(str2) <> TYPE_FILE
			]
		][RETURN_COMPARE_OTHER]

		s1: GET_BUFFER(str1)
		s2: GET_BUFFER(str2)
		unit1: GET_UNIT(s1)
		unit2: GET_UNIT(s2)
		size1: (as-integer s1/tail - s1/offset) >> (unit1 >> 1)- str1/head
		size2: (as-integer s2/tail - s2/offset) >> (unit2 >> 1)- str2/head

		if size1 <> size2 [								;-- shortcut exit for different sizes
			if any [op = COMP_EQUAL op = COMP_STRICT_EQUAL][return false]
			if op = COMP_NOT_EQUAL [return true]
		]
		if zero? size1 [								;-- shortcut exit for empty strings
			return any [op = COMP_EQUAL op = COMP_STRICT_EQUAL]
		]

		end: as byte-ptr! s1/tail						;-- only one "end" is needed
		p1:  (as byte-ptr! s1/offset) + (str1/head << (unit1 >> 1))
		p2:  (as byte-ptr! s2/offset) + (str2/head << (unit2 >> 1))
		lax?: op <> COMP_STRICT_EQUAL

		until [
			switch unit1 [
				Latin1 [c1: as-integer p1/1]
				UCS-2  [c1: (as-integer p1/2) << 8 + p1/1]
				UCS-4  [p4: as int-ptr! p1 c1: p4/1]
			]
			switch unit2 [
				Latin1 [c2: as-integer p2/1]
				UCS-2  [c2: (as-integer p2/2) << 8 + p2/1]
				UCS-4  [p4: as int-ptr! p2 c2: p4/1]
			]
			if lax? [
				if all [65 <= c1 c1 <= 90][c1: c1 + 32]	;-- lowercase c1
				if all [65 <= c2 c2 <= 90][c2: c2 + 32] ;-- lowercase c2
			]
			p1: p1 + unit1
			p2: p2 + unit2
			any [
				c1 <> c2
				p1 >= end
			]
		]
		switch op [
			COMP_EQUAL			[res: c1 = c2]
			COMP_NOT_EQUAL		[res: c1 <> c2]
			COMP_STRICT_EQUAL	[res: c1 = c2]
			COMP_LESSER			[res: c1 <  c2]
			COMP_LESSER_EQUAL	[res: c1 <= c2]
			COMP_GREATER		[res: c1 >  c2]
			COMP_GREATER_EQUAL	[res: c1 >= c2]
		]
		res
	]

	;--- Property reading actions ---

	head?: func [
		return:	  [red-value!]
		/local
			str	  [red-string!]
			state [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/head?"]]

		str:   as red-string! stack/arguments
		state: as red-logic! str

		state/header: TYPE_LOGIC
		state/value:  zero? str/head
		as red-value! state
	]

	tail?: func [
		return:	  [red-value!]
		/local
			str	  [red-string!]
			state [red-logic!]
			s	  [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/tail?"]]

		str:   as red-string! stack/arguments
		state: as red-logic! str

		s: GET_BUFFER(str)

		state/header: TYPE_LOGIC
		state/value:  (as byte-ptr! s/offset) + (str/head << (GET_UNIT(s) >> 1)) = as byte-ptr! s/tail
		as red-value! state
	]

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

		str:   as red-string! stack/arguments
		index: as red-integer! str

		index/header: TYPE_INTEGER
		index/value:  str/head + 1
		as red-value! index
	]

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

		str: as red-string! stack/arguments

		s: GET_BUFFER(str)

		int: as red-integer! str
		int/header: TYPE_INTEGER
		int/value:  (as-integer s/tail - s/offset) >> (GET_UNIT(s) >> 1) - str/head
		as red-value! int
	]

	;--- Navigation actions ---

	at: func [
		return:	[red-value!]
		/local
			str	[red-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/at"]]

		str: as red-string! stack/arguments
		str/head: get-position 1
		as red-value! str
	]

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

		block/back										;-- identical behaviour as block!
	]

	next: func [
		return:	  [red-value!]
		/local
			str	  [red-string!]
			s	  [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/next"]]

		str: as red-string! stack/arguments

		s: GET_BUFFER(str)

		if (as byte-ptr! s/offset) + (str/head + 1 << (GET_UNIT(s) >> 1)) <= as byte-ptr! s/tail [
			str/head: str/head + 1
		]
		as red-value! str
	]

	skip: func [
		return:	[red-value!]
		/local
			str	[red-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/skip"]]

		str: as red-string! stack/arguments
		str/head: get-position 0
		as red-value! str
	]

	head: func [
		return:	[red-value!]
		/local
			str	[red-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/head"]]

		str: as red-string! stack/arguments
		str/head: 0
		as red-value! str
	]

	tail: func [
		return:	[red-value!]
		/local
			str	[red-string!]
			s	[series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/tail"]]

		str: as red-string! stack/arguments
		s: GET_BUFFER(str)

		str/head: (as-integer s/tail - s/offset) >> (GET_UNIT(s) >> 1)
		as red-value! str
	]

	find: func [
		str			[red-string!]
		value		[red-value!]
		part		[red-value!]
		only?		[logic!]
		case?		[logic!]
		any?		[logic!]							;@@ not implemented
		with-arg	[red-string!]						;@@ not implemented
		skip		[red-integer!]
		last?		[logic!]
		reverse?	[logic!]
		tail?		[logic!]
		match?		[logic!]
		return:		[red-value!]
		/local
			s		[series!]
			s2		[series!]
			buffer	[byte-ptr!]
			pattern	[byte-ptr!]
			end		[byte-ptr!]
			end2	[byte-ptr!]
			result	[red-value!]
			int		[red-integer!]
			char	[red-char!]
			str2	[red-string!]
			unit	[encoding!]
			unit2	[encoding!]
			head2	[integer!]
			p1		[byte-ptr!]
			p2		[byte-ptr!]
			p4		[int-ptr!]
			c1		[integer!]
			c2		[integer!]
			step	[integer!]
			limit	[byte-ptr!]
			part?	[logic!]
			op		[integer!]
			found?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/find"]]

		result: stack/push as red-value! str

		s: GET_BUFFER(str)
		if s/offset = s/tail [							;-- early exit if string is empty
			result/header: TYPE_NONE
			return result
		]
		unit: GET_UNIT(s)
		step: 1
		part?: no

		;-- Options processing --

		if any [any? OPTION?(with-arg)][--NOT_IMPLEMENTED--]

		if OPTION?(skip) [
			assert TYPE_OF(skip) = TYPE_INTEGER
			step: skip/value
		]
		if OPTION?(part) [
			limit: either TYPE_OF(part) = TYPE_INTEGER [
				int: as red-integer! part
				if int/value <= 0 [						;-- early exit if part <= 0
					result/header: TYPE_NONE
					return result
				]
				(as byte-ptr! s/offset) + (int/value - 1 << (unit >> 1)) ;-- int argument is 1-based
			][
				str2: as red-string! part
				unless all [
					TYPE_OF(str2) = TYPE_OF(str)		;-- handles ANY-STRING!
					str2/node = str/node
				][
					print "*** Error: invalid /part series argument"	;@@ replace with error!
					halt
				]
				(as byte-ptr! s/offset) + (str2/head << (unit >> 1))
			]
			part?: yes
		]
		case [
			last? [
				step: 0 - step
				buffer: either part? [limit][(as byte-ptr! s/tail) - unit]
				end: as byte-ptr! s/offset
			]
			reverse? [
				step: 0 - step
				buffer: either part? [limit][(as byte-ptr! s/offset) + (str/head - 1 << (unit >> 1))]
				end: as byte-ptr! s/offset
				if buffer < end [							;-- early exit if str/head = 0
					result/header: TYPE_NONE
					return result
				]
			]
			true [
				buffer: (as byte-ptr! s/offset) + (str/head << (unit >> 1))
				end: either part? [limit + unit][as byte-ptr! s/tail] ;-- + unit => compensate for the '>= test
			]
		]
		case?: not case?								;-- inverted case? meaning
		reverse?: any [reverse? last?]					;-- reduce both flags to one
		step: step << (unit >> 1)
		pattern: null

		;-- Value argument processing --

		switch TYPE_OF(value) [
			TYPE_CHAR [
				char: as red-char! value
				c2: char/value
				if all [case? 65 <= c2 c2 <= 90][c2: c2 + 32] ;-- lowercase c2
			]
			TYPE_STRING TYPE_FILE TYPE_WORD [
				either TYPE_OF(value) = TYPE_WORD [
					str2: as red-string! word/get-buffer as red-word! value
					head2: 0							;-- str2/head = -1 (casted from symbol!)
				][
					str2: as red-string! value
					head2: str2/head
				]
				s2: GET_BUFFER(str2)
				unit2: GET_UNIT(s2)
				pattern: (as byte-ptr! s2/offset) + (head2 << (unit >> 1))
				end2:    (as byte-ptr! s2/tail)
			]
			default [
				result/header: TYPE_NONE
				return result
			]
		]

		;-- Search loop --
		until [
			either pattern = null [
				switch unit [
					Latin1 [c1: as-integer buffer/1]
					UCS-2  [c1: (as-integer buffer/2) << 8 + buffer/1]
					UCS-4  [p4: as int-ptr! buffer c1: p4/1]
				]
				if all [case? 65 <= c1 c1 <= 90][c1: c1 + 32] ;-- lowercase c1
				found?: c1 = c2
				if match? [buffer: buffer + 1]			;-- /match option returns tail of match
			][
				p1: buffer
				p2: pattern
				until [									;-- series comparison
					either unit = unit2 [
						switch unit [
							Latin1 [
								c1: as-integer p1/1
								c2: as-integer p2/1
							]
							UCS-2  [
								c1: (as-integer p1/2) << 8 + p1/1
								c2: (as-integer p2/2) << 8 + p2/1
							]
							UCS-4  [
								p4: as int-ptr! p1
								c1: p4/1
								p4: as int-ptr! p2
								c2: p4/1
							]
						]
					][
						switch unit [
							Latin1 [c1: as-integer p1/1]
							UCS-2  [c1: (as-integer p1/2) << 8 + p1/1]
							UCS-4  [p4: as int-ptr! p1 c1: p4/1]
						]
						switch unit2 [
							Latin1 [c2: as-integer p2/1]
							UCS-2  [c2: (as-integer p2/2) << 8 + p2/1]
							UCS-4  [p4: as int-ptr! p2 c2: p4/1]
						]
					]
					if all [case? 65 <= c1 c1 <= 90][c1: c1 + 32] ;-- lowercase c1
					if all [case? 65 <= c2 c2 <= 90][c2: c2 + 32] ;-- lowercase c2
					found?: c1 = c2

					p1: p1 + unit
					p2: p2 + unit2
					any [
						not found?						;-- no match
						p2 >= end2						;-- searched string tail reached
						all [reverse? p1 <= end]		;-- search buffer exhausted at head
						all [not reverse? p1 >= end]	;-- search buffer exhausted at tail
					]
				]
				if all [
					found?
					p2 < end2							;-- search string tail not reached
					any [								;-- search buffer exhausted
						all [reverse? p1 <= end]
						all [not reverse? p1 >= end]
					]
				][found?: no] 							;-- partial match case, make it fail

				if all [found? any [match? tail?]][buffer: p1]
			]
			buffer: buffer + step
			any [
				match?									;-- /match option limits to one comparison
				all [not match? found?]					;-- match found
				all [reverse? buffer <= end]			;-- head of block series reached
				all [not reverse? buffer >= end]		;-- tail of block series reached
			]
		]
		buffer: buffer - step							;-- compensate for extra step

		either found? [
			str: as red-string! result
			str/head: (as-integer buffer - s/offset) >> (unit >> 1)	;-- just change the head position on stack
		][
			result/header: TYPE_NONE					;-- change the stack 1st argument to none.
		]
		result
	]

	select: func [
		str		 [red-string!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		tail?	 [logic!]
		match?	 [logic!]
		return:	 [red-value!]
		/local
			s	   [series!]
			p	   [byte-ptr!]
			p4	   [int-ptr!]
			char   [red-char!]
			result [red-value!]
			str2   [red-string!]
			head2  [integer!]
			offset [integer!]
	][
		result: find str value part only? case? any? with-arg skip last? reverse? no no

		if TYPE_OF(result) <> TYPE_NONE [
			offset: switch TYPE_OF(value) [
				TYPE_STRING TYPE_FILE TYPE_WORD [
					either TYPE_OF(value) = TYPE_WORD [
						str2: as red-string! word/get-buffer as red-word! value
						head2: 0							;-- str2/head = -1 (casted from symbol!)
					][
						str2: as red-string! value
						head2: str2/head
					]
					s: GET_BUFFER(str2)
					(as-integer s/tail - s/offset) >> (GET_UNIT(s) >> 1) - head2
				]
				default [1]
			]
			str: as red-string! result
			s: GET_BUFFER(str)
			p: (as byte-ptr! s/offset) + ((str/head + offset) << (GET_UNIT(s) >> 1))

			either p < as byte-ptr! s/tail [
				char: as red-char! result
				char/header: TYPE_CHAR
				char/value: switch GET_UNIT(s) [
					Latin1 [as-integer p/value]
					UCS-2  [(as-integer p/2) << 8 + p/1]
					UCS-4  [p4: as int-ptr! p p4/value]
				]
			][
				result/header: TYPE_NONE
			]
		]
		result
	]

	;--- Reading actions ---

	pick: func [
		str	       [red-string!]
		index  	   [integer!]
		return:	   [red-value!]
		/local
			char   [red-char!]
			s	   [series!]
			offset [integer!]
			p1	   [byte-ptr!]
			p4	   [int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/pick"]]

		s: GET_BUFFER(str)

		offset: str/head + index - 1					;-- index is one-based
		if negative? index [offset: offset + 1]

		p1: (as byte-ptr! s/offset) + (offset << (GET_UNIT(s) >> 1))

		either any [
			zero? index
			p1 >= as byte-ptr! s/tail
			p1 <  as byte-ptr! s/offset
		][
			none-value
		][
			char: as red-char! stack/push*
			char/header: TYPE_CHAR
			char/value: switch GET_UNIT(s) [
				Latin1 [as-integer p1/value]
				UCS-2  [(as-integer p1/2) << 8 + p1/1]
				UCS-4  [p4: as int-ptr! p1 p4/value]
			]
			as red-value! char
		]
	]

	;--- Modifying actions ---

	append: func [
		str		 [red-string!]
		value	 [red-value!]
		part-arg [red-value!]
		only?	 [logic!]
		dup-arg	 [red-value!]
		return:	 [red-value!]
		/local
			src	  [red-block!]
			cell  [red-value!]
			limit [red-value!]
			int	  [red-integer!]
			char  [red-char!]
			sp	  [red-string!]
			s	  [series!]
			dst	  [series!]
			cnt	  [integer!]
			part  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/append"]]

		cnt:  1
		part: -1

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				int/value
			][
				sp: as red-string! part-arg
				assert all [
					TYPE_OF(sp) = TYPE_STRING			;@@ replace by ANY_STRING?
					TYPE_OF(sp) = TYPE_FILE
					sp/node = str/node
				]
				sp/head + 1								;-- /head is 0-based
			]
		]
		if OPTION?(dup-arg) [
			int: as red-integer! dup-arg
			cnt: int/value
		]

		while [not zero? cnt][							;-- /dup support
			either TYPE_OF(value) = TYPE_BLOCK [		;@@ replace it with: typeset/any-block?
				src: as red-block! value
				if negative? part [part: block/rs-length? src] ;-- if not /part, use whole value length
				s: GET_BUFFER(src)
				cell: s/offset + src/head
				limit: cell + part						;-- /part support

				while [cell < limit][					;-- multiple values case
					switch TYPE_OF(cell) [
						TYPE_CHAR [
							char: as red-char! cell
							append-char GET_BUFFER(str) char/value
						]
						TYPE_STRING TYPE_FILE [
							concatenate str as red-string! cell part no
						]
						default [
							--NOT_IMPLEMENTED--			;@@ actions/form needs to take an argument!
							;TBD once INSERT is implemented
						]
					]
					cell: cell + 1
				]
			][											;-- single value case
				switch TYPE_OF(value) [
					TYPE_CHAR [
						char: as red-char! value
						append-char GET_BUFFER(str) char/value
					]
					TYPE_STRING TYPE_FILE [
						concatenate str as red-string! value part no
					]
					default [
						;actions/form* -1				;-- FORM value before appending
						--NOT_IMPLEMENTED--
						;TBD once INSERT is implemented
					]
				]
			]
			cnt: cnt - 1
		]
		as red-value! str
	]

	clear: func [
		return:	[red-value!]
		/local
			str	[red-string!]
			s	[series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/clear"]]

		str: as red-string! stack/arguments
		s: GET_BUFFER(str)
		s/tail: as cell! (as byte-ptr! s/offset) + (str/head << (GET_UNIT(s) >> 1))
		as red-value! str
	]

	poke: func [
		str		   [red-string!]
		index	   [integer!]
		char	   [red-char!]
		return:	   [red-value!]
		/local
			s	   [series!]
			offset [integer!]
			pos	   [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/poke"]]

		s: GET_BUFFER(str)

		offset: str/head + index - 1					;-- index is one-based
		if negative? index [offset: offset + 1]

		pos: (as byte-ptr! s/offset) + (offset << (GET_UNIT(s) >> 1))

		either any [
			zero? index
			pos >= as byte-ptr! s/tail
			pos <  as byte-ptr! s/offset
		][
			--NOT_IMPLEMENTED--
			;TBD: waiting for error!
		][
			if TYPE_OF(char) <> TYPE_CHAR [
				print-line "Error: POKE expected char! value"	;@@ replace by error! when ready
				halt
			]
			poke-char s pos char/value
			stack/set-last as red-value! char
		]
		as red-value! char
	]

	;--- Misc actions ---

	copy: func [
		str	    	[red-string!]
		part-arg	[red-value!]
		deep?		[logic!]
		types		[red-value!]
		return:		[red-series!]
		/local
			int		[red-integer!]
			str2	[red-string!]
			offset	[integer!]
			s		[series!]
			buffer	[series!]
			new		[node!]
			unit	[integer!]
			part	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/copy"]]

		s: GET_BUFFER(str)
		unit: GET_UNIT(s)

		offset: str/head << (unit >> 1)
		part: (as-integer s/tail - s/offset) - offset

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

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				case [
					int/value > (part >> (unit >> 1)) [part >> (unit >> 1)]
					positive? int/value [int/value]
					true				[0]
				]
			][
				str2: as red-string! part-arg
				unless all [
					TYPE_OF(str2) = TYPE_OF(str)		;-- handles ANY-STRING!
					str2/node = str/node
				][
					print "*** Error: invalid /part series argument"	;@@ replace with error!
					halt
				]
				str2/head
			]
			part: part << (unit >> 1)
		]

		new: 	alloc-bytes part + unit
		buffer: as series! new/value

		unless zero? part [
			copy-memory
				as byte-ptr! buffer/offset
				(as byte-ptr! s/offset) + offset
				part

			buffer/tail: as cell! (as byte-ptr! buffer/offset) + part
		]
		add-terminal-NUL as byte-ptr! buffer/tail unit
		str/node: new									;-- reuse the block slot
		str/head: 0										;-- reset head offset
		as red-series! str
	]

	datatype/register [
		TYPE_STRING
		TYPE_VALUE
		"string!"
		;-- General actions --
		:make
		null			;random
		null			;reflect
		null			;to
		:form
		:mold
		null			;get-path
		null			;set-path
		: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 --
		:append
		:at
		:back
		null			;change
		:clear
		:copy
		:find
		:head
		:head?
		:index?
		null			;insert
		:length?
		:next
		:pick
		:poke
		null			;remove
		null			;reverse
		:select
		null			;sort
		:skip
		null			;swap
		:tail
		: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:   "String! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %string.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
	}
]

string: context [
	verbose: 0

	#define BRACES_THRESHOLD	50						;-- max string length for using " delimiter
	#define MAX_ESC_CHARS		60h

	escape-chars: allocate MAX_ESC_CHARS

	fill-table: func [
		/local
			c [byte!]
			i [integer!]
	][
		i: 0
		while [i <= as-integer #"@"][
			escape-chars/i: null-byte
			i: i + 1
		]

		escape-chars/9:  #"-"
		escape-chars/10: #"/"
		escape-chars/34: #"^""

		c: #"@"
		while [c <= #"_"][
			i: 1 + as-integer c
			escape-chars/i: c
			c: c + 1
		]
	]
	fill-table											;-- fill table on loading

	to-hex: func [
		cp		[integer!]								;-- codepoint <= 10FFFFh
		return: [c-string!]
		/local
			s [c-string!]
			h [c-string!]
			c [integer!]
			i [integer!]
	][
		assert cp <= 0010FFFFh

		s: "000000"
		h: "0123456789ABCDEF"

		if zero? cp [
			s/5: #"0"
			s/6: #"0"
			return s + 5
		]

		c: 6
		while [cp <> 0][
			i: cp and 15 + 1								;-- cp // 16 + 1
			s/c: h/i
			cp: cp >> 4
			c: c - 1
		]
		s + c
	]

	rs-length?: func [
		str	    [red-string!]
		return: [integer!]
	][
		get-length str
	]

	rs-head: func [
		str	    [red-string!]
		return: [byte-ptr!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(str)
		(as byte-ptr! s/offset) + (str/head << (GET_UNIT(s) >> 1))
	]

	rs-tail: func [
		str	    [red-string!]
		return: [byte-ptr!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(str)
		as byte-ptr! s/tail
	]

	get-position: func [
		base	   [integer!]
		return:	   [integer!]
		/local
			str	   [red-string!]
			index  [red-integer!]
			s	   [series!]
			offset [integer!]
			max	   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/get-position"]]

		str: as red-string! stack/arguments
		index: as red-integer! str + 1

		assert any [
			TYPE_OF(str) = TYPE_STRING					;@@ ANY_STRING?
			TYPE_OF(str) = TYPE_FILE
		]
		assert TYPE_OF(index) = TYPE_INTEGER

		s: GET_BUFFER(str)

		offset: str/head + index/value - base			;-- index is one-based
		if negative? offset [offset: 0]
		max: (as-integer s/tail - s/offset) >> (GET_UNIT(s) >> 1)
		if offset > max [offset: max]

		offset
	]

	rs-make-at: func [
		slot	[cell!]
		size 	[integer!]								;-- number of cells to pre-allocate
		return:	[red-string!]
		/local
			p	[node!]
			str	[red-string!]
	][
		p: alloc-series size 1 0
		set-type slot TYPE_STRING						;@@ decide to use or not 'set-type...
		str: as red-string! slot
		str/head: 0
		str/node: p
		str
	]

	get-length: func [
		str		   [red-string!]
		return:	   [integer!]
		/local
			s	   [series!]
			offset [integer!]
	][
		s: GET_BUFFER(str)
		offset: str/head
		if negative? offset [offset: 0]					;-- @@ beware of symbol/index leaking here...
		(as-integer s/tail - s/offset) >> (GET_UNIT(s) >> 1) - offset
	]

	add-terminal-NUL: func [
		p	   [byte-ptr!]
		unit   [integer!]
		/local
			p4 [int-ptr!]
	][
		switch unit [
			Latin1 [p/1: as-byte 0]
			UCS-2  [p/1: as-byte 0 p/2: as-byte 0]
			UCS-4  [p4: as int-ptr! p p4/1: 0]
		]
	]

	truncate-tail: func [
		s	    [series!]
		offset  [integer!]								;-- negative offset from tail
		return: [series!]
	][
		if zero? offset [return s]
		assert negative? offset

		s/tail: as cell! (as byte-ptr! s/tail) + (offset * GET_UNIT(s))
		add-terminal-NUL as byte-ptr! s/tail GET_UNIT(s)
		s
	]

	append-char: func [
		s		[series!]
		cp		[integer!]								;-- codepoint
		return: [series!]
		/local
			p	[byte-ptr!]
			p4	[int-ptr!]
	][
		switch GET_UNIT(s) [
			Latin1 [
				case [
					cp <= FFh [
						s/tail: as cell! (as byte-ptr! s/tail) + 1	;-- safe to increment here
						p: alloc-tail-unit s 1
						p/0: as-byte cp					;-- overwrite termination NUL character
						p/1: as-byte 0					;-- add it back at next position
						s: GET_BUFFER(s)				;-- refresh s pointer if relocated by alloc-tail-unit
						s/tail: as cell! p				;-- reset tail just before NUL
					]
					cp <= FFFFh [
						s: unicode/Latin1-to-UCS2 s
						s: append-char s cp
					]
					true [
						s: unicode/Latin1-to-UCS4 s
						s: append-char s cp
					]
				]
			]
			UCS-2 [
				either cp <= FFFFh [
					s/tail: as cell! (as byte-ptr! s/tail) + 2	;-- safe to increment here
					p: alloc-tail-unit s 2

					p/-1: as-byte (cp and FFh)			;-- overwrite termination NUL character
					p/0: as-byte (cp >> 8)
					p/1: as-byte 0						;-- add it back
					p/2: as-byte 0

					s: GET_BUFFER(s)					;-- refresh s pointer if relocated by alloc-tail-unit
					s/tail: as cell! p 					;-- reset tail just before NUL
				][
					s: unicode/UCS2-to-UCS4 s
					s: append-char s cp
				]
			]
			UCS-4 [
				s/tail: as cell! (as int-ptr! s/tail) + 1	;-- safe to increment here
				p4: as int-ptr! alloc-tail-unit s 4
				p4/0: cp								;-- overwrite termination NUL character
				p4/1: 0									;-- add it back
				s: GET_BUFFER(s)						;-- refresh s pointer if relocated by alloc-tail-unit
				s/tail: as cell! p4						;-- reset tail just before NUL
			]
		]
		s
	]

	poke-char: func [
		s		[series!]
		p		[byte-ptr!]								;-- target passed as pointer to favor the general code path
		cp		[integer!]								;-- codepoint
		return: [series!]
		/local
			p4	[int-ptr!]
	][
		switch GET_UNIT(s) [
			Latin1 [
				case [
					cp <= FFh [
						p/1: as-byte cp
					]
					cp <= FFFFh [
						p: (as byte-ptr! s - 1) - p		;-- calc index value
						s: unicode/Latin1-to-UCS2 s
						p: (as byte-ptr! s + 1) + ((as-integer p) << 1) ;-- calc the new position
						s: poke-char s p cp
					]
					true [
						p: (as byte-ptr! s - 1) - p		;-- calc index value
						s: unicode/Latin1-to-UCS4 s
						p: (as byte-ptr! s + 1) + ((as-integer p) << 2) ;-- calc the new position
						s: poke-char s p cp
					]
				]
			]
			UCS-2 [
				either cp <= FFFFh [
					p/1: as-byte (cp and FFh)
					p/2: as-byte (cp >> 8)
				][
					p: (as byte-ptr! s - 1) - p			;-- calc index value
					s: unicode/UCS2-to-UCS4 s
					p: (as byte-ptr! s + 1) + ((as-integer p) << 2) ;-- calc the new position
					s: poke-char s p cp
				]
			]
			UCS-4 [
				p4: as int-ptr! p
				p4/1: cp
			]
		]
		s
	]

	concatenate: func [									;-- append str2 to str1
		str1	  [red-string!]							;-- string! to extend
		str2	  [red-string!]							;-- string! to append to str1
		part	  [integer!]							;-- str2 characters to append, -1 means all
		keep?	  [logic!]								;-- do not change str2 encoding
		/local
			s1	  [series!]
			s2	  [series!]
			unit1 [integer!]
			unit2 [integer!]
			size  [integer!]
			size2 [integer!]
			p	  [byte-ptr!]
			limit [byte-ptr!]
			cp	  [integer!]
			h1	  [integer!]
			h2	  [integer!]
	][
		s1: GET_BUFFER(str1)
		s2: GET_BUFFER(str2)
		unit1: GET_UNIT(s1)
		unit2: GET_UNIT(s2)

		case [											;-- harmonize both encodings
			unit1 < unit2 [
				switch unit2 [
					UCS-2 [s1: unicode/Latin1-to-UCS2 s1]
					UCS-4 [
						s1: either unit1 = Latin1 [
							unicode/Latin1-to-UCS4 s1
						][
							unicode/UCS2-to-UCS4 s1
						]
					]
				]
				unit1: unit2
			]
			all [unit1 > unit2 not keep?][
				switch unit1 [
					UCS-2 [s2: unicode/Latin1-to-UCS2 s2]
					UCS-4 [
						s2: either unit2 = Latin1 [
							unicode/Latin1-to-UCS4 s2
						][
							unicode/UCS2-to-UCS4 s2
						]
					]
				]
			]
			true [true]									;@@ catch-all case to make compiler happy
		]

		h1: either TYPE_OF(str1) = TYPE_SYMBOL [0][str1/head << (unit2 >> 1)]	;-- make symbol! used as string! pass safely
		h2: either TYPE_OF(str2) = TYPE_SYMBOL [0][str2/head << (unit1 >> 1)]	;-- make symbol! used as string! pass safely

		size2: (as-integer s2/tail - s2/offset) - h2
		size:  (as-integer s1/tail - s1/offset) - h1 + size2
		if s1/size < size [s1: expand-series s1 size + unit1]	;-- account for terminal NUL

		if part >= 0 [
			part: part << (unit2 >> 1)
			if part < size2 [size2: part]				;-- optionally limit str2 characters to copy
		]

		either all [keep? unit1 <> unit2][
			p: (as byte-ptr! s1/offset) + h1
			limit: p + size2
			while [p < limit][
				either unit2 = UCS-2 [
					cp: (as-integer p/2) << 8 + p/1
					p: p + 2
				][
					cp: as-integer p/1
					p: p + 1
				]
				s1: append-char s1 cp
			]
		][
			p: as byte-ptr! s1/tail
			copy-memory	p (as byte-ptr! s2/offset) + h2 size2
			p: p + size2
		]
		add-terminal-NUL p unit1
		s1/tail: as cell! p								;-- reset tail just before NUL
	]

	concatenate-literal: func [
		str		  [red-string!]
		p		  [c-string!]							;-- Red/System literal string
		/local
			s	  [series!]
	][
		s: GET_BUFFER(str)
		assert p/1 <> null-byte							;-- assume no empty string passed

		until [
			s: append-char s as-integer p/1
			p: p + 1
			p/1 = null-byte
		]
	]

	concatenate-literal-part: func [
		str	   [red-string!]
		p	   [c-string!]								;-- Red/System literal string
		part   [integer!]								;-- number of bytes to append
		/local
			s	  [series!]
	][
		s: GET_BUFFER(str)
		assert p/1 <> null-byte							;-- assume no empty string passed
		assert positive? part

		until [
			s: append-char s as-integer p/1
			p: p + 1
			part: part - 1
			zero? part
		]
	]

	load-in: func [
		src		 [c-string!]							;-- UTF-8 source string buffer
		size	 [integer!]
		blk		 [red-block!]
		return:  [red-string!]
		/local
			str  [red-string!]
	][
		str: as red-string! ALLOC_TAIL(blk)
		str/header: TYPE_STRING							;-- implicit reset of all header flags
		str/head: 0
		str/node: unicode/load-utf8 src size
		str/cache: either size < 64 [src][null]			;-- cache only small strings (experimental)
		str
	]

	load: func [
		src		 [c-string!]							;-- UTF-8 source string buffer
		size	 [integer!]
		return:  [red-string!]
	][
		load-in src size root
	]

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

		copy-cell as red-value! str stack/push*
	]

	;-- Actions --

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

		size: 1
		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				int: as red-integer! spec
				size: int/value
			]
			default [--NOT_IMPLEMENTED--]
		]
		str: as red-string! stack/push*
		str/header: TYPE_STRING							;-- implicit reset of all header flags
		str/head: 	0
		str/node: 	alloc-bytes size					;-- alloc enough space for at least a Latin1 string
		str
	]

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

		limit: either OPTION?(arg) [
			int: as red-integer! arg
			int/value
		][-1]
		concatenate buffer str limit no
		part - get-length str
	]

	sniff-chars: func [
		p	  [byte-ptr!]
		tail  [byte-ptr!]
		unit  [integer!]
		curly [int-ptr!]
		quote [int-ptr!]
		nl	  [int-ptr!]
		/local
			cp [integer!]
			p4 [int-ptr!]
	][
		while [p < tail][
			cp: switch unit [
				Latin1 [as-integer p/value]
				UCS-2  [(as-integer p/2) << 8 + p/1]
				UCS-4  [p4: as int-ptr! p p4/value]
			]
			switch cp [
				#"{"    [if curly/value >= 0 [curly/value: curly/value + 1]]
				#"}"    [curly/value: curly/value - 1]
				#"^""   [quote/value: quote/value + 1]
				#"^/"   [nl/value: 	  nl/value + 1]
				default [0]
			]
			p: p + unit
		]
	]

	append-escaped-char: func [
		buffer	[red-string!]
		cp	    [integer!]
		/local
			idx [integer!]
	][
		idx: cp + 1
		case [
			any [cp > 7Fh cp = 1Eh][
				append-char GET_BUFFER(buffer) as-integer #"^^"
				append-char GET_BUFFER(buffer) as-integer #"("
				concatenate-literal buffer to-hex cp
				append-char GET_BUFFER(buffer) as-integer #")"
			]
			all [cp < MAX_ESC_CHARS escape-chars/idx <> null-byte][
				append-char GET_BUFFER(buffer) as-integer escape-chars/idx
			]
			true [
				append-char GET_BUFFER(buffer) cp
			]
		]
	]

	mold: func [
		str		  [red-string!]
		buffer	  [red-string!]
		only?	  [logic!]
		all?	  [logic!]
		flat?	  [logic!]
		arg		  [red-value!]
		part	  [integer!]
		return:	  [integer!]
		/local
			int	   [red-integer!]
			limit  [integer!]
			s	   [series!]
			unit   [integer!]
			cp	   [integer!]
			p	   [byte-ptr!]
			p4	   [int-ptr!]
			head   [byte-ptr!]
			tail   [byte-ptr!]
			curly  [integer!]
			quote  [integer!]
			nl	   [integer!]
			open   [byte!]
			close  [byte!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/mold"]]

		limit: either OPTION?(arg) [
			int: as red-integer! arg
			int/value
		][0]

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

		tail: either zero? limit [						;@@ rework that part
			as byte-ptr! s/tail
		][
			p + (part << (unit >> 1))
		]
		if tail > as byte-ptr! s/tail [tail: as byte-ptr! s/tail]

		curly: 0
		quote: 0
		nl:    0
		sniff-chars p tail unit :curly :quote :nl

		either any [
			nl >= 3
			negative? curly
			positive? quote
			BRACES_THRESHOLD <= get-length str
		][
			open:  #"{"
			close: #"}"
		][
			open:  #"^""
			close: #"^""
		]

		append-char GET_BUFFER(buffer) as-integer open

		while [p < tail][
			cp: switch unit [
				Latin1 [as-integer p/value]
				UCS-2  [(as-integer p/2) << 8 + p/1]
				UCS-4  [p4: as int-ptr! p p4/value]
			]
			either open =  #"{" [
				switch cp [
					#"{" #"}" [
						append-char GET_BUFFER(buffer) as-integer #"^^"
						append-char GET_BUFFER(buffer) cp
					]
					#"^/" #"^"" [
						append-char GET_BUFFER(buffer) cp
					]
					default [
						append-escaped-char buffer cp
					]
				]
			][
				append-escaped-char buffer cp
			]
			p: p + unit
		]

		append-char GET_BUFFER(buffer) as-integer close
		part - ((as-integer tail - head) >> (unit >> 1)) - 2
	]

	compare: func [
		str1	  [red-string!]							;-- first operand
		str2	  [red-string!]							;-- second operand
		op		  [integer!]							;-- type of comparison
		return:	  [logic!]
		/local
			s1	  [series!]
			s2	  [series!]
			unit1 [integer!]
			unit2 [integer!]
			size1 [integer!]
			size2 [integer!]
			end	  [byte-ptr!]
			p1	  [byte-ptr!]
			p2	  [byte-ptr!]
			p4	  [int-ptr!]
			c1	  [integer!]
			c2	  [integer!]
			lax?  [logic!]
			res	  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/compare"]]

		if any [
			all [
				op = COMP_STRICT_EQUAL
				TYPE_OF(str2) <> TYPE_STRING
			]
			all [
				op <> COMP_STRICT_EQUAL
				TYPE_OF(str2) <> TYPE_STRING
				TYPE_OF(str2) <> TYPE_FILE
			]
		][RETURN_COMPARE_OTHER]

		s1: GET_BUFFER(str1)
		s2: GET_BUFFER(str2)
		unit1: GET_UNIT(s1)
		unit2: GET_UNIT(s2)
		size1: (as-integer s1/tail - s1/offset) >> (unit1 >> 1)- str1/head
		size2: (as-integer s2/tail - s2/offset) >> (unit2 >> 1)- str2/head

		if size1 <> size2 [								;-- shortcut exit for different sizes
			if any [op = COMP_EQUAL op = COMP_STRICT_EQUAL][return false]
			if op = COMP_NOT_EQUAL [return true]
		]
		if zero? size1 [								;-- shortcut exit for empty strings
			return any [op = COMP_EQUAL op = COMP_STRICT_EQUAL]
		]

		end: as byte-ptr! s1/tail						;-- only one "end" is needed
		p1:  (as byte-ptr! s1/offset) + (str1/head << (unit1 >> 1))
		p2:  (as byte-ptr! s2/offset) + (str2/head << (unit2 >> 1))
		lax?: op <> COMP_STRICT_EQUAL

		until [
			switch unit1 [
				Latin1 [c1: as-integer p1/1]
				UCS-2  [c1: (as-integer p1/2) << 8 + p1/1]
				UCS-4  [p4: as int-ptr! p1 c1: p4/1]
			]
			switch unit2 [
				Latin1 [c2: as-integer p2/1]
				UCS-2  [c2: (as-integer p2/2) << 8 + p2/1]
				UCS-4  [p4: as int-ptr! p2 c2: p4/1]
			]
			if lax? [
				if all [65 <= c1 c1 <= 90][c1: c1 + 32]	;-- lowercase c1
				if all [65 <= c2 c2 <= 90][c2: c2 + 32] ;-- lowercase c2
			]
			p1: p1 + unit1
			p2: p2 + unit2
			any [
				c1 <> c2
				p1 >= end
			]
		]
		switch op [
			COMP_EQUAL			[res: c1 = c2]
			COMP_NOT_EQUAL		[res: c1 <> c2]
			COMP_STRICT_EQUAL	[res: c1 = c2]
			COMP_LESSER			[res: c1 <  c2]
			COMP_LESSER_EQUAL	[res: c1 <= c2]
			COMP_GREATER		[res: c1 >  c2]
			COMP_GREATER_EQUAL	[res: c1 >= c2]
		]
		res
	]

	;--- Property reading actions ---

	head?: func [
		return:	  [red-value!]
		/local
			str	  [red-string!]
			state [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/head?"]]

		str:   as red-string! stack/arguments
		state: as red-logic! str

		state/header: TYPE_LOGIC
		state/value:  zero? str/head
		as red-value! state
	]

	tail?: func [
		return:	  [red-value!]
		/local
			str	  [red-string!]
			state [red-logic!]
			s	  [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/tail?"]]

		str:   as red-string! stack/arguments
		state: as red-logic! str

		s: GET_BUFFER(str)

		state/header: TYPE_LOGIC
		state/value:  (as byte-ptr! s/offset) + (str/head << (GET_UNIT(s) >> 1)) = as byte-ptr! s/tail
		as red-value! state
	]

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

		str:   as red-string! stack/arguments
		index: as red-integer! str

		index/header: TYPE_INTEGER
		index/value:  str/head + 1
		as red-value! index
	]

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

		str: as red-string! stack/arguments

		s: GET_BUFFER(str)

		int: as red-integer! str
		int/header: TYPE_INTEGER
		int/value:  (as-integer s/tail - s/offset) >> (GET_UNIT(s) >> 1) - str/head
		as red-value! int
	]

	;--- Navigation actions ---

	at: func [
		return:	[red-value!]
		/local
			str	[red-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/at"]]

		str: as red-string! stack/arguments
		str/head: get-position 1
		as red-value! str
	]

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

		block/back										;-- identical behaviour as block!
	]

	next: func [
		return:	  [red-value!]
		/local
			str	  [red-string!]
			s	  [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/next"]]

		str: as red-string! stack/arguments

		s: GET_BUFFER(str)

		if (as byte-ptr! s/offset) + (str/head + 1 << (GET_UNIT(s) >> 1)) <= as byte-ptr! s/tail [
			str/head: str/head + 1
		]
		as red-value! str
	]

	skip: func [
		return:	[red-value!]
		/local
			str	[red-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/skip"]]

		str: as red-string! stack/arguments
		str/head: get-position 0
		as red-value! str
	]

	head: func [
		return:	[red-value!]
		/local
			str	[red-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/head"]]

		str: as red-string! stack/arguments
		str/head: 0
		as red-value! str
	]

	tail: func [
		return:	[red-value!]
		/local
			str	[red-string!]
			s	[series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/tail"]]

		str: as red-string! stack/arguments
		s: GET_BUFFER(str)

		str/head: (as-integer s/tail - s/offset) >> (GET_UNIT(s) >> 1)
		as red-value! str
	]

	find: func [
		str			[red-string!]
		value		[red-value!]
		part		[red-value!]
		only?		[logic!]
		case?		[logic!]
		any?		[logic!]							;@@ not implemented
		with-arg	[red-string!]						;@@ not implemented
		skip		[red-integer!]
		last?		[logic!]
		reverse?	[logic!]
		tail?		[logic!]
		match?		[logic!]
		return:		[red-value!]
		/local
			s		[series!]
			s2		[series!]
			buffer	[byte-ptr!]
			pattern	[byte-ptr!]
			end		[byte-ptr!]
			end2	[byte-ptr!]
			result	[red-value!]
			int		[red-integer!]
			char	[red-char!]
			str2	[red-string!]
			unit	[encoding!]
			unit2	[encoding!]
			head2	[integer!]
			p1		[byte-ptr!]
			p2		[byte-ptr!]
			p4		[int-ptr!]
			c1		[integer!]
			c2		[integer!]
			step	[integer!]
			limit	[byte-ptr!]
			part?	[logic!]
			op		[integer!]
			found?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/find"]]

		result: stack/push as red-value! str

		s: GET_BUFFER(str)
		if s/offset = s/tail [							;-- early exit if string is empty
			result/header: TYPE_NONE
			return result
		]
		unit: GET_UNIT(s)
		step: 1
		part?: no

		;-- Options processing --

		if any [any? OPTION?(with-arg)][--NOT_IMPLEMENTED--]

		if OPTION?(skip) [
			assert TYPE_OF(skip) = TYPE_INTEGER
			step: skip/value
		]
		if OPTION?(part) [
			limit: either TYPE_OF(part) = TYPE_INTEGER [
				int: as red-integer! part
				if int/value <= 0 [						;-- early exit if part <= 0
					result/header: TYPE_NONE
					return result
				]
				(as byte-ptr! s/offset) + (int/value - 1 << (unit >> 1)) ;-- int argument is 1-based
			][
				str2: as red-string! part
				unless all [
					TYPE_OF(str2) = TYPE_OF(str)		;-- handles ANY-STRING!
					str2/node = str/node
				][
					print "*** Error: invalid /part series argument"	;@@ replace with error!
					halt
				]
				(as byte-ptr! s/offset) + (str2/head << (unit >> 1))
			]
			part?: yes
		]
		case [
			last? [
				step: 0 - step
				buffer: either part? [limit][(as byte-ptr! s/tail) - unit]
				end: as byte-ptr! s/offset
			]
			reverse? [
				step: 0 - step
				buffer: either part? [limit][(as byte-ptr! s/offset) + (str/head - 1 << (unit >> 1))]
				end: as byte-ptr! s/offset
				if buffer < end [							;-- early exit if str/head = 0
					result/header: TYPE_NONE
					return result
				]
			]
			true [
				buffer: (as byte-ptr! s/offset) + (str/head << (unit >> 1))
				end: either part? [limit + unit][as byte-ptr! s/tail] ;-- + unit => compensate for the '>= test
			]
		]
		case?: not case?								;-- inverted case? meaning
		reverse?: any [reverse? last?]					;-- reduce both flags to one
		step: step << (unit >> 1)
		pattern: null

		;-- Value argument processing --

		switch TYPE_OF(value) [
			TYPE_CHAR [
				char: as red-char! value
				c2: char/value
				if all [case? 65 <= c2 c2 <= 90][c2: c2 + 32] ;-- lowercase c2
			]
			TYPE_STRING TYPE_FILE TYPE_WORD [
				either TYPE_OF(value) = TYPE_WORD [
					str2: as red-string! word/get-buffer as red-word! value
					head2: 0							;-- str2/head = -1 (casted from symbol!)
				][
					str2: as red-string! value
					head2: str2/head
				]
				s2: GET_BUFFER(str2)
				unit2: GET_UNIT(s2)
				pattern: (as byte-ptr! s2/offset) + (head2 << (unit >> 1))
				end2:    (as byte-ptr! s2/tail)
			]
			default [
				result/header: TYPE_NONE
				return result
			]
		]

		;-- Search loop --
		until [
			either pattern = null [
				switch unit [
					Latin1 [c1: as-integer buffer/1]
					UCS-2  [c1: (as-integer buffer/2) << 8 + buffer/1]
					UCS-4  [p4: as int-ptr! buffer c1: p4/1]
				]
				if all [case? 65 <= c1 c1 <= 90][c1: c1 + 32] ;-- lowercase c1
				found?: c1 = c2
				if match? [buffer: buffer + 1]			;-- /match option returns tail of match
			][
				p1: buffer
				p2: pattern
				until [									;-- series comparison
					either unit = unit2 [
						switch unit [
							Latin1 [
								c1: as-integer p1/1
								c2: as-integer p2/1
							]
							UCS-2  [
								c1: (as-integer p1/2) << 8 + p1/1
								c2: (as-integer p2/2) << 8 + p2/1
							]
							UCS-4  [
								p4: as int-ptr! p1
								c1: p4/1
								p4: as int-ptr! p2
								c2: p4/1
							]
						]
					][
						switch unit [
							Latin1 [c1: as-integer p1/1]
							UCS-2  [c1: (as-integer p1/2) << 8 + p1/1]
							UCS-4  [p4: as int-ptr! p1 c1: p4/1]
						]
						switch unit2 [
							Latin1 [c2: as-integer p2/1]
							UCS-2  [c2: (as-integer p2/2) << 8 + p2/1]
							UCS-4  [p4: as int-ptr! p2 c2: p4/1]
						]
					]
					if all [case? 65 <= c1 c1 <= 90][c1: c1 + 32] ;-- lowercase c1
					if all [case? 65 <= c2 c2 <= 90][c2: c2 + 32] ;-- lowercase c2
					found?: c1 = c2

					p1: p1 + unit
					p2: p2 + unit2
					any [
						not found?						;-- no match
						p2 >= end2						;-- searched string tail reached
						all [reverse? p1 <= end]		;-- search buffer exhausted at head
						all [not reverse? p1 >= end]	;-- search buffer exhausted at tail
					]
				]
				if all [
					found?
					p2 < end2							;-- search string tail not reached
					any [								;-- search buffer exhausted
						all [reverse? p1 <= end]
						all [not reverse? p1 >= end]
					]
				][found?: no] 							;-- partial match case, make it fail

				if all [found? any [match? tail?]][buffer: p1]
			]
			buffer: buffer + step
			any [
				match?									;-- /match option limits to one comparison
				all [not match? found?]					;-- match found
				all [reverse? buffer <= end]			;-- head of block series reached
				all [not reverse? buffer >= end]		;-- tail of block series reached
			]
		]
		buffer: buffer - step							;-- compensate for extra step

		either found? [
			str: as red-string! result
			str/head: (as-integer buffer - s/offset) >> (unit >> 1)	;-- just change the head position on stack
		][
			result/header: TYPE_NONE					;-- change the stack 1st argument to none.
		]
		result
	]

	select: func [
		str		 [red-string!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		tail?	 [logic!]
		match?	 [logic!]
		return:	 [red-value!]
		/local
			s	   [series!]
			p	   [byte-ptr!]
			p4	   [int-ptr!]
			char   [red-char!]
			result [red-value!]
			str2   [red-string!]
			head2  [integer!]
			offset [integer!]
	][
		result: find str value part only? case? any? with-arg skip last? reverse? no no

		if TYPE_OF(result) <> TYPE_NONE [
			offset: switch TYPE_OF(value) [
				TYPE_STRING TYPE_FILE TYPE_WORD [
					either TYPE_OF(value) = TYPE_WORD [
						str2: as red-string! word/get-buffer as red-word! value
						head2: 0							;-- str2/head = -1 (casted from symbol!)
					][
						str2: as red-string! value
						head2: str2/head
					]
					s: GET_BUFFER(str2)
					(as-integer s/tail - s/offset) >> (GET_UNIT(s) >> 1) - head2
				]
				default [1]
			]
			str: as red-string! result
			s: GET_BUFFER(str)
			p: (as byte-ptr! s/offset) + ((str/head + offset) << (GET_UNIT(s) >> 1))

			either p < as byte-ptr! s/tail [
				char: as red-char! result
				char/header: TYPE_CHAR
				char/value: switch GET_UNIT(s) [
					Latin1 [as-integer p/value]
					UCS-2  [(as-integer p/2) << 8 + p/1]
					UCS-4  [p4: as int-ptr! p p4/value]
				]
			][
				result/header: TYPE_NONE
			]
		]
		result
	]

	;--- Reading actions ---

	pick: func [
		str	       [red-string!]
		index  	   [integer!]
		return:	   [red-value!]
		/local
			char   [red-char!]
			s	   [series!]
			offset [integer!]
			p1	   [byte-ptr!]
			p4	   [int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/pick"]]

		s: GET_BUFFER(str)

		offset: str/head + index - 1					;-- index is one-based
		if negative? index [offset: offset + 1]

		p1: (as byte-ptr! s/offset) + (offset << (GET_UNIT(s) >> 1))

		either any [
			zero? index
			p1 >= as byte-ptr! s/tail
			p1 <  as byte-ptr! s/offset
		][
			none-value
		][
			char: as red-char! stack/push*
			char/header: TYPE_CHAR
			char/value: switch GET_UNIT(s) [
				Latin1 [as-integer p1/value]
				UCS-2  [(as-integer p1/2) << 8 + p1/1]
				UCS-4  [p4: as int-ptr! p1 p4/value]
			]
			as red-value! char
		]
	]

	;--- Modifying actions ---

	append: func [
		str		 [red-string!]
		value	 [red-value!]
		part-arg [red-value!]
		only?	 [logic!]
		dup-arg	 [red-value!]
		return:	 [red-value!]
		/local
			src	  [red-block!]
			cell  [red-value!]
			limit [red-value!]
			int	  [red-integer!]
			char  [red-char!]
			sp	  [red-string!]
			s	  [series!]
			dst	  [series!]
			cnt	  [integer!]
			part  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/append"]]

		cnt:  1
		part: -1

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				int/value
			][
				sp: as red-string! part-arg
				assert all [
					TYPE_OF(sp) = TYPE_STRING			;@@ replace by ANY_STRING?
					TYPE_OF(sp) = TYPE_FILE
					sp/node = str/node
				]
				sp/head + 1								;-- /head is 0-based
			]
		]
		if OPTION?(dup-arg) [
			int: as red-integer! dup-arg
			cnt: int/value
		]

		while [not zero? cnt][							;-- /dup support
			either TYPE_OF(value) = TYPE_BLOCK [		;@@ replace it with: typeset/any-block?
				src: as red-block! value
				if negative? part [part: block/rs-length? src] ;-- if not /part, use whole value length
				s: GET_BUFFER(src)
				cell: s/offset + src/head
				limit: cell + part						;-- /part support

				while [cell < limit][					;-- multiple values case
					switch TYPE_OF(cell) [
						TYPE_CHAR [
							char: as red-char! cell
							append-char GET_BUFFER(str) char/value
						]
						TYPE_STRING TYPE_FILE [
							concatenate str as red-string! cell part no
						]
						default [
							--NOT_IMPLEMENTED--			;@@ actions/form needs to take an argument!
							;TBD once INSERT is implemented
						]
					]
					cell: cell + 1
				]
			][											;-- single value case
				switch TYPE_OF(value) [
					TYPE_CHAR [
						char: as red-char! value
						append-char GET_BUFFER(str) char/value
					]
					TYPE_STRING TYPE_FILE [
						concatenate str as red-string! value part no
					]
					default [
						;actions/form* -1				;-- FORM value before appending
						--NOT_IMPLEMENTED--
						;TBD once INSERT is implemented
					]
				]
			]
			cnt: cnt - 1
		]
		as red-value! str
	]

	clear: func [
		return:	[red-value!]
		/local
			str	[red-string!]
			s	[series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/clear"]]

		str: as red-string! stack/arguments
		s: GET_BUFFER(str)
		s/tail: as cell! (as byte-ptr! s/offset) + (str/head << (GET_UNIT(s) >> 1))
		as red-value! str
	]

	poke: func [
		str		   [red-string!]
		index	   [integer!]
		char	   [red-char!]
		return:	   [red-value!]
		/local
			s	   [series!]
			offset [integer!]
			pos	   [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/poke"]]

		s: GET_BUFFER(str)

		offset: str/head + index - 1					;-- index is one-based
		if negative? index [offset: offset + 1]

		pos: (as byte-ptr! s/offset) + (offset << (GET_UNIT(s) >> 1))

		either any [
			zero? index
			pos >= as byte-ptr! s/tail
			pos <  as byte-ptr! s/offset
		][
			--NOT_IMPLEMENTED--
			;TBD: waiting for error!
		][
			if TYPE_OF(char) <> TYPE_CHAR [
				print-line "Error: POKE expected char! value"	;@@ replace by error! when ready
				halt
			]
			poke-char s pos char/value
			stack/set-last as red-value! char
		]
		as red-value! char
	]

	;--- Misc actions ---

	copy: func [
		str	    	[red-string!]
		part-arg	[red-value!]
		deep?		[logic!]
		types		[red-value!]
		return:		[red-series!]
		/local
			int		[red-integer!]
			str2	[red-string!]
			offset	[integer!]
			s		[series!]
			buffer	[series!]
			new		[node!]
			unit	[integer!]
			part	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/copy"]]

		s: GET_BUFFER(str)
		unit: GET_UNIT(s)

		offset: str/head << (unit >> 1)
		part: (as-integer s/tail - s/offset) - offset

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

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				case [
					int/value > (part >> (unit >> 1)) [part >> (unit >> 1)]
					positive? int/value [int/value]
					true				[0]
				]
			][
				str2: as red-string! part-arg
				unless all [
					TYPE_OF(str2) = TYPE_OF(str)		;-- handles ANY-STRING!
					str2/node = str/node
				][
					print "*** Error: invalid /part series argument"	;@@ replace with error!
					halt
				]
				str2/head
			]
			part: part << (unit >> 1)
		]

		new: 	alloc-bytes part + unit
		buffer: as series! new/value

		unless zero? part [
			copy-memory
				as byte-ptr! buffer/offset
				(as byte-ptr! s/offset) + offset
				part

			buffer/tail: as cell! (as byte-ptr! buffer/offset) + part
		]
		add-terminal-NUL as byte-ptr! buffer/tail unit
		str/node: new									;-- reuse the block slot
		str/head: 0										;-- reset head offset
		as red-series! str
	]

	datatype/register [
		TYPE_STRING
		TYPE_VALUE
		"string!"
		;-- General actions --
		:make
		null			;random
		null			;reflect
		null			;to
		:form
		:mold
		null			;get-path
		null			;set-path
		: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 --
		:append
		:at
		:back
		null			;change
		:clear
		:copy
		:find
		:head
		:head?
		:index?
		null			;insert
		:length?
		:next
		:pick
		:poke
		null			;remove
		null			;reverse
		:select
		null			;sort
		:skip
		null			;swap
		:tail
		: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 test re issue 1113

TESTS: added test re issue 1113

Red [
	Title:   "Red/System path! datatype test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %char-test.red
	Version: "0.1.0"
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "path"

===start-group=== "block access"
	blk: [a b c [d] e]

	--test-- "blk-1"
		--assert blk/1 = 'a
		--assert blk/2 = 'b
		--assert blk/3 = 'c
		--assert blk/4 = [d]
		--assert blk/4/1 = 'd

	--test-- "blk-2"
		blk/1: 99
		--assert blk/1 = 99
		blk/2: 'z
		--assert blk/2 = 'z
		blk/4/1: -1
		--assert blk/4 = [-1]
		--assert blk = [99 z c [-1] e]

	--test-- "blk-3"
		idx: 1
		--assert blk/:idx = 99
		--assert blk/4/:idx = -1
		idx: 4
		--assert blk/:idx/1 = -1
		idx: 1
		blk/:idx: 0
		--assert blk/:idx = 0
		--assert blk/1 = 0

	--test-- "blk-4"
	idx: 'z
	--assert blk/:idx = 'c

	--test-- "blk-5"
	--assert blk/z = 'c

	--test-- "blk-6"
		blk: [4 5 6 ["o"]]
		idx: 2
		--assert blk/(1) = 4
		--assert blk/(1 + 2) = 6
		--assert blk/(idx) = 5

		--test-- "blk-7"
		--assert blk/(idx + 2)/(1) = "o"
		--assert blk/(idx + 2)/(1)/(idx - 1) = #"o"

	--test-- "blk-8"
		blk/(1): 99
		idx: 2
		--assert blk/1 = 99
		blk/(idx + 2)/(1)/(idx - 1): #"z"
		--assert blk/4/1/1 = #"z"

		--test-- "blk-9"
		inc: func [a][a + 1]
		--assert blk/(inc 1) = 5

===end-group===

===start-group=== "string access"
	str: "abcde"

	--test-- "str-1"
		--assert str/1 = #"a"
		--assert str/2 = #"b"
		--assert str/3 = #"c"
		--assert str/4 = #"d"

	--test-- "str-2"
		str/1: #"9"
		--assert str/1 = #"9"
		str/2: #"z"
		--assert str/2 = #"z"
		--assert str = "9zcde"

	--test-- "str-3"
		idx: 1
		--assert str/:idx = #"9"
		idx: 4
		--assert str/:idx = #"d"
		idx: 1
		str/:idx: #"0"
		--assert str/:idx = #"0"
		--assert str/1 = #"0"

	--test-- "str-4"
		str: "456o"
		idx: 2
		--assert str/(1) = #"4"
		--assert str/(1 + 2) = #"6"
		--assert str/(idx) = #"5"

	--test-- "str-5"
		str/(1): #"9"
		--assert str/1 = #"9"
		idx: 2
		str/(idx + 2): #"z"
		--assert str/4 = #"z"

	--test-- "str-6"
		inc: func [a][a + 1]
		--assert str/(inc 1) = #"5"

	--test-- "str-7 - issue #1113"
		s7-a: "abcz"
		s7-b: 5
		--assert none = s7-a/5
		--assert none = s7-a/:s7-b
		--assert none = s7-a/s7-b

===end-group===

~~~end-file~~~

Red [
	Title:   "Red/System path! datatype test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %char-test.red
	Version: "0.1.0"
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "path"

===start-group=== "block access"
	blk: [a b c [d] e]
	--test-- "blk-1"
	--assert blk/1 = 'a
	--assert blk/2 = 'b
	--assert blk/3 = 'c
	--assert blk/4 = [d]
	--assert blk/4/1 = 'd

	--test-- "blk-2"
	blk/1: 99
	--assert blk/1 = 99
	blk/2: 'z
	--assert blk/2 = 'z
	blk/4/1: -1
	--assert blk/4 = [-1]
	--assert blk = [99 z c [-1] e]

	--test-- "blk-3"
	idx: 1
	--assert blk/:idx = 99
	--assert blk/4/:idx = -1
	idx: 4
	--assert blk/:idx/1 = -1
	idx: 1
	blk/:idx: 0
	--assert blk/:idx = 0
	--assert blk/1 = 0

	--test-- "blk-4"
	idx: 'z
	--assert blk/:idx = 'c

	--test-- "blk-5"
	--assert blk/z = 'c

	--test-- "blk-6"
	blk: [4 5 6 ["o"]]
	idx: 2
	--assert blk/(1) = 4
	--assert blk/(1 + 2) = 6
	--assert blk/(idx) = 5

	--test-- "blk-7"
	--assert blk/(idx + 2)/(1) = "o"
	--assert blk/(idx + 2)/(1)/(idx - 1) = #"o"

	--test-- "blk-8"
	blk/(1): 99
	idx: 2
	--assert blk/1 = 99
	blk/(idx + 2)/(1)/(idx - 1): #"z"
	--assert blk/4/1/1 = #"z"

	--test-- "blk-9"
	inc: func [a][a + 1]
	--assert blk/(inc 1) = 5

===end-group===

===start-group=== "string access"
	str: "abcde"
	--test-- "str-1"
	--assert str/1 = #"a"
	--assert str/2 = #"b"
	--assert str/3 = #"c"
	--assert str/4 = #"d"

	--test-- "str-2"
	str/1: #"9"
	--assert str/1 = #"9"
	str/2: #"z"
	--assert str/2 = #"z"
	--assert str = "9zcde"

	--test-- "str-3"
	idx: 1
	--assert str/:idx = #"9"
	idx: 4
	--assert str/:idx = #"d"
	idx: 1
	str/:idx: #"0"
	--assert str/:idx = #"0"
	--assert str/1 = #"0"

	--test-- "str-4"
	str: "456o"
	idx: 2
	--assert str/(1) = #"4"
	--assert str/(1 + 2) = #"6"
	--assert str/(idx) = #"5"

	--test-- "str-5"
	str/(1): #"9"
	--assert str/1 = #"9"
	idx: 2
	str/(idx + 2): #"z"
	--assert str/4 = #"z"

	--test-- "str-6"
	inc: func [a][a + 1]
	--assert str/(inc 1) = #"5"

===end-group===

~~~end-file~~~


TESTS: added COMPOSE tests.

TESTS: added COMPOSE tests.

Red [
	Title:   "Red evaluation test script"
	Author:  "Nenad Rakocevic"
	File: 	 %evaluation-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "evaluation"

===start-group=== "do"

	--test-- "do-1"
		--assert 123 = do [123]

	--test-- "do-2"
		--assert none = do [none]

	--test-- "do-3"
		--assert false = do [false]

	--test-- "do-4"
		--assert 'z = do ['z]

	--test-- "do-5"
		a: 123
		--assert 123 = do [a]

	--test-- "do-6"
		--assert 3 = do [1 + 2]

	--test-- "do-7"
		--assert 7 = do [1 + 2 3 + 4]

	--test-- "do-8"
		--assert 9 = do [1 + length? mold append [1] #"t"]

	--test-- "do-9"
		--assert word! = do [type? first [a]]

===end-group===

===start-group=== "reduce"

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

	--test-- "reduce-2"
		--assert [] = do [reduce []]

	--test-- "reduce-3"
		--assert [123] = reduce [123]

	--test-- "reduce-4"
		--assert none = first reduce [none]

	--test-- "reduce-5"
		--assert false = first reduce [false]

	--test-- "reduce-6"
		--assert 'z = first reduce ['z]

	--test-- "reduce-7"
		a: 123
		--assert [123 8 z] = reduce [a 3 + 5 'z]

	--test-- "reduce-8"
		blk: [a b c]
		--assert [a b c 7 123] = reduce/into [3 + 4 a] blk

	--test-- "reduce-9"
		a: 123
		--assert [123 8 z] = do [reduce [a 3 + 5 'z]]

	;--test-- "reduce-10"
	;	blk: [a b c]
	;	--assert [a b c 7 123] = do [reduce/into [3 + 4 a] blk]		;; refinements not supported yet by DO

	--test-- "reduce-11"
		code: [1 + 3 a 'z append "hell" #"o"]
		--assert [4 123 z "hello"] = reduce code

	--test-- "reduce-11"
		code: [1 + 3 a 'z append "hell" #"o"]
		--assert [4 123 z "hello"] = do [reduce code]

	--test-- "reduce-12"
		--assert none = reduce none

	--test-- "reduce-13"
		--assert none = do [reduce none]

	--test-- "reduce-14"
		--assert [[]] = reduce [reduce []]

	--test-- "reduce-15"
		--assert [3 z] = reduce [
			1 + length? reduce [3 + 4 789] 'z
		]

	--test-- "reduce-16"
		--assert [[]] = do [reduce [reduce []]]

	--test-- "reduce-17"
		--assert [3 z] = do [
			reduce [
				1 + length? reduce [3 + 4 789] 'z
			]
		]

	--test-- "reduce-18"
		a: [3 + 4]
		--assert [7] = reduce a
		--assert [7] = do [reduce a]

===end-group===

===start-group=== "compose"

	--test-- "compose-1"
	--assert  [] = compose []
	--assert  [] = compose/deep []
	--assert  [] = compose/deep/only []
	--assert  [] = do [compose []]
	;--assert [] = do [compose/deep []]						;; refinements not supported yet by DO
	;--assert [] = do [compose/deep/only []]

	--test-- "compose-2"
	--assert [1 [2] "3" a 'b c: :d] = compose [1 [2] "3" a 'b c: :d]
	--assert [1 [2] "3" a 'b c: :d] = do [compose [1 [2] "3" a 'b c: :d]]

	--test-- "compose-3"
	--assert [1] = compose [(1)]
	--assert [1] = do [compose [(1)]]

	--test-- "compose-4"
	--assert none == first compose [(none)]
	--assert none == first do [compose [(none)]]

	--test-- "compose-5"
	--assert true == first compose [(true)]
	--assert true == first do [compose [(true)]]

	--test-- "compose-6"
	--assert [3] = compose [(1 + 2)]
	--assert [3] = do [compose [(1 + 2)]]

	--test-- "compose-7"
	--assert [x 9 y] = compose [x (4 + 5) y]
	--assert [x 9 y] = do [compose [x (4 + 5) y]]

	--test-- "compose-8"
	--assert [] = compose [([])]
	--assert [] = do [compose [([])]]

	--test-- "compose-9"
	--assert [[]] = compose/only [([])]
	;--assert [[]] = do [compose/only [([])]]				;; refinements not supported yet by DO

	--test-- "compose-10"
	--assert [1 2 3] = compose [([1 2 3])]
	--assert [1 2 3] = do [compose [([1 2 3])]]

	--test-- "compose-11"
	--assert [1 2 3] = compose [([1 2 3])]
	--assert [1 2 3] = do [compose [([1 2 3])]]

	--test-- "compose-12"
	--assert [[(5 + 6)]] = compose [[(5 + 6)]]
	--assert [[(5 + 6)]] = do [compose [[(5 + 6)]]]

	--test-- "compose-13"
	--assert [[1]] = compose/deep [[(7 - 6)]]
	;--assert [[1]] = do [compose/deep [[(7 - 6)]]]			;; refinements not supported yet by DO

	--test-- "compose-14"
	--assert [[]] = compose/deep [[([])]]
	;--assert [[]] = do [compose/deep [[([])]]]				;; refinements not supported yet by DO

	--test-- "compose-15"
	--assert [[[]]] = compose/deep/only [[([])]]
	;--assert [[[]]] = do [compose/deep/only [[([])]]]		;; refinements not supported yet by DO

	--test-- "compose-16"
	--assert [[8] x [9] y] = compose/deep [[(2 + 6)] x [(4 + 5)] y]
	;--assert [[8] x [9] y] = do [compose/deep [[(2 + 6)] x [(4 + 5)] y]]		;; refinements not supported yet by DO

	--test-- "compose-17"
	--assert [a 3 b 789 1 2 3] = compose [a (1 + 2) b () (print "") ([]) 789 ([1 2 3])]
	;--assert [a 3 b 789 1 2 3] = compose [a (1 + 2) b () (print "") ([]) 789 ([1 2 3])] 	;; refinements not supported yet by DO

	--test-- "compose-18"
	--assert [a 3 b [] 789 [1 2 3]] = compose/only [a (1 + 2) b () (print "") ([]) 789 ([1 2 3])]
	;--assert [a 3 b [] 789 [1 2 3]] = compose/only [a (1 + 2) b () (print "") ([]) 789 ([1 2 3])] 	;; refinements not supported yet by DO

	--test-- "compose-19"
	--assert [a [3] 8 b [2 3 [x "hello" x]]] = compose/deep [
		a [(1 + 2)] (9 - 1) b [
			2 3 [x (append "hell" #"o") x]
		]
	]
	;--assert [a [3] 8 b [2 3 [x "hello" x]]] = do [		;; refinements not supported yet by DO
	;	compose/deep [
	;		a [(1 + 2)] (9 - 1) b [
	;			2 3 [x (append "hell" #"o") x]
	;		]
	;	]
	;]

	--test-- "compose-20"
	a: [1 2 3]
	--assert [1 2 3 r 7] = compose/into [r (1 + 6)] a
	;--assert [1 2 3 r 7] = do [compose/into [r (1 + 6)] a] ;; refinements not supported yet by DO

	--test-- "compose-21"
	a: [(mold 2 + 3)]
	--assert ["5"] = compose a
	;--assert ["5"] = do [compose a]						;; refinements not supported yet by DO

===end-group===

~~~end-file~~~

Red [
	Title:   "Red evaluation test script"
	Author:  "Nenad Rakocevic"
	File: 	 %evaluation-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "evaluation"

===start-group=== "do"

	--test-- "do-1"
		--assert 123 = do [123]

	--test-- "do-2"
		--assert none = do [none]

	--test-- "do-3"
		--assert false = do [false]

	--test-- "do-4"
		--assert 'z = do ['z]

	--test-- "do-5"
		a: 123
		--assert 123 = do [a]

	--test-- "do-6"
		--assert 3 = do [1 + 2]

	--test-- "do-7"
		--assert 7 = do [1 + 2 3 + 4]

	--test-- "do-8"
		--assert 9 = do [1 + length? mold append [1] #"t"]

	--test-- "do-9"
		--assert word! = do [type? first [a]]

===end-group===

===start-group=== "reduce"

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

	--test-- "reduce-2"
		--assert [] = do [reduce []]

	--test-- "reduce-3"
		--assert [123] = reduce [123]

	--test-- "reduce-4"
		--assert none = first reduce [none]

	--test-- "reduce-5"
		--assert false = first reduce [false]

	--test-- "reduce-6"
		--assert 'z = first reduce ['z]

	--test-- "reduce-7"
		a: 123
		--assert [123 8 z] = reduce [a 3 + 5 'z]

	--test-- "reduce-8"
		blk: [a b c]
		--assert [a b c 7 123] = reduce/into [3 + 4 a] blk

	--test-- "reduce-9"
		a: 123
		--assert [123 8 z] = do [reduce [a 3 + 5 'z]]

	;--test-- "reduce-10"
	;	blk: [a b c]
	;	--assert [a b c 7 123] = do [reduce/into [3 + 4 a] blk]		;; refinements not supported yet by DO

	--test-- "reduce-11"
		code: [1 + 3 a 'z append "hell" #"o"]
		--assert [4 123 z "hello"] = reduce code

	--test-- "reduce-11"
		code: [1 + 3 a 'z append "hell" #"o"]
		--assert [4 123 z "hello"] = do [reduce code]

	--test-- "reduce-12"
		--assert none = reduce none

	--test-- "reduce-13"
		--assert none = do [reduce none]

	--test-- "reduce-14"
		--assert [[]] = reduce [reduce []]

	--test-- "reduce-15"
		--assert [3 z] = reduce [
			1 + length? reduce [3 + 4 789] 'z
		]

	--test-- "reduce-16"
		--assert [[]] = do [reduce [reduce []]]

	--test-- "reduce-17"
		--assert [3 z] = do [
			reduce [
				1 + length? reduce [3 + 4 789] 'z
			]
		]

===end-group===

~~~end-file~~~


FEAT: added support for hexadecimal literals to lexer. FEAT: added support for multiline comments to lexer.

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
	}
]

trans-integer: routine [
	start [string!]
	end	  [string!]
	/local
		c	 [integer!]
		n	 [integer!]
		m	 [integer!]
		len  [integer!]
		p	 [byte-ptr!]
		neg? [logic!]
][
	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

		m: n * 10
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		m: n + c - #"0"
		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]
]

trans-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
]

trans-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]
	]
]

trans-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
]

trans-word: routine [
	stack [block!]
	src   [string!]
	type  [datatype!]
	/local
		value [red-value!]
][
	value: as red-value! word/push-in (symbol/make-alt src) stack
	set-type value type/value
]

trans-pop: function [stack [block!]][
	value: last stack
	remove back tail stack
	append/only last stack :value
]

transcode: func [
	src		[string!]
	dst		[block! none!]
	return: [block!]
	/local
		cs stack pos s e value line count? wrong-delimiters comment-rule
		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 block-rule literal-value
		any-value escaped-char char-rule line-string nested-curly-braces
		multiline-string string-rule cnt trans-string new base c ws
		trans-file decode-hex decode-2hex hex
][
	cs:		[- - - - - - - - - - - - - - - -]			;-- memoized bitsets
	stack:	clear []
	count?:	yes											;-- if TRUE, lines counter is enabled
	line: 	1

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

	trans-string: [
		new: make string! (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				escaped-char (append new value)
				| set c skip (append new c)
			]
		]
		new
	]

	decode-hex: [
		set c [
			digit 			(value: c - #"0")
			| hexa-upper	(value: c - #"A" + 10)
			| hexa-lower	(value: c - #"a" + 10)
			| (print "*** Syntax Error: invalid file hexa encoding") ;@@ temporary hardcoded
		]
	]

	decode-2hex: [
		decode-hex (hex: value << 4)
		decode-hex (hex: hex + value)
	]

	trans-file: [
		new: make file! (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				#"%" decode-2hex (append new hex)
				| set c skip (append new c)
			]
		]
		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 [#"^(80)" - #"^(8A)"]			;-- 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)")
			]
			| s: [2 6 hexa-char] e: (				;-- Unicode values allowed up to 10FFFFh
				value: encode-UTF8-char s e
			)
		] #")"
		| #"^^" [
			[
				#"/" 	(value: #"^/")
				| #"-"	(value: #"^-")
				| #"?" 	(value: #"^(del)")			;@@FIXME
				| #"^^" (value: #"^^")				;-- caret escaping case
				| #"{"	(value: #"{")
				| #"}"	(value: #"}")
				| #"^""	(value: #"^"")
			]
			| s: caret-char (value: s/1 - 64)
		]
	]

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

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

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

	multiline-string: [#"{" s: nested-curly-braces]

	string-rule: [line-string | multiline-string]

	file-rule: [
		#"%" s: any [ahead [not-file-char | ws-no-count] break | skip] e:
	]

	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
			trans-push-path stack type					;-- create empty path
			trans-word last stack copy/part s e type	;-- push 1st path element
		)
		some [
			slash
			s: [
				integer-number-rule			(append last stack trans-integer s e)
				| begin-symbol-rule			(trans-word last stack copy/part s e word!)
				| paren-rule
				| #":" s: begin-symbol-rule	(trans-word last stack copy/part s e get-word!)
				;@@ add more datatypes here
			]
			opt [#":" (trans-set-path back tail stack)]
		] (trans-pop stack)
	]

	word-rule: 	[
		s: begin-symbol-rule (type: word!) [
			path-rule 									;-- path matched
			| opt [#":" (type: set-word!)]
			  (trans-word last 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!)
			| (trans-word last 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
			| (trans-word last stack copy/part s e type) ;-- lit-word matched
		]
	]

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

	refinement-rule: [
		slash (type: refinement!) s: symbol-rule
		(trans-word last stack copy/part s e type)
	]

	slash-rule: [s: [slash opt slash] e:]

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

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

	integer-rule: [
		integer-number-rule
		ahead [integer-end | ws-no-count | end]
	]

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

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

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

	multiline-comment-rule: [
		"comment" any ws [
			#"{" nested-curly-braces
			| (print "*** Syntax Error: multiline string expected after COMMENT") ;@@ temporary
		]
	]

	wrong-delimiters: [
		pos: [
			  #"]" (value: #"[") | #")" (value: #"(")
			| #"[" (value: #"]") | #"(" (value: #")")
		] :pos
		(print ["missing matching" value])
	]

	literal-value: [
		pos: (e: none) s: [
			comment-rule
			| multiline-comment-rule
			;| escaped-rule    (stack/push value)
			| integer-rule		(append last stack trans-integer s e)
			| hexa-rule			(append last stack probe trans-hexa s e)
			| word-rule
			| lit-word-rule
			| get-word-rule
			| slash-rule		(trans-word last stack copy/part s e word!)
			| refinement-rule
			| file-rule			(append last stack do trans-file)
			| char-rule			(append last stack value)
			| issue-rule
			| block-rule
			| paren-rule
			| string-rule		(append last stack do trans-string)
			;| binary-rule	  	(stack/push load-binary s e)
		]
	]

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

	parse/case src [any-value opt wrong-delimiters]
	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
	}
]

trans-integer: routine [
	start [string!]
	end	  [string!]
	/local
		c	 [integer!]
		n	 [integer!]
		m	 [integer!]
		len  [integer!]
		p	 [byte-ptr!]
		neg? [logic!]
][
	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

		m: n * 10
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		m: n + c - #"0"
		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]
]

trans-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]
	]
]

trans-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
]

trans-word: routine [
	stack [block!]
	src   [string!]
	type  [datatype!]
	/local
		value [red-value!]
][
	value: as red-value! word/push-in (symbol/make-alt src) stack
	set-type value type/value
]

trans-pop: function [stack [block!]][
	value: last stack
	remove back tail stack
	append/only last stack :value
]

transcode: func [
	src		[string!]
	dst		[block! none!]
	return: [block!]
	/local
		cs stack pos s e value line count? wrong-delimiters comment-rule
		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 block-rule literal-value
		any-value escaped-char char-rule line-string nested-curly-braces
		multiline-string string-rule cnt trans-string new base c ws
		trans-file decode-hex decode-2hex hex
][
	cs:		[- - - - - - - - - - - - - - - -]			;-- memoized bitsets
	stack:	clear []
	count?:	yes											;-- if TRUE, lines counter is enabled
	line: 	1

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

	trans-string: [
		new: make string! (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				escaped-char (append new value)
				| set c skip (append new c)
			]
		]
		new
	]

	decode-hex: [
		set c [
			digit 			(base: #"0")
			| hexa-upper	(base: #"A")
			| hexa-lower	(base: #"a")
			| (print "*** Syntax Error: invalid file hexa")
		]
	]

	decode-2hex: [
		decode-hex (hex: c - base << 8)
		decode-hex (hex: hex + c - base)
	]

	trans-file: [
		new: make file! (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				#"%" decode-2hex (append new hex)
				| set c skip (append new c)
			]
		]
		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 [#"^(80)" - #"^(8A)"]			;-- 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)")
			]
			| s: [2 6 hexa-char] e: (				;-- Unicode values allowed up to 10FFFFh
				value: encode-UTF8-char s e
			)
		] #")"
		| #"^^" [
			[
				#"/" 	(value: #"^/")
				| #"-"	(value: #"^-")
				| #"?" 	(value: #"^(del)")			;@@FIXME
				| #"^^" (value: #"^^")				;-- caret escaping case
				| #"{"	(value: #"{")
				| #"}"	(value: #"}")
				| #"^""	(value: #"^"")
			]
			| s: caret-char (value: s/1 - 64)
		]
	]

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

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

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

	multiline-string: [#"{" s: nested-curly-braces]

	string-rule: [line-string | multiline-string]

	file-rule: [
		#"%" s: any [ahead [not-file-char | ws-no-count] break | skip] e:
	]

	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
			trans-push-path stack type					;-- create empty path
			trans-word last stack copy/part s e type	;-- push 1st path element
		)
		some [
			slash
			s: [
				integer-number-rule			(append last stack trans-integer s e)
				| begin-symbol-rule			(trans-word last stack copy/part s e word!)
				| paren-rule
				| #":" s: begin-symbol-rule	(trans-word last stack copy/part s e get-word!)
				;@@ add more datatypes here
			]
			opt [#":" (trans-set-path back tail stack)]
		] (trans-pop stack)
	]

	word-rule: 	[
		s: begin-symbol-rule (type: word!) [
			path-rule 									;-- path matched
			| opt [#":" (type: set-word!)]
			  (trans-word last 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!)
			| (trans-word last 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
			| (trans-word last stack copy/part s e type) ;-- lit-word matched
		]
	]

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

	refinement-rule: [
		slash (type: refinement!) s: symbol-rule
		(trans-word last stack copy/part s e type)
	]

	slash-rule: [s: [slash opt slash] e:]

	hexa-rule: [2 8 hexa e: #"h" (type: integer!)]

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

	integer-rule: [
		integer-number-rule
		ahead [integer-end | ws-no-count | end]
	]

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

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

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

	wrong-delimiters: [
		pos: [
			  #"]" (value: #"[") | #")" (value: #"(")
			| #"[" (value: #"]") | #"(" (value: #")")
		] :pos
		(print ["missing matching" value])
	]

	literal-value: [
		pos: (e: none) s: [
			comment-rule
			;| multiline-comment-rule
			;| escaped-rule    (stack/push value)
			| integer-rule		(append last stack trans-integer s e)
			;| hexa-rule		  (stack/push decode-hexa	 copy/part s e)
			| word-rule
			| lit-word-rule
			| get-word-rule
			| slash-rule		(trans-word last stack copy/part s e word!)
			| refinement-rule
			| file-rule			(append last stack do trans-file)
			| char-rule			(append last stack value)
			| issue-rule
			| block-rule
			| paren-rule
			| string-rule		(append last stack do trans-string)
			;| binary-rule	  (stack/push load-binary s e)
		]
	]

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

	parse/case src [any-value opt wrong-delimiters]
	stack/1
]