FIX: bug in decoding literal strings to UCS-4. Now all FIND unit tests are passing.

Red/System [
	Title:   "Unicode codecs"
	Author:  "Nenad Rakocevic, Rudolf W. Meijer"
	File: 	 %unicode.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
	}
]

#enum encoding! [
	UTF-8:  0
	Latin1: 1
	UCS-2:  2
	UCS-4:  4
]

unicode: context [
	verbose: 0

	#define U_REPLACEMENT 	FFFDh
	;	choose one of the following options
	;	FFFDh			; U+FFFD = replacement character
	;	1Ah				; U+001A = control SUB (substitute)
	;	241Ah			; U+241A = symbol for substitute
	;	2426h			; U+2426 = symbol for substitute form two
	;	3Fh				; U+003F = question mark
	;	BFh				; U+00BF = inverted question mark
	;	DC00h + b1		; U+DCxx where xx = b1 (never a Unicode codepoint)

	Latin1-to-UCS2: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/Latin1-to-UCS2"]]

		used: as-integer s/tail - s/offset
		if used * 2 >= s/size [							;-- ensure we have enough space
			s: expand-series s (used + 1) * 2			;-- reserve one more for edge cases
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  (as byte-ptr! s/offset) + (used * 2)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 1
			dst: dst - 2
			dst/1: src/1
			dst/2: null-byte
		]
		s/flags: s/flags and flag-unit-mask or UCS-2	;-- s/unit: UCS-2
		s
	]

	Latin1-to-UCS4: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/Latin1-to-UCS4"]]

		used: as-integer s/tail - s/offset
		if used * 4 >= s/size [							;-- ensure we have enough space
			s: expand-series s (used + 1) * 4			;-- reserve one more for edge cases
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  as int-ptr! (as byte-ptr! s/offset) + (used * 4)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 1
			dst: dst - 1
			dst/value: as-integer src/1
		]
		s/flags: s/flags and flag-unit-mask or UCS-4	;-- s/unit: UCS-4
		s
	]

	UCS2-to-UCS4: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/UCS2-to-UCS4"]]

		used: as-integer s/tail - s/offset
		if used * 2 >= s/size [							;-- ensure we have enough space
			s: expand-series s used * 2 + 1
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  as int-ptr! (as byte-ptr! s/offset) + (used * 2)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 2
			dst: dst - 1
			dst/value: (as-integer src/2) << 8 + src/1
		]
		s/flags: s/flags and flag-unit-mask or UCS-4	;-- s/unit: UCS-4
		s
	]

	load-utf8: func [
		src		   [c-string!]							;-- UTF-8 input buffer (zero-terminated)
		size	   [integer!]							;-- size of src in bytes (including terminal NUL)
		return:	   [node!]
		/local
			node   [node!]
			s 	   [series!]
			buf1   [byte-ptr!]
			buf4   [int-ptr!]
			end    [byte-ptr!]
			unit   [integer!]
			b1 	   [integer!]							;-- up to four bytes in a UTF-8 sequence
			b2	   [integer!]							;-- for computing purposes they are of integer! type
			b3     [integer!]
			b4     [integer!]
			cp	   [integer!]							; computed codepoint
			count  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/load-utf8"]]

		assert positive? size
		node: alloc-series size 1 0

		s:     as series! node/value
		buf1:  as byte-ptr! s/offset
		end:   buf1 + s/size
		unit:  Latin1									;-- start with 1 byte/codepoint
		count: size

		if size = 1 [return node]						;-- terminal NUL accounted
		;assert not zero? as-integer src/1				;@@ ensure input string not empty

		;-- the first part of loop is Rudolf's code with very minor modifications
		;-- (res/value replaced by cp, 'u renamed to 'src)
		;-- original source code: https://gist.github.com/1325840

		until [
			b1: as-integer src/1

			; cycling through res is done at the end; likewise for src
			; to account for this, as soon as a multiple byte sequence is consumed
			; the pointer in src is moved one less than the number of bytes consumed

			either b1 < 80h	[							; single byte (ASCII)
				cp: b1									; and we are done
			][
				cp: U_REPLACEMENT
				; assume error by default - this simplifies code greatly
				; cp is now only set if a correct sequence has been decoded

				unless b1 < C0h [						; 80h - BFh may not start a sequence
					case  [
						b1 < E0h [						; start of two-byte sequence
							b2: as-integer src/2
							if all [
								b2 >= 80h b2 < C0h
							][
								cp:	(b1 - C0h << 6) or
									(b2 - 80h)
	;							if any [
	;								cp > 7Fh			; optional test for overlong
	;								cp = 0				; even so, must allow U+0000
	;							][
									src: src + 1
									count: count - 1
	;							]
							]
						]
						b1 < F0h [						; start of three-byte sequence
							b2: as-integer src/2
							b3: as-integer src/3
							if all [
								b2 >= 80h b2 < C0h
								b3 >= 80h b3 < C0h
							][
								cp:	(b1 - E0h << 12) or
									(b2 - 80h <<  6) or
									(b3 - 80h)
								if all [
									any [cp < DC00h cp > DCFFh]
	;								cp > 7FFh			; optional test for overlong
								][
									src: src + 2
									count: count - 2
								]
							]
						]
						b1 < F8h [						; start of four-byte sequence
							b2: as-integer src/2
							b3: as-integer src/3
							b4: as-integer src/4
							if all [
								b2 >= 80h b2 < C0h
								b3 >= 80h b3 < C0h
								b4 >= 80h b4 < C0h
							][
								cp:	(b1 - F0h << 18) or
									(b2 - 80h << 12) or
									(b3 - 80h <<  6) or
									(b4 - 80h)
								if all [
									cp <= 0010FFFFh
	;								cp > FFFFh			; optional test for overlong
								][
									src: src + 3
									count: count - 3
								]
							]
						]
	;					true [
	;						error case					;@@ throw an error! value
	;					]
					]
				]
			]

			switch unit [
				Latin1 [
					case [
						cp <= FFh [
							buf1/value: as-byte cp
							buf1: buf1 + 1
							assert buf1 <= end			;-- should not happen if we're good
						]
						cp <= FFFFh [
							s/tail: as cell! buf1
							unit: UCS-2
							s:    Latin1-to-UCS2 s		;-- upgrade to UCS-2
							buf1: as byte-ptr! s/tail
							end:  (as byte-ptr! s/offset) + s/size

							buf1/1: as-byte cp and FFh
							buf1/2: as-byte cp >> 8
							buf1: buf1 + 2
						]
						true [
							s/tail: as cell! buf1
							unit: UCS-4
							s:    Latin1-to-UCS4 s		;-- upgrade to UCS-4
							buf4: as int-ptr! s/tail
							end:  (as byte-ptr! s/offset) + s/size

							buf4/value: cp
							buf4: buf4 + 1
						]
					]
				]
				UCS-2 [
					either cp > FFFFh [
						s/tail: as cell! buf1
						unit: UCS-4
						s:    UCS2-to-UCS4 s			;-- upgrade to UCS-4
						buf4: as int-ptr! s/tail
						end:  (as byte-ptr! s/offset) + s/size

						buf4/value: cp
						buf4: buf4 + 1
					][
						if buf1 >= end [
							s/tail: as cell! buf1
							s: expand-series s s/size + (size >> 2)	;-- increase size by 50%
							buf1: as byte-ptr! s/tail
							end: (as byte-ptr! s/offset) + s/size
						]
						buf1/1: as-byte cp and FFh
						buf1/2: as-byte cp >> 8
						buf1: buf1 + 2
					]
				]
				UCS-4 [
					if buf4 >= (as int-ptr! end) [
						s/tail: as cell! buf4
						s: expand-series s s/size + size ;-- increase size by 100%
						buf4: as int-ptr! s/tail
						end: (as byte-ptr! s/offset) + s/size
					]
					buf4/value: cp
					buf4: buf4 + 1
				]
			]
			src: src + 1
			count: count - 1
			zero? count
		] 												;-- end until

		s/tail: as cell! switch unit [					;-- position s/tail just before the NUL character
			Latin1 [buf1 - 1]
			UCS-2  [buf1 - 2]
			UCS-4  [buf4 - 1]
		]
		assert s/size - GET_UNIT(s) >= as-integer (s/tail - s/offset) ;-- tail points before NUL

		node
	]

]

