FEAT: added support for INPUT on MacOSX and FreeBSD

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 [

	#either OS <> 'Windows [
		#define OS_POLLIN 		1
		#define TERM_TCSADRAIN	1

		#case [
			any [OS = 'MacOSX OS = 'FreeBSD] [
				#define TIOCGWINSZ		40087468h
				#define TERM_VTIME		18
				#define TERM_VMIN		17

				#define TERM_BRKINT		02h
				#define TERM_INPCK		10h
				#define TERM_ISTRIP		20h
				#define TERM_ICRNL		0100h
				#define TERM_IXON		0200h
				#define TERM_OPOST		01h
				#define TERM_CS8		0300h
				#define TERM_ISIG		80h
				#define TERM_ICANON		0100h
				#define TERM_ECHO		08h
				#define TERM_IEXTEN		4000h

				termios!: alias struct! [
					c_iflag			[integer!]
					c_oflag			[integer!]
					c_cflag			[integer!]
					c_lflag			[integer!]
					c_cc1			[integer!]					;-- c_cc[20]
					c_cc2			[integer!]
					c_cc3			[integer!]
					c_cc4			[integer!]
					c_cc5			[integer!]
					c_ispeed		[integer!]
					c_ospeed		[integer!]
				]
			]
			true [
				#define TIOCGWINSZ		5413h
				#define TERM_VTIME		6
				#define TERM_VMIN		7

				#define TERM_BRKINT		2
				#define TERM_INPCK		20
				#define TERM_ISTRIP		40
				#define TERM_ICRNL		400
				#define TERM_IXON		2000
				#define TERM_OPOST		1
				#define TERM_CS8		60
				#define TERM_ISIG		1
				#define TERM_ICANON		2
				#define TERM_ECHO		10
				#define TERM_IEXTEN		100000

				termios!: alias struct! [						;-- sizeof(termios) = 60
					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!]
				]
			]
		]

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

		winsize!: alias struct! [
			rowcol			[integer!]
			xypixel			[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!]
				]
			]
		]

		saved-term: declare termios!
		utf-char:	declare c-string!
		poller: 	declare pollfd!
		lines-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 [
				#"^(0D)" [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!]
			head-as-tail? [logic!]
			return: 	[integer!]
			/local
				series	[series!]
				offset	[byte-ptr!]
				tail	[byte-ptr!]
				unit	[integer!]
				cp		[integer!]
				bytes	[integer!]
				cnt		[integer!]
				x		[integer!]
		][
			x:		0
			cnt:	0
			bytes:	0
			series: GET_BUFFER(str)
			unit: 	GET_UNIT(series)
			offset: (as byte-ptr! series/offset) + (str/head << (unit >> 1))
			tail:   as byte-ptr! series/tail
			if head-as-tail? [
				tail: offset
				offset: as byte-ptr! series/offset
			]
			until [
				while [
					all [offset < tail cnt < size]
				][
					cp: string/get-char offset unit
					cnt: either cp > FFh [
						either size - cnt = 1 [x: 2 cnt + 3][cnt + 2]	;-- reach screen edge, handle wide char
					][
						cnt + 1
					]
					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
				]
				bytes: bytes + cnt
				if cnt = size [
					emit-string "^(0A)^[[0G"				;-- emit new line and set cursor to start.
				]
				size: columns - x
				x: 0
				cnt: 0
				offset >= tail
			]
			bytes
		]

		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
			if positive? lines-y [emit-string-int "^[[" lines-y #"A"]	;-- move to origin row
			emit-string "^(0D)^[[J"					;-- erase down to the bottom of the screen

			bytes: emit-red-string prompt columns no

			psize: bytes // columns
			offset: bytes + (emit-red-string line columns - psize yes)	;-- output until reach cursor posistion

			psize: offset // columns
			bytes: offset + (emit-red-string line columns - psize no)	;-- continue until reach tail

			lines-y: bytes / columns		;-- the lines of all outputs occupy
			y: bytes / columns  - (offset / columns)
			x: offset // columns

			if all [						;-- special case: when moving cursor to the first char of a line
				widechar? line				;-- the first char of the line is a widechar
				columns - x = 1				;-- but in pre line only 1 space left
			][
				y: y - 1
				x: 0
			]

			if positive? y [				;-- set cursor position: y
			    emit-string-int "^[[" y #"A"
			    lines-y: lines-y - y
			]
			either zero? x [		 		;-- set cursor position: x
				emit #"^(0D)"
			][
				emit-string-int "^(0D)^[[" x #"C"
			]
		]

		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_ECHO or TERM_ICANON or TERM_IEXTEN or TERM_ISIG
			)
			#case [
				any [OS = 'MacOSX OS = 'FreeBSD] [
					cc: (as byte-ptr! term) + (4 * size? integer!)
				]
				true [cc: (as byte-ptr! term) + (4 * size? integer!) + 1]
			]
			cc/TERM_VMIN:  as-byte 1
			cc/TERM_VTIME: as-byte 0

			tcsetattr stdin TERM_TCSADRAIN term

			poller/fd: stdin
			poller/events: OS_POLLIN
		]

		restore: does [
			tcsetattr stdin TERM_TCSADRAIN saved-term
		]

	][;-- ================================================================= --

		#define VK_BACK 				 	08h
		#define VK_TAB 					 	09h
		#define VK_CLEAR 				 	0Ch
		#define VK_RETURN 				 	0Dh
		#define VK_SHIFT 				 	10h
		#define VK_CONTROL 				 	11h
		#define VK_PRIOR 				 	21h
		#define VK_NEXT 				 	22h
		#define VK_END 					 	23h
		#define VK_HOME 				 	24h
		#define VK_LEFT 				 	25h
		#define VK_UP 					 	26h
		#define VK_RIGHT 				 	27h
		#define VK_DOWN 				 	28h
		#define VK_SELECT 				 	29h
		#define VK_INSERT 				 	2Dh
		#define VK_DELETE 				 	2Eh
		#define KEY_EVENT 				 	01h
		#define MOUSE_EVENT 			 	02h
		#define WINDOW_BUFFER_SIZE_EVENT 	04h
		#define MENU_EVENT 				 	08h
		#define FOCUS_EVENT 			 	10h
		#define ENHANCED_KEY 			 	0100h
		#define FOREGROUND_BLUE 		 	01h
		#define FOREGROUND_GREEN 		 	02h
		#define FOREGROUND_RED 			 	04h
		#define ENABLE_LINE_INPUT 			02h
		#define ENABLE_ECHO_INPUT 			04h

		mouse-event!: alias struct! [
			Position  [integer!]			;-- high 16-bit: Y	low 16-bit: X
			BtnState  [integer!]
			KeyState  [integer!]
			Flags	  [integer!]
		]

		key-event!: alias struct! [		   ;typedef struct _KEY_EVENT_RECORD {
			KeyDown   			[integer!] ;  WINBOOL bKeyDown;  	offset: 0
			RepeatCnt-KeyCode	[integer!] ;  WORD wRepeatCount;            4
			ScanCode-Char		[integer!] ;  WORD wVirtualKeyCode;    		6
			KeyState  			[integer!] ;  WORD wVirtualScanCode;  		8
		]                          		   ;  union {
                                           ;    WCHAR UnicodeChar;
                                           ;    CHAR AsciiChar;
                                           ;  } uChar;						10
                                           ;  DWORD dwControlKeyState;		12
                                           ;} KEY_EVENT_RECORD,*PKEY_EVENT_RECORD;
		input-record!: alias struct! [
			EventType [integer!]
			Event	  [integer!]
			pad2	  [integer!]
			pad3	  [integer!]
			pad4	  [integer!]
		]

		screenbuf-info!: alias struct! [	;-- size? screenbuf-info! = 22
			Size	  [integer!]        	;typedef struct _CONSOLE_SCREEN_BUFFER_INFO {
			Position  [integer!]        	;  COORD dwSize;		offset: 0
			pad1	  [integer!]        	;  COORD dwCursorPosition;		4
			pad2	  [integer!]        	;  WORD wAttributes;			8
			pad3	  [integer!]        	;  SMALL_RECT srWindow;			10
			pad4 	  [byte!]           	;  COORD dwMaximumWindowSize;	18
			pad5 	  [byte!]           	;} CONSOLE_SCREEN_BUFFER_INFO,*PCONSOLE_SCREEN_BUFFER_INFO;
		]									;-- sizeof(CONSOLE_SCREEN_BUFFER_INFO) = 22

		#import [
			"kernel32.dll" stdcall [
				ReadConsoleInput: "ReadConsoleInputW" [
					handle			[integer!]
					arrayOfRecs		[integer!]
					length			[integer!]
					numberOfRecs	[int-ptr!]
					return:			[integer!]
				]
				SetConsoleMode: "SetConsoleMode" [
					handle			[integer!]
					mode			[integer!]
					return:			[integer!]
				]
				GetConsoleMode:	"GetConsoleMode" [
					handle			[integer!]
					mode			[int-ptr!]
					return:			[integer!]
				]
				WriteConsole: 	 "WriteConsoleW" [
					consoleOutput	[integer!]
					buffer			[byte-ptr!]
					charsToWrite	[integer!]
					numberOfChars	[int-ptr!]
					_reserved		[int-ptr!]
					return:			[integer!]
				]
				FillConsoleOutputAttribute: "FillConsoleOutputAttribute" [
					handle			[integer!]
					attributs		[integer!]
					length			[integer!]
					coord			[integer!]
					numberOfAttrs	[int-ptr!]
				]
				FillConsoleOutputCharacter: "FillConsoleOutputCharacterW" [
					handle			[integer!]
					attributs		[integer!]
					length			[integer!]
					coord			[integer!]
					numberOfChars	[int-ptr!]
				]
				SetConsoleCursorPosition: "SetConsoleCursorPosition" [
					handle 			[integer!]
					coord 			[integer!]
				]
				GetConsoleScreenBufferInfo: "GetConsoleScreenBufferInfo" [
					handle 			[integer!]
					info 			[integer!]
					return: 		[integer!]
				]
			]
		]

		input-rec: declare input-record!
		base-y:	 	 0
		saved-con:	 0

		#define STRUCT_MEMBER(base offset) ((as-integer base) + offset)
		#define FIRST_WORD(int) (int and FFFFh)
		#define SECOND_WORD(int) (int >>> 16)

		fd-read: func [
			return: 	[integer!]
			/local
				key 	[key-event!]
				n	 	[integer!]
				keycode [integer!]
		][
			n: 0
			while [true] [
				if zero? ReadConsoleInput stdin as-integer input-rec 1 :n [return -1]
				key: as key-event! STRUCT_MEMBER(input-rec (size? integer!))

				if all [
					input-rec/EventType and FFFFh = KEY_EVENT
					key/KeyDown <> 0
				][
					keycode: SECOND_WORD(key/RepeatCnt-KeyCode)  ;-- 1st RepeatCnt 2 KeyCode
					switch keycode [
						VK_LEFT		[return KEY_LEFT]
						VK_RIGHT	[return KEY_RIGHT]
						VK_UP		[return KEY_UP]
						VK_DOWN		[return KEY_DOWN]
						VK_INSERT	[return KEY_INSERT]
						VK_DELETE	[return KEY_DELETE]
						VK_HOME		[return KEY_HOME]
						VK_END		[return KEY_END]
						VK_PRIOR	[return KEY_PAGE_UP]
						VK_NEXT		[return KEY_PAGE_DOWN]
						VK_BACK 	[return KEY_BACKSPACE]
						VK_RETURN 	[return KEY_ENTER]
						VK_CONTROL  []
						default 	[
							return SECOND_WORD(key/ScanCode-Char) ;-- return Char
						]
					]
				]
			]
			-1
		]

		get-window-size: func [
			return: 	[integer!]
			/local
				info 	[screenbuf-info!]
				x-y 	[integer!]
		][
			info: declare screenbuf-info!
			if zero? GetConsoleScreenBufferInfo stdout as-integer info [return -1]
			x-y: info/Size
			columns: FIRST_WORD(x-y)
			rows: SECOND_WORD(x-y)
			if columns <= 0 [columns: 80 return -1]
			x-y: info/Position
			base-y: SECOND_WORD(x-y)
			0
		]

		init: func [
			line 		[red-string!]
			hist-blk	[red-block!]
			/local
				mode	[integer!]
		][
			copy-cell as red-value! line as red-value! input-line
			copy-cell as red-value! hist-blk as red-value! history

			GetConsoleMode stdin :saved-con
			mode: not (ENABLE_LINE_INPUT and ENABLE_ECHO_INPUT)		;-- turn off some features
			SetConsoleMode stdin saved-con and mode
		]

		emit-red-string: func [
			str	 		  [red-string!]
			size 		  [integer!]
			head-as-tail? [logic!]
			return:		  [integer!]
			/local
				x		  [integer!]
				cnt		  [integer!]
				n		  [integer!]
				bytes	  [integer!]
				cp		  [integer!]
				unit	  [integer!]
				series	  [series!]
				offset	  [byte-ptr!]
				tail	  [byte-ptr!]
		][
			x:		0
			n:		0
			bytes:	0
			cnt:	0
			series: GET_BUFFER(str)
			unit: 	GET_UNIT(series)
			offset: (as byte-ptr! series/offset) + (str/head << (unit >> 1))
			tail:	as byte-ptr! series/tail
			if head-as-tail? [
				tail: offset
				offset: as byte-ptr! series/offset
			]
			until [
				while [
					all [offset < tail cnt < size]
				][
					cp: string/get-char offset unit
					cnt: either cp > FFh [
						either size - cnt = 1 [x: 2 cnt + 3][cnt + 2]	;-- reach screen edge, handle wide char
					][
						cnt + 1
					]
					WriteConsole stdout (as byte-ptr! :cp) 1 :n null
					offset: offset + unit
				]
				bytes: bytes + cnt
				size: columns - x
				cnt: 0
				x: 0

				offset >= tail
			]
			bytes
		]

		refresh: func [
			/local
				line	[red-string!]
				offset	[integer!]
				n		[integer!]
				x		[integer!]
				y		[integer!]
				x-y		[integer!]
				bytes	[integer!]
				psize	[integer!]
				info	[screenbuf-info!]
		][
			n:	  0
			line: input-line

			SetConsoleCursorPosition stdout base-y << 16

			info: declare screenbuf-info!
			GetConsoleScreenBufferInfo stdout as-integer info
			x-y: info/Position
			FillConsoleOutputCharacter							;-- clear screen
				stdout
				20h												;-- #" " = 20h
				rows - SECOND_WORD(x-y) * columns
				x-y
				:n

			bytes: emit-red-string prompt columns no

			psize: bytes // columns
			offset: bytes + (emit-red-string line columns - psize yes)	;-- output until reach cursor posistion

			psize: offset // columns
			bytes: offset + (emit-red-string line columns - psize no)	;-- continue until reach tail

			y: offset / columns
			x: offset // columns
			if all [
				widechar? line
				columns - x = 1
			][
				y: y + 1
				x: 0
			]

			SetConsoleCursorPosition stdout base-y + y << 16 or x
		]

		restore: does [SetConsoleMode stdin saved-con]

	] ;-- =================End Of OS Dependent Functions==================== --

		#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"

		input-line: declare red-string!
		saved-line:	declare red-string!
		prompt:		declare	red-string!
		history:	declare red-block!
		columns:	-1
		rows:		-1

		widechar?: func [
			str			[red-string!]
			return:		[logic!]
			/local
				cp		[integer!]
				unit	[integer!]
				s		[series!]
				offset	[byte-ptr!]
		][
			s: GET_BUFFER(str)
			unit: GET_UNIT(s)
			offset: (as byte-ptr! s/offset) + (str/head << (unit >> 1))
			cp: 0
			if offset < as byte-ptr! s/tail [cp: string/get-char offset unit]
			cp > FFh
		]

		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
		]

		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
			refresh

			while [true][
				c: fd-read
				#if OS <> 'Windows [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
					KEY_NONE []						;-- 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
		]
	]
]

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 [
	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 [

	#either OS <> 'Windows [
		#define OS_POLLIN 		1

		#define TERM_VTIME		6
		#define TERM_VMIN		7

		#define TERM_BRKINT		2
		#define TERM_INPCK		20
		#define TERM_ISTRIP		40
		#define TERM_ICRNL		400
		#define TERM_IXON		2000
		#define TERM_OPOST		1
		#define TERM_CS8		60
		#define TERM_ISIG		1
		#define TERM_ICANON		2
		#define TERM_ECHO		10
		#define TERM_IEXTEN		100000

		#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!]
				]
			]
		]

		saved-term: declare termios!
		utf-char:	declare c-string!
		poller: 	declare pollfd!
		lines-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 [
				#"^(0D)" [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!]
			head-as-tail? [logic!]
			return: 	[integer!]
			/local
				series	[series!]
				offset	[byte-ptr!]
				tail	[byte-ptr!]
				unit	[integer!]
				cp		[integer!]
				bytes	[integer!]
				cnt		[integer!]
				x		[integer!]
		][
			x:		0
			cnt:	0
			bytes:	0
			series: GET_BUFFER(str)
			unit: 	GET_UNIT(series)
			offset: (as byte-ptr! series/offset) + (str/head << (unit >> 1))
			tail:   as byte-ptr! series/tail
			if head-as-tail? [
				tail: offset
				offset: as byte-ptr! series/offset
			]
			until [
				while [
					all [offset < tail cnt < size]
				][
					cp: string/get-char offset unit
					cnt: either cp > FFh [
						either size - cnt = 1 [x: 2 cnt + 3][cnt + 2]	;-- reach screen edge, handle wide char
					][
						cnt + 1
					]
					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
				]
				bytes: bytes + cnt
				if cnt = size [
					emit-string "^(0A)^[[0G"				;-- emit new line and set cursor to start.
				]
				size: columns - x
				x: 0
				cnt: 0
				offset >= tail
			]
			bytes
		]

		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
			if positive? lines-y [emit-string-int "^[[" lines-y #"A"]	;-- move to origin row
			emit-string "^(0D)^[[J"					;-- erase down to the bottom of the screen

			bytes: emit-red-string prompt columns no

			psize: bytes // columns
			offset: bytes + (emit-red-string line columns - psize yes)	;-- output until reach cursor posistion

			psize: offset // columns
			bytes: offset + (emit-red-string line columns - psize no)	;-- continue until reach tail

			lines-y: bytes / columns		;-- the lines of all outputs occupy
			y: bytes / columns  - (offset / columns)
			x: offset // columns

			if all [						;-- special case: when moving cursor to the first char of a line
				widechar? line				;-- the first char of the line is a widechar
				columns - x = 1				;-- but in pre line only 1 space left
			][
				y: y - 1
				x: 0
			]

			if positive? y [				;-- set cursor position: y
			    emit-string-int "^[[" y #"A"
			    lines-y: lines-y - y
			]
			either zero? x [		 		;-- set cursor position: x
				emit #"^(0D)"
			][
				emit-string-int "^(0D)^[[" x #"C"
			]
		]

		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_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

			poller/fd: stdin
			poller/events: OS_POLLIN
		]

		restore: does [
			tcsetattr stdin TERM_TCSADRAIN saved-term
		]

	][;-- ================================================================= --

		#define VK_BACK 				 	08h
		#define VK_TAB 					 	09h
		#define VK_CLEAR 				 	0Ch
		#define VK_RETURN 				 	0Dh
		#define VK_SHIFT 				 	10h
		#define VK_CONTROL 				 	11h
		#define VK_PRIOR 				 	21h
		#define VK_NEXT 				 	22h
		#define VK_END 					 	23h
		#define VK_HOME 				 	24h
		#define VK_LEFT 				 	25h
		#define VK_UP 					 	26h
		#define VK_RIGHT 				 	27h
		#define VK_DOWN 				 	28h
		#define VK_SELECT 				 	29h
		#define VK_INSERT 				 	2Dh
		#define VK_DELETE 				 	2Eh
		#define KEY_EVENT 				 	01h
		#define MOUSE_EVENT 			 	02h
		#define WINDOW_BUFFER_SIZE_EVENT 	04h
		#define MENU_EVENT 				 	08h
		#define FOCUS_EVENT 			 	10h
		#define ENHANCED_KEY 			 	0100h
		#define FOREGROUND_BLUE 		 	01h
		#define FOREGROUND_GREEN 		 	02h
		#define FOREGROUND_RED 			 	04h
		#define ENABLE_LINE_INPUT 			02h
		#define ENABLE_ECHO_INPUT 			04h

		mouse-event!: alias struct! [
			Position  [integer!]			;-- high 16-bit: Y	low 16-bit: X
			BtnState  [integer!]
			KeyState  [integer!]
			Flags	  [integer!]
		]

		key-event!: alias struct! [		   ;typedef struct _KEY_EVENT_RECORD {
			KeyDown   			[integer!] ;  WINBOOL bKeyDown;  	offset: 0
			RepeatCnt-KeyCode	[integer!] ;  WORD wRepeatCount;            4
			ScanCode-Char		[integer!] ;  WORD wVirtualKeyCode;    		6
			KeyState  			[integer!] ;  WORD wVirtualScanCode;  		8
		]                          		   ;  union {
                                           ;    WCHAR UnicodeChar;
                                           ;    CHAR AsciiChar;
                                           ;  } uChar;						10
                                           ;  DWORD dwControlKeyState;		12
                                           ;} KEY_EVENT_RECORD,*PKEY_EVENT_RECORD;
		input-record!: alias struct! [
			EventType [integer!]
			Event	  [integer!]
			pad2	  [integer!]
			pad3	  [integer!]
			pad4	  [integer!]
		]

		screenbuf-info!: alias struct! [	;-- size? screenbuf-info! = 22
			Size	  [integer!]        	;typedef struct _CONSOLE_SCREEN_BUFFER_INFO {
			Position  [integer!]        	;  COORD dwSize;		offset: 0
			pad1	  [integer!]        	;  COORD dwCursorPosition;		4
			pad2	  [integer!]        	;  WORD wAttributes;			8
			pad3	  [integer!]        	;  SMALL_RECT srWindow;			10
			pad4 	  [byte!]           	;  COORD dwMaximumWindowSize;	18
			pad5 	  [byte!]           	;} CONSOLE_SCREEN_BUFFER_INFO,*PCONSOLE_SCREEN_BUFFER_INFO;
		]									;-- sizeof(CONSOLE_SCREEN_BUFFER_INFO) = 22

		#import [
			"kernel32.dll" stdcall [
				ReadConsoleInput: "ReadConsoleInputW" [
					handle			[integer!]
					arrayOfRecs		[integer!]
					length			[integer!]
					numberOfRecs	[int-ptr!]
					return:			[integer!]
				]
				SetConsoleMode: "SetConsoleMode" [
					handle			[integer!]
					mode			[integer!]
					return:			[integer!]
				]
				GetConsoleMode:	"GetConsoleMode" [
					handle			[integer!]
					mode			[int-ptr!]
					return:			[integer!]
				]
				WriteConsole: 	 "WriteConsoleW" [
					consoleOutput	[integer!]
					buffer			[byte-ptr!]
					charsToWrite	[integer!]
					numberOfChars	[int-ptr!]
					_reserved		[int-ptr!]
					return:			[integer!]
				]
				FillConsoleOutputAttribute: "FillConsoleOutputAttribute" [
					handle			[integer!]
					attributs		[integer!]
					length			[integer!]
					coord			[integer!]
					numberOfAttrs	[int-ptr!]
				]
				FillConsoleOutputCharacter: "FillConsoleOutputCharacterW" [
					handle			[integer!]
					attributs		[integer!]
					length			[integer!]
					coord			[integer!]
					numberOfChars	[int-ptr!]
				]
				SetConsoleCursorPosition: "SetConsoleCursorPosition" [
					handle 			[integer!]
					coord 			[integer!]
				]
				GetConsoleScreenBufferInfo: "GetConsoleScreenBufferInfo" [
					handle 			[integer!]
					info 			[integer!]
					return: 		[integer!]
				]
			]
		]

		input-rec: declare input-record!
		base-y:	 	 0
		saved-con:	 0

		#define STRUCT_MEMBER(base offset) ((as-integer base) + offset)
		#define FIRST_WORD(int) (int and FFFFh)
		#define SECOND_WORD(int) (int >>> 16)

		fd-read: func [
			return: 	[integer!]
			/local
				key 	[key-event!]
				n	 	[integer!]
				keycode [integer!]
		][
			n: 0
			while [true] [
				if zero? ReadConsoleInput stdin as-integer input-rec 1 :n [return -1]
				key: as key-event! STRUCT_MEMBER(input-rec (size? integer!))

				if all [
					input-rec/EventType and FFFFh = KEY_EVENT
					key/KeyDown <> 0
				][
					keycode: SECOND_WORD(key/RepeatCnt-KeyCode)  ;-- 1st RepeatCnt 2 KeyCode
					switch keycode [
						VK_LEFT		[return KEY_LEFT]
						VK_RIGHT	[return KEY_RIGHT]
						VK_UP		[return KEY_UP]
						VK_DOWN		[return KEY_DOWN]
						VK_INSERT	[return KEY_INSERT]
						VK_DELETE	[return KEY_DELETE]
						VK_HOME		[return KEY_HOME]
						VK_END		[return KEY_END]
						VK_PRIOR	[return KEY_PAGE_UP]
						VK_NEXT		[return KEY_PAGE_DOWN]
						VK_BACK 	[return KEY_BACKSPACE]
						VK_RETURN 	[return KEY_ENTER]
						VK_CONTROL  []
						default 	[
							return SECOND_WORD(key/ScanCode-Char) ;-- return Char
						]
					]
				]
			]
			-1
		]

		get-window-size: func [
			return: 	[integer!]
			/local
				info 	[screenbuf-info!]
				x-y 	[integer!]
		][
			info: declare screenbuf-info!
			if zero? GetConsoleScreenBufferInfo stdout as-integer info [return -1]
			x-y: info/Size
			columns: FIRST_WORD(x-y)
			rows: SECOND_WORD(x-y)
			if columns <= 0 [columns: 80 return -1]
			x-y: info/Position
			base-y: SECOND_WORD(x-y)
			0
		]

		init: func [
			line 		[red-string!]
			hist-blk	[red-block!]
			/local
				mode	[integer!]
		][
			copy-cell as red-value! line as red-value! input-line
			copy-cell as red-value! hist-blk as red-value! history

			GetConsoleMode stdin :saved-con
			mode: not (ENABLE_LINE_INPUT and ENABLE_ECHO_INPUT)		;-- turn off some features
			SetConsoleMode stdin saved-con and mode
		]

		emit-red-string: func [
			str	 		  [red-string!]
			size 		  [integer!]
			head-as-tail? [logic!]
			return:		  [integer!]
			/local
				x		  [integer!]
				cnt		  [integer!]
				n		  [integer!]
				bytes	  [integer!]
				cp		  [integer!]
				unit	  [integer!]
				series	  [series!]
				offset	  [byte-ptr!]
				tail	  [byte-ptr!]
		][
			x:		0
			n:		0
			bytes:	0
			cnt:	0
			series: GET_BUFFER(str)
			unit: 	GET_UNIT(series)
			offset: (as byte-ptr! series/offset) + (str/head << (unit >> 1))
			tail:	as byte-ptr! series/tail
			if head-as-tail? [
				tail: offset
				offset: as byte-ptr! series/offset
			]
			until [
				while [
					all [offset < tail cnt < size]
				][
					cp: string/get-char offset unit
					cnt: either cp > FFh [
						either size - cnt = 1 [x: 2 cnt + 3][cnt + 2]	;-- reach screen edge, handle wide char
					][
						cnt + 1
					]
					WriteConsole stdout (as byte-ptr! :cp) 1 :n null
					offset: offset + unit
				]
				bytes: bytes + cnt
				size: columns - x
				cnt: 0
				x: 0

				offset >= tail
			]
			bytes
		]

		refresh: func [
			/local
				line	[red-string!]
				offset	[integer!]
				n		[integer!]
				x		[integer!]
				y		[integer!]
				x-y		[integer!]
				bytes	[integer!]
				psize	[integer!]
				info	[screenbuf-info!]
		][
			n:	  0
			line: input-line

			SetConsoleCursorPosition stdout base-y << 16

			info: declare screenbuf-info!
			GetConsoleScreenBufferInfo stdout as-integer info
			x-y: info/Position
			FillConsoleOutputCharacter							;-- clear screen
				stdout
				20h												;-- #" " = 20h
				rows - SECOND_WORD(x-y) * columns
				x-y
				:n

			bytes: emit-red-string prompt columns no

			psize: bytes // columns
			offset: bytes + (emit-red-string line columns - psize yes)	;-- output until reach cursor posistion

			psize: offset // columns
			bytes: offset + (emit-red-string line columns - psize no)	;-- continue until reach tail

			y: offset / columns
			x: offset // columns
			if all [
				widechar? line
				columns - x = 1
			][
				y: y + 1
				x: 0
			]

			SetConsoleCursorPosition stdout base-y + y << 16 or x
		]

		restore: does [SetConsoleMode stdin saved-con]

	] ;-- =================End Of OS Dependent Functions==================== --

		#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"

		input-line: declare red-string!
		saved-line:	declare red-string!
		prompt:		declare	red-string!
		history:	declare red-block!
		columns:	-1
		rows:		-1

		widechar?: func [
			str			[red-string!]
			return:		[logic!]
			/local
				cp		[integer!]
				unit	[integer!]
				s		[series!]
				offset	[byte-ptr!]
		][
			s: GET_BUFFER(str)
			unit: GET_UNIT(s)
			offset: (as byte-ptr! s/offset) + (str/head << (unit >> 1))
			cp: 0
			if offset < as byte-ptr! s/tail [cp: string/get-char offset unit]
			cp > FFh
		]

		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
		]

		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
			refresh

			while [true][
				c: fd-read
				#if OS <> 'Windows [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
					KEY_NONE []						;-- 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
		]
	]
]

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]


