FIX: added proper header to the %input.red file.

Red [
	Title:	"INPUT prototype for Unix platforms"
	Author: "Nenad Rakocevic"
	File: 	%input.red
	Tabs: 	4
	Rights: "Copyright (C) 2014 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
	Notes: {
		Freely inspired by linenoise fork from msteveb:
		https://github.com/msteveb/linenoise/blob/master/linenoise.c
	}
]

#system [

	terminal: context [
		#define OS_POLLIN 		1

		#define TERM_VTIME		5
		#define TERM_VMIN		6

		#define TERM_BRKINT		00000002h
		#define TERM_INPCK		00000020h
		#define TERM_ISTRIP		00000040h
		#define TERM_ICRNL		00000400h
		#define TERM_IXON		00002000h
		#define TERM_OPOST		00000001h
		#define TERM_CS8		00000060h
		#define TERM_ISIG		00000001h
		#define TERM_ICANON		00000002h
		#define TERM_ECHO		00000010h
		#define TERM_IEXTEN		01000000h
		#define TERM_VOODOO		00000008h					;-- undocumented value...

		#define TERM_TCSADRAIN	1

		#either OS = 'MacOSX [
			#define TIOCGWINSZ	40087468h
		][
			#define TIOCGWINSZ	5413h
		]

		pollfd!: alias struct! [
			fd				[integer!]
			events			[integer!]						;-- high 16-bit: events
		]													;-- low  16-bit: revents

		winsize!: alias struct! [
			rowcol			[integer!]
			xypixel			[integer!]
		]

		termios!: alias struct! [
			c_iflag			[integer!]
			c_oflag			[integer!]
			c_cflag			[integer!]
			c_lflag			[integer!]
			c_line			[byte!]
			c_cc1			[byte!]							;-- c_cc[32]
			c_cc2			[byte!]
			c_cc3			[byte!]
			c_cc4			[integer!]
			c_cc5			[integer!]
			c_cc6			[integer!]
			c_cc7			[integer!]
			c_cc8			[integer!]
			c_cc9			[integer!]
			c_cc10			[integer!]
			pad				[integer!]						;-- for proper alignment
			c_ispeed		[integer!]
			c_ospeed		[integer!]
		]

		#import [
			LIBC-file cdecl [
				tcgetattr: "tcgetattr" [
					fd		[integer!]
					termios [termios!]
					return: [integer!]
				]
				tcsetattr: "tcsetattr" [
					fd			[integer!]
					opt_actions [integer!]
					termios 	[termios!]
					return: 	[integer!]
				]
				read: "read" [
					fd		[integer!]
					buf		[byte-ptr!]
					size	[integer!]
					return: [integer!]
				]
				write: "write" [
					fd		[integer!]
					buf		[byte-ptr!]
					size	[integer!]
					return: [integer!]
				]
				poll: "poll" [
					fds		[pollfd!]
					nfds	[integer!]
					timeout [integer!]
					return: [integer!]
				]
				ioctl: "ioctl" [
					fd		[integer!]
					request	[integer!]
					ws		[winsize!]
					return: [integer!]
				]
			]
		]

		#enum special-key! [
			KEY_UNSET:		 -1
			KEY_NONE:		  0
			KEY_UP:			-20
			KEY_DOWN:		-21
			KEY_RIGHT:		-22
			KEY_LEFT:		-23
			KEY_END:		-24
			KEY_HOME:		-25
			KEY_INSERT:		-26
			KEY_DELETE:		-27
			KEY_PAGE_UP:	-28
			KEY_PAGE_DOWN:	-29
			KEY_ENTER:		-30
			KEY_BACKSPACE:	-31
		]

		#define KEY-CTRL-A	#"^A"
		#define	KEY-CTRL-E	#"^E"

		saved-term: declare termios!
		utf-char:	declare c-string!
		poller: 	declare pollfd!
		input-line: declare red-string!
		saved-line:	declare red-string!
		prompt:		declare	red-string!
		history:	declare red-block!
		columns:	-1
		lines-y:	 0
		caret-y:	 0

		fd-read-char: func [
			timeout [integer!]
			return: [byte!]
			/local
				c [byte!]
		][
			c: as-byte -1
			if any [
				zero? poll poller 1 timeout
				1 <> read stdin :c 1
			][
				return as-byte -1
			]
			c
		]

		fd-read: func [
			return: [integer!]								;-- input codepoint or -1
			/local
				c	[integer!]
				len [integer!]
				i	[integer!]
				p	[byte-ptr!]
		][
			if 1 <> read stdin as byte-ptr! utf-char 1 [return -1]
			c: as-integer utf-char/1
			case [
				c and 80h = 0	[len: 1]
				c and E0h = C0h [len: 2]
				c and F0h = E0h [len: 3]
				c and F8h = F0h [len: 4]
			]
			if any [len < 1 len > 4][return -1]

			i: 1
			while [i < len][
				if all [
					len >= (i + 1)
					1 <> read stdin as byte-ptr! utf-char + i 1
				][
					return -1
				]
				i: i + 1
			]
			c: unicode/decode-utf8-char utf-char :len
			switch c [
				#"^(0A)" [KEY_ENTER]
				#"^(7F)" [KEY_BACKSPACE]
				default  [c]
			]
		]

		check-special: func [
			return: [integer!]
			/local
				c  [byte!]
				c2 [byte!]
		][
			c: fd-read-char 50
			if (as-integer c) < 0 [return 27]

			c2: fd-read-char 50
			if (as-integer c) < 0 [return as-integer c2]

			if any [c = #"[" c = #"O"][
				switch c2 [
					#"A" [return KEY_UP]
					#"B" [return KEY_DOWN]
					#"C" [return KEY_RIGHT]
					#"D" [return KEY_LEFT]
					#"F" [return KEY_END]
					#"H" [return KEY_HOME]
				]
			]
			if all [c = #"[" #"1" <= c2 c2 <= #"8"][
				c: fd-read-char 50
				if c = #"~" [
					switch c2 [
						#"2" [return KEY_INSERT]
						#"3" [return KEY_DELETE]
						#"5" [return KEY_PAGE_UP]
						#"6" [return KEY_PAGE_DOWN]
						#"7" [return KEY_HOME]
						#"8" [return KEY_END]
					]
				]
				while [all [(as-integer c) <> -1 c <> #"~"]][
					c: fd-read-char 50
				]
			]
			KEY_NONE
		]

		emit: func [c [byte!]][
			write stdout :c 1
		]

		emit-string: func [
			s [c-string!]
		][
			write stdout as byte-ptr! s length? s
		]

		emit-string-int: func [
			begin [c-string!]
			n	  [integer!]
			end	  [byte!]
		][
			emit-string begin
			emit-string integer/form-signed n
			emit end
		]

		emit-red-string: func [
			str	 [red-string!]
			size [integer!]
			/local
				series	[series!]
				offset	[byte-ptr!]
				tail	[byte-ptr!]
				max		[byte-ptr!]
				unit	[integer!]
				cp		[integer!]
		][
			series: GET_BUFFER(str)
			unit: 	GET_UNIT(series)
			offset: (as byte-ptr! series/offset) + (str/head << (unit >> 1))
			tail:   as byte-ptr! series/tail
			max:	offset + (size << (unit >> 1))

			if max < tail [tail: max]

			while [offset < tail][
				cp: string/get-char offset unit

				case [
					cp <= 7Fh [
						emit as-byte cp
					]
					cp <= 07FFh [
						emit as-byte cp >> 6 or C0h
						emit as-byte cp and 3Fh or 80h
					]
					cp <= FFFFh [
						emit as-byte cp >> 12 or E0h
						emit as-byte cp >> 6 and 3Fh or 80h
						emit as-byte cp and 3Fh or 80h
					]
					cp <= 001FFFFFh [
						emit as-byte cp >> 18 or F0h
						emit as-byte cp >> 12 and 3Fh or 80h
						emit as-byte cp >>  6 and 3Fh or 80h
						emit as-byte cp and 3Fh or 80h
					]
					true [
						print-line "Error in emit-red-string: codepoint > 1FFFFFh"
					]
				]
				offset: offset + unit
			]
		]

		query-cursor: func [
			return: [logic!]								;-- FALSE: failed to retrieve it
			/local
				c [byte!]
				n [integer!]
		][
			emit-string "^[[6n"								;-- ask for cursor location
			if all [
				  esc = fd-read-char 100
				 #"[" = fd-read-char 100
			][
				while [true][
					c: fd-read-char 100
					n: 0
					case [
						c = #";" [n: 0]
						all [c = #"R" n <> 0 n < 1000][
							columns: n
							return true
						]
						all [#"0" <= c c <= #"9"][
							n: n * 10 + (c - #"0")
						]
						true [
							columns: n
							return true
						]
					]
				]
			]
			false
		]

		get-window-size: func [
			/local
				ws	 [winsize!]
				here [integer!]
		][
			ws: declare winsize!

			if zero? ioctl stdout TIOCGWINSZ ws [
				columns: ws/rowcol >> 16
				exit
			]

			if zero? columns [
				columns: 80

				if query-cursor [
					here: columns
					emit-string "^[[999C"

					either query-cursor [
						if columns > here [				;-- reset cursor position
							emit-string-int "^[[" columns - here #"D"
						]
					][
						emit cr
					]
				]
			]
		]

		refresh: func [
			/local
				line   [red-string!]
				offset [integer!]
				x	   [integer!]
				y	   [integer!]
				saved  [integer!]
				psize  [integer!]
		][
			line: 	input-line
			psize: 	string/rs-length? prompt
			offset: psize + line/head
			x: 		offset // columns
			y: 		(offset + string/rs-length? line) / columns

			if y > lines-y [emit-string "^[D"]			;-- scroll one line up
			if y < lines-y [emit-string "^[7^[[H^[M^[8"] ;-- scroll one line down preserving cursor
			lines-y: y

			emit-string "^[7"							;-- save cursor position/attributs
			if caret-y > 0 [emit-string-int "^[[" caret-y #"A"]		;-- move cursor up <n> lines
			saved: line/head
			y: 0
			until [
				emit #"^(0D)"							;-- set cursor left
				either zero? y [
					emit-red-string prompt columns
					line/head: 0
					emit-red-string line columns - psize ;-- output from head to EOL
				][
					emit-string "^[E"					;-- move to next line
					line/head: (y - 1) * columns + (columns - psize)
					emit-red-string line columns		;-- output from head to EOL
				]
				y: y + 1
				y = (lines-y + 1)
			]
			line/head: saved
			emit-string "^[[0K^[8"						;-- erase to EOL, restore cursor position/attributs

			y: offset / columns
			if y > caret-y [emit-string "^[[1B"]		;-- move cursor down one line
			if y < caret-y [emit-string "^[[1A"]		;-- move cursor up one line
			caret-y: y

			either zero? x [
				emit #"^(0D)"
			][
				emit-string-int "^(0D)^[[" x #"C"		 ;-- set cursor position
			]
		]

		on-resize: does [
			get-window-size
			refresh
		]

		fetch-history: does [
			string/rs-reset input-line
			string/concatenate input-line as red-string! block/rs-head history -1 0 yes no
			input-line/head: string/get-length input-line yes
		]

		init: func [
			line 	 [red-string!]
			hist-blk [red-block!]
			/local
				term [termios!]
				cc	 [byte-ptr!]
				so	 [sigaction!]
		][
			utf-char: as-c-string allocate 10

			copy-cell as red-value! line as red-value! input-line
			copy-cell as red-value! hist-blk as red-value! history

			so: declare sigaction!						;-- install resizing signal trap
			so/sigaction: as-integer :on-resize
			so/flags: 	SA_SIGINFO ;or SA_RESTART
			sigaction SIGWINCH so as sigaction! 0

			term: declare termios!
			tcgetattr stdin saved-term					;@@ check returned value

			copy-memory
				as byte-ptr! term
				as byte-ptr! saved-term
				size? term

			term/c_iflag: term/c_iflag and not (
				TERM_BRKINT or TERM_ICRNL or TERM_INPCK or TERM_ISTRIP or TERM_IXON
			)
			term/c_oflag: term/c_oflag and not TERM_OPOST
			term/c_cflag: term/c_cflag or TERM_CS8
			term/c_lflag: term/c_lflag and not (
				TERM_VOODOO or TERM_ECHO or TERM_ICANON or TERM_IEXTEN or TERM_ISIG
			)
			cc: (as byte-ptr! term) + (4 * size? integer!) + 2
			cc/TERM_VMIN:  as-byte 1
			cc/TERM_VTIME: as-byte 0

			tcsetattr stdin TERM_TCSADRAIN term
			emit-string "^[[?7l"						;-- disable auto-wrap

			poller/fd: stdin
			poller/events: OS_POLLIN
		]

		edit: func [
			prompt-str [red-string!]
			/local
				line   [red-string!]
				c	   [integer!]
				offset [integer!]
		][
			line: input-line
			copy-cell as red-value! prompt-str as red-value! prompt
			history/head: block/rs-length? history		;@@ set history list to tail (temporary)

			get-window-size
			emit-red-string prompt columns
			refresh

			while [true][
				c: fd-read
				if c = 27 [c: check-special]

				switch c [
					KEY_ENTER [
						exit
					]
					KEY_BACKSPACE [
						unless zero? line/head [
							line/head: line/head - 1
							string/remove-char line line/head
							refresh
						]
					]
					KEY_LEFT [
						unless zero? line/head [
							line/head: line/head - 1
							refresh
						]
					]
					KEY_RIGHT [
						if 0 < string/rs-length? line [
							line/head: line/head + 1
							refresh
						]
					]
					KEY_UP [
						unless zero? history/head [
							history/head: history/head - 1
							fetch-history
							line/head: string/get-length line yes
							refresh
						]
					]
					KEY_DOWN [
						unless block/rs-tail? history [
							history/head: history/head + 1
							either block/rs-tail? history [
								string/rs-reset line
							][
								fetch-history
							]
							refresh
						]
					]
					KEY_HOME
					KEY-CTRL-A [
						line/head: 0
						refresh
					]
					KEY_END
					KEY-CTRL-E [
						line/head: string/get-length line yes
						refresh
					]
					KEY_UNSET []						;-- do nothing

					default [
						either zero? string/rs-length? line [
							string/append-char GET_BUFFER(line) c
						][
							string/insert-char GET_BUFFER(line) line/head c
						]
						line/head: line/head + 1
						refresh
					]
				]
			]
			line/head: 0
		]

		restore: does [
			emit-string "^[[?7h"						;-- enable auto-wrap
			tcsetattr stdin TERM_TCSADRAIN saved-term
		]
	]
]