Red/System [
	Title:   "Unicode codecs"
	Author:  "Nenad Rakocevic, Rudolf W. Meijer"
	File: 	 %unicode.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
	}
]

#enum encoding! [
	UTF-8:  0
	Latin1: 1
	UCS-2:  2
	UCS-4:  4
]

unicode: context [
	verbose: 0

	#define U_REPLACEMENT 	FFFDh
	;	choose one of the following options
	;	FFFDh			; U+FFFD = replacement character
	;	1Ah				; U+001A = control SUB (substitute)
	;	241Ah			; U+241A = symbol for substitute
	;	2426h			; U+2426 = symbol for substitute form two
	;	3Fh				; U+003F = question mark
	;	BFh				; U+00BF = inverted question mark
	;	DC00h + b1		; U+DCxx where xx = b1 (never a Unicode codepoint)

	Latin1-to-UCS2: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/Latin1-to-UCS2"]]

		used: as-integer s/tail - s/offset
		if used * 2 >= s/size [							;-- ensure we have enough space
			s: expand-series s (used + 1) * 2			;-- reserve one more for edge cases
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  (as byte-ptr! s/offset) + (used * 2)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 1
			dst: dst - 2
			dst/1: src/1
			dst/2: null-byte
		]
		s/flags: s/flags and flag-unit-mask or UCS-2	;-- s/unit: UCS-2
		s
	]

	Latin1-to-UCS4: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/Latin1-to-UCS4"]]

		used: as-integer s/tail - s/offset
		if used * 4 >= s/size [							;-- ensure we have enough space
			s: expand-series s (used + 1) * 4			;-- reserve one more for edge cases
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  as int-ptr! (as byte-ptr! s/offset) + (used * 4)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 1
			dst: dst - 1
			dst/value: as-integer src/1
		]
		s/flags: s/flags and flag-unit-mask or UCS-4	;-- s/unit: UCS-4
		s
	]

	UCS2-to-UCS4: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/UCS2-to-UCS4"]]

		used: as-integer s/tail - s/offset
		if used * 2 >= s/size [							;-- ensure we have enough space
			s: expand-series s used * 2 + 1
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  as int-ptr! (as byte-ptr! s/offset) + (used * 2)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 2
			dst: dst - 1
			dst/value: (as-integer src/2) << 8 + src/1
		]
		s/flags: s/flags and flag-unit-mask or UCS-4	;-- s/unit: UCS-4
		s
	]

	load-utf8: func [
		src		   [c-string!]							;-- UTF-8 input buffer (zero-terminated)
		size	   [integer!]							;-- size of src in bytes (including terminal NUL)
		return:	   [node!]
		/local
			node   [node!]
			s 	   [series!]
			buf1   [byte-ptr!]
			buf4   [int-ptr!]
			end    [byte-ptr!]
			unit   [integer!]
			b1 	   [integer!]							;-- up to four bytes in a UTF-8 sequence
			b2	   [integer!]							;-- for computing purposes they are of integer! type
			b3     [integer!]
			b4     [integer!]
			cp	   [integer!]							; computed codepoint
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/load-utf8"]]

		assert positive? size
		node: alloc-series size 1 0

		s:    as series! node/value
		buf1: as byte-ptr! s/offset
		end:  buf1 + s/size
		unit: Latin1									;-- start with 1 byte/codepoint

		if size = 1 [return node]						;-- terminal NUL accounted
		;assert not zero? as-integer src/1				;@@ ensure input string not empty

		;-- the first part of loop is Rudolf's code with very minor modifications
		;-- (res/value replaced by cp, 'u renamed to 'src)
		;-- original source code: https://gist.github.com/1325840

		until [
			b1: as-integer src/1

			; cycling through res is done at the end; likewise for src
			; to account for this, as soon as a multiple byte sequence is consumed
			; the pointer in src is moved one less than the number of bytes consumed

			either b1 < 80h	[							; single byte (ASCII)
				cp: b1									; and we are done
			][
				cp: U_REPLACEMENT
				; assume error by default - this simplifies code greatly
				; cp is now only set if a correct sequence has been decoded

				unless b1 < C0h [						; 80h - BFh may not start a sequence
					case  [
						b1 < E0h [						; start of two-byte sequence
							b2: as-integer src/2
							if all [
								b2 >= 80h b2 < C0h
							][
								cp:	(b1 - C0h << 6) or
									(b2 - 80h)
	;							if any [
	;								cp > 7Fh			; optional test for overlong
	;								cp = 0				; even so, must allow U+0000
	;							][
									src: src + 1
									size: size - 1
	;							]
							]
						]
						b1 < F0h [						; start of three-byte sequence
							b2: as-integer src/2
							b3: as-integer src/3
							if all [
								b2 >= 80h b2 < C0h
								b3 >= 80h b3 < C0h
							][
								cp:	(b1 - E0h << 12) or
									(b2 - 80h <<  6) or
									(b3 - 80h)
								if all [
									any [cp < DC00h cp > DCFFh]
	;								cp > 7FFh			; optional test for overlong
								][
									src: src + 2
									size: size - 2
								]
							]
						]
						b1 < F8h [						; start of four-byte sequence
							b2: as-integer src/2
							b3: as-integer src/3
							b4: as-integer src/4
							if all [
								b2 >= 80h b2 < C0h
								b3 >= 80h b3 < C0h
								b4 >= 80h b4 < C0h
							][
								cp:	(b1 - F0h << 18) or
									(b2 - 80h << 12) or
									(b3 - 80h <<  6) or
									(b4 - 80h)
								if all [
									cp <= 0010FFFFh
	;								cp > FFFFh			; optional test for overlong
								][
									src: src + 3
									size: size - 3
								]
							]
						]
	;					true [
	;						error case					;@@ throw an error! value
	;					]
					]
				]
			]

			switch unit [
				Latin1 [
					case [
						cp <= FFh [
							buf1/value: as-byte cp
							buf1: buf1 + 1
							assert buf1 <= end			;-- should not happen if we're good
						]
						cp <= FFFFh [
							s/tail: as cell! buf1
							unit: UCS-2
							s:    Latin1-to-UCS2 s		;-- upgrade to UCS-2
							buf1: as byte-ptr! s/tail
							end:  (as byte-ptr! s/offset) + s/size

							buf1/1: as-byte cp and FFh
							buf1/2: as-byte cp >> 8
							buf1: buf1 + 2
						]
						true [
							s/tail: as cell! buf1
							unit: UCS-4
							s:    Latin1-to-UCS4 s		;-- upgrade to UCS-4
							buf4: as int-ptr! s/tail
							end:  (as byte-ptr! s/offset) + s/size

							buf4/value: cp
							buf4: buf4 + 1
						]
					]
				]
				UCS-2 [
					either cp > FFFFh [
						s/tail: as cell! buf1
						unit: UCS-4
						s:    UCS2-to-UCS4 s			;-- upgrade to UCS-4
						buf4: as int-ptr! s/tail
						end:  (as byte-ptr! s/offset) + s/size

						buf4/value: cp
						buf4: buf4 + 1
					][
						if buf1 >= end [
							s/tail: as cell! buf1
							s: expand-series s s/size + (size >> 2)	;-- increase size by 50%
							buf1: as byte-ptr! s/tail
							end: (as byte-ptr! s/offset) + s/size
						]
						buf1/1: as-byte cp and FFh
						buf1/2: as-byte cp >> 8
						buf1: buf1 + 2
					]
				]
				UCS-4 [
					if buf4 >= (as int-ptr! end) [
						s: expand-series s s/size + size ;-- increase size by 100%
						buf4: as int-ptr! s/tail
						end: (as byte-ptr! s/offset) + s/size
					]
					buf4/value: cp
					buf4: buf4 + 1
				]
			]
			src: src + 1
			size: size - 1
			zero? size
		] 												;-- end until

		s/tail: as cell! switch unit [					;-- position s/tail just before the NUL character
			Latin1 [buf1 - 1]
			UCS-2  [buf1 - 2]
			UCS-4  [buf4 - 1]
		]
		assert s/size - GET_UNIT(s) >= as-integer (s/tail - s/offset) ;-- tail points before NUL

		node
	]

]