TESTS: updated to pass fit new remainder on floats definition.


FIX: NEGATE action was not enabled.

FIX: NEGATE action was not enabled.

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

actions: context [
	verbose: 0

	table: declare int-ptr!

	register: func [
		[variadic]
		count	[integer!]
		list	[int-ptr!]
		/local
			offset [integer!]
			index  [integer!]
	][
		offset: 0
		index:  1

		until [
			table/index: list/value
			index: index + 1
			list: list + 1
			count: count - 1
			zero? count
		]
		assert index = (ACTIONS_NB + 1)
	]

	get-action-ptr-from: func [
		type	[integer!]								;-- datatype ID
		action	[integer!]								;-- action ID
		return: [integer!]								;-- action pointer (datatype-dependent)
		/local
			index [integer!]
	][
		index: type << 8 + action
		index: action-table/index						;-- lookup action function pointer

		if zero? index [
			print-line [
				"^/*** Script error: action " action
				" not defined for type: " type
			]
			halt
		]
		index
	]

	;@@ temporary stack-oriented version kept until internal API fully changed
	get-action-ptr*: func [
		action	[integer!]								;-- action ID
		return: [integer!]								;-- action pointer (datatype-dependent)
		/local
			arg  [red-value!]
	][
		arg: stack/arguments
		get-action-ptr-from TYPE_OF(arg) action
	]

	get-action-ptr: func [
		value	[red-value!]							;-- any-type! value
		action	[integer!]								;-- action ID
		return: [integer!]								;-- action pointer (datatype-dependent)
	][
		get-action-ptr-from TYPE_OF(value) action
	]

	get-index-argument: func [
		return:	 [integer!]
		/local
			arg  [red-value!]
			int  [red-integer!]
			char [red-char!]
			bool [red-logic!]
	][
		arg: stack/arguments + 1
		switch TYPE_OF(arg) [
			TYPE_INTEGER [int:  as red-integer! arg int/value]
			TYPE_CHAR 	 [char: as red-char! 	arg char/value]
			TYPE_LOGIC	 [bool: as red-logic! 	arg 2 - as-integer bool/value]
			default		 [0]
		]
	]

	;--- Actions polymorphic calls ---

	make*: func [
		return:	 [red-value!]
	][
		stack/set-last make stack/arguments stack/arguments + 1
	]

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

		type: TYPE_OF(proto)
		if type = TYPE_DATATYPE [
			dt: as red-datatype! proto
			type: dt/value
		]

		action-make: as function! [
			proto 	 [red-value!]
			spec	 [red-value!]
			return:	 [red-value!]						;-- newly created value
		] get-action-ptr-from type ACT_MAKE

		action-make proto spec
	]

	random*: func [][]

	reflect*: func [
		return: [red-block!]
	][
		reflect stack/arguments as red-word! stack/arguments + 1
	]

	reflect: func [
		value	[red-value!]
		field	[red-word!]
		return: [red-block!]
		/local
			action-reflect
	][
		action-reflect: as function! [
			value	[red-value!]
			field	[integer!]
			return:	[red-block!]
		] get-action-ptr-from TYPE_OF(value) ACT_REFLECT

		action-reflect value field/symbol
	]

	to*: func [][]

	form*: func [
		part	   [integer!]
		/local
			arg	   [red-value!]
			buffer [red-string!]
			int    [red-integer!]
			limit  [integer!]
	][
		arg: stack/arguments + part

		limit: either part >= 0 [
			int: as red-integer! arg
			int/value
		][0]

		stack/keep										;-- keep last value
		buffer: string/rs-make-at stack/push* 16		;@@ /part argument
		limit: form stack/arguments buffer arg limit

		if all [part >= 0 negative? limit][
			string/truncate-from-tail GET_BUFFER(buffer) limit
		]
		stack/set-last as red-value! buffer
	]

	form: func [
		value   [red-value!]							;-- FORM argument
		buffer  [red-string!]							;-- FORM buffer
		arg		[red-value!]							;-- max bytes count
		part	[integer!]
		return: [integer!]
		/local
			action-form
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/form"]]

		action-form: as function! [
			value	[red-value!]						;-- FORM argument
			buffer	[red-string!]						;-- FORM buffer
			arg		[red-value!]						;-- max bytes count
			part	[integer!]
			return: [integer!]							;-- remaining part count
		] get-action-ptr value ACT_FORM

		action-form value buffer arg part
	]

	mold*: func [
		only	[integer!]
		_all	[integer!]
		flat	[integer!]
		part	[integer!]
		/local
			arg	   [red-value!]
			buffer [red-string!]
			int    [red-integer!]
			limit  [integer!]
	][
		arg: stack/arguments + part

		limit: either part >= 0 [
			int: as red-integer! arg
			int/value
		][0]

		stack/keep										;-- keep last value
		buffer: string/rs-make-at stack/push* 16		;@@ /part argument
		limit: mold
			stack/arguments
			buffer
			as logic! only + 1
			as logic! _all + 1
			as logic! flat + 1
			arg
			limit

		if all [part >= 0 negative? limit][
			string/truncate-from-tail GET_BUFFER(buffer) limit
		]
		stack/set-last as red-value! buffer
	]

	mold: func [
		value    [red-value!]							;-- MOLD argument
		buffer   [red-string!]							;-- MOLD buffer
		only?	 [logic!]
		all?	 [logic!]
		flat?	 [logic!]
		arg		 [red-value!]
		part     [integer!]								;-- max bytes count
		return:  [integer!]
		/local
			action-mold
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/mold"]]

		action-mold: as function! [
			value	 [red-value!]						;-- FORM argument
			buffer	 [red-string!]						;-- FORM buffer
			only?	 [logic!]
			all?	 [logic!]
			flat?	 [logic!]
			part-arg [red-value!]
			part	 [integer!]							;-- max bytes count
			return:  [integer!]							;-- remaining part count
		] get-action-ptr value ACT_MOLD

		action-mold value buffer only? all? flat? arg part
	]

	get-path*: func [][]
	set-path*: func [][]

	compare: func [
		value1  [red-value!]
		value2  [red-value!]
		op	    [integer!]
		return: [logic!]
		/local
			action-compare
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/compare"]]

		action-compare: as function! [
			value1  [red-value!]						;-- first operand
			value2  [red-value!]						;-- second operand
			op	    [integer!]							;-- type of comparison
			return: [logic!]
		] get-action-ptr value1 ACT_COMPARE

		action-compare value1 value2 op
	]

	absolute*: func [][]

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

		action-add: as function! [
			return:	[red-value!]						;-- addition resulting value
		] get-action-ptr* ACT_ADD
		action-add
	]

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

		action-divide: as function! [
			return:	[red-value!]						;-- division resulting value
		] get-action-ptr* ACT_DIVIDE
		action-divide
	]

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

		action-multiply: as function! [
			return:	[red-value!]						;-- multiplication resulting value
		] get-action-ptr* ACT_MULTIPLY
		action-multiply
	]

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

		negate-action stack/arguments
	]

	negate-action: func [								;-- negate is a Red/System keyword
		value	[red-value!]
		return:	[red-value!]
		/local
			action-negate
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/negate"]]

		action-negate: as function! [
			value	[red-value!]
			return:	[red-value!]						;-- negated value
		] get-action-ptr value ACT_NEGATE

		action-negate value
	]

	power*: func [][]
	remainder*: func [][]
	round*: func [][]

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

		action-subtract: as function! [
			return:	[red-value!]						;-- addition resulting value
		] get-action-ptr* ACT_SUBTRACT
		action-subtract
	]

	even?*: func [][]
	odd?*: func [][]
	and~*: func [][]

	complement*: does [
		stack/set-last complement stack/arguments
	]

	complement: func [
		value	[red-value!]
		return:	[red-value!]
		/local
			action-complement
	][
		action-complement: as function! [
			value	[red-value!]
			return:	[red-value!]						;-- complemented value
		] get-action-ptr value ACT_COMPLEMENT

		action-complement value
	]

	or~*: func [][]
	xor~*: func [][]

	append*: func [
		part  [integer!]
		only  [integer!]
		dup   [integer!]
	][
		; assert ANY-SERIES?(TYPE_OF(stack/arguments))
		insert
			as red-series! stack/arguments
			stack/arguments + 1
			stack/arguments + part
			as logic! only + 1
			stack/arguments + dup
			yes
	]

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

		action-at: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_AT
		action-at
	]

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

		action-back: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_BACK
		action-back
	]

	change*: func [][]

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

	clear: func [
		value	[red-value!]
		return:	[red-value!]
		/local
			action-clear
	][
		action-clear: as function! [
			value	[red-value!]
			return:	[red-value!]						;-- argument series
		] get-action-ptr value ACT_CLEAR

		action-clear value
	]

	copy*: func [
		part	[integer!]
		deep	[integer!]
		types	[integer!]
		return:	[red-series!]
	][
		copy
			as red-series! stack/arguments
			stack/arguments + part
			as logic! deep + 1
			stack/arguments + types
	]

	copy: func [
		series  [red-series!]
		part	[red-value!]
		deep?	[logic!]
		types	[red-value!]
		return:	[red-series!]
		/local
			action-copy
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/copy"]]

		action-copy: as function! [
			series  [red-series!]
			part	[red-value!]
			deep?	[logic!]
			types	[red-value!]
			return: [red-series!]
		] get-action-ptr as red-value! series ACT_COPY

		action-copy series part deep? types
	]

	find*: func [
		part	 [integer!]
		only	 [integer!]
		case-arg [integer!]
		any-arg  [integer!]
		with-arg [integer!]
		skip	 [integer!]
		last	 [integer!]
		reverse	 [integer!]
		tail	 [integer!]
		match	 [integer!]
	][
		; assert ANY-SERIES?(TYPE_OF(stack/arguments))
		stack/set-last find
			as red-series! stack/arguments
			stack/arguments + 1
			stack/arguments + part
			as logic! only + 1
			as logic! case-arg + 1
			as logic! any-arg + 1
			as red-string!  stack/arguments + with-arg
			as red-integer! stack/arguments + skip
			as logic! last + 1
			as logic! reverse + 1
			as logic! tail + 1
			as logic! match + 1
	]

	find: func [
		series   [red-series!]
		value    [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		tail?	 [logic!]
		match?	 [logic!]
		return:  [red-value!]
		/local
			action-find
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/find"]]

		action-find: as function! [
			series   [red-series!]
			value    [red-value!]
			part	 [red-value!]
			only?	 [logic!]
			case?	 [logic!]
			any?	 [logic!]
			with-arg [red-string!]
			skip	 [red-integer!]
			last?	 [logic!]
			reverse? [logic!]
			tail?	 [logic!]
			match?	 [logic!]
			return:  [red-value!]
		] get-action-ptr as red-value! series ACT_FIND

		action-find series value part only? case? any? with-arg skip last? reverse? tail? match?
	]

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

		action-head: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_HEAD
		action-head
	]

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

		action-head?: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_HEAD?
		action-head?
	]

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

		action-index?: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_INDEX?
		action-index?
	]

	insert*: func [
		part  [integer!]
		only  [integer!]
		dup   [integer!]
	][
		; assert ANY-SERIES?(TYPE_OF(stack/arguments))
		insert
			as red-series! stack/arguments
			stack/arguments + 1
			stack/arguments + part
			as logic! only + 1
			stack/arguments + dup
			no
	]

	insert: func [
		series  [red-series!]
		value   [red-value!]
		part	[red-value!]
		only?	[logic!]
		dup		[red-value!]
		append? [logic!]
		return:	[red-value!]
		/local
			action-insert
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/insert"]]

		action-insert: as function! [
			series  [red-series!]
			value   [red-value!]
			part	[red-value!]
			only?	[logic!]
			dup		[red-value!]
			append? [logic!]
			return:	[red-value!]						;-- series after insertion position
		] get-action-ptr as red-value! series ACT_INSERT

		action-insert series value part only? dup append?
	]

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

		int: as red-integer! stack/arguments
		int/value:  length? stack/arguments				;-- must be set before slot is modified
		int/header: TYPE_INTEGER
		int
	]

	length?: func [
		value	[red-value!]
		return: [integer!]
	][
		action-length?: as function! [
			value	[red-value!]
			return:	[integer!]							;-- length of series
		] get-action-ptr value ACT_LENGTH?

		action-length? value
	]

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

		action-next: as function! [
			return:	[red-value!]						;-- next value from series
		] get-action-ptr* ACT_NEXT
		action-next
	]

	pick*: func [
		return:	 [red-value!]
	][
		stack/set-last pick
			as red-series! stack/arguments
			get-index-argument
			stack/arguments + 1
	]

	pick: func [
		series	[red-series!]
		index	[integer!]
		boxed	[red-value!]							;-- boxed index value
		return:	[red-value!]
		/local
			action-pick
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/pick"]]

		action-pick: as function! [
			series	[red-series!]
			index	[integer!]
			boxed	[red-value!]						;-- boxed index value
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr as red-value! series ACT_PICK

		action-pick series index boxed
	]

	poke*: func [
		return:	[red-value!]
	][
		poke
			as red-series! stack/arguments
			get-index-argument
			stack/arguments + 2
			stack/arguments + 1

		stack/set-last stack/arguments
	]

	poke: func [
		series	[red-series!]
		index	[integer!]								;-- unboxed value
		data	[red-value!]
		boxed	[red-value!]							;-- boxed index value
		/local
			action-poke
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/poke"]]

		action-poke: as function! [
			series	[red-series!]
			index	[integer!]
			data	[red-value!]
			boxed	[red-value!]
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr as red-value! series ACT_POKE

		action-poke series index data boxed
	]

	remove*: func [
		part [integer!]
	][
		remove
			as red-series! stack/arguments
			stack/arguments + part
	]

	remove: func [
		series  [red-series!]
		part	[red-value!]
		return:	[red-value!]
		/local
			action-remove
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/remove"]]

		action-remove: as function! [
			series	[red-series!]
			part	[red-value!]
			return:	[red-value!]
		] get-action-ptr as red-value! series ACT_REMOVE

		action-remove series part
	]

	reverse*: func [][]

	select*: func [
		part	 [integer!]
		only	 [integer!]
		case-arg [integer!]
		any-arg  [integer!]
		with-arg [integer!]
		skip	 [integer!]
		last	 [integer!]
		reverse	 [integer!]
	][
		; assert ANY-SERIES?(TYPE_OF(stack/arguments))
		stack/set-last select
			as red-series! stack/arguments
			stack/arguments + 1
			stack/arguments + part
			as logic! only + 1
			as logic! case-arg + 1
			as logic! any-arg + 1
			as red-string!  stack/arguments + with-arg
			as red-integer! stack/arguments + skip
			as logic! last + 1
			as logic! reverse + 1
	]

	select: func [
		series   [red-series!]
		value    [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		return:  [red-value!]
		/local
			action-select
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/select"]]

		action-select: as function! [
			series   [red-series!]
			value    [red-value!]
			part	 [red-value!]
			only?	 [logic!]
			case?	 [logic!]
			any?	 [logic!]
			with-arg [red-string!]
			skip	 [red-integer!]
			last?	 [logic!]
			reverse? [logic!]
			return:  [red-value!]
		] get-action-ptr as red-value! series ACT_SELECT

		action-select series value part only? case? any? with-arg skip last? reverse?
	]

	sort*: func [][]

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

		action-skip: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_SKIP
		action-skip
	]

	swap*: func [][]

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

		action-tail: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_TAIL
		action-tail
	]

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

		action-tail?: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_TAIL?
		action-tail?
	]

	take*: func [][]
	trim*: func [][]
	create*: func [][]
	close*: func [][]
	delete*: func [][]
	modify*: func [][]
	open*: func [][]
	open?*: func [][]
	query*: func [][]
	read*: func [][]
	rename*: func [][]
	update*: func [][]
	write*: func [][]

	init: does [
		table: as int-ptr! allocate ACTIONS_NB * size? integer!

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

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

actions: context [
	verbose: 0

	table: declare int-ptr!

	register: func [
		[variadic]
		count	[integer!]
		list	[int-ptr!]
		/local
			offset [integer!]
			index  [integer!]
	][
		offset: 0
		index:  1

		until [
			table/index: list/value
			index: index + 1
			list: list + 1
			count: count - 1
			zero? count
		]
		assert index = (ACTIONS_NB + 1)
	]

	get-action-ptr-from: func [
		type	[integer!]								;-- datatype ID
		action	[integer!]								;-- action ID
		return: [integer!]								;-- action pointer (datatype-dependent)
		/local
			index [integer!]
	][
		index: type << 8 + action
		index: action-table/index						;-- lookup action function pointer

		if zero? index [
			print-line [
				"^/*** Script error: action " action
				" not defined for type: " type
			]
			halt
		]
		index
	]

	;@@ temporary stack-oriented version kept until internal API fully changed
	get-action-ptr*: func [
		action	[integer!]								;-- action ID
		return: [integer!]								;-- action pointer (datatype-dependent)
		/local
			arg  [red-value!]
	][
		arg: stack/arguments
		get-action-ptr-from TYPE_OF(arg) action
	]

	get-action-ptr: func [
		value	[red-value!]							;-- any-type! value
		action	[integer!]								;-- action ID
		return: [integer!]								;-- action pointer (datatype-dependent)
	][
		get-action-ptr-from TYPE_OF(value) action
	]

	get-index-argument: func [
		return:	 [integer!]
		/local
			arg  [red-value!]
			int  [red-integer!]
			char [red-char!]
			bool [red-logic!]
	][
		arg: stack/arguments + 1
		switch TYPE_OF(arg) [
			TYPE_INTEGER [int:  as red-integer! arg int/value]
			TYPE_CHAR 	 [char: as red-char! 	arg char/value]
			TYPE_LOGIC	 [bool: as red-logic! 	arg 2 - as-integer bool/value]
			default		 [0]
		]
	]

	;--- Actions polymorphic calls ---

	make*: func [
		return:	 [red-value!]
	][
		stack/set-last make stack/arguments stack/arguments + 1
	]

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

		type: TYPE_OF(proto)
		if type = TYPE_DATATYPE [
			dt: as red-datatype! proto
			type: dt/value
		]

		action-make: as function! [
			proto 	 [red-value!]
			spec	 [red-value!]
			return:	 [red-value!]						;-- newly created value
		] get-action-ptr-from type ACT_MAKE

		action-make proto spec
	]

	random*: func [][]

	reflect*: func [
		return: [red-block!]
	][
		reflect stack/arguments as red-word! stack/arguments + 1
	]

	reflect: func [
		value	[red-value!]
		field	[red-word!]
		return: [red-block!]
		/local
			action-reflect
	][
		action-reflect: as function! [
			value	[red-value!]
			field	[integer!]
			return:	[red-block!]
		] get-action-ptr-from TYPE_OF(value) ACT_REFLECT

		action-reflect value field/symbol
	]

	to*: func [][]

	form*: func [
		part	   [integer!]
		/local
			arg	   [red-value!]
			buffer [red-string!]
			int    [red-integer!]
			limit  [integer!]
	][
		arg: stack/arguments + part

		limit: either part >= 0 [
			int: as red-integer! arg
			int/value
		][0]

		stack/keep										;-- keep last value
		buffer: string/rs-make-at stack/push* 16		;@@ /part argument
		limit: form stack/arguments buffer arg limit

		if all [part >= 0 negative? limit][
			string/truncate-from-tail GET_BUFFER(buffer) limit
		]
		stack/set-last as red-value! buffer
	]

	form: func [
		value   [red-value!]							;-- FORM argument
		buffer  [red-string!]							;-- FORM buffer
		arg		[red-value!]							;-- max bytes count
		part	[integer!]
		return: [integer!]
		/local
			action-form
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/form"]]

		action-form: as function! [
			value	[red-value!]						;-- FORM argument
			buffer	[red-string!]						;-- FORM buffer
			arg		[red-value!]						;-- max bytes count
			part	[integer!]
			return: [integer!]							;-- remaining part count
		] get-action-ptr value ACT_FORM

		action-form value buffer arg part
	]

	mold*: func [
		only	[integer!]
		_all	[integer!]
		flat	[integer!]
		part	[integer!]
		/local
			arg	   [red-value!]
			buffer [red-string!]
			int    [red-integer!]
			limit  [integer!]
	][
		arg: stack/arguments + part

		limit: either part >= 0 [
			int: as red-integer! arg
			int/value
		][0]

		stack/keep										;-- keep last value
		buffer: string/rs-make-at stack/push* 16		;@@ /part argument
		limit: mold
			stack/arguments
			buffer
			as logic! only + 1
			as logic! _all + 1
			as logic! flat + 1
			arg
			limit

		if all [part >= 0 negative? limit][
			string/truncate-from-tail GET_BUFFER(buffer) limit
		]
		stack/set-last as red-value! buffer
	]

	mold: func [
		value    [red-value!]							;-- MOLD argument
		buffer   [red-string!]							;-- MOLD buffer
		only?	 [logic!]
		all?	 [logic!]
		flat?	 [logic!]
		arg		 [red-value!]
		part     [integer!]								;-- max bytes count
		return:  [integer!]
		/local
			action-mold
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/mold"]]

		action-mold: as function! [
			value	 [red-value!]						;-- FORM argument
			buffer	 [red-string!]						;-- FORM buffer
			only?	 [logic!]
			all?	 [logic!]
			flat?	 [logic!]
			part-arg [red-value!]
			part	 [integer!]							;-- max bytes count
			return:  [integer!]							;-- remaining part count
		] get-action-ptr value ACT_MOLD

		action-mold value buffer only? all? flat? arg part
	]

	get-path*: func [][]
	set-path*: func [][]

	compare: func [
		value1  [red-value!]
		value2  [red-value!]
		op	    [integer!]
		return: [logic!]
		/local
			action-compare
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/compare"]]

		action-compare: as function! [
			value1  [red-value!]						;-- first operand
			value2  [red-value!]						;-- second operand
			op	    [integer!]							;-- type of comparison
			return: [logic!]
		] get-action-ptr value1 ACT_COMPARE

		action-compare value1 value2 op
	]

	absolute*: func [][]

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

		action-add: as function! [
			return:	[red-value!]						;-- addition resulting value
		] get-action-ptr* ACT_ADD
		action-add
	]

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

		action-divide: as function! [
			return:	[red-value!]						;-- division resulting value
		] get-action-ptr* ACT_DIVIDE
		action-divide
	]

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

		action-multiply: as function! [
			return:	[red-value!]						;-- multiplication resulting value
		] get-action-ptr* ACT_MULTIPLY
		action-multiply
	]

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

		action-negate: as function! [
			return:	[red-value!]						;-- negated value
		] get-action-ptr* ACT_NEGATE
		action-negate
	]

	power*: func [][]
	remainder*: func [][]
	round*: func [][]

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

		action-subtract: as function! [
			return:	[red-value!]						;-- addition resulting value
		] get-action-ptr* ACT_SUBTRACT
		action-subtract
	]

	even?*: func [][]
	odd?*: func [][]
	and~*: func [][]

	complement*: does [
		stack/set-last complement stack/arguments
	]

	complement: func [
		value	[red-value!]
		return:	[red-value!]
		/local
			action-complement
	][
		action-complement: as function! [
			value	[red-value!]
			return:	[red-value!]						;-- complemented value
		] get-action-ptr value ACT_COMPLEMENT

		action-complement value
	]

	or~*: func [][]
	xor~*: func [][]

	append*: func [
		part  [integer!]
		only  [integer!]
		dup   [integer!]
	][
		; assert ANY-SERIES?(TYPE_OF(stack/arguments))
		insert
			as red-series! stack/arguments
			stack/arguments + 1
			stack/arguments + part
			as logic! only + 1
			stack/arguments + dup
			yes
	]

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

		action-at: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_AT
		action-at
	]

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

		action-back: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_BACK
		action-back
	]

	change*: func [][]

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

	clear: func [
		value	[red-value!]
		return:	[red-value!]
		/local
			action-clear
	][
		action-clear: as function! [
			value	[red-value!]
			return:	[red-value!]						;-- argument series
		] get-action-ptr value ACT_CLEAR

		action-clear value
	]

	copy*: func [
		part	[integer!]
		deep	[integer!]
		types	[integer!]
		return:	[red-series!]
	][
		copy
			as red-series! stack/arguments
			stack/arguments + part
			as logic! deep + 1
			stack/arguments + types
	]

	copy: func [
		series  [red-series!]
		part	[red-value!]
		deep?	[logic!]
		types	[red-value!]
		return:	[red-series!]
		/local
			action-copy
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/copy"]]

		action-copy: as function! [
			series  [red-series!]
			part	[red-value!]
			deep?	[logic!]
			types	[red-value!]
			return: [red-series!]
		] get-action-ptr as red-value! series ACT_COPY

		action-copy series part deep? types
	]

	find*: func [
		part	 [integer!]
		only	 [integer!]
		case-arg [integer!]
		any-arg  [integer!]
		with-arg [integer!]
		skip	 [integer!]
		last	 [integer!]
		reverse	 [integer!]
		tail	 [integer!]
		match	 [integer!]
	][
		; assert ANY-SERIES?(TYPE_OF(stack/arguments))
		stack/set-last find
			as red-series! stack/arguments
			stack/arguments + 1
			stack/arguments + part
			as logic! only + 1
			as logic! case-arg + 1
			as logic! any-arg + 1
			as red-string!  stack/arguments + with-arg
			as red-integer! stack/arguments + skip
			as logic! last + 1
			as logic! reverse + 1
			as logic! tail + 1
			as logic! match + 1
	]

	find: func [
		series   [red-series!]
		value    [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		tail?	 [logic!]
		match?	 [logic!]
		return:  [red-value!]
		/local
			action-find
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/find"]]

		action-find: as function! [
			series   [red-series!]
			value    [red-value!]
			part	 [red-value!]
			only?	 [logic!]
			case?	 [logic!]
			any?	 [logic!]
			with-arg [red-string!]
			skip	 [red-integer!]
			last?	 [logic!]
			reverse? [logic!]
			tail?	 [logic!]
			match?	 [logic!]
			return:  [red-value!]
		] get-action-ptr as red-value! series ACT_FIND

		action-find series value part only? case? any? with-arg skip last? reverse? tail? match?
	]

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

		action-head: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_HEAD
		action-head
	]

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

		action-head?: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_HEAD?
		action-head?
	]

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

		action-index?: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_INDEX?
		action-index?
	]

	insert*: func [
		part  [integer!]
		only  [integer!]
		dup   [integer!]
	][
		; assert ANY-SERIES?(TYPE_OF(stack/arguments))
		insert
			as red-series! stack/arguments
			stack/arguments + 1
			stack/arguments + part
			as logic! only + 1
			stack/arguments + dup
			no
	]

	insert: func [
		series  [red-series!]
		value   [red-value!]
		part	[red-value!]
		only?	[logic!]
		dup		[red-value!]
		append? [logic!]
		return:	[red-value!]
		/local
			action-insert
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/insert"]]

		action-insert: as function! [
			series  [red-series!]
			value   [red-value!]
			part	[red-value!]
			only?	[logic!]
			dup		[red-value!]
			append? [logic!]
			return:	[red-value!]						;-- series after insertion position
		] get-action-ptr as red-value! series ACT_INSERT

		action-insert series value part only? dup append?
	]

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

		int: as red-integer! stack/arguments
		int/value:  length? stack/arguments				;-- must be set before slot is modified
		int/header: TYPE_INTEGER
		int
	]

	length?: func [
		value	[red-value!]
		return: [integer!]
	][
		action-length?: as function! [
			value	[red-value!]
			return:	[integer!]							;-- length of series
		] get-action-ptr value ACT_LENGTH?

		action-length? value
	]

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

		action-next: as function! [
			return:	[red-value!]						;-- next value from series
		] get-action-ptr* ACT_NEXT
		action-next
	]

	pick*: func [
		return:	 [red-value!]
	][
		stack/set-last pick
			as red-series! stack/arguments
			get-index-argument
			stack/arguments + 1
	]

	pick: func [
		series	[red-series!]
		index	[integer!]
		boxed	[red-value!]							;-- boxed index value
		return:	[red-value!]
		/local
			action-pick
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/pick"]]

		action-pick: as function! [
			series	[red-series!]
			index	[integer!]
			boxed	[red-value!]						;-- boxed index value
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr as red-value! series ACT_PICK

		action-pick series index boxed
	]

	poke*: func [
		return:	[red-value!]
	][
		poke
			as red-series! stack/arguments
			get-index-argument
			stack/arguments + 2
			stack/arguments + 1

		stack/set-last stack/arguments
	]

	poke: func [
		series	[red-series!]
		index	[integer!]								;-- unboxed value
		data	[red-value!]
		boxed	[red-value!]							;-- boxed index value
		/local
			action-poke
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/poke"]]

		action-poke: as function! [
			series	[red-series!]
			index	[integer!]
			data	[red-value!]
			boxed	[red-value!]
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr as red-value! series ACT_POKE

		action-poke series index data boxed
	]

	remove*: func [
		part [integer!]
	][
		remove
			as red-series! stack/arguments
			stack/arguments + part
	]

	remove: func [
		series  [red-series!]
		part	[red-value!]
		return:	[red-value!]
		/local
			action-remove
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/remove"]]

		action-remove: as function! [
			series	[red-series!]
			part	[red-value!]
			return:	[red-value!]
		] get-action-ptr as red-value! series ACT_REMOVE

		action-remove series part
	]

	reverse*: func [][]

	select*: func [
		part	 [integer!]
		only	 [integer!]
		case-arg [integer!]
		any-arg  [integer!]
		with-arg [integer!]
		skip	 [integer!]
		last	 [integer!]
		reverse	 [integer!]
	][
		; assert ANY-SERIES?(TYPE_OF(stack/arguments))
		stack/set-last select
			as red-series! stack/arguments
			stack/arguments + 1
			stack/arguments + part
			as logic! only + 1
			as logic! case-arg + 1
			as logic! any-arg + 1
			as red-string!  stack/arguments + with-arg
			as red-integer! stack/arguments + skip
			as logic! last + 1
			as logic! reverse + 1
	]

	select: func [
		series   [red-series!]
		value    [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		return:  [red-value!]
		/local
			action-select
	][
		#if debug? = yes [if verbose > 0 [print-line "actions/select"]]

		action-select: as function! [
			series   [red-series!]
			value    [red-value!]
			part	 [red-value!]
			only?	 [logic!]
			case?	 [logic!]
			any?	 [logic!]
			with-arg [red-string!]
			skip	 [red-integer!]
			last?	 [logic!]
			reverse? [logic!]
			return:  [red-value!]
		] get-action-ptr as red-value! series ACT_SELECT

		action-select series value part only? case? any? with-arg skip last? reverse?
	]

	sort*: func [][]

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

		action-skip: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_SKIP
		action-skip
	]

	swap*: func [][]

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

		action-tail: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_TAIL
		action-tail
	]

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

		action-tail?: as function! [
			return:	[red-value!]						;-- picked value from series
		] get-action-ptr* ACT_TAIL?
		action-tail?
	]

	take*: func [][]
	trim*: func [][]
	create*: func [][]
	close*: func [][]
	delete*: func [][]
	modify*: func [][]
	open*: func [][]
	open?*: func [][]
	query*: func [][]
	read*: func [][]
	rename*: func [][]
	update*: func [][]
	write*: func [][]

	init: does [
		table: as int-ptr! allocate ACTIONS_NB * size? integer!

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


FIX: minor code refactoring.

FIX: minor code refactoring.

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

#define zero? 		  [0 =]
#define positive?	  [0 < ]				;-- space required after the lesser-than symbol
#define negative?	  [0 > ]
#define negate		  [0 -]
#define null?		  [null =]

#define forever		  [while [true]]
#define does		  [func []]
#define unless		  [if not]
#define	raise-error	  ***-on-quit

#define as-byte		  [as byte!]
#define as-logic	  [as logic!]
#define as-integer	  [as integer!]
#define as-c-string	  [as c-string!]

#define null-byte	  #"^(00)"
#define yes			  true
#define no			  false
#define on			  true
#define off			  false

#define byte-ptr!	  [pointer! [byte!]]
#define int-ptr!	  [pointer! [integer!]]
#define make-c-string [as c-string! allocate]

#define type-logic!		1					;-- type ID list for 'typeinfo attribut
#define type-integer!	2
#define type-byte!	    3
#define type-c-string!  4
#define type-byte-ptr!  5
#define type-int-ptr!	6
#define type-function!	7
#define type-struct!	1000
#define any-struct?		[1000 <=]
#define alias?  		[1001 <=]

;-- Global variables definition --
stdout:		-1								;-- uninitialized default value
stdin:		-1								;-- uninitialized default value
stderr:		-1								;-- uninitialized default value

str-array!: alias struct! [
	item [c-string!]
]

typed-value!: alias struct! [
	value	[integer!]
	type	[integer!]
]

__stack!: alias struct! [
	top		[int-ptr!]
	frame	[int-ptr!]
]

system: declare struct! [					;-- store runtime accessible system values
	args-count	[integer!]					;-- command-line arguments count (do not move member)
	args-list	[str-array!]				;-- command-line arguments array pointer (do not move member)
	env-vars 	[str-array!]				;-- environment variables array pointer (always null for Windows)
	stack		[__stack!]					;-- stack virtual access
	pc			[byte-ptr!]					;-- CPU program counter value
	alias		[integer!]					;-- aliases ID virtual access
]

;-------------------------------------------
;-- Convert a type ID to a c-string!
;-------------------------------------------
form-type: func [
	type 	[integer!]				  		;-- type ID
	return: [c-string!]						;-- type representation as c-string
][
	if type = type-integer!    [return "integer!"]
	if type = type-c-string!   [return "c-string!"]
	if type = type-logic! 	   [return "logic!"]
	if type = type-byte! 	     [return "byte!"]
	if type = type-byte-ptr!   [return "pointer! [byte!]"]
	if type = type-int-ptr!    [return "pointer! [integer!]"]
	if type = type-struct!     [return "struct!"]
	if type = type-function!   [return "function!"]
	if alias? type             [return "alias"]
	"not valid type"
]

#switch OS [
	Windows  [#define LIBC-file	"msvcrt.dll"]
	Syllable [#define LIBC-file	"libc.so.2"]
	MacOSX	 [#define LIBC-file	"libc.dylib"]
	#default [
		#either config-name = 'Android [	;-- @@ see if declaring it as an OS wouldn't be too costly
			#define LIBC-file	"libc.so"
		][
			#define LIBC-file	"libc.so.6"	;-- Linux
		]
	]
]

#either use-natives? = no [					;-- C bindings or native counterparts
	#include %lib-C.reds
][
	#include %lib-natives.reds
]