init-console: routine [line [string!] hist [block!]][
	terminal/init line hist
]

input: routine [prompt [string!]][
	terminal/edit prompt
	terminal/restore
]

input-line: make string! 10'000

history: [
	"hello world"
	{print mold [append "hello" [40 + 2] "world"]}
	"mold 2 + 3"
	"1 + 2"
]

init-console input-line history

input "red> "
print lf

print ["input:" mold head input-line]

Red []

#system [

	terminal: context [
		#define OS_POLLIN 		1

		#define TERM_VTIME		5
		#define TERM_VMIN		6

		#define TERM_BRKINT		00000002h
		#define TERM_INPCK		00000020h
		#define TERM_ISTRIP		00000040h
		#define TERM_ICRNL		00000400h
		#define TERM_IXON		00002000h
		#define TERM_OPOST		00000001h
		#define TERM_CS8		00000060h
		#define TERM_ISIG		00000001h
		#define TERM_ICANON		00000002h
		#define TERM_ECHO		00000010h
		#define TERM_IEXTEN		01000000h
		#define TERM_VOODOO		00000008h					;-- undocumented value...

		#define TERM_TCSADRAIN	1

		#either OS = 'MacOSX [
			#define TIOCGWINSZ	40087468h
		][
			#define TIOCGWINSZ	5413h
		]

		pollfd!: alias struct! [
			fd				[integer!]
			events			[integer!]						;-- high 16-bit: events
		]													;-- low  16-bit: revents

		winsize!: alias struct! [
			rowcol			[integer!]
			xypixel			[integer!]
		]

		termios!: alias struct! [
			c_iflag			[integer!]
			c_oflag			[integer!]
			c_cflag			[integer!]
			c_lflag			[integer!]
			c_line			[byte!]
			c_cc1			[byte!]							;-- c_cc[32]
			c_cc2			[byte!]
			c_cc3			[byte!]
			c_cc4			[integer!]
			c_cc5			[integer!]
			c_cc6			[integer!]
			c_cc7			[integer!]
			c_cc8			[integer!]
			c_cc9			[integer!]
			c_cc10			[integer!]
			pad				[integer!]						;-- for proper alignment
			c_ispeed		[integer!]
			c_ospeed		[integer!]
		]

		#import [
			LIBC-file cdecl [
				tcgetattr: "tcgetattr" [
					fd		[integer!]
					termios [termios!]
					return: [integer!]
				]
				tcsetattr: "tcsetattr" [
					fd			[integer!]
					opt_actions [integer!]
					termios 	[termios!]
					return: 	[integer!]
				]
				read: "read" [
					fd		[integer!]
					buf		[byte-ptr!]
					size	[integer!]
					return: [integer!]
				]
				write: "write" [
					fd		[integer!]
					buf		[byte-ptr!]
					size	[integer!]
					return: [integer!]
				]
				poll: "poll" [
					fds		[pollfd!]
					nfds	[integer!]
					timeout [integer!]
					return: [integer!]
				]
				ioctl: "ioctl" [
					fd		[integer!]
					request	[integer!]
					ws		[winsize!]
					return: [integer!]
				]
			]
		]

		#enum special-key! [
			KEY_UNSET:		 -1
			KEY_NONE:		  0
			KEY_UP:			-20
			KEY_DOWN:		-21
			KEY_RIGHT:		-22
			KEY_LEFT:		-23
			KEY_END:		-24
			KEY_HOME:		-25
			KEY_INSERT:		-26
			KEY_DELETE:		-27
			KEY_PAGE_UP:	-28
			KEY_PAGE_DOWN:	-29
			KEY_ENTER:		-30
			KEY_BACKSPACE:	-31
		]

		#define KEY-CTRL-A	#"^A"
		#define	KEY-CTRL-E	#"^E"

		saved-term: declare termios!
		utf-char:	declare c-string!
		poller: 	declare pollfd!
		input-line: declare red-string!
		saved-line:	declare red-string!
		prompt:		declare	red-string!
		history:	declare red-block!
		columns:	-1
		lines-y:	 0
		caret-y:	 0

		fd-read-char: func [
			timeout [integer!]
			return: [byte!]
			/local
				c [byte!]
		][
			c: as-byte -1
			if any [
				zero? poll poller 1 timeout
				1 <> read stdin :c 1
			][
				return as-byte -1
			]
			c
		]

		fd-read: func [
			return: [integer!]								;-- input codepoint or -1
			/local
				c	[integer!]
				len [integer!]
				i	[integer!]
				p	[byte-ptr!]
		][
			if 1 <> read stdin as byte-ptr! utf-char 1 [return -1]
			c: as-integer utf-char/1
			case [
				c and 80h = 0	[len: 1]
				c and E0h = C0h [len: 2]
				c and F0h = E0h [len: 3]
				c and F8h = F0h [len: 4]
			]
			if any [len < 1 len > 4][return -1]

			i: 1
			while [i < len][
				if all [
					len >= (i + 1)
					1 <> read stdin as byte-ptr! utf-char + i 1
				][
					return -1
				]
				i: i + 1
			]
			c: unicode/decode-utf8-char utf-char :len
			switch c [
				#"^(0A)" [KEY_ENTER]
				#"^(7F)" [KEY_BACKSPACE]
				default  [c]
			]
		]

		check-special: func [
			return: [integer!]
			/local
				c  [byte!]
				c2 [byte!]
		][
			c: fd-read-char 50
			if (as-integer c) < 0 [return 27]

			c2: fd-read-char 50
			if (as-integer c) < 0 [return as-integer c2]

			if any [c = #"[" c = #"O"][
				switch c2 [
					#"A" [return KEY_UP]
					#"B" [return KEY_DOWN]
					#"C" [return KEY_RIGHT]
					#"D" [return KEY_LEFT]
					#"F" [return KEY_END]
					#"H" [return KEY_HOME]
				]
			]
			if all [c = #"[" #"1" <= c2 c2 <= #"8"][
				c: fd-read-char 50
				if c = #"~" [
					switch c2 [
						#"2" [return KEY_INSERT]
						#"3" [return KEY_DELETE]
						#"5" [return KEY_PAGE_UP]
						#"6" [return KEY_PAGE_DOWN]
						#"7" [return KEY_HOME]
						#"8" [return KEY_END]
					]
				]
				while [all [(as-integer c) <> -1 c <> #"~"]][
					c: fd-read-char 50
				]
			]
			KEY_NONE
		]

		emit: func [c [byte!]][
			write stdout :c 1
		]

		emit-string: func [
			s [c-string!]
		][
			write stdout as byte-ptr! s length? s
		]

		emit-string-int: func [
			begin [c-string!]
			n	  [integer!]
			end	  [byte!]
		][
			emit-string begin
			emit-string integer/form-signed n
			emit end
		]

		emit-red-string: func [
			str	 [red-string!]
			size [integer!]
			/local
				series	[series!]
				offset	[byte-ptr!]
				tail	[byte-ptr!]
				max		[byte-ptr!]
				unit	[integer!]
				cp		[integer!]
		][
			series: GET_BUFFER(str)
			unit: 	GET_UNIT(series)
			offset: (as byte-ptr! series/offset) + (str/head << (unit >> 1))
			tail:   as byte-ptr! series/tail
			max:	offset + (size << (unit >> 1))

			if max < tail [tail: max]

			while [offset < tail][
				cp: string/get-char offset unit

				case [
					cp <= 7Fh [
						emit as-byte cp
					]
					cp <= 07FFh [
						emit as-byte cp >> 6 or C0h
						emit as-byte cp and 3Fh or 80h
					]
					cp <= FFFFh [
						emit as-byte cp >> 12 or E0h
						emit as-byte cp >> 6 and 3Fh or 80h
						emit as-byte cp and 3Fh or 80h
					]
					cp <= 001FFFFFh [
						emit as-byte cp >> 18 or F0h
						emit as-byte cp >> 12 and 3Fh or 80h
						emit as-byte cp >>  6 and 3Fh or 80h
						emit as-byte cp and 3Fh or 80h
					]
					true [
						print-line "Error in emit-red-string: codepoint > 1FFFFFh"
					]
				]
				offset: offset + unit
			]
		]

		query-cursor: func [
			return: [logic!]								;-- FALSE: failed to retrieve it
			/local
				c [byte!]
				n [integer!]
		][
			emit-string "^[[6n"								;-- ask for cursor location
			if all [
				  esc = fd-read-char 100
				 #"[" = fd-read-char 100
			][
				while [true][
					c: fd-read-char 100
					n: 0
					case [
						c = #";" [n: 0]
						all [c = #"R" n <> 0 n < 1000][
							columns: n
							return true
						]
						all [#"0" <= c c <= #"9"][
							n: n * 10 + (c - #"0")
						]
						true [
							columns: n
							return true
						]
					]
				]
			]
			false
		]

		get-window-size: func [
			/local
				ws	 [winsize!]
				here [integer!]
		][
			ws: declare winsize!

			if zero? ioctl stdout TIOCGWINSZ ws [
				columns: ws/rowcol >> 16
				exit
			]

			if zero? columns [
				columns: 80

				if query-cursor [
					here: columns
					emit-string "^[[999C"

					either query-cursor [
						if columns > here [				;-- reset cursor position
							emit-string-int "^[[" columns - here #"D"
						]
					][
						emit cr
					]
				]
			]
		]

		refresh: func [
			/local
				line   [red-string!]
				offset [integer!]
				x	   [integer!]
				y	   [integer!]
				saved  [integer!]
				psize  [integer!]
		][
			line: 	input-line
			psize: 	string/rs-length? prompt
			offset: psize + line/head
			x: 		offset // columns
			y: 		(offset + string/rs-length? line) / columns

			if y > lines-y [emit-string "^[D"]			;-- scroll one line up
			if y < lines-y [emit-string "^[7^[[H^[M^[8"] ;-- scroll one line down preserving cursor
			lines-y: y

			emit-string "^[7"							;-- save cursor position/attributs
			if caret-y > 0 [emit-string-int "^[[" caret-y #"A"]		;-- move cursor up <n> lines
			saved: line/head
			y: 0
			until [
				emit #"^(0D)"							;-- set cursor left
				either zero? y [
					emit-red-string prompt columns
					line/head: 0
					emit-red-string line columns - psize ;-- output from head to EOL
				][
					emit-string "^[E"					;-- move to next line
					line/head: (y - 1) * columns + (columns - psize)
					emit-red-string line columns		;-- output from head to EOL
				]
				y: y + 1
				y = (lines-y + 1)
			]
			line/head: saved
			emit-string "^[[0K^[8"						;-- erase to EOL, restore cursor position/attributs

			y: offset / columns
			if y > caret-y [emit-string "^[[1B"]		;-- move cursor down one line
			if y < caret-y [emit-string "^[[1A"]		;-- move cursor up one line
			caret-y: y

			either zero? x [
				emit #"^(0D)"
			][
				emit-string-int "^(0D)^[[" x #"C"		 ;-- set cursor position
			]
		]

		on-resize: does [
			get-window-size
			refresh
		]

		fetch-history: does [
			string/rs-reset input-line
			string/concatenate input-line as red-string! block/rs-head history -1 0 yes no
			input-line/head: string/get-length input-line yes
		]

		init: func [
			line 	 [red-string!]
			hist-blk [red-block!]
			/local
				term [termios!]
				cc	 [byte-ptr!]
				so	 [sigaction!]
		][
			utf-char: as-c-string allocate 10

			copy-cell as red-value! line as red-value! input-line
			copy-cell as red-value! hist-blk as red-value! history

			so: declare sigaction!						;-- install resizing signal trap
			so/sigaction: as-integer :on-resize
			so/flags: 	SA_SIGINFO ;or SA_RESTART
			sigaction SIGWINCH so as sigaction! 0

			term: declare termios!
			tcgetattr stdin saved-term					;@@ check returned value

			copy-memory
				as byte-ptr! term
				as byte-ptr! saved-term
				size? term

			term/c_iflag: term/c_iflag and not (
				TERM_BRKINT or TERM_ICRNL or TERM_INPCK or TERM_ISTRIP or TERM_IXON
			)
			term/c_oflag: term/c_oflag and not TERM_OPOST
			term/c_cflag: term/c_cflag or TERM_CS8
			term/c_lflag: term/c_lflag and not (
				TERM_VOODOO or TERM_ECHO or TERM_ICANON or TERM_IEXTEN or TERM_ISIG
			)
			cc: (as byte-ptr! term) + (4 * size? integer!) + 2
			cc/TERM_VMIN:  as-byte 1
			cc/TERM_VTIME: as-byte 0

			tcsetattr stdin TERM_TCSADRAIN term
			emit-string "^[[?7l"						;-- disable auto-wrap

			poller/fd: stdin
			poller/events: OS_POLLIN
		]

		edit: func [
			prompt-str [red-string!]
			/local
				line   [red-string!]
				c	   [integer!]
				offset [integer!]
		][
			line: input-line
			copy-cell as red-value! prompt-str as red-value! prompt
			history/head: block/rs-length? history		;@@ set history list to tail (temporary)

			get-window-size
			emit-red-string prompt columns
			refresh

			while [true][
				c: fd-read
				if c = 27 [c: check-special]

				switch c [
					KEY_ENTER [
						exit
					]
					KEY_BACKSPACE [
						unless zero? line/head [
							line/head: line/head - 1
							string/remove-char line line/head
							refresh
						]
					]
					KEY_LEFT [
						unless zero? line/head [
							line/head: line/head - 1
							refresh
						]
					]
					KEY_RIGHT [
						if 0 < string/rs-length? line [
							line/head: line/head + 1
							refresh
						]
					]
					KEY_UP [
						unless zero? history/head [
							history/head: history/head - 1
							fetch-history
							line/head: string/get-length line yes
							refresh
						]
					]
					KEY_DOWN [
						unless block/rs-tail? history [
							history/head: history/head + 1
							either block/rs-tail? history [
								string/rs-reset line
							][
								fetch-history
							]
							refresh
						]
					]
					KEY_HOME
					KEY-CTRL-A [
						line/head: 0
						refresh
					]
					KEY_END
					KEY-CTRL-E [
						line/head: string/get-length line yes
						refresh
					]
					KEY_UNSET []						;-- do nothing

					default [
						either zero? string/rs-length? line [
							string/append-char GET_BUFFER(line) c
						][
							string/insert-char GET_BUFFER(line) line/head c
						]
						line/head: line/head + 1
						refresh
					]
				]
			]
			line/head: 0
		]

		restore: does [
			emit-string "^[[?7h"						;-- enable auto-wrap
			tcsetattr stdin TERM_TCSADRAIN saved-term
		]
	]
]