FEAT: optimized evaluation result output in console to avoid excessive flooding.

Result line now limited to 72 characters max. A trailing three dots sequence will signal a truncation.

Red [
	Title:	"Red console"
	Author: ["Nenad Rakocevic" "Kaj de Vos"]
	File: 	%console.red
	Tabs: 	4
	Rights: "Copyright (C) 2012-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-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: 	 "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
				ReadConsole: 	 "ReadConsoleA" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
	][
		#switch OS [
			MacOSX [
				#define ReadLine-library "libreadline.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
				rl-bind-key: "rl_bind_key" [
					key				[integer!]
					command			[integer!]
					return:			[integer!]
				]
				rl-insert:	 "rl_insert" [
					count			[integer!]
					key				[integer!]
					return:			[integer!]
				]
			]
			#if OS <> 'MacOSX [
				History-library cdecl [
					add-history: "add_history" [  ; Add line to the history.
						line		[c-string!]
					]
				]
			]
		]

		rl-insert-wrapper: func [
			[cdecl]
			count   [integer!]
			key	    [integer!]
			return: [integer!]
		][
			rl-insert count key
		]

	]
]

Windows?: system/platform = 'Windows

init-console: routine [
	str [string!]
	/local
		ret
][
	#either OS = 'Windows [
		;ret: AttachConsole -1
		;if zero? ret [print-line "ReadConsole failed!" halt]

		ret: SetConsoleTitle as c-string! string/rs-head str
		if zero? ret [print-line "SetConsoleTitle failed!" halt]
	][
		rl-bind-key as-integer tab as-integer :rl-insert-wrapper
	]
]