#switch OS [								;-- loading OS-specific bindings
	Windows  [#include %win32.reds]
	Syllable [#include %syllable.reds]
	MacOSX	 [#include %darwin.reds]
	#default [#include %linux.reds]
]

#include %utils.reds						;-- load additional utility functions

#if debug? = yes [#include %debug.reds]		;-- loads optionally debug functions

;-- Run-time error handling --

#define RED_ERR_VMEM_RELEASE_FAILED		96
#define RED_ERR_VMEM_OUT_OF_MEMORY		97

***-on-quit: func [							;-- global exit handler
	status [integer!]
	address [integer!]
	/local msg
][
	unless zero? status [
		print [lf "*** Runtime Error " status ": "]

		if status =  1 [msg: "access violation"]
		if status =  2 [msg: "invalid alignment"]
		if status =  3 [msg: "breakpoint"]
		if status =  4 [msg: "single step"]
		if status =  5 [msg: "bounds exceeded"]
		if status =  6 [msg: "float denormal operan"]
		if status =  7 [msg: "float divide by zero"]
		if status =  8 [msg: "float inexact result"]
		if status =  9 [msg: "float invalid operation"]
		if status = 10 [msg: "float overflow"]
		if status = 11 [msg: "float stack check"]
		if status = 12 [msg: "float underflow"]
		if status = 13 [msg: "integer divide by zero"]
		if status = 14 [msg: "integer overflow"]
		if status = 15 [msg: "privileged instruction"]
		if status = 16 [msg: "invalid virtual address"]
		if status = 17 [msg: "illegal instruction"]
		if status = 18 [msg: "non-continuable exception"]
		if status = 19 [msg: "stack error or overflow"]
		if status = 20 [msg: "invalid disposition"]
		if status = 21 [msg: "guard page"]
		if status = 22 [msg: "invalid handle"]
		if status = 23 [msg: "illegal operand"]
		if status = 24 [msg: "illegal addressing mode"]
		if status = 25 [msg: "illegal trap"]
		if status = 26 [msg: "coprocessor error"]
		if status = 27 [msg: "non-existant physical address"]
		if status = 28 [msg: "object specific hardware error"]
		if status = 29 [msg: "hardware memory error consumed AR"]
		if status = 30 [msg: "hardware memory error consumed AO"]
		if status = 31 [msg: "privileged register"]

		if status = 96 [msg: "virtual memory release failed"]
		if status = 97 [msg: "out of memory"]
		if status = 98 [msg: "assertion failed"]
		if status = 99 [msg: "unknown error"]

		print msg

		#either debug? = yes [
			__print-debug-line as byte-ptr! address
		][
			print [lf "*** at: " as byte-ptr! address "h" lf]
		]
	]

	#if OS = 'Windows [						;-- special exit handler for Windows
		***-on-win32-quit
	]
	quit status
]

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

