FIX: several bugs in COMPARE on string! values. FIX: `type` local variable removed.

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

	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 TYPE_OF(str)   = TYPE_STRING
		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
	]

	truncate-tail: func [
		s	    [series!]
		offset  [integer!]								;-- negative offset from tail
		return: [series!]
		/local
			p	[byte-ptr!]
			p4	[int-ptr!]
	][
		if zero? offset [return s]
		assert negative? offset

		s/tail: as cell! (as byte-ptr! s/tail) + (offset * GET_UNIT(s))
		switch GET_UNIT(s) [
			Latin1 [p: as byte-ptr! s/tail p/1: as-byte 0]
			UCS-2  [p: as byte-ptr! s/tail p/1: as-byte 0 p/2: as-byte 0]
			UCS-4  [p4: as int-ptr! s/tail p4/1: 0]
		]
		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! p						;-- 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!]
			p4	  [int-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][str2/head]	;-- make symbol! used as string! pass safely
		h2: either TYPE_OF(str2) = TYPE_SYMBOL [0][str2/head]	;-- make symbol! used as string! pass safely

		size2: as-integer (as byte-ptr! s2/tail - s2/offset) - h2
		size: (as-integer (as byte-ptr! s1/tail - s1/offset )- h1) + size2
		if s1/size < size [s1: expand-series s1 size + unit1]	;-- account for terminal NUL
		if all [part >= 0 part < size2][size2: part]	;-- optionally limit str2 characters to copy

		either all [keep? unit1 <> unit2][
			p: as byte-ptr! s1/offset
			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 size2
			p: p + size2
		]
		switch unit1 [									;-- add terminal NUL
			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]
		]
		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: func [
		src		 [c-string!]							;-- UTF-8 source string buffer
		return:  [red-string!]
		/local
			str  [red-string!]
			size [integer!]
	][
		size: 1 + system/words/length? src
		str: as red-string! ALLOC_TAIL(root)
		str/header: TYPE_STRING							;-- implicit reset of all header flags
		str/head: 0
		str/node: unicode/load-utf8 src size			;@@ try to avoid length? call
		str/cache: either size < 64 [src][null]			;-- cache only small strings (experimental)
		str
	]

	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
	]

	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!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/mold"]]

		limit: either OPTION?(arg) [
			int: as red-integer! arg
			int/value
		][-1]
		append-char GET_BUFFER(buffer) as-integer #"^""
		concatenate buffer str limit no
		append-char GET_BUFFER(buffer) as-integer #"^""
		part - 2 - get-length str
	]

	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 TYPE_OF(str2) <> TYPE_STRING [
			return switch op [
				COMP_EQUAL
				COMP_STRICT_EQUAL [false]
				COMP_NOT_EQUAL 	  [true]
				default [
					--NOT_IMPLEMENTED--					;@@ add error handling
					false
				]
			]
		]
		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 - 1 << (unit1 >> 1))
		p2:  (as byte-ptr! s2/offset) + (str2/head - 1 << (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
	]

	;--- 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
					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 [
							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 [
						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 [
		return:	   [red-value!]
		/local
			str	   [red-string!]
			index  [red-integer!]
			char   [red-char!]
			s	   [series!]
			idx	   [integer!]
			offset [integer!]
			pos	   [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/poke"]]

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

		index: as red-integer! str + 1
		idx: index/value

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

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

		either any [
			zero? idx
			pos >= as byte-ptr! s/tail
			pos <  as byte-ptr! s/offset
		][
			--NOT_IMPLEMENTED--
			;TBD: waiting for error!
		][
			char: as red-char! str + 2
			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
		]
		as red-value! 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
		null			;copy
		null			;find
		:head
		:head?
		:index?
		null			;insert
		:length?
		:next
		:pick
		:poke
		null			;remove
		null			;reverse
		null			;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

	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 TYPE_OF(str)   = TYPE_STRING
		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
	]

	truncate-tail: func [
		s	    [series!]
		offset  [integer!]								;-- negative offset from tail
		return: [series!]
		/local
			p	[byte-ptr!]
			p4	[int-ptr!]
	][
		if zero? offset [return s]
		assert negative? offset

		s/tail: as cell! (as byte-ptr! s/tail) + (offset * GET_UNIT(s))
		switch GET_UNIT(s) [
			Latin1 [p: as byte-ptr! s/tail p/1: as-byte 0]
			UCS-2  [p: as byte-ptr! s/tail p/1: as-byte 0 p/2: as-byte 0]
			UCS-4  [p4: as int-ptr! s/tail p4/1: 0]
		]
		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! p						;-- 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!]
			p4	  [int-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][str2/head]	;-- make symbol! used as string! pass safely
		h2: either TYPE_OF(str2) = TYPE_SYMBOL [0][str2/head]	;-- make symbol! used as string! pass safely

		size2: as-integer (as byte-ptr! s2/tail - s2/offset) - h2
		size: (as-integer (as byte-ptr! s1/tail - s1/offset )- h1) + size2
		if s1/size < size [s1: expand-series s1 size + unit1]	;-- account for terminal NUL
		if all [part >= 0 part < size2][size2: part]	;-- optionally limit str2 characters to copy

		either all [keep? unit1 <> unit2][
			p: as byte-ptr! s1/offset
			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 size2
			p: p + size2
		]
		switch unit1 [									;-- add terminal NUL
			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]
		]
		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: func [
		src		 [c-string!]							;-- UTF-8 source string buffer
		return:  [red-string!]
		/local
			str  [red-string!]
			size [integer!]
	][
		size: 1 + system/words/length? src
		str: as red-string! ALLOC_TAIL(root)
		str/header: TYPE_STRING							;-- implicit reset of all header flags
		str/head: 0
		str/node: unicode/load-utf8 src size			;@@ try to avoid length? call
		str/cache: either size < 64 [src][null]			;-- cache only small strings (experimental)
		str
	]

	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
	]

	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!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/mold"]]

		limit: either OPTION?(arg) [
			int: as red-integer! arg
			int/value
		][-1]
		append-char GET_BUFFER(buffer) as-integer #"^""
		concatenate buffer str limit no
		append-char GET_BUFFER(buffer) as-integer #"^""
		part - 2 - get-length str
	]

	compare: func [
		str1	  [red-string!]							;-- first operand
		str2	  [red-string!]							;-- second operand
		op		  [integer!]							;-- type of comparison
		return:	  [logic!]
		/local
			type  [integer!]
			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"]]

		type: TYPE_OF(str2)
		if type <> TYPE_STRING [
			return switch op [
				COMP_EQUAL
				COMP_STRICT_EQUAL [false]
				COMP_NOT_EQUAL 	  [true]
				default [
					--NOT_IMPLEMENTED--					;@@ add error handling
					false
				]
			]
		]
		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/offset						;-- only one "end" is needed
		p1:  as byte-ptr! s1/offset
		p2:  as byte-ptr! s2/offset
		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
	]

	;--- 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
					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 [
							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 [
						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 [
		return:	   [red-value!]
		/local
			str	   [red-string!]
			index  [red-integer!]
			char   [red-char!]
			s	   [series!]
			idx	   [integer!]
			offset [integer!]
			pos	   [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "string/poke"]]

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

		index: as red-integer! str + 1
		idx: index/value

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

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

		either any [
			zero? idx
			pos >= as byte-ptr! s/tail
			pos <  as byte-ptr! s/offset
		][
			--NOT_IMPLEMENTED--
			;TBD: waiting for error!
		][
			char: as red-char! str + 2
			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
		]
		as red-value! 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
		null			;copy
		null			;find
		:head
		:head?
		:index?
		null			;insert
		:length?
		:next
		:pick
		:poke
		null			;remove
		null			;reverse
		null			;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
	]
]


FIX: issue! values comparison was not working.

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

word: context [
	verbose: 0

	load-in: func [
		str 	[c-string!]
		blk		[red-block!]
		return:	[red-word!]
		/local
			id    [integer!]							;-- symbol ID
			cell  [red-word!]
	][
		id: symbol/make str

		cell: as red-word! ALLOC_TAIL(blk)
		cell/header: TYPE_WORD							;-- implicit reset of all header flags
		cell/ctx: 	 global-ctx
		cell/symbol: id
		cell/index:  _context/add global-ctx cell
		cell
	]

	load: func [
		str 	[c-string!]
		return:	[red-word!]
	][
		load-in str root
	]

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

		cell: as red-word! stack/push*
		copy-cell as cell! word as cell! cell
		cell
	]

	push-local: func [
		ctx		[red-context!]
		index	[integer!]
		return: [red-word!]
		/local
			s	[series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "word/push-local"]]

		s: as series! ctx/symbols/value
		push as red-word! s/offset + index
	]

	get-buffer: func [
		w		[red-word!]
		return: [red-symbol!]
	][
		symbol/get w/symbol
	]

	set: func [
		/local
			args [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "word/set"]]

		args: stack/arguments
		_context/set as red-word! args args + 1
		stack/set-last args + 1
	]

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

		value: copy-cell _context/get word stack/push*

		if TYPE_OF(value) = TYPE_LIT_WORD [
			value/header: TYPE_WORD						;-- cast lit-word! to word!
		]
		value
	]

	;-- Actions --

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

		s: GET_BUFFER(symbols)

		string/form
			as red-string! s/offset + w/symbol - 1		;-- symbol! and string! structs are overlapping
			buffer
			arg
			part
	]

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

		form w buffer arg part
	]

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

		type: TYPE_OF(arg2)
		switch op [
			COMP_EQUAL [
				res: all [
					any [								;@@ replace by ANY_WORD? when available
						type = TYPE_WORD
						type = TYPE_GET_WORD
						type = TYPE_SET_WORD
						type = TYPE_LIT_WORD
						type = TYPE_REFINEMENT
						type = TYPE_ISSUE
					]
					(symbol/resolve arg1/symbol) = (symbol/resolve arg2/symbol)
				]
			]
			COMP_STRICT_EQUAL [
				res: all [
					type = TYPE_WORD
					arg1/symbol = arg2/symbol
				]
			]
			COMP_NOT_EQUAL [
				res: not compare arg1 arg2 COMP_EQUAL
			]
			default [
				print-line ["Error: cannot use: " op " comparison on any-word! value"]
			]
		]
		res
	]

	datatype/register [
		TYPE_WORD
		TYPE_SYMBOL
		"word!"
		;-- General actions --
		null			;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 --
		null			;append
		null			;at
		null			;back
		null			;change
		null			;clear
		null			;copy
		null			;find
		null			;head
		null			;head?
		null			;index?
		null			;insert
		null			;length?
		null			;next
		null			;pick
		null			;poke
		null			;remove
		null			;reverse
		null			;select
		null			;sort
		null			;skip
		null			;swap
		null			;tail
		null			;tail?
		null			;take
		null			;trim
		;-- I/O actions --
		null			;create
		null			;close
		null			;delete
		null			;modify
		null			;open
		null			;open?
		null			;query
		null			;read
		null			;rename
		null			;update
		null			;write
	]
]

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