init-console: routine [line [string!] hist [block!]][
	terminal/init line hist
]

input: routine [prompt [string!]][
	terminal/edit prompt
	terminal/restore
]

input-line: make string! 10'000

history: [
	"hello world"
	{print mold [append "hello" [40 + 2] "world"]}
	"mold 2 + 3"
	"1 + 2"
]

init-console input-line history

input "red> "
print lf

print ["input:" mold head input-line]


FIX: unset words corrupt stack in nested expressions, when run from interpreter.

Red/System [
	Title:   "Red interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %interpreter.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
	}
]

#define CHECK_INFIX [
	if all [
		next < end
		TYPE_OF(next) = TYPE_WORD
	][
		value: _context/get next
		if TYPE_OF(value) = TYPE_OP [
			if verbose > 0 [log "infix detected!"]
			infix?: yes
		]
	]
]

#define FETCH_ARGUMENT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
	either TYPE_OF(value) = TYPE_WORD [
		if verbose > 0 [log "evaluating argument"]
		pc: eval-expression pc end no yes
	][
		if verbose > 0 [log "fetching argument"]
		stack/push pc
		pc: pc + 1
	]
]

interpreter: context [
	verbose: 0

	return-type: -1										;-- return type for routine calls

	log: func [msg [c-string!]][
		print "eval: "
		print-line msg
	]

	print-symbol: func [
		word [red-word!]
		/local
			sym [red-symbol!]
	][
		sym: symbol/get word/symbol
		print sym/cache
	]

	eval-option: func [
		pc		  [red-value!]
		end		  [red-value!]
		value	  [red-value!]
		tail	  [red-value!]
		word	  [red-word!]
		offset	  [int-ptr!]
		args	  [int-ptr!]
		function? [logic!]
		return:	  [red-value!]
		/local
			ref	  [red-refinement!]
			slot  [red-logic!]
			type  [integer!]
			pos	  [integer!]
			idx	  [integer!]
			pos2  [integer!]
	][
		pos:  0											;-- stack offset
		idx:  1											;-- native stack ref-array index
		args/value: 0

		while [value < tail][

			switch TYPE_OF(value) [
				TYPE_REFINEMENT [
					ref: as red-refinement! value
					either (symbol/resolve ref/symbol) = (symbol/resolve word/symbol) [
						slot: as red-logic! stack/arguments + pos
						slot/value: true

						value: value + 1
						pos2: pos + 1
						while [
							type: TYPE_OF(value)
							all [
								value < tail
								any [
									type = TYPE_WORD
									type = TYPE_GET_WORD
									type = TYPE_LIT_WORD
								]
							]
						][
							FETCH_ARGUMENT
							if function? [
								copy-cell stack/top - 1 stack/arguments + pos2
								stack/pop 1
							]
							pos2: pos2 + 1
							args/value: args/value + 1
							value: value + 1
						]
						unless function? [offset/value: idx]
						return pc
					][
						idx: idx + 1
					]
					pos: pos + 1
				]
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					pos: pos + 1
				]
				default [0]
			]

			value: value + 1
		]
		print "Error: refinement /"
		print-symbol word
		print-line " not found!"
		halt
		null
	]

	eval-function: func [
		fun  [red-function!]
		body [red-block!]
		/local
			saved
	][
		saved: fun/ctx/values
		fun/ctx/values: as node! stack/arguments
		eval body
		fun/ctx/values: saved
	]

	exec-routine: func [
		fun	 [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			count  [integer!]
			call
	][
		s: as series! fun/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: (routine/get-arity fun) - 1				;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert false]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			infix? [logic!]
			op	   [red-op!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op

		if verbose > 0 [
			value: stack/arguments
			print-line ["eval: op return type: " TYPE_OF(value)]
		]

		infix?: no
		next: as red-word! pc
		CHECK_INFIX
		if infix? [pc: eval-infix value pc end sub?]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		path	[red-path!]
		pos 	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			head	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			path-end  [red-value!]
			s		  [series!]
			required? [logic!]
			index	  [integer!]
			count	  [integer!]
			offset	  [integer!]
			args	  [integer!]
			size	  [integer!]
			ref-array [int-ptr!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]

		s: as series! either function? [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]

		head:  s/offset
		value: head
		tail:  s/tail

		unless null? path [
			path-end: block/rs-tail as red-block! path
			if pos + 1 = path-end [path: null]			;-- no refinement following the function
		]												;-- so, process it as a non-path call

		count:  	 0									;-- base arity (mandatory arguments only)
		index: 	 	 1
		args:		 -1
		offset:		 -1
		return-type: -1
		ref?:		 no
		required?:	 yes								;-- yes: processing mandatory args, no: optional args

		unless function? [
			size: as-integer tail - value				;@@ takes more space than really needed
			ref-array: system/stack/top - size
			system/stack/top: ref-array					;-- reserve space on native stack for refs array
		]

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					either required? [
						FETCH_ARGUMENT
						count: count + 1
					][
						if function? [none/push]
					]
				]
				TYPE_REFINEMENT [
					if required? [required?: no]		;-- no more mandatory arguments

					either function? [
						logic/push false
					][
						ref-array/index: -1
						index: index + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]

		unless routine? [
			if path <> null [
				pos: pos + 1

				while [pos < path-end][
					pc: eval-option pc end head tail as red-word! pos :offset :args function?

					unless function? [
						either args > 0 [
							ref-array/offset: count + args - 1
							count: count + args
						][
							ref-array/offset: 0
						]
					]
					pos: pos + 1
				]
			]
		]

		unless function? [
			system/stack/top: ref-array					;-- reset native stack to our custom arguments frame
			call: as function! [] native/code			;-- direct call for actions/natives
			call
		]
		pc
	]

	eval-path-element: func [
		slot     [red-value!]
		head     [red-value!]
		tail     [red-value!]
		result   [red-value!]
		alt-slot [red-value!]							;-- alternative element (computed from paren)
		set?     [logic!]
		return:  [red-value!]
		/local
			value  [red-value!]
			int	   [red-integer!]
	][
		value: case [
			TYPE_OF(slot) = TYPE_GET_WORD [_context/get as red-word! slot]
			null? alt-slot 				  [slot]
			true		   				  [alt-slot]
		]
		switch TYPE_OF(value) [
			TYPE_WORD [
				either slot = head [
					result: _context/get as red-word! value
					switch TYPE_OF(result) [
						TYPE_UNSET [
							return unset-value
						]
						TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
						TYPE_NATIVE
						TYPE_ROUTINE
						TYPE_FUNCTION [
							return result
						]
						TYPE_BLOCK 						;@@ replace with TYPE_SERIES
						TYPE_PATH
						TYPE_LIT_PATH
						TYPE_GET_PATH
						TYPE_SET_PATH
						TYPE_STRING
						TYPE_FILE [

						]
						;TYPE_OBJECT
						;TYPE_PORT [
						;
						;]
						default [
							;; TBD raise an error
						]
					]
				][
					result: either all [set? slot + 1 = tail][
						value: actions/find as red-series! result value null no no no null null no no no no
						actions/poke as red-series! value 2 stack/arguments
						stack/arguments
					][
						actions/select as red-series! result value null no no no null null no no
					]
				]
			]
			TYPE_PAREN [
				stack/mark-native words/_body			;@@ ~paren
				eval as red-block! value				;-- eval paren content
				stack/unwind
				result: eval-path-element slot head tail result stack/top - 1 set?
			]
			TYPE_INTEGER [
				int: as red-integer! value
				result: either all [set? slot + 1 = tail][
					actions/poke as red-series! result int/value stack/arguments
					stack/arguments
				][
					actions/pick as red-series! result int/value
				]
			]
			TYPE_STRING [
				--NOT_IMPLEMENTED--
			]
		]
		result
	]

	eval-path: func [
		value   [red-value!]
		pc		[red-value!]							;-- path to evaluate
		end		[red-value!]
		set?	[logic!]
		return: [red-value!]
		/local
			path   [red-path!]
			head   [red-value!]
			tail   [red-value!]
			slot   [red-value!]
			result [red-value!]
			saved  [red-value!]
	][
		if verbose > 0 [print-line "eval: path"]

		path:  as red-path! value
		head:  block/rs-head as red-block! path
		tail:  block/rs-tail as red-block! path
		slot:  head
		saved: stack/top

		if TYPE_OF(slot) <> TYPE_WORD [
			print-line "*** Error: path value must start with a word!"
			halt
		]

		result: null

		while [slot < tail][
			if verbose > 1 [print-line ["slot type: " TYPE_OF(slot)]]

			result: eval-path-element slot head tail result null set?

			switch TYPE_OF(result) [
				TYPE_UNSET [
					print-line "*** Error: word in path has no value!"
					stack/push result
					return pc
				]
				TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code result pc end yes path slot
					return pc
				]
				default [0]
			]
			slot: slot + 1
		]

		stack/top: saved
		stack/push result
		pc
	]

	eval-code: func [
		value	[red-value!]
		pc		[red-value!]
		end		[red-value!]
		sub?	[logic!]
		path	[red-path!]
		slot 	[red-value!]
		return: [red-value!]
		/local
			fun	   [red-function!]
			native [red-native!]
			s	   [series!]
			call
	][
		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				if verbose > 0 [log "pushing action/native frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot 	;-- fetch args and exec
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: action/native return type: " TYPE_OF(value)]
				]
			]
			TYPE_ROUTINE [
				if verbose > 0 [log "pushing routine frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot
				exec-routine as red-routine! value
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: routine return type: " TYPE_OF(value)]
				]
			]
			TYPE_FUNCTION [
				if verbose > 0 [log "pushing function frame"]
				stack/mark-func as red-word! pc	;@@
				pc: eval-arguments as red-native! value pc end path slot
				fun: as red-function! value
				s: as series! fun/more/value

				native: as red-native! s/offset + 2
				either zero? native/code [
					eval-function fun as red-block! s/offset
				][
					call: as function! [] native/code
					call
					0
				]
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: function return type: " TYPE_OF(value)]
				]
			]
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		prefix?	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			value  [red-value!]
			w	   [red-word!]
			sym	   [red-symbol!]
			op	   [red-value!]
			infix? [logic!]
	][
		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

		infix?: no
		unless prefix? [
			next: as red-word! pc + 1
			CHECK_INFIX
			if infix? [
				stack/mark-native as red-word! pc + 1
				sub?: yes								;-- force sub? for infix expressions
				op: value
			]
		]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no yes		;-- yes: push value on top of stack
				pc: eval-path value pc end yes
			]
			TYPE_GET_WORD [
				copy-cell _context/get as red-word! pc stack/push*
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				either sub? [
					w: word/push as red-word! pc		;-- nested expression: push value
				][
					w: as red-word! stack/set-last pc	;-- root expression: return value
				]
				w/header: TYPE_WORD						;-- coerce it to a word!
				pc: pc + 1
			]
			TYPE_WORD [
				if verbose > 0 [
					print-line "eval: '"
					print-symbol as red-word! pc
				]
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_UNSET [
						print-line "*** Error: word has no value!"
						either sub? [stack/push unset-value][stack/set-last unset-value]
					]
					TYPE_LIT_WORD [
						w: word/push as red-word! value	;-- push lit-word! on stack
						w/header: TYPE_WORD				;-- coerce it to a word!
					]
					TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: word return type: " TYPE_OF(value)]
						]
					]
				]
			]
			TYPE_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no
			]
			TYPE_LIT_PATH [
				value: stack/push pc
				value/header: TYPE_PATH
				pc: pc + 1
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]

		if infix? [
			pc: eval-infix op pc end sub?
			unless prefix? [
				either sub? [stack/unwind][stack/unwind-last]
			]
		]
		pc
	]

	eval-next: func [
		value	[red-value!]
		tail	[red-value!]
		sub?	[logic!]
		return: [red-value!]							;-- return start of next expression
	][
		stack/mark-native words/_body					;-- outer stack frame
		value: eval-expression value tail no sub?
		either sub? [stack/unwind][stack/unwind-last]
		value
	]

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			arg	  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			arg: stack/arguments
			arg/header: TYPE_UNSET
			exit
		]

		stack/mark-native words/_body					;-- outer stack frame

		while [value < tail][
			if verbose > 0 [log "root loop..."]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]

		stack/unwind-last
	]

]