#define zero? 		  [0 =]
#define positive?	  [0 < ]				;-- space required after the lesser-than symbol
#define negative?	  [0 > ]
#define negate		  [0 -]
#define null?		  [null =]

#define forever		  [while [true]]
#define does		  [func []]
#define unless		  [if not]
#define	raise-error	  ***-on-quit

#define as-byte		  [as byte!]
#define as-logic	  [as logic!]
#define as-integer	  [as integer!]
#define as-c-string	  [as c-string!]

#define null-byte	  #"^(00)"
#define yes			  true
#define no			  false
#define on			  true
#define off			  false

#define byte-ptr!	  [pointer! [byte!]]
#define int-ptr!	  [pointer! [integer!]]
#define make-c-string [as c-string! allocate]

#define type-logic!		1					;-- type ID list for 'typeinfo attribut
#define type-integer!	2
#define type-byte!	    3
#define type-c-string!  4
#define type-byte-ptr!  5
#define type-int-ptr!	6
#define type-function!	7
#define type-struct!	1000
#define alias?  [1001 <=]
#define any-struct?		[1000 <=]

;-- Global variables definition --
stdout:		-1								;-- uninitialized default value
stdin:		-1								;-- uninitialized default value
stderr:		-1								;-- uninitialized default value

str-array!: alias struct! [
	item [c-string!]
]