word: context [
	verbose: 0

	load-in: func [
		str 	[c-string!]
		blk		[red-block!]
		return:	[red-word!]
		/local
			id    [integer!]							;-- symbol ID
			cell  [red-word!]
	][
		id: symbol/make str

		cell: as red-word! ALLOC_TAIL(blk)
		cell/header: TYPE_WORD							;-- implicit reset of all header flags
		cell/ctx: 	 global-ctx
		cell/symbol: id
		cell/index:  _context/add global-ctx cell
		cell
	]

	load: func [
		str 	[c-string!]
		return:	[red-word!]
	][
		load-in str root
	]

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

		cell: as red-word! stack/push*
		copy-cell as cell! word as cell! cell
		cell
	]

	push-local: func [
		ctx		[red-context!]
		index	[integer!]
		return: [red-word!]
		/local
			s	[series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "word/push-local"]]

		s: as series! ctx/symbols/value
		push as red-word! s/offset + index
	]

	get-buffer: func [
		w		[red-word!]
		return: [red-symbol!]
	][
		symbol/get w/symbol
	]

	set: func [
		/local
			args [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "word/set"]]

		args: stack/arguments
		_context/set as red-word! args args + 1
		stack/set-last args + 1
	]

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

		value: copy-cell _context/get word stack/push*

		if TYPE_OF(value) = TYPE_LIT_WORD [
			value/header: TYPE_WORD						;-- cast lit-word! to word!
		]
		value
	]

	;-- Actions --

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

		s: GET_BUFFER(symbols)

		string/form
			as red-string! s/offset + w/symbol - 1		;-- symbol! and string! structs are overlapping
			buffer
			arg
			part
	]

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

		form w buffer arg part
	]

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

		type: TYPE_OF(arg2)
		switch op [
			COMP_EQUAL [
				res: all [
					any [								;@@ replace by ANY_WORD? when available
						type = TYPE_WORD
						type = TYPE_GET_WORD
						type = TYPE_SET_WORD
						type = TYPE_LIT_WORD
						type = TYPE_REFINEMENT
					]
					(symbol/resolve arg1/symbol) = (symbol/resolve arg2/symbol)
				]
			]
			COMP_STRICT_EQUAL [
				res: all [
					type = TYPE_WORD
					arg1/symbol = arg2/symbol
				]
			]
			COMP_NOT_EQUAL [
				res: not compare arg1 arg2 COMP_EQUAL
			]
			default [
				print-line ["Error: cannot use: " op " comparison on any-word! value"]
			]
		]
		res
	]

	datatype/register [
		TYPE_WORD
		TYPE_SYMBOL
		"word!"
		;-- General actions --
		null			;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 --
		null			;append
		null			;at
		null			;back
		null			;change
		null			;clear
		null			;copy
		null			;find
		null			;head
		null			;head?
		null			;index?
		null			;insert
		null			;length?
		null			;next
		null			;pick
		null			;poke
		null			;remove
		null			;reverse
		null			;select
		null			;sort
		null			;skip
		null			;swap
		null			;tail
		null			;tail?
		null			;take
		null			;trim
		;-- I/O actions --
		null			;create
		null			;close
		null			;delete
		null			;modify
		null			;open
		null			;open?
		null			;query
		null			;read
		null			;rename
		null			;update
		null			;write
	]
]