Red/System [
	Title:   "Red interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %interpreter.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
	}
]

#define CHECK_INFIX [
	if all [
		next < end
		TYPE_OF(next) = TYPE_WORD
	][
		value: _context/get next
		if TYPE_OF(value) = TYPE_OP [
			if verbose > 0 [log "infix detected!"]
			infix?: yes
		]
	]
]

#define FETCH_ARGUMENT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
	either TYPE_OF(value) = TYPE_WORD [
		if verbose > 0 [log "evaluating argument"]
		pc: eval-expression pc end no yes
	][
		if verbose > 0 [log "fetching argument"]
		stack/push pc
		pc: pc + 1
	]
]

interpreter: context [
	verbose: 0

	return-type: -1										;-- return type for routine calls

	log: func [msg [c-string!]][
		print "eval: "
		print-line msg
	]

	print-symbol: func [
		word [red-word!]
		/local
			sym [red-symbol!]
	][
		sym: symbol/get word/symbol
		print sym/cache
	]

	eval-option: func [
		pc		  [red-value!]
		end		  [red-value!]
		value	  [red-value!]
		tail	  [red-value!]
		word	  [red-word!]
		offset	  [int-ptr!]
		args	  [int-ptr!]
		function? [logic!]
		return:	  [red-value!]
		/local
			ref	  [red-refinement!]
			slot  [red-logic!]
			type  [integer!]
			pos	  [integer!]
			idx	  [integer!]
			pos2  [integer!]
	][
		pos:  0											;-- stack offset
		idx:  1											;-- native stack ref-array index
		args/value: 0

		while [value < tail][

			switch TYPE_OF(value) [
				TYPE_REFINEMENT [
					ref: as red-refinement! value
					either (symbol/resolve ref/symbol) = (symbol/resolve word/symbol) [
						slot: as red-logic! stack/arguments + pos
						slot/value: true

						value: value + 1
						pos2: pos + 1
						while [
							type: TYPE_OF(value)
							all [
								value < tail
								any [
									type = TYPE_WORD
									type = TYPE_GET_WORD
									type = TYPE_LIT_WORD
								]
							]
						][
							FETCH_ARGUMENT
							if function? [
								copy-cell stack/top - 1 stack/arguments + pos2
								stack/pop 1
							]
							pos2: pos2 + 1
							args/value: args/value + 1
							value: value + 1
						]
						unless function? [offset/value: idx]
						return pc
					][
						idx: idx + 1
					]
					pos: pos + 1
				]
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					pos: pos + 1
				]
				default [0]
			]

			value: value + 1
		]
		print "Error: refinement /"
		print-symbol word
		print-line " not found!"
		halt
		null
	]

	eval-function: func [
		fun  [red-function!]
		body [red-block!]
		/local
			saved
	][
		saved: fun/ctx/values
		fun/ctx/values: as node! stack/arguments
		eval body
		fun/ctx/values: saved
	]

	exec-routine: func [
		fun	 [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			count  [integer!]
			call
	][
		s: as series! fun/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: (routine/get-arity fun) - 1				;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert false]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			infix? [logic!]
			op	   [red-op!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op

		if verbose > 0 [
			value: stack/arguments
			print-line ["eval: op return type: " TYPE_OF(value)]
		]

		infix?: no
		next: as red-word! pc
		CHECK_INFIX
		if infix? [pc: eval-infix value pc end sub?]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		path	[red-path!]
		pos 	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			head	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			path-end  [red-value!]
			s		  [series!]
			required? [logic!]
			index	  [integer!]
			count	  [integer!]
			offset	  [integer!]
			args	  [integer!]
			size	  [integer!]
			ref-array [int-ptr!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]

		s: as series! either function? [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]

		head:  s/offset
		value: head
		tail:  s/tail

		unless null? path [
			path-end: block/rs-tail as red-block! path
			if pos + 1 = path-end [path: null]			;-- no refinement following the function
		]												;-- so, process it as a non-path call

		count:  	 0									;-- base arity (mandatory arguments only)
		index: 	 	 1
		args:		 -1
		offset:		 -1
		return-type: -1
		ref?:		 no
		required?:	 yes								;-- yes: processing mandatory args, no: optional args

		unless function? [
			size: as-integer tail - value				;@@ takes more space than really needed
			ref-array: system/stack/top - size
			system/stack/top: ref-array					;-- reserve space on native stack for refs array
		]

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					either required? [
						FETCH_ARGUMENT
						count: count + 1
					][
						if function? [none/push]
					]
				]
				TYPE_REFINEMENT [
					if required? [required?: no]		;-- no more mandatory arguments

					either function? [
						logic/push false
					][
						ref-array/index: -1
						index: index + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]

		unless routine? [
			if path <> null [
				pos: pos + 1

				while [pos < path-end][
					pc: eval-option pc end head tail as red-word! pos :offset :args function?

					unless function? [
						either args > 0 [
							ref-array/offset: count + args - 1
							count: count + args
						][
							ref-array/offset: 0
						]
					]
					pos: pos + 1
				]
			]
		]

		unless function? [
			system/stack/top: ref-array					;-- reset native stack to our custom arguments frame
			call: as function! [] native/code			;-- direct call for actions/natives
			call
		]
		pc
	]

	eval-path-element: func [
		slot     [red-value!]
		head     [red-value!]
		tail     [red-value!]
		result   [red-value!]
		alt-slot [red-value!]							;-- alternative element (computed from paren)
		set?     [logic!]
		return:  [red-value!]
		/local
			value  [red-value!]
			int	   [red-integer!]
	][
		value: case [
			TYPE_OF(slot) = TYPE_GET_WORD [_context/get as red-word! slot]
			null? alt-slot 				  [slot]
			true		   				  [alt-slot]
		]
		switch TYPE_OF(value) [
			TYPE_WORD [
				either slot = head [
					result: _context/get as red-word! value
					switch TYPE_OF(result) [
						TYPE_UNSET [
							return unset-value
						]
						TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
						TYPE_NATIVE
						TYPE_ROUTINE
						TYPE_FUNCTION [
							return result
						]
						TYPE_BLOCK 						;@@ replace with TYPE_SERIES
						TYPE_PATH
						TYPE_LIT_PATH
						TYPE_GET_PATH
						TYPE_SET_PATH
						TYPE_STRING
						TYPE_FILE [

						]
						;TYPE_OBJECT
						;TYPE_PORT [
						;
						;]
						default [
							;; TBD raise an error
						]
					]
				][
					result: either all [set? slot + 1 = tail][
						value: actions/find as red-series! result value null no no no null null no no no no
						actions/poke as red-series! value 2 stack/arguments
						stack/arguments
					][
						actions/select as red-series! result value null no no no null null no no
					]
				]
			]
			TYPE_PAREN [
				stack/mark-native words/_body			;@@ ~paren
				eval as red-block! value				;-- eval paren content
				stack/unwind
				result: eval-path-element slot head tail result stack/top - 1 set?
			]
			TYPE_INTEGER [
				int: as red-integer! value
				result: either all [set? slot + 1 = tail][
					actions/poke as red-series! result int/value stack/arguments
					stack/arguments
				][
					actions/pick as red-series! result int/value
				]
			]
			TYPE_STRING [
				--NOT_IMPLEMENTED--
			]
		]
		result
	]

	eval-path: func [
		value   [red-value!]
		pc		[red-value!]							;-- path to evaluate
		end		[red-value!]
		set?	[logic!]
		return: [red-value!]
		/local
			path   [red-path!]
			head   [red-value!]
			tail   [red-value!]
			slot   [red-value!]
			result [red-value!]
			saved  [red-value!]
	][
		if verbose > 0 [print-line "eval: path"]

		path:  as red-path! value
		head:  block/rs-head as red-block! path
		tail:  block/rs-tail as red-block! path
		slot:  head
		saved: stack/top

		if TYPE_OF(slot) <> TYPE_WORD [
			print-line "*** Error: path value must start with a word!"
			halt
		]

		result: null

		while [slot < tail][
			if verbose > 1 [print-line ["slot type: " TYPE_OF(slot)]]

			result: eval-path-element slot head tail result null set?

			switch TYPE_OF(result) [
				TYPE_UNSET [
					print-line "*** Error: word in path has no value!"
					stack/push result
					return pc
				]
				TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code result pc end yes path slot
					return pc
				]
				default [0]
			]
			slot: slot + 1
		]

		stack/top: saved
		stack/push result
		pc
	]

	eval-code: func [
		value	[red-value!]
		pc		[red-value!]
		end		[red-value!]
		sub?	[logic!]
		path	[red-path!]
		slot 	[red-value!]
		return: [red-value!]
		/local
			fun	   [red-function!]
			native [red-native!]
			s	   [series!]
			call
	][
		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				if verbose > 0 [log "pushing action/native frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot 	;-- fetch args and exec
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: action/native return type: " TYPE_OF(value)]
				]
			]
			TYPE_ROUTINE [
				if verbose > 0 [log "pushing routine frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot
				exec-routine as red-routine! value
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: routine return type: " TYPE_OF(value)]
				]
			]
			TYPE_FUNCTION [
				if verbose > 0 [log "pushing function frame"]
				stack/mark-func as red-word! pc	;@@
				pc: eval-arguments as red-native! value pc end path slot
				fun: as red-function! value
				s: as series! fun/more/value

				native: as red-native! s/offset + 2
				either zero? native/code [
					eval-function fun as red-block! s/offset
				][
					call: as function! [] native/code
					call
					0
				]
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: function return type: " TYPE_OF(value)]
				]
			]
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		prefix?	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			value  [red-value!]
			w	   [red-word!]
			sym	   [red-symbol!]
			op	   [red-value!]
			infix? [logic!]
	][
		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

		infix?: no
		unless prefix? [
			next: as red-word! pc + 1
			CHECK_INFIX
			if infix? [
				stack/mark-native as red-word! pc + 1
				sub?: yes								;-- force sub? for infix expressions
				op: value
			]
		]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no yes		;-- yes: push value on top of stack
				pc: eval-path value pc end yes
			]
			TYPE_GET_WORD [
				copy-cell _context/get as red-word! pc stack/push*
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				either sub? [
					w: word/push as red-word! pc		;-- nested expression: push value
				][
					w: as red-word! stack/set-last pc	;-- root expression: return value
				]
				w/header: TYPE_WORD						;-- coerce it to a word!
				pc: pc + 1
			]
			TYPE_WORD [
				if verbose > 0 [
					print-line "eval: '"
					print-symbol as red-word! pc
				]
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_UNSET [
						print-line "*** Error: word has no value!"
						stack/set-last unset-value
					]
					TYPE_LIT_WORD [
						w: word/push as red-word! value	;-- push lit-word! on stack
						w/header: TYPE_WORD				;-- coerce it to a word!
					]
					TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: word return type: " TYPE_OF(value)]
						]
					]
				]
			]
			TYPE_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no
			]
			TYPE_LIT_PATH [
				value: stack/push pc
				value/header: TYPE_PATH
				pc: pc + 1
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]

		if infix? [
			pc: eval-infix op pc end sub?
			unless prefix? [
				either sub? [stack/unwind][stack/unwind-last]
			]
		]
		pc
	]

	eval-next: func [
		value	[red-value!]
		tail	[red-value!]
		sub?	[logic!]
		return: [red-value!]							;-- return start of next expression
	][
		stack/mark-native words/_body					;-- outer stack frame
		value: eval-expression value tail no sub?
		either sub? [stack/unwind][stack/unwind-last]
		value
	]

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			arg	  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			arg: stack/arguments
			arg/header: TYPE_UNSET
			exit
		]

		stack/mark-native words/_body					;-- outer stack frame

		while [value < tail][
			if verbose > 0 [log "root loop..."]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]

		stack/unwind-last
	]

]