typed-value!: alias struct! [
	value	[integer!]
	type	[integer!]
]

__stack!: alias struct! [
	top		[int-ptr!]
	frame	[int-ptr!]
]

system: declare struct! [					;-- store runtime accessible system values
	args-count	[integer!]					;-- command-line arguments count (do not move member)
	args-list	[str-array!]				;-- command-line arguments array pointer (do not move member)
	env-vars 	[str-array!]				;-- environment variables array pointer (always null for Windows)
	stack		[__stack!]					;-- stack virtual access
	pc			[byte-ptr!]					;-- CPU program counter value
	alias		[integer!]					;-- aliases ID virtual access
]

;-------------------------------------------
;-- Convert a type ID to a c-string!
;-------------------------------------------
form-type: func [
	type 	[integer!]				  		;-- type ID
	return: [c-string!]						;-- type representation as c-string
][
	if type = type-integer!    [return "integer!"]
	if type = type-c-string!   [return "c-string!"]
	if type = type-logic! 	   [return "logic!"]
	if type = type-byte! 	     [return "byte!"]
	if type = type-byte-ptr!   [return "pointer! [byte!]"]
	if type = type-int-ptr!    [return "pointer! [integer!]"]
	if type = type-struct!     [return "struct!"]
	if type = type-function!   [return "function!"]
	if alias? type             [return "alias"]
	"not valid type"
]