FIX: minor change, capitalizing the main error messages.

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

system: context [
	version: #version
	build:	 #build-date

	words: func	["Return a block of global words available"][
		#system [_context/get-words]
	]

	platform: func ["Return a word identifying the operating system"][
		#system [
			#switch OS [
				Windows  [SET_RETURN(words/_windows)]
				Syllable [SET_RETURN(words/_syllable)]
				MacOSX	 [SET_RETURN(words/_macosx)]
				#default [SET_RETURN(words/_linux)]
			]
		]
	]

	catalog: context [
		datatypes:
		actions:
		natives:
		errors: context [
			throw: object [
				code: 0
				type: "Throw error"
				break: "no loop to break"
				return: "return or exit not in function"
				throw: ["no catch for throw:" :arg1]
				continue: "no loop to continue"
			]
			note: object [
				code: 100
				type: "note"
				no-load: ["cannot load: " :arg1]
			]
			syntax: object [
				code: 200
				type: "Syntax error"
				invalid: ["invalid" :arg1 "--" :arg2]
				missing: ["missing" :arg2 "at" :arg1]
				no-header: ["script is missing a Red header:" :arg1]
				no-rs-header: ["script is missing a Red/System header:" :arg1]
				bad-header: ["script header is not valid:" :arg1]
				malconstruct: ["invalid construction spec:" :arg1]
				bad-char: ["invalid character in:" :arg1]
			]
			script: object [
				code: 300
				type: "Script error"
				no-value: [:arg1 "has no value"]
				need-value: [:arg1 "needs a value"]
				not-defined: [:arg1 "word is not bound to a context"]
				not-in-context: [:arg1 "is not in the specified context"]
				no-arg: [:arg1 "is missing its" :arg2 "argument"]
				expect-arg: [:arg1 "does not allow" :arg2 "for its" :arg3 "argument"]
				expect-val: ["expected" :arg1 "not" :arg2]

				expect-type: [:arg1 :arg2 "field must be of type" :arg3]
				cannot-use: ["cannot use" :arg1 "on" :arg2 "value"]
				invalid-arg: ["invalid argument:" :arg1]
				invalid-type: [:arg1 "type is not allowed here"]
				invalid-op: ["invalid operator:" :arg1]
				no-op-arg: [:arg1 "operator is missing an argument"]
				invalid-data: ["data not in correct format:" :arg1]
				not-same-type: "values must be of the same type"
				not-related: ["incompatible argument for" :arg1 "of" :arg2]
				bad-func-def: ["invalid function definition:" :arg1]
				bad-func-arg: ["function argument" :arg1 "is not valid"]
				no-refine: [:arg1 "has no refinement called" :arg2]
				bad-refines: "incompatible or invalid refinements"
				bad-refine: ["incompatible refinement:" :arg1]
				invalid-path: ["cannot access" :arg2 "in path" :arg1]
				bad-path-type: ["path" :arg1 "is not valid for" :arg2 "type"]
				bad-path-set: ["cannot set" :arg2 "in path" :arg1]
				bad-field-set: ["cannot set" :arg1 "field to" :arg2 "datatype"]
				dup-vars: ["duplicate variable specified:" :arg1]
				past-end: "out of range or past end"
				missing-arg: "missing a required argument or refinement"
				out-of-range: ["value out of range:" :arg1]
				invalid-chars: "contains invalid characters"
				invalid-compare: ["cannot compare" :arg1 "with" :arg2]
				wrong-type: ["datatype assertion failed for:" :arg1]
				invalid-part: ["invalid /part count:" :arg1]
				type-limit: [:arg1 "overflow/underflow"]
				size-limit: ["maximum limit reached:" :arg1]
				no-return: "block did not return a value"
				throw-usage: "invalid use of a thrown error value"
				;locked-word: ["protected variable - cannot modify:" :arg1]
				;protected: "protected value or series - cannot modify"
				;self-protected: "cannot set/unset self - it is protected"
				bad-bad: [:arg1 "error:" :arg2]
				bad-make-arg: ["cannot MAKE/TO" :arg1 "from:" :arg2]
				;bad-decode: "missing or unsupported encoding marker"
				;already-used: ["alias word is already in use:" :arg1]
				;wrong-denom: [:arg1 "not same denomination as" :arg2]
				;bad-press: ["invalid compressed data - problem:" :arg1]
				;dialect: ["incorrect" :arg1 "dialect usage at:" :arg2]
				;parse-rule: ["PARSE - invalid rule or usage of rule:" :arg1]
				;parse-end: ["PARSE - unexpected end of rule after:" :arg1]
				;parse-variable: ["PARSE - expected a variable, not:" :arg1]
				;parse-command: ["PARSE - command cannot be used as variable:" :arg1]
				;parse-series: ["PARSE - input must be a series:" :arg1]
			]
			math: object [
				code: 400
				type: "Math error"
				zero-divide: "attempt to divide by zero"
				overflow: "math or number overflow"
				positive: "positive number required"
			]
			access: object [
				code: 500
				type: "Access error"
				;cannot-open: ["cannot open:" :arg1 "reason:" :arg2]
				;not-open: ["port is not open:" :arg1]
				;already-open: ["port is already open:" :arg1]
				;no-connect: ["cannot connect:" :arg1 "reason:" :arg2]
				;not-connected: ["port is not connected:" :arg1]
				;no-script: ["script not found:" :arg1]
				;no-scheme-name: ["new scheme must have a name:" :arg1]
				;no-scheme: ["missing port scheme:" :arg1]
				;invalid-spec: ["invalid spec or options:" :arg1]
				;invalid-port: ["invalid port object (invalid field values)"]
				;invalid-actor: ["invalid port actor (must be native or object)"]
				;invalid-port-arg: ["invalid port argument:" arg1]
				;no-port-action: ["this port does not support:" :arg1]
				;protocol: ["protocol error:" :arg1]
				;invalid-check: ["invalid checksum (tampered file):" :arg1]
				;write-error: ["write failed:" :arg1 "reason:" :arg2]
				;read-error: ["read failed:" :arg1 "reason:" :arg2]
				;read-only: ["read-only - write not allowed:" :arg1]
				;no-buffer: ["port has no data buffer:" :arg1]
				;timeout: ["port action timed out:" :arg1]
				;no-create: ["cannot create:" :arg1]
				;no-delete: ["cannot delete:" :arg1]
				;no-rename: ["cannot rename:" :arg1]
				;bad-file-path: ["bad file path:" :arg1]
				;bad-file-mode: ["bad file mode:" :arg1]
				;security: ["security violation:" :arg1 " (refer to SECURE function)"]
				;security-level: ["attempt to lower security to" :arg1]
				;security-error: ["invalid" :arg1 "security policy:" :arg2]
				;no-codec: ["cannot decode or encode (no codec):" :arg1]
				;bad-media: ["bad media data (corrupt image, sound, video)"]
				;no-extension: ["cannot open extension:" :arg1]
				;bad-extension: ["invalid extension format:" :arg1]
				;extension-init: ["extension cannot be initialized (check version):" :arg1]
				;call-fail: ["external process failed:" :arg1]
			]
			user: object [
				code: 800
				type: "User error"
				message: [:arg1]
			]
			internal: object [
				code: 900
				type: "Internal error"
				bad-path: ["bad path:" arg1]
				not-here: [arg1 "not supported on your system"]
				no-memory: "not enough memory"
				stack-overflow: "stack overflow"
				;bad-series: "invalid series"
				;limit-hit: ["internal limit reached:" :arg1]
				;bad-sys-func: ["invalid or missing system function:" :arg1]
				feature-na: "feature not available"
				not-done: "reserved for future use (or not yet implemented)"
				;invalid-error: "error object or fields were not valid"
			]
		]

	]

	state: context [
		interpreted?: func ["Return TRUE if called from the interpreter"][
			#system [logic/box stack/eval?]
		]

		last-error: none
	]

	modules: make block! 8
	codecs:  context []
	schemes: context []
	ports:	 context []

	locale: context [
		language:
		language*:										;-- in locale language
		locale:
		locale*: none									;-- in locale language

		months: [
		  "January" "February" "March" "April" "May" "June"
		  "July" "August" "September" "October" "November" "December"
		]

		days: [
		  "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"
		]
	]

	options: context [
		boot: 			none
		home: 			none
		path: 			none
		script: 		none
		args: 			none
		do-arg: 		none
		debug: 			none
		secure: 		none
		quiet: 			false
		binary-base: 	16
		decimal-digits: 15
		module-paths: 	make block! 1
		file-types: 	none

		;-- change the way float numbers are processed
		float: context [
			pretty?: false
			full?: 	 false

			on-change*: func [word old new][
				switch word [
					pretty? [
						either new [
							#system [float/pretty-print?: yes]
						][
							#system [float/pretty-print?: no]
						]
					]
					full? [
						either new [
							#system [float/full-support?: yes]
						][
							#system [float/full-support?: no]
						]
					]
				]
			]
		]
	]

	script: context [
		title: header: parent: path: args: none
	]

	standard: context [
		header: context [
			title: name: type: version: date: file: author: needs: none
		]
		error: context [
			code: type: id: arg1: arg2: arg3: near: where: none
		]
	]

	view: context [
		screen: 	none
		event-port: none

		metrics: context [
			screen-size: 	none
			dpi:			none
			;scaling:		1x1
		]
	]

	lexer: none
	console: none
]

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