FIX: issue #388 (type? lit-word! inconsistent between compiler and interpreter)

Red/System [
	Title:   "Red interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %interpreter.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
	}
]

#define EVAL_CHECK_INPUT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
]

#define EVAL_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "evaluating argument"]
	pc: eval-expression pc end no yes					;-- eval argument
	count: count + 1
]

#define EVAL_FETCH_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "fetching argument"]
	stack/push pc
	pc: pc + 1
	count: count + 1
]

interpreter: context [
	verbose: 0

	ref-array: as int-ptr! allocate 64 * size? integer!	;-- for natives/actions refinements handling
	offset: 0											;-- refinements counter for last call
	count:  0											;-- arguments counter for last call
	return-type: -1										;-- return type for routine calls

	log: func [msg [c-string!]][
		print "eval: "
		print-line msg
	]

	exec: func [
		native	  [red-native!]							;-- works for action! too
		/local
			index [integer!]
			call
	][
		call: as function! [] native/code
		index: 0
		if positive? offset [
			until [
				system/words/push ref-array/index
				index: index + 1
				offset: offset - 1
				zero? offset
			]
		]
		call
	]

	exec-routine: func [
		routine [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			call
	][
		s: as series! routine/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: count - 1								;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert true]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			op	  [red-op!]
			call-op
	][
		if verbose > 0 [log "infix detected!"]

		stack/mark-native as red-word! pc + 1
		eval-expression pc end yes	yes
		pc: pc + 2										;-- skip both left operand and operator
		pc: eval-expression pc end no yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op
		either sub? [stack/unwind][stack/unwind-last]

		if verbose > 0 [
			value: stack/arguments
			print-line ["eval: op return type: " TYPE_OF(value)]
		]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			s		  [series!]
			ref?	  [logic!]
	][
		function?: TYPE_OF(native) = TYPE_FUNCTION
		routine?:  TYPE_OF(native) = TYPE_ROUTINE

		s: as series! either any [function? routine?][
			fun: as red-function! native
			fun/spec/node/value
		][
			native/spec/value
		]
		value: s/offset
		tail:  s/tail

		count:  	 0
		offset: 	 0
		return-type: -1
		ref?:		 no

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD [
					either zero? offset [
						EVAL_ARGUMENT
					][
						either ref? [
							either any [function? routine?][
								none/push
							][
								ref-array/offset: count
								EVAL_ARGUMENT
							]
						][
							ref-array/offset: -1
						]
						offset: offset + 1
					]
				]
				TYPE_LIT_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_GET_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_REFINEMENT [
					ref?: yes
					either any [function? routine?][
						;TBD: check here if refinement is used
						logic/push false
						offset: 1
					][
						ref-array/offset: -1
						offset: offset + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
					return pc
				]
				default [0]
			]
			value: value + 1
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		infix	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next  [red-word!]
			value [red-value!]
			fun	  [red-function!]
			w	  [red-word!]
			s	  [series!]
	][
		next: as red-word! pc + 1

		if all [
			not infix
			TYPE_OF(next) = TYPE_WORD
		][
			value: _context/get next
			if TYPE_OF(value) = TYPE_OP [
				return eval-infix value pc end sub?
			]
		]

		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc no
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				--NOT_IMPLEMENTED--
			]
			TYPE_GET_WORD [
				word/get as red-word! pc
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				w: word/push as red-word! pc			;-- push lit-word! on stack
				w/header: TYPE_WORD						;-- set correct value type on stack
				pc: pc + 1
			]
			TYPE_WORD [
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_ACTION
					TYPE_NATIVE [
						if verbose > 0 [log "pushing action/native frame"]
						stack/mark-native as red-word! pc
						pc: eval-arguments as red-native! value pc end
						exec as red-native! value
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: action/native return type: " TYPE_OF(value)]
						]
					]
					TYPE_ROUTINE [
						if verbose > 0 [log "pushing routine frame"]
						stack/mark-native as red-word! pc
						pc: eval-arguments as red-native! value pc end
						exec-routine as red-routine! value
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: routine return type: " TYPE_OF(value)]
						]
					]
					TYPE_FUNCTION [
						if verbose > 0 [log "pushing function frame"]
						stack/mark-func as red-word! pc	;@@
						pc: eval-arguments as red-native! value pc end
						fun: as red-function! value
						s: as series! fun/more/value
						;eval as red-block! s/offset	;@@ eval body version (add an option for that)
						exec as red-native! s/offset + 2
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: function return type: " TYPE_OF(value)]
						]
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: word return type: " TYPE_OF(value)]
						]
					]
				]
			]
			TYPE_PATH [
				--NOT_IMPLEMENTED--
			]
			TYPE_LIT_PATH [
				--NOT_IMPLEMENTED--
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]
		pc
	]

	eval-next: func [
		value	[red-value!]
		tail	[red-value!]
		return: [red-value!]							;-- return start of next expression
	][
		stack/mark-native words/_body					;-- outer stack frame
		value: eval-expression value tail no no
		stack/unwind-last
		value
	]

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			stack/set-last unset-value
			exit
		]

		stack/mark-native words/_body					;-- outer stack frame

		while [value < tail][
			if verbose > 0 [log "root loop..."]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]

		stack/unwind-last
	]

]