input: routine [
	prompt [string!]
	/local
		len ret str buffer line
][
	#either OS = 'Windows [
		len: 0
		buffer: allocate 128
		print as c-string! string/rs-head prompt
		ret: ReadConsole stdin buffer 127 :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		len: len + 1
		buffer/len: null-byte
		str: string/load as c-string! buffer len
;		free buffer
	][
		line: read-line as c-string! string/rs-head prompt
		if line = null [halt]  ; EOF

		 #if OS <> 'MacOSX [add-history line]

		str: string/load line  1 + length? line
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

count-delimiters: function [
	buffer	[string!]
	return: [block!]
][
	list: copy [0 0]
	c: none

	foreach c buffer [
		switch c [
			#"[" [list/1: list/1 + 1]
			#"]" [list/1: list/1 - 1]
			#"{" [list/2: list/2 + 1]
			#"}" [list/2: list/2 - 1]
		]
	]
	list
]

do-console: function [][
	buffer: make string! 10000
	prompt: red-prompt: "red>> "
	mode:  'mono

	switch-mode: [
		mode: case [
			cnt/1 > 0 ['block]
			cnt/2 > 0 ['string]
			'else 	  [
				prompt: red-prompt
				do eval
				'mono
			]
		]
		prompt: switch mode [
			block  ["[^-"]
			string ["{^-"]
			mono   [red-prompt]
		]
	]

	eval: [
		code: load/all buffer

		unless tail? code [
			set/any 'result do code

			unless unset? :result [
				if 67 = length? result: mold/part :result 67 [	;-- optimized for width = 72
					clear back tail result
					append result "..."
				]
				print ["==" result]
			]
		]
		clear buffer
	]

	while [true][
		unless tail? line: input prompt [
			append buffer line
			cnt: count-delimiters buffer

			either Windows? [
				remove skip tail buffer -2			;-- clear extra CR (Windows)
			][
				append buffer lf					;-- Unix
			]

			switch mode [
				block  [if cnt/1 <= 0 [do switch-mode]]
				string [if cnt/2 <= 0 [do switch-mode]]
				mono   [do either any [cnt/1 > 0 cnt/2 > 0][switch-mode][eval]]
			]
		]
	]
]

q: :quit

init-console "Red Console"

print {
-=== Red Console alpha version ===-
(only Latin-1 input supported)
}

do-console

Red [
	Title:	"Red console"
	Author: ["Nenad Rakocevic" "Kaj de Vos"]
	File: 	%console.red
	Tabs: 	4
	Rights: "Copyright (C) 2012-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-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: 	 "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
				ReadConsole: 	 "ReadConsoleA" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
	][
		#switch OS [
			MacOSX [
				#define ReadLine-library "libreadline.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
				rl-bind-key: "rl_bind_key" [
					key				[integer!]
					command			[integer!]
					return:			[integer!]
				]
				rl-insert:	 "rl_insert" [
					count			[integer!]
					key				[integer!]
					return:			[integer!]
				]
			]
			#if OS <> 'MacOSX [
				History-library cdecl [
					add-history: "add_history" [  ; Add line to the history.
						line		[c-string!]
					]
				]
			]
		]

		rl-insert-wrapper: func [
			[cdecl]
			count   [integer!]
			key	    [integer!]
			return: [integer!]
		][
			rl-insert count key
		]

	]
]