system: context [
	version: #version
	build:	 #build-date

	words: func	["Return a block of global words available"][
		#system [_context/get-words]
	]

	platform: func ["Return a word identifying the operating system"][
		#system [
			#switch OS [
				Windows  [SET_RETURN(words/_windows)]
				Syllable [SET_RETURN(words/_syllable)]
				MacOSX	 [SET_RETURN(words/_macosx)]
				#default [SET_RETURN(words/_linux)]
			]
		]
	]

	catalog: context [
		datatypes:
		actions:
		natives:
		errors: context [
			throw: object [
				code: 0
				type: "throw error"
				break: "no loop to break"
				return: "return or exit not in function"
				throw: ["no catch for throw:" :arg1]
				continue: "no loop to continue"
			]
			note: object [
				code: 100
				type: "note"
				no-load: ["cannot load: " :arg1]
			]
			syntax: object [
				code: 200
				type: "syntax error"
				invalid: ["invalid" :arg1 "--" :arg2]
				missing: ["missing" :arg2 "at" :arg1]
				no-header: ["script is missing a Red header:" :arg1]
				no-rs-header: ["script is missing a Red/System header:" :arg1]
				bad-header: ["script header is not valid:" :arg1]
				malconstruct: ["invalid construction spec:" :arg1]
				bad-char: ["invalid character in:" :arg1]
			]
			script: object [
				code: 300
				type: "script error"
				no-value: [:arg1 "has no value"]
				need-value: [:arg1 "needs a value"]
				not-defined: [:arg1 "word is not bound to a context"]
				not-in-context: [:arg1 "is not in the specified context"]
				no-arg: [:arg1 "is missing its" :arg2 "argument"]
				expect-arg: [:arg1 "does not allow" :arg3 "for its" :arg2 "argument"]
				expect-val: ["expected" :arg1 "not" :arg2]
				expect-type: [:arg1 :arg2 "field must be of type" :arg3]
				cannot-use: ["cannot use" :arg1 "on" :arg2 "value"]
				invalid-arg: ["invalid argument:" :arg1]
				invalid-type: [:arg1 "type is not allowed here"]
				invalid-op: ["invalid operator:" :arg1]
				no-op-arg: [:arg1 "operator is missing an argument"]
				invalid-data: ["data not in correct format:" :arg1]
				not-same-type: "values must be of the same type"
				not-related: ["incompatible argument for" :arg1 "of" :arg2]
				bad-func-def: ["invalid function definition:" :arg1]
				bad-func-arg: ["function argument" :arg1 "is not valid"]
				no-refine: [:arg1 "has no refinement called" :arg2]
				bad-refines: "incompatible or invalid refinements"
				bad-refine: ["incompatible refinement:" :arg1]
				invalid-path: ["cannot access" :arg2 "in path" :arg1]
				bad-path-type: ["path" :arg1 "is not valid for" :arg2 "type"]
				bad-path-set: ["cannot set" :arg2 "in path" :arg1]
				bad-field-set: ["cannot set" :arg1 "field to" :arg2 "datatype"]
				dup-vars: ["duplicate variable specified:" :arg1]
				past-end: "out of range or past end"
				missing-arg: "missing a required argument or refinement"
				out-of-range: ["value out of range:" :arg1]
				invalid-chars: "contains invalid characters"
				invalid-compare: ["cannot compare" :arg1 "with" :arg2]
				wrong-type: ["datatype assertion failed for:" :arg1]
				invalid-part: ["invalid /part count:" :arg1]
				type-limit: [:arg1 "overflow/underflow"]
				size-limit: ["maximum limit reached:" :arg1]
				no-return: "block did not return a value"
				throw-usage: "invalid use of a thrown error value"
				;locked-word: ["protected variable - cannot modify:" :arg1]
				;protected: "protected value or series - cannot modify"
				;self-protected: "cannot set/unset self - it is protected"
				bad-bad: [:arg1 "error:" :arg2]
				bad-make-arg: ["cannot MAKE/TO" :arg1 "from:" :arg2]
				;bad-decode: "missing or unsupported encoding marker"
				;already-used: ["alias word is already in use:" :arg1]
				;wrong-denom: [:arg1 "not same denomination as" :arg2]
				;bad-press: ["invalid compressed data - problem:" :arg1]
				;dialect: ["incorrect" :arg1 "dialect usage at:" :arg2]
				;parse-rule: ["PARSE - invalid rule or usage of rule:" :arg1]
				;parse-end: ["PARSE - unexpected end of rule after:" :arg1]
				;parse-variable: ["PARSE - expected a variable, not:" :arg1]
				;parse-command: ["PARSE - command cannot be used as variable:" :arg1]
				;parse-series: ["PARSE - input must be a series:" :arg1]
			]
			math: object [
				code: 400
				type: "math error"
				zero-divide: "attempt to divide by zero"
				overflow: "math or number overflow"
				positive: "positive number required"
			]
			access: object [
				code: 500
				type: "access error"
				;cannot-open: ["cannot open:" :arg1 "reason:" :arg2]
				;not-open: ["port is not open:" :arg1]
				;already-open: ["port is already open:" :arg1]
				;no-connect: ["cannot connect:" :arg1 "reason:" :arg2]
				;not-connected: ["port is not connected:" :arg1]
				;no-script: ["script not found:" :arg1]
				;no-scheme-name: ["new scheme must have a name:" :arg1]
				;no-scheme: ["missing port scheme:" :arg1]
				;invalid-spec: ["invalid spec or options:" :arg1]
				;invalid-port: ["invalid port object (invalid field values)"]
				;invalid-actor: ["invalid port actor (must be native or object)"]
				;invalid-port-arg: ["invalid port argument:" arg1]
				;no-port-action: ["this port does not support:" :arg1]
				;protocol: ["protocol error:" :arg1]
				;invalid-check: ["invalid checksum (tampered file):" :arg1]
				;write-error: ["write failed:" :arg1 "reason:" :arg2]
				;read-error: ["read failed:" :arg1 "reason:" :arg2]
				;read-only: ["read-only - write not allowed:" :arg1]
				;no-buffer: ["port has no data buffer:" :arg1]
				;timeout: ["port action timed out:" :arg1]
				;no-create: ["cannot create:" :arg1]
				;no-delete: ["cannot delete:" :arg1]
				;no-rename: ["cannot rename:" :arg1]
				;bad-file-path: ["bad file path:" :arg1]
				;bad-file-mode: ["bad file mode:" :arg1]
				;security: ["security violation:" :arg1 " (refer to SECURE function)"]
				;security-level: ["attempt to lower security to" :arg1]
				;security-error: ["invalid" :arg1 "security policy:" :arg2]
				;no-codec: ["cannot decode or encode (no codec):" :arg1]
				;bad-media: ["bad media data (corrupt image, sound, video)"]
				;no-extension: ["cannot open extension:" :arg1]
				;bad-extension: ["invalid extension format:" :arg1]
				;extension-init: ["extension cannot be initialized (check version):" :arg1]
				;call-fail: ["external process failed:" :arg1]
			]
			user: object [
				code: 800
				type: "user error"
				message: [:arg1]
			]
			internal: object [
				code: 900
				type: "internal error"
				bad-path: ["bad path:" arg1]
				not-here: [arg1 "not supported on your system"]
				no-memory: "not enough memory"
				stack-overflow: "stack overflow"
				;bad-series: "invalid series"
				;limit-hit: ["internal limit reached:" :arg1]
				;bad-sys-func: ["invalid or missing system function:" :arg1]
				feature-na: "feature not available"
				not-done: "reserved for future use (or not yet implemented)"
				;invalid-error: "error object or fields were not valid"
			]
		]

	]

	state: context [
		interpreted?: func ["Return TRUE if called from the interpreter"][
			#system [logic/box stack/eval?]
		]

		last-error: none
	]

	modules: make block! 8
	codecs:  context []
	schemes: context []
	ports:	 context []

	locale: context [
		language:
		language*:										;-- in locale language
		locale:
		locale*: none									;-- in locale language

		months: [
		  "January" "February" "March" "April" "May" "June"
		  "July" "August" "September" "October" "November" "December"
		]

		days: [
		  "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"
		]
	]

	options: context [
		boot: 			none
		home: 			none
		path: 			none
		script: 		none
		args: 			none
		do-arg: 		none
		debug: 			none
		secure: 		none
		quiet: 			false
		binary-base: 	16
		decimal-digits: 15
		module-paths: 	make block! 1
		file-types: 	none

		;-- change the way float numbers are processed
		float: context [
			pretty?: false
			full?: 	 false

			on-change*: func [word old new][
				switch word [
					pretty? [
						either new [
							#system [float/pretty-print?: yes]
						][
							#system [float/pretty-print?: no]
						]
					]
					full? [
						either new [
							#system [float/full-support?: yes]
						][
							#system [float/full-support?: no]
						]
					]
				]
			]
		]
	]

	script: context [
		title: header: parent: path: args: none
	]

	standard: context [
		header: context [
			title: name: type: version: date: file: author: needs: none
		]
		error: context [
			code: type: id: arg1: arg2: arg3: near: where: none
		]
	]

	view: context [
		screen: 	none
		event-port: none

		metrics: context [
			screen-size: 	none
			dpi:			none
			;scaling:		1x1
		]
	]

	lexer: none
	console: none
]