Red/System [
	Title:   "Red interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %interpreter.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
	}
]

#define EVAL_CHECK_INPUT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
]

#define EVAL_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "evaluating argument"]
	pc: eval-expression pc end no yes					;-- eval argument
	count: count + 1
]

#define EVAL_FETCH_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "fetching argument"]
	stack/push pc
	pc: pc + 1
	count: count + 1
]

interpreter: context [
	verbose: 0

	ref-array: as int-ptr! allocate 64 * size? integer!	;-- for natives/actions refinements handling
	offset: 0											;-- refinements counter for last call
	count:  0											;-- arguments counter for last call
	return-type: -1										;-- return type for routine calls

	log: func [msg [c-string!]][
		print "eval: "
		print-line msg
	]

	exec: func [
		native	  [red-native!]							;-- works for action! too
		/local
			index [integer!]
			call
	][
		call: as function! [] native/code
		index: 0
		if positive? offset [
			until [
				system/words/push ref-array/index
				index: index + 1
				offset: offset - 1
				zero? offset
			]
		]
		call
	]

	exec-routine: func [
		routine [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			call
	][
		s: as series! routine/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: count - 1								;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert true]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			op	  [red-op!]
			call-op
	][
		if verbose > 0 [log "infix detected!"]

		stack/mark-native as red-word! pc + 1
		eval-expression pc end yes	yes
		pc: pc + 2										;-- skip both left operand and operator
		pc: eval-expression pc end no yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op
		either sub? [stack/unwind][stack/unwind-last]

		if verbose > 0 [
			value: stack/arguments
			print-line ["eval: op return type: " TYPE_OF(value)]
		]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			s		  [series!]
			ref?	  [logic!]
	][
		function?: TYPE_OF(native) = TYPE_FUNCTION
		routine?:  TYPE_OF(native) = TYPE_ROUTINE

		s: as series! either any [function? routine?][
			fun: as red-function! native
			fun/spec/node/value
		][
			native/spec/value
		]
		value: s/offset
		tail:  s/tail

		count:  	 0
		offset: 	 0
		return-type: -1
		ref?:		 no

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD [
					either zero? offset [
						EVAL_ARGUMENT
					][
						either ref? [
							either any [function? routine?][
								none/push
							][
								ref-array/offset: count
								EVAL_ARGUMENT
							]
						][
							ref-array/offset: -1
						]
						offset: offset + 1
					]
				]
				TYPE_LIT_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_GET_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_REFINEMENT [
					ref?: yes
					either any [function? routine?][
						;TBD: check here if refinement is used
						logic/push false
						offset: 1
					][
						ref-array/offset: -1
						offset: offset + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
					return pc
				]
				default [0]
			]
			value: value + 1
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		infix	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next  [red-word!]
			value [red-value!]
			fun	  [red-function!]
			s	  [series!]
	][
		next: as red-word! pc + 1

		if all [
			not infix
			TYPE_OF(next) = TYPE_WORD
		][
			value: _context/get next
			if TYPE_OF(value) = TYPE_OP [
				return eval-infix value pc end sub?
			]
		]

		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc no
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				--NOT_IMPLEMENTED--
			]
			TYPE_GET_WORD [
				word/get as red-word! pc
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				word/push as red-word! pc				;@@ type??
				pc: pc + 1
			]
			TYPE_WORD [
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_ACTION
					TYPE_NATIVE [
						if verbose > 0 [log "pushing action/native frame"]
						stack/mark-native as red-word! pc
						pc: eval-arguments as red-native! value pc end
						exec as red-native! value
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: action/native return type: " TYPE_OF(value)]
						]
					]
					TYPE_ROUTINE [
						if verbose > 0 [log "pushing routine frame"]
						stack/mark-native as red-word! pc
						pc: eval-arguments as red-native! value pc end
						exec-routine as red-routine! value
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: routine return type: " TYPE_OF(value)]
						]
					]
					TYPE_FUNCTION [
						if verbose > 0 [log "pushing function frame"]
						stack/mark-func as red-word! pc	;@@
						pc: eval-arguments as red-native! value pc end
						fun: as red-function! value
						s: as series! fun/more/value
						;eval as red-block! s/offset	;@@ eval body version (add an option for that)
						exec as red-native! s/offset + 2
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: function return type: " TYPE_OF(value)]
						]
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: word return type: " TYPE_OF(value)]
						]
					]
				]
			]
			TYPE_PATH [
				--NOT_IMPLEMENTED--
			]
			TYPE_LIT_PATH [
				--NOT_IMPLEMENTED--
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]
		pc
	]

	eval-next: func [
		value	[red-value!]
		tail	[red-value!]
		return: [red-value!]							;-- return start of next expression
	][
		stack/mark-native words/_body					;-- outer stack frame
		value: eval-expression value tail no no
		stack/unwind-last
		value
	]

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			stack/set-last unset-value
			exit
		]

		stack/mark-native words/_body					;-- outer stack frame

		while [value < tail][
			if verbose > 0 [log "root loop..."]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]

		stack/unwind-last
	]

]


FEAT: minor comment added.

FEAT: minor comment added.

Red/System [
	Title:   "Red runtime macro definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %macros.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 datatypes! [										;-- Order must not be changed!
	TYPE_VALUE											;-- 00		00
	TYPE_DATATYPE										;-- 01		01
	TYPE_UNSET											;-- 02		02
	TYPE_NONE											;-- 03		03
	TYPE_LOGIC											;-- 04		04
	TYPE_BLOCK											;-- 05		05
	TYPE_PAREN											;-- 06		06
	TYPE_STRING											;-- 07		07
	TYPE_FILE											;-- 08		08
	TYPE_URL											;-- 09		09
	TYPE_CHAR											;-- 0A		10
	TYPE_INTEGER										;-- 0B		11
	TYPE_FLOAT											;-- 0C		12
	TYPE_SYMBOL											;-- 0D		13
	TYPE_CONTEXT										;-- 0E		14
	TYPE_WORD											;-- 0F		15
	TYPE_SET_WORD										;-- 10		16
	TYPE_LIT_WORD										;-- 11		17
	TYPE_GET_WORD										;-- 12		18
	TYPE_REFINEMENT										;-- 13		19
	TYPE_ISSUE											;-- 14		20
	TYPE_NATIVE											;-- 15		21
	TYPE_ACTION											;-- 16		22
	TYPE_OP												;-- 17		23
	TYPE_FUNCTION										;-- 18		24
	TYPE_PATH											;-- 19		25
	TYPE_LIT_PATH										;-- 1A		26
	TYPE_SET_PATH										;-- 1B		27
	TYPE_GET_PATH										;-- 1C		28
	TYPE_ROUTINE										;-- 1D		29
	TYPE_BITSET											;-- 1E		30
	TYPE_POINT											;-- 1F		31
	TYPE_OBJECT											;-- 20		32
	TYPE_TYPESET										;-- 21		33
	TYPE_ERROR											;-- 22		34
	TYPE_VECTOR											;-- 23		35

	TYPE_BINARY
	TYPE_CLOSURE
	TYPE_PORT
]