Windows?: system/platform = 'Windows

init-console: routine [
	str [string!]
	/local
		ret
][
	#either OS = 'Windows [
		;ret: AttachConsole -1
		;if zero? ret [print-line "ReadConsole failed!" halt]

		ret: SetConsoleTitle as c-string! string/rs-head str
		if zero? ret [print-line "SetConsoleTitle failed!" halt]
	][
		rl-bind-key as-integer tab as-integer :rl-insert-wrapper
	]
]

input: routine [
	prompt [string!]
	/local
		len ret str buffer line
][
	#either OS = 'Windows [
		len: 0
		buffer: allocate 128
		print as c-string! string/rs-head prompt
		ret: ReadConsole stdin buffer 127 :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		len: len + 1
		buffer/len: null-byte
		str: string/load as c-string! buffer len
;		free buffer
	][
		line: read-line as c-string! string/rs-head prompt
		if line = null [halt]  ; EOF

		 #if OS <> 'MacOSX [add-history line]

		str: string/load line  1 + length? line
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

count-delimiters: function [
	buffer	[string!]
	return: [block!]
][
	list: copy [0 0]
	c: none

	foreach c buffer [
		switch c [
			#"[" [list/1: list/1 + 1]
			#"]" [list/1: list/1 - 1]
			#"{" [list/2: list/2 + 1]
			#"}" [list/2: list/2 - 1]
		]
	]
	list
]

do-console: function [][
	buffer: make string! 10000
	prompt: red-prompt: "red>> "
	mode:  'mono

	switch-mode: [
		mode: case [
			cnt/1 > 0 ['block]
			cnt/2 > 0 ['string]
			'else 	  [
				prompt: red-prompt
				do eval
				'mono
			]
		]
		prompt: switch mode [
			block  ["[^-"]
			string ["{^-"]
			mono   [red-prompt]
		]
	]

	eval: [
		code: load/all buffer
		unless tail? code [
			set/any 'result do code
			unless unset? :result [
				print ["==" mold :result]				;@@ use mold/part
			]
		]
		clear buffer
	]

	while [true][
		unless tail? line: input prompt [
			append buffer line
			cnt: count-delimiters buffer

			either Windows? [
				remove skip tail buffer -2			;-- clear extra CR (Windows)
			][
				append buffer lf					;-- Unix
			]

			switch mode [
				block  [if cnt/1 <= 0 [do switch-mode]]
				string [if cnt/2 <= 0 [do switch-mode]]
				mono   [do either any [cnt/1 > 0 cnt/2 > 0][switch-mode][eval]]
			]
		]
	]
]

q: :quit

init-console "Red Console"

print {
-=== Red Console alpha version ===-
(only Latin-1 input supported)
}

do-console


FIX: action functions re-ordering to class them by affinity rather than alphabetical order.

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

block: context [
	verbose: 0

	rs-length?: func [
		blk 	[red-block!]
		return: [integer!]
	][
		series: GET_BUFFER(blk)
		(as-integer (series/tail - series/offset)) >> 4 - blk/head
	]

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

		blk: as red-block! stack/arguments
		index: as red-integer! blk + 1

		assert TYPE_OF(blk)   = TYPE_BLOCK
		assert TYPE_OF(index) = TYPE_INTEGER

		s: GET_BUFFER(blk)

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

		offset
	]

	append*: func [
		return: [red-block!]
		/local
			arg	[red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/append*"]]

		arg: as red-block! stack/arguments
		assert TYPE_OF(arg) = TYPE_BLOCK

		copy-cell
			as cell! arg + 1
			ALLOC_TAIL(arg)

		arg
	]

	make-in: func [
		parent	[red-block!]
		size 	[integer!]								;-- number of cells to pre-allocate
		return:	[red-block!]
		/local
			blk [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/make-in"]]

		blk: either null? parent [
			_root
		][
			assert TYPE_OF(parent) = TYPE_BLOCK
			as red-block! ALLOC_TAIL(parent)
		]
		blk/header: TYPE_BLOCK							;-- implicit reset of all header flags
		blk/head: 	0
		blk/node: 	alloc-cells size
		blk
	]

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

		blk: as red-block! stack/push
		blk/header: TYPE_BLOCK							;-- implicit reset of all header flags
		blk/head: 	0
		blk/node: 	alloc-cells size
		blk
	]

	;--- Actions ---

	make: func [

	][

	]

	mold: func [
		part	[integer!]
	][

	]

	;--- Property reading actions ---

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

		blk:   as red-block! stack/arguments
		state: as red-logic! blk

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

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

		blk:   as red-block! stack/arguments
		state: as red-logic! blk

		s: GET_BUFFER(blk)

		state/header: TYPE_LOGIC
		state/value:  (s/offset + blk/head) = s/tail
		as red-value! state
	]

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

		blk:   as red-block! stack/arguments
		index: as red-integer! blk

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

		int: as red-integer! blk
		int/header: TYPE_INTEGER
		int/value:  (as-integer s/tail - s/offset - blk/head) >> 4
		as red-value! int
	]

	;--- Navigation actions ---

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

		blk: as red-block! stack/arguments
		blk/head: get-position 1
		as red-value! blk
	]

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

		if (s/offset + blk/head - 1) >= s/offset [
			blk/head: blk/head - 1
		]
		as red-value! blk
	]

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

		if (s/offset + blk/head + 1) <= s/tail [
			blk/head: blk/head + 1
		]
		as red-value! blk
	]

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

		blk: as red-block! stack/arguments
		blk/head: get-position 0
		as red-value! blk
	]

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

		blk: as red-block! stack/arguments
		blk/head: 0
		as red-value! blk
	]

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

		blk: as red-block! stack/arguments
		s: GET_BUFFER(blk)

		blk/head: (as-integer s/tail - s/offset) >> 4
		as red-value! blk
	]

	;--- Reading actions ---

	pick: func [
		return:	   [red-value!]
		/local
			blk	   [red-block!]
			index  [red-integer!]
			s	   [series!]
			offset [integer!]
			max	   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/pick"]]

		blk: as red-block! stack/arguments
		index: as red-integer! blk + 1
		s: GET_BUFFER(blk)

		offset: blk/head + index/value - 1				;-- index is one-based
		stack/push-last either any [
			negative? offset
			s/offset + offset >= s/tail
		][
			none-value
		][
			s/offset + offset
		]
	]

	;--- Modifying actions ---

	append: func [
		return:	  [red-value!]
		/local
			blk	  [red-block!]
			value [red-value!]
			src	  [red-block!]
			s	  [series!]
			cell  [red-value!]
			i	  [integer!]
	][
		;@@ implement /part and /only support
		blk: as red-block! stack/arguments
		value: as red-value! blk + 1

		either TYPE_OF(value) = TYPE_BLOCK [			;@@ replace it with: typeset/any-block?
			src: as red-block! value
			s: GET_BUFFER(src)
			cell: s/offset + src/head

			while [cell < s/tail][						;-- multiple values case
				copy-cell cell ALLOC_TAIL(blk)
				cell: cell + 1
			]
		][												;-- single value case
			copy-cell value	ALLOC_TAIL(blk)
		]
		as red-value! blk
	]

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

		blk: as red-block! stack/arguments
		s: GET_BUFFER(blk)
		s/tail: s/offset + blk/head
		as red-value! blk
	]

	datatype/register [
		TYPE_BLOCK
		;-- General actions --
		:make
		null			;random
		null			;reflect
		null			;to
		null			;form
		null			;mold
		null			;get-path
		null			;set-path
		;-- 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-of
		null			;insert
		:length-of
		:next
		:pick
		null			;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:   "Block! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %block.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
	}
]