#switch OS [
	Windows  [#define LIBC-file	"msvcrt.dll"]
	Syllable [#define LIBC-file	"libc.so.2"]
	MacOSX	 [#define LIBC-file	"libc.dylib"]
	#default [
		#either config-name = 'Android [	;-- @@ see if declaring it as an OS wouldn't be too costly
			#define LIBC-file	"libc.so"
		][
			#define LIBC-file	"libc.so.6"	;-- Linux
		]
	]
]

#either use-natives? = no [					;-- C bindings or native counterparts
	#include %lib-C.reds
][
	#include %lib-natives.reds
]

#switch OS [								;-- loading OS-specific bindings
	Windows  [#include %win32.reds]
	Syllable [#include %syllable.reds]
	MacOSX	 [#include %darwin.reds]
	#default [#include %linux.reds]
]

#include %utils.reds						;-- load additional utility functions

#if debug? = yes [#include %debug.reds]		;-- loads optionally debug functions

;-- Run-time error handling --

#define RED_ERR_VMEM_RELEASE_FAILED		96
#define RED_ERR_VMEM_OUT_OF_MEMORY		97

***-on-quit: func [							;-- global exit handler
	status [integer!]
	address [integer!]
	/local msg
][
	unless zero? status [
		print [lf "*** Runtime Error " status ": "]

		if status =  1 [msg: "access violation"]
		if status =  2 [msg: "invalid alignment"]
		if status =  3 [msg: "breakpoint"]
		if status =  4 [msg: "single step"]
		if status =  5 [msg: "bounds exceeded"]
		if status =  6 [msg: "float denormal operan"]
		if status =  7 [msg: "float divide by zero"]
		if status =  8 [msg: "float inexact result"]
		if status =  9 [msg: "float invalid operation"]
		if status = 10 [msg: "float overflow"]
		if status = 11 [msg: "float stack check"]
		if status = 12 [msg: "float underflow"]
		if status = 13 [msg: "integer divide by zero"]
		if status = 14 [msg: "integer overflow"]
		if status = 15 [msg: "privileged instruction"]
		if status = 16 [msg: "invalid virtual address"]
		if status = 17 [msg: "illegal instruction"]
		if status = 18 [msg: "non-continuable exception"]
		if status = 19 [msg: "stack error or overflow"]
		if status = 20 [msg: "invalid disposition"]
		if status = 21 [msg: "guard page"]
		if status = 22 [msg: "invalid handle"]
		if status = 23 [msg: "illegal operand"]
		if status = 24 [msg: "illegal addressing mode"]
		if status = 25 [msg: "illegal trap"]
		if status = 26 [msg: "coprocessor error"]
		if status = 27 [msg: "non-existant physical address"]
		if status = 28 [msg: "object specific hardware error"]
		if status = 29 [msg: "hardware memory error consumed AR"]
		if status = 30 [msg: "hardware memory error consumed AO"]
		if status = 31 [msg: "privileged register"]

		if status = 96 [msg: "virtual memory release failed"]
		if status = 97 [msg: "out of memory"]
		if status = 98 [msg: "assertion failed"]
		if status = 99 [msg: "unknown error"]

		print msg

		#either debug? = yes [
			__print-debug-line as byte-ptr! address
		][
			print [lf "*** at: " as byte-ptr! address "h" lf]
		]
	]

	#if OS = 'Windows [						;-- special exit handler for Windows
		***-on-win32-quit
	]
	quit status
]