#enum actions! [

	;-- General actions --
	ACT_MAKE: 	1										;-- used as index in action-table (one-based)
	ACT_RANDOM
	ACT_REFLECT
	ACT_TO
	ACT_FORM
	ACT_MOLD

	ACT_EVALPATH
	ACT_SETPATH											;@@ Deprecate it?
	ACT_COMPARE

	;-- Scalar actions --
	ACT_ABSOLUTE
	ACT_ADD
	ACT_DIVIDE
	ACT_MULTIPLY
	ACT_NEGATE
	ACT_POWER
	ACT_REMAINDER
	ACT_ROUND
	ACT_SUBTRACT
	ACT_EVEN?
	ACT_ODD?

	;-- Bitwise actions --
	ACT_AND~
	ACT_COMPLEMENT
	ACT_OR~
	ACT_XOR~

	;-- Series actions --
	ACT_APPEND
	ACT_AT
	ACT_BACK
	ACT_CHANGE
	ACT_CLEAR
	ACT_COPY
	ACT_FIND
	ACT_HEAD
	ACT_HEAD?
	ACT_INDEX?
	ACT_INSERT
	ACT_LENGTH?
	ACT_NEXT
	ACT_PICK
	ACT_POKE
	ACT_REMOVE
	ACT_REVERSE
	ACT_SELECT
	ACT_SORT
	ACT_SKIP
	ACT_SWAP
	ACT_TAIL
	ACT_TAIL?
	ACT_TAKE
	ACT_TRIM

	;-- I/O actions --
	ACT_CREATE
	ACT_CLOSE
	ACT_DELETE
	ACT_MODIFY
	ACT_OPEN
	ACT_OPEN?
	ACT_QUERY
	ACT_READ
	ACT_RENAME
	ACT_UPDATE
	ACT_WRITE

	;ACT_APPLY											;; add it? @@
]

#enum natives! [
	NAT_IF: 	1										;-- one-based index
	NAT_UNLESS
	NAT_EITHER
	NAT_ANY
	NAT_ALL
	NAT_WHILE
	NAT_UNTIL
	NAT_LOOP
	NAT_REPEAT
	NAT_FOREVER
	NAT_FOREACH
	NAT_FORALL
	NAT_FUNC
	NAT_FUNCTION
	NAT_DOES
	NAT_HAS
	NAT_SWITCH
	NAT_CASE
	NAT_DO
	NAT_GET
	NAT_SET
	NAT_PRINT
	NAT_PRIN
	NAT_EQUAL?
	NAT_NOT_EQUAL?
	NAT_STRICT_EQUAL?
	NAT_LESSER?
	NAT_GREATER?
	NAT_LESSER_OR_EQUAL?
	NAT_GREATER_OR_EQUAL?
	NAT_SAME?
	NAT_NOT
	NAT_HALT
	NAT_TYPE?
	NAT_REDUCE
	NAT_COMPOSE
	NAT_STATS
	NAT_BIND
	NAT_IN
	NAT_PARSE
	NAT_UNION
	NAT_INTERSECT
	NAT_UNIQUE
	NAT_DIFFERENCE
	NAT_COMPLEMENT?
	NAT_DEHEX
	NAT_NEGATIVE?
	NAT_POSITIVE?
	NAT_MAX
	NAT_MIN
	NAT_SHIFT
	NAT_TO_HEX
	NAT_SINE
	NAT_COSINE
	NAT_TANGENT
	NAT_ARCSINE
	NAT_ARCCOSINE
	NAT_ARCTANGENT
	NAT_ARCTANGENT2
	NAT_NAN?
	NAT_LOG_2
	NAT_LOG_10
	NAT_LOG_E
	NAT_EXP
	NAT_SQUARE_ROOT
	NAT_CONSTRUCT
	NAT_VALUE?
	NAT_TRY
]

#enum math-op! [
	OP_ADD
	OP_SUB
	OP_MUL
	OP_DIV
	OP_REM
	;-- bitwise op!
	OP_OR
	OP_AND
	OP_XOR
]

#enum comparison-op! [
	COMP_EQUAL
	COMP_NOT_EQUAL
	COMP_STRICT_EQUAL
	COMP_LESSER
	COMP_LESSER_EQUAL
	COMP_GREATER
	COMP_GREATER_EQUAL
	COMP_SORT
	COMP_CASE_SORT
]

#enum exceptions! [
	NO_EXCEPTION
	THROWN_EXIT
	THROWN_RETURN
]

#define NATIVES_NB		100							;-- max number of natives (arbitrary set)
#define ACTIONS_NB		60							;-- number of actions (exact number)
#define INHERIT_ACTION	-1							;-- placeholder for letting parent's action pass through

#either debug? = yes [
	#define ------------| 	print-line
][
	#define ------------| 	comment
]

#define RED_ERROR			195939070				;-- #0BADCAFE (keep it positive)

#define TYPE_OF(value)		(value/header and get-type-mask)
#define GET_BUFFER(series)  (as series! series/node/value)
#define GET_UNIT(series)	(series/flags and get-unit-mask)
#define ALLOC_TAIL(series)	[alloc-at-tail series]
#define FLAG_SET?(flag)		(flags and flag <> 0)
#define OPTION?(ref-ptr)	(ref-ptr > stack/arguments)	;-- a bit inelegant, but saves a lot of code
#define ON_STACK?(ctx)		(ctx/header and flag-series-stk <> 0)
#define EQUAL_SYMBOLS?(a b) ((symbol/resolve a) = (symbol/resolve b))
#define EQUAL_WORDS?(a b) 	((symbol/resolve a/symbol) = (symbol/resolve b/symbol))
#define TO_CTX(node)		(as red-context! ((as series! node/value) + 1))
#define GET_CTX(obj)		(as red-context! ((as series! obj/ctx/value) + 1))
#define FLAG_NOT?(s)		(s/flags and flag-bitset-not <> 0)
#define SET_RETURN(value)	[stack/set-last as red-value! value]
#define TO_ERROR(cat id)	[#in system/catalog/errors cat #in system/catalog/errors/cat id]

#define WHITE_CHAR?(char)	[
	any [
		all [0 < char char < 33]			;-- All white chars: NL, CR, BS, etc...
		char = 133							;-- #"^(85)"
		char = 160							;-- #"^(A0)"
		char = 5760							;-- #"^(1680)"
		char = 6158							;-- #"^(180E)"
		all [8192 <= char char <= 8202]		;-- #"^(2000)" - #"^(200A)"
		char = 8232							;-- #"^(2028)"
		char = 8233							;-- #"^(2029)"
		char = 8239							;-- #"^(202F)"
		char = 8287							;-- #"^(205F)"
		char = 12288						;-- #"^(3000)"
	]
]

#define SPACE_CHAR?(char)	[
	any [
		char = 32							;-- #" "
		char = 9							;-- #"^-"
		char = 133							;-- #"^(85)"
		char = 160							;-- #"^(A0)"
		char = 5760							;-- #"^(1680)"
		char = 6158							;-- #"^(180E)"
		all [8192 <= char char <= 8202]		;-- #"^(2000)" - #"^(200A)"
		char = 8232							;-- #"^(2028)"
		char = 8233							;-- #"^(2029)"
		char = 8239							;-- #"^(202F)"
		char = 8287							;-- #"^(205F)"
		char = 12288						;-- #"^(3000)"
	]
]

#define ANY_SERIES?(type)	[
	any [
		type = TYPE_BLOCK
		type = TYPE_PAREN
		type = TYPE_PATH
		type = TYPE_LIT_PATH
		type = TYPE_SET_PATH
		type = TYPE_GET_PATH
		type = TYPE_STRING
		type = TYPE_FILE
		type = TYPE_URL
	]
]

#define BS_SET_BIT(array bit)  [
	pos: array + (bit >> 3)
	pos/value: pos/value or (as-byte 128 >> (bit and 7))
]

#define BS_CLEAR_BIT(array bit)  [
	pos: array + (bit >> 3)
	pos/value: pos/value and (as-byte 128 >> (bit and 7) xor 255)
]

#define BS_TEST_BIT(array bit set?)  [
	pos: array + (bit >> 3)
	set?: pos/value and (as-byte 128 >> (bit and 7)) <> null-byte
]

#define BS_PROCESS_SET_VIRTUAL(bs bit) [
	either not? [
		if virtual-bit? bs bit [return 1]
	][
		pbits: bound-check bs bit
	]
]

#define BS_PROCESS_CLEAR_VIRTUAL(bs bit) [
	either not? [
		pbits: bound-check bs bit
	][
		if virtual-bit? bs bit [return 0]
	]
]

#define ERR_INVALID_REFINEMENT_ARG(refine arg) [
	fire [
		TO_ERROR(script invalid-refine-arg)
		refine
		arg
	]
]

#define ERR_EXPECT_ARGUMENT(type arg-idx) [
	fire [
		TO_ERROR(script expect-arg)
		stack/get-call
		datatype/push type
		error/get-call-argument arg-idx
	]
]

#define --NOT_IMPLEMENTED--	[
	fire [TO_ERROR(internal not-done)]
]

#define RETURN_COMPARE_OTHER [
	return -2
]

#define CHECK_COMPARE_OTHER(type) [
	if all [
		TYPE_OF(str2) <> type
		any [
			all [
				op <> COMP_EQUAL
				op <> COMP_NOT_EQUAL
			]
			all [
				TYPE_OF(str2) <> TYPE_STRING		;@@ use ANY_STRING?
				TYPE_OF(str2) <> TYPE_FILE
				TYPE_OF(str2) <> TYPE_URL
			]
		]
	][RETURN_COMPARE_OTHER]
]

#define SIGN_COMPARE_RESULT(a b) [
	either a < b [-1][either a > b [1][0]]
]

#if debug? = yes [
	#define dump4	[dump-hex4 as int-ptr!]
	#define dump1	[dump-hex  as byte-ptr!]
]