block: context [
	verbose: 0

	rs-length?: func [
		blk 	[red-block!]
		return: [integer!]
	][
		series: GET_BUFFER(blk)
		(as-integer (series/tail - series/offset)) >> 4 - blk/head
	]

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

		blk: as red-block! stack/arguments
		index: as red-integer! blk + 1

		assert TYPE_OF(blk)   = TYPE_BLOCK
		assert TYPE_OF(index) = TYPE_INTEGER

		s: GET_BUFFER(blk)

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

		offset
	]

	append*: func [
		return: [red-block!]
		/local
			arg	[red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/append*"]]

		arg: as red-block! stack/arguments
		assert TYPE_OF(arg) = TYPE_BLOCK

		copy-cell
			as cell! arg + 1
			ALLOC_TAIL(arg)

		arg
	]

	make-in: func [
		parent	[red-block!]
		size 	[integer!]								;-- number of cells to pre-allocate
		return:	[red-block!]
		/local
			blk [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/make-in"]]

		blk: either null? parent [
			_root
		][
			assert TYPE_OF(parent) = TYPE_BLOCK
			as red-block! ALLOC_TAIL(parent)
		]
		blk/header: TYPE_BLOCK							;-- implicit reset of all header flags
		blk/head: 	0
		blk/node: 	alloc-cells size
		blk
	]

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

		blk: as red-block! stack/push
		blk/header: TYPE_BLOCK							;-- implicit reset of all header flags
		blk/head: 	0
		blk/node: 	alloc-cells size
		blk
	]

	;--- Actions ---

	make: func [

	][

	]

	append: func [
		return:	  [red-value!]
		/local
			blk	  [red-block!]
			value [red-value!]
			src	  [red-block!]
			s	  [series!]
			cell  [red-value!]
			i	  [integer!]
	][
		;@@ implement /part and /only support
		blk: as red-block! stack/arguments
		value: as red-value! blk + 1

		either TYPE_OF(value) = TYPE_BLOCK [			;@@ replace it with: typeset/any-block?
			src: as red-block! value
			s: GET_BUFFER(src)
			cell: s/offset + src/head

			while [cell < s/tail][						;-- multiple values case
				copy-cell cell ALLOC_TAIL(blk)
				cell: cell + 1
			]
		][												;-- single value case
			copy-cell value	ALLOC_TAIL(blk)
		]
		as red-value! blk
	]

	mold: func [
		part	[integer!]
	][

	]

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

		blk: as red-block! stack/arguments
		blk/head: 0
		as red-value! blk
	]

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

		blk:   as red-block! stack/arguments
		state: as red-logic! blk

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

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

		blk:   as red-block! stack/arguments
		index: as red-integer! blk

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

		int: as red-integer! blk
		int/header: TYPE_INTEGER
		int/value:  (as-integer s/tail - s/offset - blk/head) >> 4
		as red-value! int
	]

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

		blk: as red-block! stack/arguments
		blk/head: get-position 1
		as red-value! blk
	]

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

		if (s/offset + blk/head - 1) >= s/offset [
			blk/head: blk/head - 1
		]
		as red-value! blk
	]

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

		if (s/offset + blk/head + 1) <= s/tail [
			blk/head: blk/head + 1
		]
		as red-value! blk
	]

	pick: func [
		return:	   [red-value!]
		/local
			blk	   [red-block!]
			index  [red-integer!]
			s	   [series!]
			offset [integer!]
			max	   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/pick"]]

		blk: as red-block! stack/arguments
		index: as red-integer! blk + 1
		s: GET_BUFFER(blk)

		offset: blk/head + index/value - 1				;-- index is one-based
		stack/push-last either any [
			negative? offset
			s/offset + offset >= s/tail
		][
			none-value
		][
			s/offset + offset
		]
	]

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

		blk: as red-block! stack/arguments
		blk/head: get-position 0
		as red-value! blk
	]

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

		blk: as red-block! stack/arguments
		s: GET_BUFFER(blk)

		blk/head: (as-integer s/tail - s/offset) >> 4
		as red-value! blk
	]

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

		blk:   as red-block! stack/arguments
		state: as red-logic! blk

		s: GET_BUFFER(blk)

		state/header: TYPE_LOGIC
		state/value:  (s/offset + blk/head) = s/tail
		as red-value! state
	]

	;--- Modifying actions ---

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

		blk: as red-block! stack/arguments
		s: GET_BUFFER(blk)
		s/tail: s/offset + blk/head
		as red-value! blk
	]

	datatype/register [
		TYPE_BLOCK
		;-- General actions --
		:make
		null			;random
		null			;reflect
		null			;to
		null			;form
		null			;mold
		null			;get-path
		null			;set-path
		;-- 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-of
		null			;insert
		:length-of
		:next
		:pick
		null			;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 #764 (Strange behavior for some variable names in functions).

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

symbol: context [
	verbose: 0

	is-any-type?: func [
		word	[red-word!]
		return: [logic!]
	][
		assert TYPE_OF(word) = TYPE_WORD
		(symbol/resolve word/symbol) = symbol/resolve words/any-type!
	]

	same?: func [										;-- case-insensitive UTF-8 string comparison
		str1	     [c-string!]
		str2	     [c-string!]
		return:      [integer!]
		/local
			aliased? [logic!]
			c1	     [byte!]
			c2	     [byte!]
	][
		aliased?: no
		c1:   str1/1
		c2:   str2/1

		while [all [c1 <> null-byte c2 <> null-byte]][
			unless c1 = c2 [
				if all [#"A" <= c1 c1 <= #"Z"][c1: c1 + 32]	;-- lowercase c1
				if all [#"A" <= c2 c2 <= #"Z"][c2: c2 + 32] ;-- lowercase c2
				if c1 <> c2 [return 0]					;-- not same case-insensitive character
				aliased?: yes
			]
			str1: str1 + 1
			str2: str2 + 1
			c1: str1/1
			c2: str2/1									;@@ unsafe memory access
		]
		case [
			c1 <> c2 		[ 0]						;-- not matching
			c2 <> null-byte [ 0]						;-- not matching
			aliased? 		[-1]						;-- similar (case-insensitive matching)
			true 			[ 1]						;-- same (case-sensitive matching)
		]
	]

	search: func [										;@@ use a faster lookup method later
		str 	  [c-string!]							;-- UTF-8 string
		return:	  [integer!]
		/local
			s		[series!]
			entry	[red-symbol!]
			end		[red-symbol!]
			id		[integer!]
			i		[integer!]
			aliased [integer!]
	][
		s: GET_BUFFER(symbols)
		entry: as red-symbol! s/offset
		end:   as red-symbol! s/tail
		i: 1
		aliased: 0

		while [entry < end][
			id: same? entry/cache str
			if positive? id [return i]					;-- matching symbol found, exit
			if all [zero? aliased negative? id][
				aliased: 0 - i							;-- alias symbol found, continue searching
			]
			i: i + 1
			entry: entry + 1
		]
		aliased											;-- alias id or no matching symbol
	]

	duplicate: func [
		src		 [c-string!]
		return:  [c-string!]
		/local
			node [node!]
			dst  [c-string!]
			s	 [series!]
			len	 [integer!]
	][
		len: 1 + length? src							;-- account for terminal NUL
		node: alloc-bytes len							;@@ TBD: mark this buffer as protected!
		s: as series! node/value
		dst: as c-string! s/offset

		copy-memory as byte-ptr! dst as byte-ptr! src len
		dst
	]

	make-alt: func [
		str 	[red-string!]
		return:	[integer!]
		/local
			sym	[red-symbol!]
			s 	[c-string!]
			id	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "symbol/make-alt"]]

		s: unicode/to-utf8 str
		id: search s
		if positive? id [return id]

		sym: as red-symbol! ALLOC_TAIL(symbols)
		sym/header: TYPE_SYMBOL							;-- implicit reset of all header flags
		sym/alias:  either zero? id [-1][0 - id]		;-- -1: no alias, abs(id)>0: alias id
		sym/node:   str/node
		sym/cache:  s
		block/rs-length? symbols
	]

	make: func [
		s 		[c-string!]								;-- input c-string!
		return:	[integer!]
		/local
			sym	[red-symbol!]
			id	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "symbol/make"]]

		id: search s
		if positive? id [return id]

		sym: as red-symbol! ALLOC_TAIL(symbols)
		sym/header: TYPE_SYMBOL							;-- implicit reset of all header flags
		sym/alias:  either zero? id [-1][0 - id]		;-- -1: no alias, abs(id)>0: alias id
		sym/node:   unicode/load-utf8 s 1 + system/words/length? s
		sym/cache:  duplicate s
		block/rs-length? symbols
	]

	get: func [
		id		[integer!]
		return:	[red-symbol!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(symbols)
		as red-symbol! s/offset + id - 1
	]

	resolve: func [
		id		[integer!]
		return:	[integer!]
		/local
			sym	[red-symbol!]
			s	[series!]
	][
		s: GET_BUFFER(symbols)
		sym: as red-symbol! s/offset + id - 1
		either positive? sym/alias [sym/alias][id]
	]

	push: func [

	][

	]

	;-- Actions --

	init: does [
		datatype/register [
			TYPE_SYMBOL
			TYPE_VALUE
			"symbol!"
			;-- 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:   "Symbol! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %symbol.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
	}
]

symbol: context [
	verbose: 0

	is-any-type?: func [
		word	[red-word!]
		return: [logic!]
	][
		assert TYPE_OF(word) = TYPE_WORD
		(symbol/resolve word/symbol) = symbol/resolve words/any-type!
	]

	same?: func [										;-- case-insensitive UTF-8 string comparison
		str1	     [c-string!]
		str2	     [c-string!]
		return:      [integer!]
		/local
			aliased? [logic!]
			c1	     [byte!]
			c2	     [byte!]
	][
		aliased?: no
		c1:   str1/1
		c2:   str2/1

		while [all [c1 <> null-byte c2 <> null-byte]][
			unless c1 = c2 [
				if all [#"A" <= c1 c1 <= #"Z"][c1: c1 + 32]	;-- lowercase c1
				if all [#"A" <= c2 c2 <= #"Z"][c2: c2 + 32] ;-- lowercase c2
				if c1 <> c2 [return 0]					;-- not same case-insensitive character
				aliased?: yes
			]
			str1: str1 + 1
			str2: str2 + 1
			c1: str1/1
			c2: str2/1									;@@ unsafe memory access
		]
		case [
			c1 <> c2 		[ 0]						;-- not matching
			c2 <> null-byte [ 0]						;-- not matching
			aliased? 		[-1]						;-- similar (case-insensitive matching)
			true 			[ 1]						;-- same (case-sensitive matching)
		]
	]

	search: func [										;@@ use a faster lookup method later
		str 	  [c-string!]							;-- UTF-8 string
		return:	  [integer!]
		/local
			s	  [series!]
			entry [red-symbol!]
			end   [red-symbol!]
			id	  [integer!]
			i	  [integer!]
	][
		s: GET_BUFFER(symbols)
		entry: as red-symbol! s/offset
		end:   as red-symbol! s/tail
		i: 1

		while [entry < end][
			id: same? entry/cache str
			if id <> 0 [
				return either positive? id [i][0 - i]	;-- matching symbol found
			]
			i: i + 1
			entry: entry + 1
		]
		0												;-- no matching symbol
	]

	duplicate: func [
		src		 [c-string!]
		return:  [c-string!]
		/local
			node [node!]
			dst  [c-string!]
			s	 [series!]
			len	 [integer!]
	][
		len: 1 + length? src							;-- account for terminal NUL
		node: alloc-bytes len							;@@ TBD: mark this buffer as protected!
		s: as series! node/value
		dst: as c-string! s/offset

		copy-memory as byte-ptr! dst as byte-ptr! src len
		dst
	]

	make-alt: func [
		str 	[red-string!]
		return:	[integer!]
		/local
			sym	[red-symbol!]
			s 	[c-string!]
			id	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "symbol/make-alt"]]

		s: unicode/to-utf8 str
		id: search s
		if positive? id [return id]

		sym: as red-symbol! ALLOC_TAIL(symbols)
		sym/header: TYPE_SYMBOL							;-- implicit reset of all header flags
		sym/alias:  either zero? id [-1][0 - id]		;-- -1: no alias, abs(id)>0: alias id
		sym/node:   str/node
		sym/cache:  s
		block/rs-length? symbols
	]

	make: func [
		s 		[c-string!]								;-- input c-string!
		return:	[integer!]
		/local
			sym	[red-symbol!]
			id	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "symbol/make"]]

		id: search s
		if positive? id [return id]

		sym: as red-symbol! ALLOC_TAIL(symbols)
		sym/header: TYPE_SYMBOL							;-- implicit reset of all header flags
		sym/alias:  either zero? id [-1][0 - id]		;-- -1: no alias, abs(id)>0: alias id
		sym/node:   unicode/load-utf8 s 1 + system/words/length? s
		sym/cache:  duplicate s
		block/rs-length? symbols
	]

	get: func [
		id		[integer!]
		return:	[red-symbol!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(symbols)
		as red-symbol! s/offset + id - 1
	]

	resolve: func [
		id		[integer!]
		return:	[integer!]
		/local
			sym	[red-symbol!]
			s	[series!]
	][
		s: GET_BUFFER(symbols)
		sym: as red-symbol! s/offset + id - 1
		either positive? sym/alias [sym/alias][id]
	]

	push: func [

	][

	]

	;-- Actions --

	init: does [
		datatype/register [
			TYPE_SYMBOL
			TYPE_VALUE
			"symbol!"
			;-- 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
		]
	]
]