FIX: issue #412 (Crash on out of scope word)

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

_context: context [
	verbose: 0

	find-word: func [
		ctx		[red-context!]
		sym		[integer!]
		return:	[integer!]								;-- value > 0: success, value = -1: failure
		/local
			series	[series!]
			list	[red-word!]
			end		[red-word!]
	][
		series: as series! ctx/symbols/value
		list:   as red-word! series/offset
		end:    as red-word! series/tail
		sym:	symbol/resolve sym

		while [list < end][
			if list/symbol = sym [
				return (as-integer list - as red-word! series/offset) >> 4	;@@ log2(size? cell!) hardcoded
			]
			list: list + 1
		]
		-1												;-- search failed
	]

	add: func [
		ctx		[red-context!]
		word 	[red-word!]
		return:	[integer!]
		/local
			sym	  [cell!]
			value [cell!]
			s  	  [series!]
			id	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/add"]]

		id: find-word ctx word/symbol
		if id <> -1 [return id]

		s: as series! ctx/symbols/value
		sym: alloc-tail s
		copy-cell as cell! word sym

		unless ON_STACK?(ctx) [
			value: alloc-tail as series! ctx/values/value
			value/header: TYPE_UNSET
		]

		(as-integer s/tail - s/offset) >> 4 - 1
	]

	set-integer: func [
		word 		[red-word!]
		value		[integer!]
		/local
			int 	[red-integer!]
			values	[series!]
			ctx		[red-context!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/set-integer"]]

		ctx: word/ctx

		if word/index = -1 [
			word/index: find-word ctx word/symbol
		]
		int: as red-integer! either ON_STACK?(ctx) [
			(as red-value! ctx/values) + word/index
		][
			values: as series! word/ctx/values/value
			values/offset + word/index
		]
		int/header: TYPE_INTEGER
		int/value: value
	]

	set: func [
		word 		[red-word!]
		value		[red-value!]
		return:		[red-value!]
		/local
			values	[series!]
			ctx		[red-context!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/set"]]

		ctx: word/ctx

		if word/index = -1 [
			word/index: find-word ctx word/symbol
		]
		either ON_STACK?(ctx) [
			copy-cell value (as red-value! ctx/values) + word/index
		][
			values: as series! ctx/values/value
			copy-cell value values/offset + word/index
		]
	]

	get: func [
		word	   [red-word!]
		return:	   [red-value!]
		/local
			values [series!]
			sym	   [red-symbol!]
			ctx	   [red-context!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/get"]]

		ctx: word/ctx

		if any [										;-- ensure word is properly bound to a context
			null? ctx
			word/index = -1
		][
			sym: symbol/get word/symbol
			print-line ["*** Error: word '" sym/cache " has no value"]
			halt
		]
		if null? ctx/values [
			sym: symbol/get word/symbol
			print-line ["*** Error: undefined context for word '" sym/cache]
			halt
		]
		either ON_STACK?(ctx) [
			(as red-value! ctx/values) + word/index
		][
			values: as series! ctx/values/value
			values/offset + word/index
		]
	]

	create: func [
		blk			[red-block!]						;-- storage place (at tail of block)
		slots		[integer!]							;-- max number of words in the context
		stack?		[logic!]							;-- TRUE: alloc values on stack, FALSE: alloc them from heap
		return:		[red-context!]
		/local
			cell 	[red-context!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/create"]]

		if zero? slots [slots: 1]
		cell: as red-context! ALLOC_TAIL(blk)
		cell/header: TYPE_CONTEXT						;-- implicit reset of all header flags
		cell/symbols: alloc-series slots 16 0			;-- force offset at head of buffer

		either stack? [
			cell/header: TYPE_CONTEXT or flag-series-stk
			cell/values: null							;-- will be set to stack frame dynamically
		][
			cell/values: alloc-cells slots
		]
		cell
	]

	make: func [
		spec	[red-block!]
		stack?	[logic!]
		return:	[red-context!]
		/local
			ctx	 [red-context!]
			cell [red-value!]
			slot [red-word!]
			s	 [series!]
			type [integer!]
			i	 [integer!]
	][
		ctx: create root block/rs-length? spec stack?
		s: GET_BUFFER(spec)
		cell: s/offset
		i: 0

		while [cell < s/tail][
			type: TYPE_OF(cell)
			if any [									;TBD: use typeset/any-word?
				type = TYPE_WORD
				type = TYPE_GET_WORD
				type = TYPE_LIT_WORD
				type = TYPE_REFINEMENT
			][											;-- add new word to context
				slot: as red-word! alloc-tail as series! ctx/symbols/value
				copy-cell cell as red-value! slot
				slot/header: TYPE_WORD
				slot/ctx: ctx
				slot/index: i
				i: i + 1
			]
			cell: cell + 1
		]
		ctx
	]

	;-- Actions --

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

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

_context: context [
	verbose: 0

	find-word: func [
		ctx		[red-context!]
		sym		[integer!]
		return:	[integer!]								;-- value > 0: success, value = -1: failure
		/local
			series	[series!]
			list	[red-word!]
			end		[red-word!]
	][
		series: as series! ctx/symbols/value
		list:   as red-word! series/offset
		end:    as red-word! series/tail
		sym:	symbol/resolve sym

		while [list < end][
			if list/symbol = sym [
				return (as-integer list - as red-word! series/offset) >> 4	;@@ log2(size? cell!) hardcoded
			]
			list: list + 1
		]
		-1												;-- search failed
	]

	add: func [
		ctx		[red-context!]
		word 	[red-word!]
		return:	[integer!]
		/local
			sym	  [cell!]
			value [cell!]
			s  	  [series!]
			id	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/add"]]

		id: find-word ctx word/symbol
		if id <> -1 [return id]

		s: as series! ctx/symbols/value
		sym: alloc-tail s
		copy-cell as cell! word sym

		unless ON_STACK?(ctx) [
			value: alloc-tail as series! ctx/values/value
			value/header: TYPE_UNSET
		]

		(as-integer s/tail - s/offset) >> 4 - 1
	]

	set-integer: func [
		word 		[red-word!]
		value		[integer!]
		/local
			int 	[red-integer!]
			values	[series!]
			ctx		[red-context!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/set-integer"]]

		ctx: word/ctx

		if word/index = -1 [
			word/index: find-word ctx word/symbol
		]
		int: as red-integer! either ON_STACK?(ctx) [
			(as red-value! ctx/values) + word/index
		][
			values: as series! word/ctx/values/value
			values/offset + word/index
		]
		int/header: TYPE_INTEGER
		int/value: value
	]

	set: func [
		word 		[red-word!]
		value		[red-value!]
		return:		[red-value!]
		/local
			values	[series!]
			ctx		[red-context!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/set"]]

		ctx: word/ctx

		if word/index = -1 [
			word/index: find-word ctx word/symbol
		]
		either ON_STACK?(ctx) [
			copy-cell value (as red-value! ctx/values) + word/index
		][
			values: as series! ctx/values/value
			copy-cell value values/offset + word/index
		]
	]

	get: func [
		word	   [red-word!]
		return:	   [red-value!]
		/local
			values [series!]
			sym	   [red-symbol!]
			ctx	   [red-context!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/get"]]

		ctx: word/ctx

		if any [										;-- ensure word is properly bound to a context
			null? ctx
			word/index = -1
		][
			sym: symbol/get word/symbol
			print-line [
				"*** Error: word '" sym/cache " has no value"
			]
			halt
		]
		either ON_STACK?(ctx) [
			(as red-value! ctx/values) + word/index
		][
			values: as series! ctx/values/value
			values/offset + word/index
		]
	]

	create: func [
		blk			[red-block!]						;-- storage place (at tail of block)
		slots		[integer!]							;-- max number of words in the context
		stack?		[logic!]							;-- TRUE: alloc values on stack, FALSE: alloc them from heap
		return:		[red-context!]
		/local
			cell 	[red-context!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/create"]]

		if zero? slots [slots: 1]
		cell: as red-context! ALLOC_TAIL(blk)
		cell/header: TYPE_CONTEXT						;-- implicit reset of all header flags
		cell/symbols: alloc-series slots 16 0			;-- force offset at head of buffer

		either stack? [
			cell/header: TYPE_CONTEXT or flag-series-stk
			cell/values: null							;-- will be set to stack frame dynamically
		][
			cell/values: alloc-cells slots
		]
		cell
	]

	make: func [
		spec	[red-block!]
		stack?	[logic!]
		return:	[red-context!]
		/local
			ctx	 [red-context!]
			cell [red-value!]
			slot [red-word!]
			s	 [series!]
			type [integer!]
			i	 [integer!]
	][
		ctx: create root block/rs-length? spec stack?
		s: GET_BUFFER(spec)
		cell: s/offset
		i: 0

		while [cell < s/tail][
			type: TYPE_OF(cell)
			if any [									;TBD: use typeset/any-word?
				type = TYPE_WORD
				type = TYPE_GET_WORD
				type = TYPE_LIT_WORD
				type = TYPE_REFINEMENT
			][											;-- add new word to context
				slot: as red-word! alloc-tail as series! ctx/symbols/value
				copy-cell cell as red-value! slot
				slot/header: TYPE_WORD
				slot/ctx: ctx
				slot/index: i
				i: i + 1
			]
			cell: cell + 1
		]
		ctx
	]

	;-- Actions --

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


FIX: missing file from the previous commit (`store-bodies?` flag fix for routines).

Red/System [
	Title:   "Routine! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %routine.reds
	Tabs:	 4
	Rights:  "Copyright (C) 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
	}
]

routine: context [
	verbose: 0

	get-arity: func [
		value	[red-routine!]
		return: [integer!]
	][
		value/header >> 25 and 1Fh
	]

	set-arity: func [
		value	[red-routine!]
		/local
			slot  [red-value!]
			tail  [red-value!]
			s	  [series!]
			count [integer!]
	][
		s: as series! value/spec/value

		slot:  s/offset
		tail:  s/tail
		count: 0

		while [slot < tail][
			if TYPE_OF(slot) = TYPE_WORD [
				count: count + 1
			]
			slot: slot + 1
		]

		value/header: (value/header and flag-arity-mask) or (count << 25)
	]

	push: func [
		spec	 [red-block!]
		body	 [red-block!]
		code	 [integer!]
		return:	 [red-routine!]							;-- return function's local context
		/local
			cell   [red-routine!]
			native [red-native!]
			value  [red-value!]
			more   [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "routine/push"]]

		cell: as red-routine! stack/push*
		cell/header: TYPE_ROUTINE						;-- implicit reset of all header flags
		cell/spec:	 spec/node
		cell/more:	 alloc-cells 3

		more: as series! cell/more/value
		value: either null? body [none-value][as red-value! body]
		copy-cell value alloc-tail more					;-- store body block or none
		alloc-tail more									;-- reserved place for "symbols"

		native: as red-native! alloc-tail more
		native/header: TYPE_NATIVE
		native/code: code

		set-arity cell
		cell
	]

	;-- Actions --

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

		string/concatenate-literal buffer "?routine?"
		part - 10
	]

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

		string/concatenate-literal buffer "routine "

		blk: as red-block! stack/push*
		blk/header: TYPE_ROUTINE
		blk/head: 0
		blk/node: fun/spec
		part: block/mold blk buffer only? all? flat? arg part - 8			;-- spec

		s: as series! fun/more/value
		block/mold as red-block! s/offset buffer only? all? flat? arg part	;-- body
	]

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

Red/System [
	Title:   "Routine! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %routine.reds
	Tabs:	 4
	Rights:  "Copyright (C) 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
	}
]

routine: context [
	verbose: 0

	get-arity: func [
		value	[red-routine!]
		return: [integer!]
	][
		value/header >> 25 and 1Fh
	]

	set-arity: func [
		value	[red-routine!]
		/local
			slot  [red-value!]
			tail  [red-value!]
			s	  [series!]
			count [integer!]
	][
		s: as series! value/spec/value

		slot:  s/offset
		tail:  s/tail
		count: 0

		while [slot < tail][
			if TYPE_OF(slot) = TYPE_WORD [
				count: count + 1
			]
			slot: slot + 1
		]

		value/header: (value/header and flag-arity-mask) or (count << 25)
	]

	push: func [
		spec	 [red-block!]
		body	 [red-block!]
		code	 [integer!]
		return:	 [red-routine!]							;-- return function's local context
		/local
			cell   [red-routine!]
			native [red-native!]
			more   [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "routine/push"]]

		cell: as red-routine! stack/push*
		cell/header: TYPE_ROUTINE						;-- implicit reset of all header flags
		cell/spec:	 spec/node
		cell/more:	 alloc-cells 3

		more: as series! cell/more/value
		copy-cell
			as cell! body
			alloc-tail more

		alloc-tail more									;-- reserved place for "symbols"

		native: as red-native! alloc-tail more
		native/header: TYPE_NATIVE
		native/code: code

		set-arity cell
		cell
	]

	;-- Actions --

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

		string/concatenate-literal buffer "?routine?"
		part - 10
	]

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

		string/concatenate-literal buffer "routine "

		blk: as red-block! stack/push*
		blk/header: TYPE_ROUTINE
		blk/head: 0
		blk/node: fun/spec
		part: block/mold blk buffer only? all? flat? arg part - 8			;-- spec

		s: as series! fun/more/value
		block/mold as red-block! s/offset buffer only? all? flat? arg part	;-- body
	]

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


FIX: Unicode characters were not displayed properly on Syllable Desktop.

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

#define MMAP_PROT_RW		03h				;-- PROT_READ | PROT_WRITE
#define MMAP_PROT_RWX		07h				;-- PROT_READ | PROT_WRITE | PROT_EXEC

#define MMAP_MAP_SHARED     10h
#define MMAP_MAP_PRIVATE    20h
#define MMAP_MAP_ANONYMOUS  80h

#define SC_PAGE_SIZE		30

#define SYSCALL_MMAP		222
#define SYSCALL_MUNMAP		223

platform: context [

	#define wprintf		printf
	#define putwchar	[putchar as-byte]

	#include %_POSIX.reds

	#import  [
		LIBC-file cdecl [
			sysconf: "sysconf" [
				property	[integer!]
				return:		[integer!]
			]
		]
	]

	page-size: sysconf SC_PAGE_SIZE

	#syscall [
		mmap: SYSCALL_MMAP [
			address		[byte-ptr!]
			size		[integer!]
			flags		[integer!]
			fd			[integer!]
			offset		[integer!]
			return:		[byte-ptr!]
		]
		munmap: SYSCALL_MUNMAP [
			address		[byte-ptr!]
			size		[integer!]
			return:		[integer!]
		]
	]
	;-------------------------------------------
	;-- Allocate paged virtual memory region from OS
	;-------------------------------------------
	allocate-virtual: func [
		size 	[integer!]						;-- allocated size in bytes (page size multiple)
		exec? 	[logic!]						;-- TRUE => executable region
		return: [int-ptr!]						;-- allocated memory region pointer
		/local ptr flags
	][
		assert zero? (size and 0Fh)				;-- size is a multiple of 16
		flags: either exec? [MMAP_PROT_RWX][MMAP_PROT_RW]
		flags: flags or MMAP_MAP_PRIVATE or MMAP_MAP_ANONYMOUS

		ptr: mmap null size flags -1 0

		if -1 = as-integer ptr [
			raise-error RED_ERR_VMEM_OUT_OF_MEMORY as-integer system/pc
		]
		as int-ptr! ptr
	]

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

	init: does [
		setlocale __LC_ALL ""					;@@ check if "utf8" is present in returned string?
	]

]

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

#define MMAP_PROT_RW		03h				;-- PROT_READ | PROT_WRITE
#define MMAP_PROT_RWX		07h				;-- PROT_READ | PROT_WRITE | PROT_EXEC

#define MMAP_MAP_SHARED     10h
#define MMAP_MAP_PRIVATE    20h
#define MMAP_MAP_ANONYMOUS  80h

#define SC_PAGE_SIZE		30

#define SYSCALL_MMAP		222
#define SYSCALL_MUNMAP		223

platform: context [

	#include %_POSIX.reds

	#import  [
		LIBC-file cdecl [
			sysconf: "sysconf" [
				property	[integer!]
				return:		[integer!]
			]
		]
	]

	page-size: sysconf SC_PAGE_SIZE

	#syscall [
		mmap: SYSCALL_MMAP [
			address		[byte-ptr!]
			size		[integer!]
			flags		[integer!]
			fd			[integer!]
			offset		[integer!]
			return:		[byte-ptr!]
		]
		munmap: SYSCALL_MUNMAP [
			address		[byte-ptr!]
			size		[integer!]
			return:		[integer!]
		]
	]
	;-------------------------------------------
	;-- Allocate paged virtual memory region from OS
	;-------------------------------------------
	allocate-virtual: func [
		size 	[integer!]						;-- allocated size in bytes (page size multiple)
		exec? 	[logic!]						;-- TRUE => executable region
		return: [int-ptr!]						;-- allocated memory region pointer
		/local ptr flags
	][
		assert zero? (size and 0Fh)				;-- size is a multiple of 16
		flags: either exec? [MMAP_PROT_RWX][MMAP_PROT_RW]
		flags: flags or MMAP_MAP_PRIVATE or MMAP_MAP_ANONYMOUS

		ptr: mmap null size flags -1 0

		if -1 = as-integer ptr [
			raise-error RED_ERR_VMEM_OUT_OF_MEMORY as-integer system/pc
		]
		as int-ptr! ptr
	]

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

	init: does [
		setlocale __LC_ALL ""					;@@ check if "utf8" is present in returned string?
	]

]