Red/System [
	Title:   "Red runtime macro definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %macros.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 datatypes! [
	TYPE_VALUE											;-- 00		00
	TYPE_DATATYPE										;-- 01		01
	TYPE_UNSET											;-- 02		02
	TYPE_NONE											;-- 03		03
	TYPE_LOGIC											;-- 04		04
	TYPE_BLOCK											;-- 05		05
	TYPE_PAREN											;-- 06		06
	TYPE_STRING											;-- 07		07
	TYPE_FILE											;-- 08		08
	TYPE_URL											;-- 09		09
	TYPE_CHAR											;-- 0A		10
	TYPE_INTEGER										;-- 0B		11
	TYPE_FLOAT											;-- 0C		12
	TYPE_SYMBOL											;-- 0D		13
	TYPE_CONTEXT										;-- 0E		14
	TYPE_WORD											;-- 0F		15
	TYPE_SET_WORD										;-- 10		16
	TYPE_LIT_WORD										;-- 11		17
	TYPE_GET_WORD										;-- 12		18
	TYPE_REFINEMENT										;-- 13		19
	TYPE_ISSUE											;-- 14		20
	TYPE_NATIVE											;-- 15		21
	TYPE_ACTION											;-- 16		22
	TYPE_OP												;-- 17		23
	TYPE_FUNCTION										;-- 18		24
	TYPE_PATH											;-- 19		25
	TYPE_LIT_PATH										;-- 1A		26
	TYPE_SET_PATH										;-- 1B		27
	TYPE_GET_PATH										;-- 1C		28
	TYPE_ROUTINE										;-- 1D		29
	TYPE_BITSET											;-- 1E		30
	TYPE_POINT											;-- 1F		31
	TYPE_OBJECT											;-- 20		32
	TYPE_TYPESET										;-- 21		33
	TYPE_ERROR											;-- 22		34
	TYPE_VECTOR											;-- 23		35

	TYPE_BINARY
	TYPE_CLOSURE
	TYPE_PORT
]

#enum actions! [

	;-- General actions --
	ACT_MAKE: 	1										;-- used as index in action-table (one-based)
	ACT_RANDOM
	ACT_REFLECT
	ACT_TO
	ACT_FORM
	ACT_MOLD

	ACT_EVALPATH
	ACT_SETPATH											;@@ Deprecate it?
	ACT_COMPARE

	;-- Scalar actions --
	ACT_ABSOLUTE
	ACT_ADD
	ACT_DIVIDE
	ACT_MULTIPLY
	ACT_NEGATE
	ACT_POWER
	ACT_REMAINDER
	ACT_ROUND
	ACT_SUBTRACT
	ACT_EVEN?
	ACT_ODD?

	;-- Bitwise actions --
	ACT_AND~
	ACT_COMPLEMENT
	ACT_OR~
	ACT_XOR~

	;-- Series actions --
	ACT_APPEND
	ACT_AT
	ACT_BACK
	ACT_CHANGE
	ACT_CLEAR
	ACT_COPY
	ACT_FIND
	ACT_HEAD
	ACT_HEAD?
	ACT_INDEX?
	ACT_INSERT
	ACT_LENGTH?
	ACT_NEXT
	ACT_PICK
	ACT_POKE
	ACT_REMOVE
	ACT_REVERSE
	ACT_SELECT
	ACT_SORT
	ACT_SKIP
	ACT_SWAP
	ACT_TAIL
	ACT_TAIL?
	ACT_TAKE
	ACT_TRIM

	;-- I/O actions --
	ACT_CREATE
	ACT_CLOSE
	ACT_DELETE
	ACT_MODIFY
	ACT_OPEN
	ACT_OPEN?
	ACT_QUERY
	ACT_READ
	ACT_RENAME
	ACT_UPDATE
	ACT_WRITE

	;ACT_APPLY											;; add it? @@
]

#enum natives! [
	NAT_IF: 	1										;-- one-based index
	NAT_UNLESS
	NAT_EITHER
	NAT_ANY
	NAT_ALL
	NAT_WHILE
	NAT_UNTIL
	NAT_LOOP
	NAT_REPEAT
	NAT_FOREVER
	NAT_FOREACH
	NAT_FORALL
	NAT_FUNC
	NAT_FUNCTION
	NAT_DOES
	NAT_HAS
	NAT_SWITCH
	NAT_CASE
	NAT_DO
	NAT_GET
	NAT_SET
	NAT_PRINT
	NAT_PRIN
	NAT_EQUAL?
	NAT_NOT_EQUAL?
	NAT_STRICT_EQUAL?
	NAT_LESSER?
	NAT_GREATER?
	NAT_LESSER_OR_EQUAL?
	NAT_GREATER_OR_EQUAL?
	NAT_SAME?
	NAT_NOT
	NAT_HALT
	NAT_TYPE?
	NAT_REDUCE
	NAT_COMPOSE
	NAT_STATS
	NAT_BIND
	NAT_IN
	NAT_PARSE
	NAT_UNION
	NAT_INTERSECT
	NAT_UNIQUE
	NAT_DIFFERENCE
	NAT_COMPLEMENT?
	NAT_DEHEX
	NAT_NEGATIVE?
	NAT_POSITIVE?
	NAT_MAX
	NAT_MIN
	NAT_SHIFT
	NAT_TO_HEX
	NAT_SINE
	NAT_COSINE
	NAT_TANGENT
	NAT_ARCSINE
	NAT_ARCCOSINE
	NAT_ARCTANGENT
	NAT_ARCTANGENT2
	NAT_NAN?
	NAT_LOG_2
	NAT_LOG_10
	NAT_LOG_E
	NAT_EXP
	NAT_SQUARE_ROOT
	NAT_CONSTRUCT
	NAT_VALUE?
	NAT_TRY
]

#enum math-op! [
	OP_ADD
	OP_SUB
	OP_MUL
	OP_DIV
	OP_REM
	;-- bitwise op!
	OP_OR
	OP_AND
	OP_XOR
]

#enum comparison-op! [
	COMP_EQUAL
	COMP_NOT_EQUAL
	COMP_STRICT_EQUAL
	COMP_LESSER
	COMP_LESSER_EQUAL
	COMP_GREATER
	COMP_GREATER_EQUAL
	COMP_SORT
	COMP_CASE_SORT
]

#enum exceptions! [
	NO_EXCEPTION
	THROWN_EXIT
	THROWN_RETURN
]

#define NATIVES_NB		100							;-- max number of natives (arbitrary set)
#define ACTIONS_NB		60							;-- number of actions (exact number)
#define INHERIT_ACTION	-1							;-- placeholder for letting parent's action pass through

#either debug? = yes [
	#define ------------| 	print-line
][
	#define ------------| 	comment
]

#define RED_ERROR			195939070				;-- #0BADCAFE (keep it positive)

#define TYPE_OF(value)		(value/header and get-type-mask)
#define GET_BUFFER(series)  (as series! series/node/value)
#define GET_UNIT(series)	(series/flags and get-unit-mask)
#define ALLOC_TAIL(series)	[alloc-at-tail series]
#define FLAG_SET?(flag)		(flags and flag <> 0)
#define OPTION?(ref-ptr)	(ref-ptr > stack/arguments)	;-- a bit inelegant, but saves a lot of code
#define ON_STACK?(ctx)		(ctx/header and flag-series-stk <> 0)
#define EQUAL_SYMBOLS?(a b) ((symbol/resolve a) = (symbol/resolve b))
#define EQUAL_WORDS?(a b) 	((symbol/resolve a/symbol) = (symbol/resolve b/symbol))
#define TO_CTX(node)		(as red-context! ((as series! node/value) + 1))
#define GET_CTX(obj)		(as red-context! ((as series! obj/ctx/value) + 1))
#define FLAG_NOT?(s)		(s/flags and flag-bitset-not <> 0)
#define SET_RETURN(value)	[stack/set-last as red-value! value]
#define TO_ERROR(cat id)	[#in system/catalog/errors cat #in system/catalog/errors/cat id]

#define WHITE_CHAR?(char)	[
	any [
		all [0 < char char < 33]			;-- All white chars: NL, CR, BS, etc...
		char = 133							;-- #"^(85)"
		char = 160							;-- #"^(A0)"
		char = 5760							;-- #"^(1680)"
		char = 6158							;-- #"^(180E)"
		all [8192 <= char char <= 8202]		;-- #"^(2000)" - #"^(200A)"
		char = 8232							;-- #"^(2028)"
		char = 8233							;-- #"^(2029)"
		char = 8239							;-- #"^(202F)"
		char = 8287							;-- #"^(205F)"
		char = 12288						;-- #"^(3000)"
	]
]

#define SPACE_CHAR?(char)	[
	any [
		char = 32							;-- #" "
		char = 9							;-- #"^-"
		char = 133							;-- #"^(85)"
		char = 160							;-- #"^(A0)"
		char = 5760							;-- #"^(1680)"
		char = 6158							;-- #"^(180E)"
		all [8192 <= char char <= 8202]		;-- #"^(2000)" - #"^(200A)"
		char = 8232							;-- #"^(2028)"
		char = 8233							;-- #"^(2029)"
		char = 8239							;-- #"^(202F)"
		char = 8287							;-- #"^(205F)"
		char = 12288						;-- #"^(3000)"
	]
]

#define ANY_SERIES?(type)	[
	any [
		type = TYPE_BLOCK
		type = TYPE_PAREN
		type = TYPE_PATH
		type = TYPE_LIT_PATH
		type = TYPE_SET_PATH
		type = TYPE_GET_PATH
		type = TYPE_STRING
		type = TYPE_FILE
		type = TYPE_URL
	]
]

#define BS_SET_BIT(array bit)  [
	pos: array + (bit >> 3)
	pos/value: pos/value or (as-byte 128 >> (bit and 7))
]

#define BS_CLEAR_BIT(array bit)  [
	pos: array + (bit >> 3)
	pos/value: pos/value and (as-byte 128 >> (bit and 7) xor 255)
]

#define BS_TEST_BIT(array bit set?)  [
	pos: array + (bit >> 3)
	set?: pos/value and (as-byte 128 >> (bit and 7)) <> null-byte
]

#define BS_PROCESS_SET_VIRTUAL(bs bit) [
	either not? [
		if virtual-bit? bs bit [return 1]
	][
		pbits: bound-check bs bit
	]
]

#define BS_PROCESS_CLEAR_VIRTUAL(bs bit) [
	either not? [
		pbits: bound-check bs bit
	][
		if virtual-bit? bs bit [return 0]
	]
]

#define ERR_INVALID_REFINEMENT_ARG(refine arg) [
	fire [
		TO_ERROR(script invalid-refine-arg)
		refine
		arg
	]
]

#define ERR_EXPECT_ARGUMENT(type arg-idx) [
	fire [
		TO_ERROR(script expect-arg)
		stack/get-call
		datatype/push type
		error/get-call-argument arg-idx
	]
]

#define --NOT_IMPLEMENTED--	[
	fire [TO_ERROR(internal not-done)]
]

#define RETURN_COMPARE_OTHER [
	return -2
]

#define CHECK_COMPARE_OTHER(type) [
	if all [
		TYPE_OF(str2) <> type
		any [
			all [
				op <> COMP_EQUAL
				op <> COMP_NOT_EQUAL
			]
			all [
				TYPE_OF(str2) <> TYPE_STRING		;@@ use ANY_STRING?
				TYPE_OF(str2) <> TYPE_FILE
				TYPE_OF(str2) <> TYPE_URL
			]
		]
	][RETURN_COMPARE_OTHER]
]

#define SIGN_COMPARE_RESULT(a b) [
	either a < b [-1][either a > b [1][0]]
]

#if debug? = yes [
	#define dump4	[dump-hex4 as int-ptr!]
	#define dump1	[dump-hex  as byte-ptr!]
]