FEAT: read-from-pipe, buffer allocation improved

Red/System [
	Title:  "Red/System call binding"
	Author: "Bruno Anselme"
	EMail:  "be.red@free.fr"
	File:   %call.reds
	Rights: "Copyright (c) 2014 Bruno Anselme"
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
	Needs: {
		Red/System >= 0.4.1
		%stdio.reds
		%unistd.reds
		%windows.reds
	}
	Purpose: {
		This binding implements a call function for Red/System (similar to rebol's call function).
		POSIX version uses "wordexp" function to perform word expansion.
		Windows version performs home made string parsing (no expansion nor substitution).
		Any proposal to improve this parsing (with native Windows functions) is welcome.
	}
	Reference: {
		POSIX wordexp :
		http://pubs.opengroup.org/onlinepubs/9699919799/functions/wordexp.html
	}
]

#include %../stdio.reds
#switch OS [
	Windows   [ #include %../windows.reds ]
	#default  [ #include %../unistd.reds  ]
]

#define READ-BUFFER-SIZE 4096

p-buffer!: alias struct! [                              ;-- Data buffer struct, pointer and count
	count  [integer!]
	buffer [byte-ptr!]
]

f-desc!: alias struct! [                                ;-- Files descriptors for pipe
	reading  [integer!]
	writing  [integer!]
]

system-call: context [
with stdcalls [
	outputs: declare struct! [                          ;--  Global var to store outputs values before setting call /output and /error refinements
		out    [p-buffer!]
		err    [p-buffer!]
	]

	free-str-array: func [ "Free str-array! created by word-expand"
		args [str-array!]
		/local n
	][
		n: 0
		while [ args/item <> null ][
			free as byte-ptr! args/item
			args: args + 1
			n: n + 1
		]
		args: args  - n
		free as byte-ptr! args
	]
	resize-buffer: func [   "Reallocate buffer, error check"
		buffer       [byte-ptr!]
		newsize      [integer!]
		return:      [byte-ptr!]
	][
		tmp: re-allocate buffer newsize                 ;-- Resize output buffer to new size
		either tmp = null [                             ;-- reallocation failed, uses current output buffer
			print [ "Red/System resize-buffer : Memory allocation failed." lf ]
			halt
		][ buffer: tmp ]
		return buffer
	]

	#switch OS [
	Windows   [                                         ;-- Windows
		read-from-pipe: func [      "Read data from pipe fd into buffer"
			fd           [opaque!]      "File descriptor"
			data         [p-buffer!]
			/local len size total
		][
			size: READ-BUFFER-SIZE                      ;-- get initial buffer size
			total: 0
			until [
				len: 0
				read-file fd (data/buffer + total) (size - total) :len null
				if len > 0 [
				    total: total + len
				    if total = size [
				        size: 2 * size
				        data/buffer: resize-buffer data/buffer size
				    ]
				]
				get-last-error = ERROR_BROKEN_PIPE      ;-- Pipe done - normal exit
			]
			data/buffer: resize-buffer data/buffer (total + 1)    ;-- Resize output buffer to minimum size
			data/count: total
;			dump-memory data/buffer 1 (1 + (total / 16));-- uncomment this line for debug and compile with '-d' option
		] ; read-from-pipe
		call: func [ "Executes a DOS command to run another process."
			cmd           [c-string!]  "The shell command"
			waitend       [logic!]     "Wait for end of command, implicit if any buffer is set"
			console       [logic!]     "Redirect outputs to console"
			in-buf        [p-buffer!]  "Input data buffer or null"
			out-buf       [p-buffer!]  "Output data buffer or null"
			err-buf       [p-buffer!]  "Error data buffer or null"
			return:       [integer!]
			/local
				pid        [integer!]
				inherit    [logic!]
				in-read    [opaque!]
				in-write   [opaque!]
				out-read   [opaque!]
				out-write  [opaque!]
				err-read   [opaque!]
				err-write  [opaque!]
				sa p-inf s-inf len success error
		][
			s-inf: declare startup-info!
			p-inf: declare process-info!
			sa: declare security-attributes!
			sa/nLength: size? sa
			sa/lpSecurityDescriptor: 0
			sa/bInheritHandle: true
			out-read:  0
			out-write: 0
			in-read:   0
			in-write:  0
			err-read:  0
			err-write: 0
			inherit: false
			s-inf/cb: size? s-inf
			s-inf/dwFlags: 0
			s-inf/hStdInput:  stdin
			s-inf/hStdOutput: stdout
			s-inf/hStdError:  stderr
			if in-buf <> null [
				if not create-pipe :in-read :in-write sa 0 [ ;-- Create a pipe for child's input
					print "Error Red/System call : stdin pipe creation failed^/"   return -1
				]
				if not set-handle-information in-read HANDLE_FLAG_INHERIT 0 [
					print "Error Red/System call : SetHandleInformation failed^/"  return -1
				]
				s-inf/hStdInput: in-read
			]
			if out-buf <> null [
				out-buf/count: 0
				out-buf/buffer: allocate READ-BUFFER-SIZE
				if not create-pipe :out-read :out-write sa 0 [ ;-- Create a pipe for child's output
					print "Error Red/System call : stdout pipe creation failed^/"  return -1
				]
				if not set-handle-information out-read HANDLE_FLAG_INHERIT 0 [
					print "Error Red/System call : SetHandleInformation failed^/"  return -1
				]
				s-inf/hStdOutput: out-write
			]
			if err-buf <> null [
				err-buf/count: 0
				err-buf/buffer: allocate READ-BUFFER-SIZE
				if not create-pipe :err-read :err-write sa 0 [ ;-- Create a pipe for child's error output
					print "Error Red/System call : stderr pipe creation failed^/"  return -1
				]
				if not set-handle-information err-read HANDLE_FLAG_INHERIT 0 [
					print "Error Red/System call : SetHandleInformation failed^/"  return -1
				]
				s-inf/hStdError:  err-write
			]
			if any [ (in-buf <> null) (out-buf <> null) (err-buf <> null) ] [
				waitend: false                          ;-- child's process is completed after end of pipe
				inherit: true
				s-inf/dwFlags: STARTF_USESTDHANDLES
			]
			if not console [
				if in-buf  = null [ s-inf/hStdInput:  0 ]
				if out-buf = null [ s-inf/hStdOutput: 0 ]
				if err-buf = null [ s-inf/hStdError:  0 ]
				inherit: true
				s-inf/dwFlags: STARTF_USESTDHANDLES
			]

			if not create-process null cmd 0 0 inherit 0 0 null s-inf p-inf [
				print [ "Error Red/System call : CreateProcess : ^"" cmd "^" Error : " get-last-error "^/" ]
				return -1
			]

			either waitend [
				wait-for-single-object p-inf/hProcess INFINITE
				pid: 0
			][
				pid: p-inf/dwProcessId
			]
			if in-buf <> null [       ;-- FIX: to be debugged, doesn't work
				close-handle in-read
				success: true
				len: in-buf/count
				success: write-file in-write in-buf/buffer in-buf/count :len null
				if not success [
;					print [ "Error  : " get-last-error lf ]
;					print [ "Length : " len lf ]
					print "Error Red/System call : write into pipe failed^/"
				]
				close-handle in-write
				pid: 0
			]
			if out-buf <> null [
				close-handle out-write
				read-from-pipe out-read out-buf
				close-handle out-read
				pid: 0
			]
			if err-buf <> null [
				close-handle err-write
				read-from-pipe err-read err-buf
				close-handle err-read
				pid: 0
			]
			close-handle p-inf/hProcess
			close-handle p-inf/hThread
			outputs/out: out-buf                        ;-- Store values in global var
			outputs/err: err-buf
			return pid
		] ; call
	] ; Windows
	#default  [                                         ;-- POSIX
		read-from-pipe: func [ "Read data from pipe fd into buffer"
			fd        [f-desc!]   "File descriptor"
			data      [p-buffer!]
			/local len size total
		][
			close fd/writing                            ;-- close unused pipe end
			size: READ-BUFFER-SIZE                      ;-- initial buffer size and grow step
			total: 0
			until [
				len: ioread fd/reading (data/buffer + total) (size - total)    ;-- read pipe, store into buffer
				if len > -1 [                           ;-- FIX: there's something wrong here, need to test errno
					total: total + len
					if total = size [                   ;-- buffer must be expanded
						size: 2 * size
						data/buffer: resize-buffer data/buffer size
					]
				]
				len = 0
			]
			data/buffer: resize-buffer data/buffer (total + 1)  ;-- Resize output buffer to minimum size
			data/count: total
			close fd/reading                            ;-- close other pipe end
		] ; read-from-pipe
		call: func [                   "Executes a shell command, IO redirections to buffers."
			cmd			[c-string!]    "The shell command"
			waitend		[logic!]       "Wait for end of command, implicit if any buffer is set"
			console		[logic!]       "Redirect outputs to console"
			in-buf		[p-buffer!]    "Input data buffer or null"
			out-buf		[p-buffer!]    "Output data buffer or null "
			err-buf		[p-buffer!]    "Error data buffer or null"
			return:		[integer!]
			/local pid status err wexp fd-in fd-out fd-err
		][
			if in-buf <> null [
				fd-in: declare f-desc!
				if (pipe as int-ptr! fd-in) = -1 [     ; Create a pipe for child's input
					print "Error Red/System call : Input pipe creation failed^/"  return -1
				]
			]
			if out-buf <> null [
				out-buf/count: 0
				out-buf/buffer: allocate READ-BUFFER-SIZE
				fd-out: declare f-desc!
				if (pipe as int-ptr! fd-out) = -1 [    ; Create a pipe for child's output
					print "Error Red/System call : Output pipe creation failed^/"  return -1
				]
			]
			if err-buf <> null [
				err-buf/count: 0
				err-buf/buffer: allocate READ-BUFFER-SIZE
				fd-err: declare f-desc!
				if (pipe as int-ptr! fd-err) = -1 [    ; Create a pipe for child's error
					print "Error Red/System call : Error pipe creation failed^/"  return -1
				]
			]
			pid: fork
			either pid = 0 [                            ;-- Child process
				if in-buf <> null [                     ;-- redirect stdin to the pipe
					close fd-in/writing
					err: dup2 fd-in/reading stdin
					if err = -1 [ print "Error Red/System call : Error dup2 stdin^/" return -1 ]
					close fd-in/reading
				]
				if out-buf <> null [                    ;-- redirect stdout to the pipe
					close fd-out/reading
					err: dup2 fd-out/writing stdout
					if err = -1 [ print "Error Red/System call : Error dup2 stdout^/" return -1 ]
					close fd-out/writing
				]
				if err-buf <> null [                    ;-- redirect stderr to the pipe
					close fd-err/reading
					err: dup2 fd-err/writing stderr
					if err = -1 [ print "Error Red/System call : Error dup2 stderr^/" return -1 ]
					close fd-err/writing
				]
				if not console [
					if in-buf  = null [ close stdin ]
					if out-buf = null [ close stdout ]
					if err-buf = null [ close stderr ]
				]
				wexp: declare wordexp-type!             ;-- Create wordexp struct
				status: wordexp cmd wexp WRDE_SHOWERR   ;-- Parse cmd into str-array
				either status = 0 [                     ;-- Parsing ok
					execvp wexp/we_wordv/item wexp/we_wordv ;-- Process is launched here, execvp with str-array parameters
					print [ "Error Red/System call while calling execvp : {" cmd "}" lf ]  ;-- Should never occur
					quit 1
				][                                      ;-- Parsing nok
					print [ "Error Red/System call, wordexp parsing command : " cmd lf ]
					switch status [
						WRDE_NOSPACE [ print [ "Attempt to allocate memory failed" lf ] ]
						WRDE_BADCHAR [ print [ "Use of the unquoted characters- <newline>, '|', '&', ';', '<', '>', '(', ')', '{', '}'" lf ] ]
						WRDE_BADVAL  [ print [ "Reference to undefined shell variable" lf ] ]
						WRDE_CMDSUB  [ print [ "Command substitution requested" lf ] ]
						WRDE_SYNTAX  [ print [ "Shell syntax error, such as unbalanced parentheses or unterminated string" lf ] ]
					]
					if in-buf  <> null [ free in-buf/buffer  ] ;-- free allocated buffers before exit
					if out-buf <> null [ free out-buf/buffer ]
					if err-buf <> null [ free err-buf/buffer ]
					return -1
				]
			][                                          ;-- Parent process
				if in-buf <> null [                     ;-- write input buffer to child process' stdin
					close fd-in/reading
					iowrite fd-in/writing in-buf/buffer in-buf/count
					close fd-in/writing
					waitend: true
				]
				if out-buf <> null [
					read-from-pipe fd-out out-buf       ;-- read output buffer from child process' stdout
					waitend: false                      ;-- child's process is completed after end of pipe
					pid: 0                              ;-- Process is completed, return 0
				]
				if err-buf <> null [                    ;-- Same with error stream
					read-from-pipe fd-err err-buf
					waitend: false
					pid: 0
				]
				if waitend [
					status: 0
					waitpid pid :status 0               ;-- Wait child process terminate
					pid: 0                              ;-- Process is completed, return 0
				]
				outputs/out: out-buf                    ;-- Store values in global var
				outputs/err: err-buf
			] ; either pid
			return pid
		] ; call
	] ; #default
	] ; #switch
] ; with stdcalls
] ; context

Red/System [
	Title:  "Red/System call binding"
	Author: "Bruno Anselme"
	EMail:  "be.red@free.fr"
	File:   %call.reds
	Rights: "Copyright (c) 2014 Bruno Anselme"
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
	Needs: {
		Red/System >= 0.4.1
		%stdio.reds
		%unistd.reds
		%windows.reds
	}
	Purpose: {
		This binding implements a call function for Red/System (similar to rebol's call function).
		POSIX version uses "wordexp" function to perform word expansion.
		Windows version performs home made string parsing (no expansion nor substitution).
		Any proposal to improve this parsing (with native Windows functions) is welcome.
	}
	Reference: {
		POSIX wordexp :
		http://pubs.opengroup.org/onlinepubs/9699919799/functions/wordexp.html
	}
]

#include %../stdio.reds
#switch OS [
	Windows   [ #include %../windows.reds ]
	#default  [ #include %../unistd.reds  ]
]

#define READ-BUFFER-SIZE 4096

p-buffer!: alias struct! [                              ;-- Data buffer struct, pointer and count
	count  [integer!]
	buffer [byte-ptr!]
]

f-desc!: alias struct! [                                ;-- Files descriptors for pipe
	reading  [integer!]
	writing  [integer!]
]

system-call: context [
with stdcalls [
	outputs: declare struct! [                          ;--  Global var to store outputs values before setting call output and error refinements
		out    [p-buffer!]
		err    [p-buffer!]
	]

	free-str-array: func [ "Free str-array! created by word-expand"
		args [str-array!]
		/local n
	][
		n: 0
		while [ args/item <> null ][
			free as byte-ptr! args/item
			args: args + 1
			n: n + 1
		]
		args: args  - n
		free as byte-ptr! args
	]

	print-str-array: func [ "Print str-array, used for debug"
		args [str-array!]
	][
		while [ args/item <> null ][
			print [ "- " args/item lf ]
			args: args + 1
		]
	]

	resize-buffer: func [   "Reallocate buffer, error check"
		buffer       [byte-ptr!]
		newsize      [integer!]
		return:      [byte-ptr!]
	][
		tmp: re-allocate buffer newsize                 ;-- Resize output buffer to new size
		either tmp = null [                             ;-- reallocation failed, uses current output buffer
			print [ "Red/System resize-buffer : Memory allocation failed." lf ]
			halt
		][ buffer: tmp ]
		return buffer
	]

	#switch OS [
	Windows   [                                         ;-- Windows, use minimal home made parsing
		read-from-pipe: func [      "Read data from pipe fd into buffer"
			fd           [opaque!]      "File descriptor"
			data         [p-buffer!]
			/local
				len          [integer!]
				count        [integer!]
				total        [integer!]
				success      [logic!]
		][
			len: READ-BUFFER-SIZE                       ;-- initial buffer size and grow step
			count: 0
			total: 0
			success: true
			until [
				len: 0
				success: read-file fd (data/buffer + total) (READ-BUFFER-SIZE - count) :len null
				if len > 0 [
				    total: total + len
				    count: count + len
				    if count = READ-BUFFER-SIZE [
				        data/buffer: resize-buffer data/buffer (total + READ-BUFFER-SIZE)
				        count: 0
				    ]
				]
;				any [ (not success) (len = 0) ]
				get-last-error = ERROR_BROKEN_PIPE      ;-- Pipe done - normal exit
			]
			data/buffer: resize-buffer data/buffer (total + 1)    ;-- Resize output buffer to minimum size
			data/count: total
;			dump-memory data/buffer 1 (1 + (total / 16))        ;-- uncomment this line for debug and compile with '-d' option
		] ; read-from-pipe
		call: func [ "Executes a DOS command to run another process."
			cmd           [c-string!]    "The shell command"
			waitend       [logic!]       "Wait for end of command, implicit if any buffer is set"
			console       [logic!]       "Redirect outputs to console"
			in-buf        [p-buffer!]    "Pointer to input data or null"
			out-buf       [p-buffer!]    "Pointer to output data buffer or null"
			err-buf       [p-buffer!]    "Pointer to error data buffer or null"
			return:       [integer!]
			/local
				pid        [integer!]
				inherit    [logic!]
				in-read    [opaque!]
				in-write   [opaque!]
				out-read   [opaque!]
				out-write  [opaque!]
				err-read   [opaque!]
				err-write  [opaque!]
				sa p-inf s-inf len success error
		][
			s-inf: declare startup-info!
			p-inf: declare process-info!
			sa: declare security-attributes!
			sa/nLength: size? sa
			sa/lpSecurityDescriptor: 0
			sa/bInheritHandle: true
			out-read:  0
			out-write: 0
			in-read:   0
			in-write:  0
			err-read:  0
			err-write: 0
			inherit: false
			s-inf/cb: size? s-inf
			s-inf/dwFlags: 0
			s-inf/hStdInput:  stdin
			s-inf/hStdOutput: stdout
			s-inf/hStdError:  stderr
			if in-buf <> null [
				if not create-pipe :in-read :in-write sa 0 [ ;-- Create a pipe for child's input
					print "Error Red/System call : stdin pipe creation failed^/"   return -1
				]
				if not set-handle-information in-read HANDLE_FLAG_INHERIT 0 [
					print "Error Red/System call : SetHandleInformation failed^/"  return -1
				]
				s-inf/hStdInput: in-read
			]
			if out-buf <> null [
				out-buf/count: 0
				out-buf/buffer: allocate READ-BUFFER-SIZE
				if not create-pipe :out-read :out-write sa 0 [ ;-- Create a pipe for child's output
					print "Error Red/System call : stdout pipe creation failed^/"  return -1
				]
				if not set-handle-information out-read HANDLE_FLAG_INHERIT 0 [
					print "Error Red/System call : SetHandleInformation failed^/"  return -1
				]
				s-inf/hStdOutput: out-write
			]
			if err-buf <> null [
				err-buf/count: 0
				err-buf/buffer: allocate READ-BUFFER-SIZE
				if not create-pipe :err-read :err-write sa 0 [ ;-- Create a pipe for child's error output
					print "Error Red/System call : stderr pipe creation failed^/"  return -1
				]
				if not set-handle-information err-read HANDLE_FLAG_INHERIT 0 [
					print "Error Red/System call : SetHandleInformation failed^/"  return -1
				]
				s-inf/hStdError:  err-write
			]
			if any [ (in-buf <> null) (out-buf <> null) (err-buf <> null) ] [
				waitend: false                          ;-- child's process is completed after end of pipe
				inherit: true
				s-inf/dwFlags: STARTF_USESTDHANDLES
			]
			if not console [
				if in-buf  = null [ s-inf/hStdInput:  0 ]
				if out-buf = null [ s-inf/hStdOutput: 0 ]
				if err-buf = null [ s-inf/hStdError:  0 ]
				inherit: true
				s-inf/dwFlags: STARTF_USESTDHANDLES
			]

			if not create-process null cmd 0 0 inherit 0 0 null s-inf p-inf [
				print [ "Error Red/System call : CreateProcess : ^"" cmd "^" Error : " get-last-error "^/" ]
				return -1
			]

			either waitend [
				wait-for-single-object p-inf/hProcess INFINITE
				pid: 0
			][
				pid: p-inf/dwProcessId
			]
			if in-buf <> null [       ;-- FIX: to be debugged, doesn't work
				close-handle in-read
				success: true
				len: in-buf/count
				success: write-file in-write in-buf/buffer in-buf/count :len null
				if not success [
;					print [ "Error  : " get-last-error lf ]
;					print [ "Length : " len lf ]
					print "Error Red/System call : write into pipe failed^/"
				]
				close-handle in-write
				pid: 0
			]
			if out-buf <> null [
				close-handle out-write
				read-from-pipe out-read out-buf
				close-handle out-read
				pid: 0
			]
			if err-buf <> null [
				close-handle err-write
				read-from-pipe err-read err-buf
				close-handle err-read
				pid: 0
			]
			close-handle p-inf/hProcess
			close-handle p-inf/hThread
			outputs/out: out-buf                        ;-- Store values in global var
			outputs/err: err-buf
			return pid
		] ; call
	] ; Windows
	#default  [                                         ;-- POSIX
		read-from-pipe: func [      "Read data from pipe fd into buffer"
			fd           [f-desc!]       "File descriptor"
			data         [p-buffer!]
			/local
				cpt          [integer!]
				total        [integer!]
		][
			close fd/writing                            ;-- close unused pipe end
			cpt: READ-BUFFER-SIZE                       ;-- initial buffer size and grow step
			total: 0
			while [cpt = READ-BUFFER-SIZE ][                   ; FIX: there's something wrong here, need to test errno
				cpt: ioread fd/reading (data/buffer + total) READ-BUFFER-SIZE    ; read pipe, store into buffer
				if cpt > -1 [
					total: total + cpt
					if cpt = READ-BUFFER-SIZE [                                      ; buffer must be expanded
						data/buffer: resize-buffer data/buffer (total + READ-BUFFER-SIZE)
					]
				]
			]
			data/buffer: resize-buffer data/buffer (total + 1)                 ; Resize output buffer to minimum size
			data/count: total
			close fd/reading                                                   ; close other pipe end
		] ; read-from-pipe
		expand-and-exec: func[         "Use wordexp to parse command and run it. Halt if error. Should never return"
			cmd          [c-string!]       "The shell command"
			return:      [integer!]
			/local
			status       [integer!]
			wexp
		][
			wexp: as wordexp-type! allocate size? wordexp-type!      ; Create wordexp struct
			status: wordexp cmd wexp WRDE_SHOWERR                              ; Parse cmd into str-array
			either status = 0 [                           ; Parsing ok
	;          print-str-array wexp/we_wordv                         ; Debug: Print expanded values
				execvp wexp/we_wordv/item wexp/we_wordv                ; Call execvp with str-array parameters
				print [ "Error Red/System call while calling execvp : {" cmd "}" lf ]  ; Should never occur
				quit 1
			][                                            ; Parsing nok
				print [ "Error Red/System call, wordexp parsing command : " cmd lf ]
				switch status [
					WRDE_NOSPACE [ print [ "Attempt to allocate memory failed" lf ] ]
					WRDE_BADCHAR [ print [ "Use of the unquoted characters- <newline>, '|', '&', ';', '<', '>', '(', ')', '{', '}'" lf ] ]
					WRDE_BADVAL  [ print [ "Reference to undefined shell variable" lf ] ]
					WRDE_CMDSUB  [ print [ "Command substitution requested" lf ] ]
					WRDE_SYNTAX  [ print [ "Shell syntax error, such as unbalanced parentheses or unterminated string" lf ] ]
				]
				quit status
			]
			return -1
		] ; expand-and-exec

		call: func [                   "Executes a shell command, IO redirections to buffers."
			cmd			[c-string!]    "The shell command"
			waitend		[logic!]       "Wait for end of command, implicit if any buffer is set"
			console		[logic!]       "Redirect outputs to console"
			in-buf		[p-buffer!]    "Pointer to input data or null"
			out-buf		[p-buffer!]    "Pointer to output data buffer or null"
			err-buf		[p-buffer!]    "Pointer to error data buffer or null"
			return:		[integer!]
			/local
				pid          [integer!]
				status       [integer!]
				err          [integer!]
				fd-in fd-out fd-err
			][
			if in-buf <> null [
				fd-in: declare f-desc!
				if (pipe as int-ptr! fd-in) = -1 [     ; Create a pipe for child's input
					print "Error Red/System call : Input pipe creation failed^/"  return -1
				]
			]
			if out-buf <> null [
				out-buf/count: 0
				out-buf/buffer: allocate READ-BUFFER-SIZE
				fd-out: declare f-desc!
				if (pipe as int-ptr! fd-out) = -1 [    ; Create a pipe for child's output
					print "Error Red/System call : Output pipe creation failed^/"  return -1
				]
			]
			if err-buf <> null [
				err-buf/count: 0
				err-buf/buffer: allocate READ-BUFFER-SIZE
				fd-err: declare f-desc!
				if (pipe as int-ptr! fd-err) = -1 [    ; Create a pipe for child's error
					print "Error Red/System call : Error pipe creation failed^/"  return -1
				]
			]
			pid: fork
			either pid = 0 [                        ;----- Child process -----
				if in-buf <> null [                   ; redirect stdin to the pipe
					close fd-in/writing
					err: dup2 fd-in/reading stdin
					if err = -1 [ print "Error Red/System call : Error dup2 stdin^/" return -1 ]
					close fd-in/reading
				]
				if out-buf <> null [                  ; redirect stdout to the pipe
					close fd-out/reading
					err: dup2 fd-out/writing stdout
					if err = -1 [ print "Error Red/System call : Error dup2 stdout^/" return -1 ]
					close fd-out/writing
				]
				if err-buf <> null [                  ; redirect stderr to the pipe
					close fd-err/reading
					err: dup2 fd-err/writing stderr
					if err = -1 [ print "Error Red/System call : Error dup2 stderr^/" return -1 ]
					close fd-err/writing
				]
				if not console [
					if in-buf  = null [ close stdin ]
					if out-buf = null [ close stdout ]
					if err-buf = null [ close stderr ]
				]
				expand-and-exec cmd
			][                                      ;----- Parent process -----
				if in-buf <> null [                   ; write input buffer to child process' stdin
					close fd-in/reading
					iowrite fd-in/writing in-buf/buffer in-buf/count
					close fd-in/writing
					waitend: true
				]
				if out-buf <> null [                  ; read output from pipe, store in buffer
					read-from-pipe fd-out out-buf       ; read output buffer from child process' stdout
					waitend: false                      ; child's process is completed after end of pipe
					pid: 0                              ; Process is completed, return 0
				]
				if err-buf <> null [                  ; Same with error stream
					read-from-pipe fd-err err-buf
					waitend: false
					pid: 0
				]
				if waitend [
					status: 0
					waitpid pid :status 0               ; Wait child process terminate
					pid: 0                              ; Process is completed, return 0
				]
				outputs/out: out-buf                  ; Store values in global var
				outputs/err: err-buf
			] ; either pid
			return pid
		] ; call

	] ; #default
	] ; #switch
] ; with stdcalls
] ; context


FIX: memory allocation of bigger-than-base-frame series was not safe enough.

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

#define _512KB				524288
#define _2MB				2097152
#define _16MB				16777216
#define nodes-per-frame		5000
#define node-frame-size		[((nodes-per-frame * 2 * size? pointer!) + size? node-frame!)]

#define series-in-use		80000000h		;-- mark a series as used (not collectable by the GC)
#define flag-ins-both		30000000h		;-- optimize for both head & tail insertions
#define flag-ins-tail		20000000h		;-- optimize for tail insertions
#define flag-ins-head		10000000h		;-- optimize for head insertions
#define flag-series-big		01000000h		;-- 1 = big, 0 = series
#define flag-series-small	00800000h		;-- series <= 16 bytes
#define flag-series-stk		00400000h		;-- values block allocated on stack
#define flag-series-nogc	00200000h		;-- protected from GC (system-critical series)
#define flag-series-fixed	00100000h		;-- series cannot be relocated (system-critical series)

#define flag-arity-mask		C1FFFFFFh		;-- mask for routines arity field
#define flag-unit-mask		FFFFFFE0h		;-- mask for unit field in series-buffer!
#define get-unit-mask		0000001Fh		;-- mask for unit field in series-buffer!
#define series-free-mask	7FFFFFFFh		;-- mark a series as used (not collectable by the GC)

#define type-mask			FFFFFF00h		;-- mask for clearing type ID in cell header
#define get-type-mask		000000FFh		;-- mask for reading type ID in cell header
#define node!				int-ptr!
#define default-offset		-1				;-- for offset value in alloc-series calls

#define series!				series-buffer!

int-array!: alias struct! [ptr [int-ptr!]]

;-- cell header bits layout --
;   31:		lock							;-- lock series for active thread access only
;   30:		new-line						;-- new-line (LF) marker (before the slot)
;	29-25:	arity							;-- arity for routine! functions.
;   24-8:	<reserved>
;   7-0:	datatype ID						;-- datatype number

cell!: alias struct! [
	header	[integer!]						;-- cell's header flags
	data1	[integer!]						;-- placeholders to make a 128-bit cell
	data2	[integer!]
	data3	[integer!]
]

;-- series flags --
;	31: 	used 							;-- 1 = used, 0 = free
;	30: 	type 							;-- always 0 for series-buffer!
;	29-28: 	insert-opt						;-- optimized insertions: 2 = head, 1 = tail, 0 = both
;   27:		mark							;-- mark as referenced for the GC (mark phase)
;   26:		lock							;-- lock series for active thread access only
;   25:		immutable						;-- mark as read-only
;   24:		big								;-- indicates a big series (big-frame!)
;	23:		small							;-- reserved
;	22:		stack							;-- series buffer is allocated on stack
;   21:		permanent						;-- protected from GC (system-critical series)
;   20:     fixed							;-- series cannot be relocated (system-critical series)
;	19-3: 	<reserved>
;	4-0:	unit							;-- size in bytes of atomic element stored in buffer
											;-- 0: UTF-8, 1: Latin1/binary, 2: UCS-2, 4: UCS-4, 16: block! cell
series-buffer!: alias struct! [
	flags	[integer!]						;-- series flags
	node	[int-ptr!]						;-- point back to referring node
	size	[integer!]						;-- usable buffer size (series-buffer! struct excluded)
	offset	[cell!]							;-- series buffer offset pointer (insert at head optimization)
	tail	[cell!]							;-- series buffer tail pointer
]

series-frame!: alias struct! [				;-- series frame header
	next	[series-frame!]					;-- next frame or null
	prev	[series-frame!]					;-- previous frame or null
	heap	[series-buffer!]				;-- point to allocatable region
	tail	[byte-ptr!]						;-- point to last byte in allocatable region
]

node-frame!: alias struct! [				;-- node frame header
	next	[node-frame!]					;-- next frame or null
	prev	[node-frame!]					;-- previous frame or null
	nodes	[integer!]						;-- number of nodes
	bottom	[int-ptr!]						;-- bottom of stack (last entry, fixed)
	top		[int-ptr!]						;-- top of stack (first entry, moving)
]

big-frame!: alias struct! [					;-- big frame header (for >= 2MB series)
	flags	[integer!]						;-- bit 30: 1 (type = big)
	next	[big-frame!]					;-- next frame or null
	size	[integer!]						;-- size (up to 4GB - size? header)
	padding [integer!]						;-- make this header same size as series-buffer! header
]

memory: declare struct! [					; TBD: instanciate this structure per OS thread
	total	 [integer!]						;-- total memory size allocated (in bytes)
	n-head	 [node-frame!]					;-- head of node frames list
	n-active [node-frame!]					;-- actively used node frame
	n-tail	 [node-frame!]					;-- tail of node frames list
	s-head	 [series-frame!]				;-- head of series frames list
	s-active [series-frame!]				;-- actively used series frame
	s-tail	 [series-frame!]				;-- tail of series frames list
	s-start	 [integer!]						;-- start size for new series frame		(1)
	s-size	 [integer!]						;-- current size for new series frame	(1)
	s-max	 [integer!]						;-- max size for new series frames		(1)
	b-head	 [big-frame!]					;-- head of big frames list
]

init-mem: does [
	memory/total: 	0
	memory/s-start: _512KB
	memory/s-max: 	_2MB
	memory/s-size: 	memory/s-start
]

;; (1) Series frames size will grow from 512KB up to 2MB (arbitrary selected). This
;; range will need fine-tuning with real Red apps. This growing size, with low starting value
;; will allow small apps to not consume much memory while avoiding to penalize big apps.

;-------------------------------------------
;-- Allocate paged virtual memory region
;-------------------------------------------
allocate-virtual: func [
	size 	[integer!]						;-- allocated size in bytes (page size multiple)
	exec? 	[logic!]						;-- TRUE => executable region
	return: [int-ptr!]						;-- allocated memory region pointer
	/local ptr
][
	size: round-to size + 4	platform/page-size	;-- account for header (one word)
	memory/total: memory/total + size
	ptr: platform/allocate-virtual size exec?
	ptr/value: size							;-- store size in header
	ptr + 1									;-- return pointer after header
]

;-------------------------------------------
;-- Free paged virtual memory region from OS
;-------------------------------------------
free-virtual: func [
	ptr [int-ptr!]							;-- address of memory region to release
][
	ptr: ptr - 1							;-- return back to header
	memory/total: memory/total - ptr/value
	platform/free-virtual ptr
]

;-------------------------------------------
;-- Free all frames (part of Red's global exit handler)
;-------------------------------------------
free-all: func [
	/local n-frame s-frame b-frame n-next s-next b-next
][
	n-frame: memory/n-head
	while [n-frame <> null][
		n-next: n-frame/next
		free-virtual as int-ptr! n-frame
		n-frame: n-next
	]

	s-frame: memory/s-head
	while [s-frame <> null][
		s-next: s-frame/next
		free-virtual as int-ptr! s-frame
		s-frame: s-next
	]

	b-frame: memory/b-head
	while [b-frame <> null][
		b-next: b-frame/next
		free-virtual as int-ptr! b-frame
		b-frame: b-next
	]
]

;-------------------------------------------
;-- Format the node frame stack by filling it with pointers to all nodes
;-------------------------------------------
format-node-stack: func [
	frame [node-frame!]						;-- node frame to format
	/local node ptr
][
	ptr: frame/bottom						;-- point to bottom of stack
	node: ptr + frame/nodes					;-- first free node address
	until [
		ptr/value: as-integer node			;-- store free node address on stack
		node: node + 1
		ptr: ptr + 1
		ptr > frame/top						;-- until the stack is filled up
	]
]

;-------------------------------------------
;-- Allocate a node frame buffer and initialize it
;-------------------------------------------
alloc-node-frame: func [
	size 	[integer!]						;-- nb of nodes
	return:	[node-frame!]					;-- newly initialized frame
	/local sz frame
][
	assert positive? size
	sz: size * 2 * (size? pointer!) + (size? node-frame!) ;-- total required size for a node frame
	frame: as node-frame! allocate-virtual sz no ;-- R/W only

	frame/prev:  null
	frame/next:  null
	frame/nodes: size

	frame/bottom: as int-ptr! (as byte-ptr! frame) + size? node-frame!
	frame/top: frame/bottom + size - 1		;-- point to the top element

	either null? memory/n-head [
		memory/n-head: frame				;-- first item in the list
		memory/n-tail: frame
		memory/n-active: frame
	][
		memory/n-tail/next: frame			;-- append new item at tail of the list
		frame/prev: memory/n-tail			;-- link back to previous tail
		memory/n-tail: frame				;-- now tail is the new item
	]

	format-node-stack frame					;-- prepare the node frame for use
	frame
]

;-------------------------------------------
;-- Release a node frame buffer
;-------------------------------------------
free-node-frame: func [
	frame [node-frame!]						;-- frame to release
][
	either null? frame/prev [				;-- if frame = head
		memory/n-head: frame/next			;-- head now points to next one
	][
		either null? frame/next [			;-- if frame = tail
			memory/n-tail: frame/prev		;-- tail is now at one position back
		][
			frame/prev/next: frame/next		;-- link preceding frame to next frame
			frame/next/prev: frame/prev		;-- link back next frame to preceding frame
		]
	]
	if memory/n-active = frame [
		memory/n-active: memory/n-tail		;-- reset active frame to last one @@
	]

	assert not all [						;-- ensure that list is not empty
		null? memory/n-head
		null? memory/n-tail
	]

	free-virtual as int-ptr! frame			;-- release the memory to the OS
]

;-------------------------------------------
;-- Obtain a free node from a node frame
;-------------------------------------------
alloc-node: func [
	return: [int-ptr!]						;-- return a free node pointer
	/local frame node
][
	frame: memory/n-active					;-- take node from active node frame
	node: as int-ptr! frame/top/value		;-- pop free node address from stack
	frame/top: frame/top - 1

	if frame/top = frame/bottom [
		; TBD: trigger a "light" GC pass from here and update memory/n-active
		frame: alloc-node-frame nodes-per-frame	;-- allocate a new frame
		memory/n-active: frame				;@@ to be removed once GC implemented
		node: as int-ptr! frame/top/value	;-- pop free node address from stack
		frame/top: frame/top - 1
	]
	node
]

;-------------------------------------------
;-- Release a used node
;-------------------------------------------
free-node: func [
	node [int-ptr!]							;-- node to release
	/local frame offset
][
	assert not null? node

	frame: memory/n-active
	offset: as-integer node - frame

	unless all [
		positive? offset					;-- check if node address is part of active frame
		offset < node-frame-size
	][										;@@ following code not be needed if freed only by the GC...
		frame: memory/n-head				;-- search for right frame from head of the list
		while [								; @@ could be optimized by searching backward/forward from active frame
			offset: as-integer node - frame
			not all [						;-- test if node address is part of that frame
				positive? offset
				offset < node-frame-size	; @@ check upper bound case
			]
		][
			frame: frame/next
			assert frame <> null			;-- should found the right one before the list end
		]
	]

	frame/top: frame/top + 1				;-- free node by pushing its address on stack
	frame/top/value: as-integer node

	assert frame/top < (frame/bottom + frame/nodes)	;-- top should not overflow
]

;-------------------------------------------
;-- Allocate a series frame buffer
;-------------------------------------------
alloc-series-frame: func [
	return:	[series-frame!]					;-- newly initialized frame
	/local size frame
][
	size: memory/s-size
	if size < memory/s-max [memory/s-size: size * 2]

	size: size + size? series-frame! 		;-- total required size for a series frame
	frame: as series-frame! allocate-virtual size no ;-- RW only

	either null? memory/s-head [
		memory/s-head: frame				;-- first item in the list
		memory/s-tail: frame
		memory/s-active: frame
		frame/prev:  null
	][
		memory/s-tail/next: frame			;-- append new item at tail of the list
		frame/prev: memory/s-tail			;-- link back to previous tail
		memory/s-tail: frame				;-- now tail is the new item
	]

	frame/next: null
	frame/heap: as series-buffer! (as byte-ptr! frame) + size? series-frame!
	frame/tail: (as byte-ptr! frame) + size	;-- point to last byte in frame
	frame
]

;-------------------------------------------
;-- Release a series frame buffer
;-------------------------------------------
free-series-frame: func [
	frame [series-frame!]					;-- frame to release
][
	either null? frame/prev [				;-- if frame = head
		memory/s-head: frame/next			;-- head now points to next one
	][
		either null? frame/next [			;-- if frame = tail
			memory/s-tail: frame/prev		;-- tail is now at one position back
		][
			frame/prev/next: frame/next		;-- link preceding frame to next frame
			frame/next/prev: frame/prev		;-- link back next frame to preceding frame
		]
	]
	if memory/s-active = frame [
		memory/s-active: memory/s-tail		;-- reset active frame to last one @@
	]

	assert not all [						;-- ensure that list is not empty
		null? memory/s-head
		null? memory/s-tail
	]

	free-virtual as int-ptr! frame			;-- release the memory to the OS
]

;-------------------------------------------
;-- Update moved series internal pointers
;-------------------------------------------
update-series: func [
	series	[series-buffer!]				;-- start of series region with nodes to re-sync
	offset	[integer!]
][
	until [
		;-- update the node pointer to the new series address
		series/node/value: as-integer series

		;-- update offset and tail pointers
		series/offset: as cell! (as byte-ptr! series/offset) - offset
		series/tail:   as cell! (as byte-ptr! series/tail) - offset

		;-- advance to the next series buffer
		series: as series-buffer! (as byte-ptr! series) + series/size + size? series-buffer!

		;-- exit when a freed series is met (<=> end of region)
		zero? (series/flags and series-in-use)
	]
]

;-------------------------------------------
;-- Compact a series frame by moving down in-use series buffer regions
;-------------------------------------------
#define SM1_INIT		1					;-- enter the state machine
#define SM1_GAP			2					;-- begin of contiguous region of freed buffers (hole)
#define SM1_GAP_END		3					;-- end of freed buffers region
#define SM1_USED		4					;-- begin of contiguous region of buffers in use
#define SM1_USED_END	5					;-- end of used buffers region

compact-series-frame: func [
	frame [series-frame!]					;-- series frame to compact
	/local heap series state
		free? [logic!] src [byte-ptr!] dst [byte-ptr!]
][
	series: as series-buffer! (as byte-ptr! frame) + size? series-frame! ;-- point to first series buffer
	free?: zero? (series/flags and series-in-use)  ;-- true: series is not used
	heap: frame/heap

	src: null								;-- src will point to start of buffer region to move down
	dst: null								;-- dst will point to start of free region
	state: SM1_INIT

	until [
		if all [state = SM1_INIT free?][
			dst: as byte-ptr! series		 ;-- start of gap region
			state: SM1_GAP
		]
		if all [state = SM1_GAP not free?][ ;-- search for first used series (<=> end of gap)
			state: SM1_GAP_END
		]
		if state = SM1_GAP_END [
			src: as byte-ptr! series		 ;-- start of new "alive" region
			state: SM1_USED
		]
	 	;-- point to next series buffer
		series: as series-buffer! (as byte-ptr! series) + series/size  + size? series-buffer!
		free?: zero? (series/flags and series-in-use)  ;-- true: series is not used

		if all [state = SM1_USED any [free? series >= heap]][	;-- handle both normal and "exit" states
			state: SM1_USED_END
		]
		if state = SM1_USED_END [
			assert dst < src				 ;-- regions are moved down in memory
			assert src < as byte-ptr! series ;-- src should point at least at series - series/size
			copy-memory dst	src as-integer series - src
			update-series as series-buffer! dst as-integer src - dst
			dst: dst + (as-integer series - src) ;-- points after moved region (ready for next move)
			state: SM1_GAP
		]
		series >= heap						;-- exit state machine
	]

	unless null? dst [						;-- no compaction occurred, all series were in use
		frame/heap: as series-buffer! dst	;-- set new heap after last moved region
	]
]

;-------------------------------------------
;-- Allocate a series from the active series frame, return the series
;-------------------------------------------
alloc-series-buffer: func [
	usize	[integer!]						;-- size in units
	unit	[integer!]						;-- size of atomic elements stored
	offset	[integer!]						;-- force a given offset for series buffer (in bytes)
	return: [series-buffer!]				;-- return the new series buffer
	/local series size frame sz
][
	assert positive? usize
	size: round-to usize * unit size? cell!	;-- size aligned to cell! size

	frame: memory/s-active
	sz: size + size? series-buffer!			;-- add series header size

	;-- size should not be greater than the frame capacity
	assert sz < as-integer (frame/tail - ((as byte-ptr! frame) + size? series-frame!))

	series: frame/heap
	if ((as byte-ptr! series) + sz) >= frame/tail [
		; TBD: trigger a GC pass from here and update memory/s-active
		if sz >= memory/s-size [				;@@ temporary checks
			memory/s-size: memory/s-max
		]
		if sz >= memory/s-max [				;@@ temporary checks
			print-line "Memory error: series too big!"
			--NOT_IMPLEMENTED--
		]
		frame: alloc-series-frame
		memory/s-active: frame				;@@ to be removed once GC implemented
		series: frame/heap
	]

	assert sz < _16MB						;-- max series size allowed in a series frame @@

	frame/heap: as series-buffer! (as byte-ptr! frame/heap) + sz

	series/size: size
	series/flags: unit
		or series-in-use 					;-- mark series as in-use
		and not flag-series-big				;-- set type bit to 0 (= series)

	either offset = default-offset [
		offset: size >> 1					;-- target middle of buffer
		series/flags: series/flags or flag-ins-both	;-- optimize for both head & tail insertions (default)
	][
		series/flags: series/flags or flag-ins-tail ;-- optimize for tail insertions only
	]

	series/offset: as cell! (as byte-ptr! series + 1) + offset
	series/tail: series/offset
	series
]

;-------------------------------------------
;-- Allocate a node and a series from the active series frame, return the node
;-------------------------------------------
alloc-series: func [
	size	[integer!]						;-- number of elements to store
	unit	[integer!]						;-- size of atomic elements stored
	offset	[integer!]						;-- force a given offset for series buffer
	return: [int-ptr!]						;-- return a new node pointer (pointing to the newly allocated series buffer)
	/local series node
][
;	#if debug? = yes [print-wide ["allocating series:" size unit offset lf]]

	series: alloc-series-buffer size unit offset
	node: alloc-node						;-- get a new node
	series/node: node						;-- link back series to node
	node/value: as-integer series ;(as byte-ptr! series) + size? series-buffer!
	node									;-- return the node pointer
]

;-------------------------------------------
;-- Wrapper on alloc-series for easy cells allocation
;-------------------------------------------
alloc-cells: func [
	size	[integer!]						;-- number of 16 bytes cells to preallocate
	return: [int-ptr!]						;-- return a new node pointer (pointing to the newly allocated series buffer)
][
	alloc-series size 16 0					;-- optimize by default for tail insertion
]

;-------------------------------------------
;-- Wrapper on alloc-series for byte buffer allocation
;-------------------------------------------
alloc-bytes: func [
	size	[integer!]						;-- number of 16 bytes cells to preallocate
	return: [int-ptr!]						;-- return a new node pointer (pointing to the newly allocated series buffer)
][
	if zero? size [size: 16]
	alloc-series size 1 0					;-- optimize by default for tail insertion
]

;-------------------------------------------
;-- Set series header flags
;-------------------------------------------
set-flag: func [
	node	[node!]
	flags	[integer!]
	/local series
][
	series: as series-buffer! node/value
	series/flags: (series/flags and not flags) or flags	;-- reset flags bits, then apply flags
]

;-------------------------------------------
;-- Release a series
;-------------------------------------------
free-series: func [
	frame	[series-frame!]					;-- frame containing the series (should be provided by the GC)
	node	[int-ptr!]						;-- series' node pointer
	/local series
][
	assert not null? frame
	assert not null? node
	assert not null? (as byte-ptr! node/value)

	series: as series-buffer! node/value
	assert not zero? (series/flags and not series-in-use) ;-- ensure that 'used bit is set
	series/flags: series/flags and series-free-mask		  ;-- clear 'used bit (enough to free the series)

	if frame/heap = as series-buffer! (		;-- test if series is on top of heap
		(as byte-ptr! node/value) +  series/size + size? series-buffer!
	) [
		frame/heap = series					;-- cheap collecting of last allocated series
	]
	free-node node
]

;-------------------------------------------
;-- Expand a series to a new size
;-------------------------------------------
expand-series: func [
	series  [series-buffer!]				;-- series to expand
	new-sz	[integer!]						;-- new size in bytes
	return: [series-buffer!]				;-- return new series with new size
	/local new units delta
][
	;#if debug? = yes [print-wide ["series expansion triggered for:" series new-sz lf]]

	assert not null? series
	assert any [
		zero? new-sz
		new-sz > series/size				;-- ensure requested size is bigger than current one
	]
	units: GET_UNIT(series)

	if zero? new-sz [
		new-sz: series/size * 2				;-- by default, alloc twice the old size
		if new-sz >= _2MB [
			--NOT_IMPLEMENTED--
			;TBD: alloc big
		]
	]

	new: alloc-series-buffer new-sz / units units 0

	series/node/value: as-integer new		;-- link node to new series buffer
	delta: as-integer series/tail - series/offset

	new/node:   series/node
	new/tail:   as cell! (as byte-ptr! new/offset) + delta

	;TBD: honor flag-ins-head and flag-ins-tail when copying!
	copy-memory 							;-- copy old series in new buffer
		as byte-ptr! new/offset
		as byte-ptr! series/offset
		series/size

	assert not zero? (series/flags and not series-in-use) ;-- ensure that 'used bit is set
	series/flags: series/flags xor series-in-use		  ;-- clear 'used bit (enough to free the series)
	new
]

;-------------------------------------------
;-- Shrink a series to a smaller size (not needed for now)
;-------------------------------------------
;shrink-series: func [
;	series  [series-buffer!]
;	return: [series-buffer!]
;][
;
;]

;-------------------------------------------
;-- Allocate a big series
;-------------------------------------------
alloc-big: func [
	size [integer!]							;-- buffer size to allocate (in bytes)
	return: [byte-ptr!]						;-- return allocated buffer pointer
	/local sz frame frm
][
	assert positive? size
	assert size >= _2MB						;-- should be bigger than a series frame

	sz: size + size? big-frame! 			;-- total required size for a big frame
	frame: as big-frame! allocate-virtual sz no ;-- R/W only

	frame/next: null
	frame/size: size

	either null? memory/b-head [
		memory/b-head: frame				;-- first item in the list
	][
		frm: memory/b-head					;-- search for tail of list (@@ might want to save it?)
		until [frm: frm/next null? frm/next]
		assert not null? frm

		frm/next: frame						;-- append new item at tail of the list
	]

	(as byte-ptr! frame) + size? big-frame!	;-- return a pointer to the requested buffer
]

;-------------------------------------------
;-- Release a big series
;-------------------------------------------
free-big: func [
	buffer	[byte-ptr!]						;-- big buffer to release
	/local frame frm
][
	assert not null? buffer

	frame: as big-frame! (buffer - size? big-frame!)  ;-- point to frame header

	either frame = memory/b-head [
		memory/b-head: null
	][
		frm: memory/b-head					;-- search for frame position in list
		while [frm/next <> frame][			;-- frm should point to one item behind frame on exit
			frm: frm/next
			assert not null? frm			;-- ensure tail of list is not passed
		]
		frm/next: frame/next				;-- remove frame from list
	]

	free-virtual as int-ptr! frame			;-- release the memory to the OS
]

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

#define _512KB				524288
#define _2MB				2097152
#define _16MB				16777216
#define nodes-per-frame		5000
#define node-frame-size		[((nodes-per-frame * 2 * size? pointer!) + size? node-frame!)]

#define series-in-use		80000000h		;-- mark a series as used (not collectable by the GC)
#define flag-ins-both		30000000h		;-- optimize for both head & tail insertions
#define flag-ins-tail		20000000h		;-- optimize for tail insertions
#define flag-ins-head		10000000h		;-- optimize for head insertions
#define flag-series-big		01000000h		;-- 1 = big, 0 = series
#define flag-series-small	00800000h		;-- series <= 16 bytes
#define flag-series-stk		00400000h		;-- values block allocated on stack
#define flag-series-nogc	00200000h		;-- protected from GC (system-critical series)
#define flag-series-fixed	00100000h		;-- series cannot be relocated (system-critical series)

#define flag-arity-mask		C1FFFFFFh		;-- mask for routines arity field
#define flag-unit-mask		FFFFFFE0h		;-- mask for unit field in series-buffer!
#define get-unit-mask		0000001Fh		;-- mask for unit field in series-buffer!
#define series-free-mask	7FFFFFFFh		;-- mark a series as used (not collectable by the GC)

#define type-mask			FFFFFF00h		;-- mask for clearing type ID in cell header
#define get-type-mask		000000FFh		;-- mask for reading type ID in cell header
#define node!				int-ptr!
#define default-offset		-1				;-- for offset value in alloc-series calls

#define series!				series-buffer!

int-array!: alias struct! [ptr [int-ptr!]]

;-- cell header bits layout --
;   31:		lock							;-- lock series for active thread access only
;   30:		new-line						;-- new-line (LF) marker (before the slot)
;	29-25:	arity							;-- arity for routine! functions.
;   24-8:	<reserved>
;   7-0:	datatype ID						;-- datatype number

cell!: alias struct! [
	header	[integer!]						;-- cell's header flags
	data1	[integer!]						;-- placeholders to make a 128-bit cell
	data2	[integer!]
	data3	[integer!]
]

;-- series flags --
;	31: 	used 							;-- 1 = used, 0 = free
;	30: 	type 							;-- always 0 for series-buffer!
;	29-28: 	insert-opt						;-- optimized insertions: 2 = head, 1 = tail, 0 = both
;   27:		mark							;-- mark as referenced for the GC (mark phase)
;   26:		lock							;-- lock series for active thread access only
;   25:		immutable						;-- mark as read-only
;   24:		big								;-- indicates a big series (big-frame!)
;	23:		small							;-- reserved
;	22:		stack							;-- series buffer is allocated on stack
;   21:		permanent						;-- protected from GC (system-critical series)
;   20:     fixed							;-- series cannot be relocated (system-critical series)
;	19-3: 	<reserved>
;	4-0:	unit							;-- size in bytes of atomic element stored in buffer
											;-- 0: UTF-8, 1: Latin1/binary, 2: UCS-2, 4: UCS-4, 16: block! cell
series-buffer!: alias struct! [
	flags	[integer!]						;-- series flags
	node	[int-ptr!]						;-- point back to referring node
	size	[integer!]						;-- usable buffer size (series-buffer! struct excluded)
	offset	[cell!]							;-- series buffer offset pointer (insert at head optimization)
	tail	[cell!]							;-- series buffer tail pointer
]

series-frame!: alias struct! [				;-- series frame header
	next	[series-frame!]					;-- next frame or null
	prev	[series-frame!]					;-- previous frame or null
	heap	[series-buffer!]				;-- point to allocatable region
	tail	[byte-ptr!]						;-- point to last byte in allocatable region
]

node-frame!: alias struct! [				;-- node frame header
	next	[node-frame!]					;-- next frame or null
	prev	[node-frame!]					;-- previous frame or null
	nodes	[integer!]						;-- number of nodes
	bottom	[int-ptr!]						;-- bottom of stack (last entry, fixed)
	top		[int-ptr!]						;-- top of stack (first entry, moving)
]

big-frame!: alias struct! [					;-- big frame header (for >= 2MB series)
	flags	[integer!]						;-- bit 30: 1 (type = big)
	next	[big-frame!]					;-- next frame or null
	size	[integer!]						;-- size (up to 4GB - size? header)
	padding [integer!]						;-- make this header same size as series-buffer! header
]

memory: declare struct! [					; TBD: instanciate this structure per OS thread
	total	 [integer!]						;-- total memory size allocated (in bytes)
	n-head	 [node-frame!]					;-- head of node frames list
	n-active [node-frame!]					;-- actively used node frame
	n-tail	 [node-frame!]					;-- tail of node frames list
	s-head	 [series-frame!]				;-- head of series frames list
	s-active [series-frame!]				;-- actively used series frame
	s-tail	 [series-frame!]				;-- tail of series frames list
	s-start	 [integer!]						;-- start size for new series frame		(1)
	s-size	 [integer!]						;-- current size for new series frame	(1)
	s-max	 [integer!]						;-- max size for new series frames		(1)
	b-head	 [big-frame!]					;-- head of big frames list
]

init-mem: does [
	memory/total: 	0
	memory/s-start: _512KB
	memory/s-max: 	_2MB
	memory/s-size: 	memory/s-start
]

;; (1) Series frames size will grow from 512KB up to 2MB (arbitrary selected). This
;; range will need fine-tuning with real Red apps. This growing size, with low starting value
;; will allow small apps to not consume much memory while avoiding to penalize big apps.

;-------------------------------------------
;-- Allocate paged virtual memory region
;-------------------------------------------
allocate-virtual: func [
	size 	[integer!]						;-- allocated size in bytes (page size multiple)
	exec? 	[logic!]						;-- TRUE => executable region
	return: [int-ptr!]						;-- allocated memory region pointer
	/local ptr
][
	size: round-to size + 4	platform/page-size	;-- account for header (one word)
	memory/total: memory/total + size
	ptr: platform/allocate-virtual size exec?
	ptr/value: size							;-- store size in header
	ptr + 1									;-- return pointer after header
]

;-------------------------------------------
;-- Free paged virtual memory region from OS
;-------------------------------------------
free-virtual: func [
	ptr [int-ptr!]							;-- address of memory region to release
][
	ptr: ptr - 1							;-- return back to header
	memory/total: memory/total - ptr/value
	platform/free-virtual ptr
]

;-------------------------------------------
;-- Free all frames (part of Red's global exit handler)
;-------------------------------------------
free-all: func [
	/local n-frame s-frame b-frame n-next s-next b-next
][
	n-frame: memory/n-head
	while [n-frame <> null][
		n-next: n-frame/next
		free-virtual as int-ptr! n-frame
		n-frame: n-next
	]

	s-frame: memory/s-head
	while [s-frame <> null][
		s-next: s-frame/next
		free-virtual as int-ptr! s-frame
		s-frame: s-next
	]

	b-frame: memory/b-head
	while [b-frame <> null][
		b-next: b-frame/next
		free-virtual as int-ptr! b-frame
		b-frame: b-next
	]
]

;-------------------------------------------
;-- Format the node frame stack by filling it with pointers to all nodes
;-------------------------------------------
format-node-stack: func [
	frame [node-frame!]						;-- node frame to format
	/local node ptr
][
	ptr: frame/bottom						;-- point to bottom of stack
	node: ptr + frame/nodes					;-- first free node address
	until [
		ptr/value: as-integer node			;-- store free node address on stack
		node: node + 1
		ptr: ptr + 1
		ptr > frame/top						;-- until the stack is filled up
	]
]

;-------------------------------------------
;-- Allocate a node frame buffer and initialize it
;-------------------------------------------
alloc-node-frame: func [
	size 	[integer!]						;-- nb of nodes
	return:	[node-frame!]					;-- newly initialized frame
	/local sz frame
][
	assert positive? size
	sz: size * 2 * (size? pointer!) + (size? node-frame!) ;-- total required size for a node frame
	frame: as node-frame! allocate-virtual sz no ;-- R/W only

	frame/prev:  null
	frame/next:  null
	frame/nodes: size

	frame/bottom: as int-ptr! (as byte-ptr! frame) + size? node-frame!
	frame/top: frame/bottom + size - 1		;-- point to the top element

	either null? memory/n-head [
		memory/n-head: frame				;-- first item in the list
		memory/n-tail: frame
		memory/n-active: frame
	][
		memory/n-tail/next: frame			;-- append new item at tail of the list
		frame/prev: memory/n-tail			;-- link back to previous tail
		memory/n-tail: frame				;-- now tail is the new item
	]

	format-node-stack frame					;-- prepare the node frame for use
	frame
]

;-------------------------------------------
;-- Release a node frame buffer
;-------------------------------------------
free-node-frame: func [
	frame [node-frame!]						;-- frame to release
][
	either null? frame/prev [				;-- if frame = head
		memory/n-head: frame/next			;-- head now points to next one
	][
		either null? frame/next [			;-- if frame = tail
			memory/n-tail: frame/prev		;-- tail is now at one position back
		][
			frame/prev/next: frame/next		;-- link preceding frame to next frame
			frame/next/prev: frame/prev		;-- link back next frame to preceding frame
		]
	]
	if memory/n-active = frame [
		memory/n-active: memory/n-tail		;-- reset active frame to last one @@
	]

	assert not all [						;-- ensure that list is not empty
		null? memory/n-head
		null? memory/n-tail
	]

	free-virtual as int-ptr! frame			;-- release the memory to the OS
]

;-------------------------------------------
;-- Obtain a free node from a node frame
;-------------------------------------------
alloc-node: func [
	return: [int-ptr!]						;-- return a free node pointer
	/local frame node
][
	frame: memory/n-active					;-- take node from active node frame
	node: as int-ptr! frame/top/value		;-- pop free node address from stack
	frame/top: frame/top - 1

	if frame/top = frame/bottom [
		; TBD: trigger a "light" GC pass from here and update memory/n-active
		frame: alloc-node-frame nodes-per-frame	;-- allocate a new frame
		memory/n-active: frame				;@@ to be removed once GC implemented
		node: as int-ptr! frame/top/value	;-- pop free node address from stack
		frame/top: frame/top - 1
	]
	node
]

;-------------------------------------------
;-- Release a used node
;-------------------------------------------
free-node: func [
	node [int-ptr!]							;-- node to release
	/local frame offset
][
	assert not null? node

	frame: memory/n-active
	offset: as-integer node - frame

	unless all [
		positive? offset					;-- check if node address is part of active frame
		offset < node-frame-size
	][										;@@ following code not be needed if freed only by the GC...
		frame: memory/n-head				;-- search for right frame from head of the list
		while [								; @@ could be optimized by searching backward/forward from active frame
			offset: as-integer node - frame
			not all [						;-- test if node address is part of that frame
				positive? offset
				offset < node-frame-size	; @@ check upper bound case
			]
		][
			frame: frame/next
			assert frame <> null			;-- should found the right one before the list end
		]
	]

	frame/top: frame/top + 1				;-- free node by pushing its address on stack
	frame/top/value: as-integer node

	assert frame/top < (frame/bottom + frame/nodes)	;-- top should not overflow
]

;-------------------------------------------
;-- Allocate a series frame buffer
;-------------------------------------------
alloc-series-frame: func [
	return:	[series-frame!]					;-- newly initialized frame
	/local size frame
][
	size: memory/s-size
	if size < memory/s-max [memory/s-size: size * 2]

	size: size + size? series-frame! 		;-- total required size for a series frame
	frame: as series-frame! allocate-virtual size no ;-- RW only

	either null? memory/s-head [
		memory/s-head: frame				;-- first item in the list
		memory/s-tail: frame
		memory/s-active: frame
		frame/prev:  null
	][
		memory/s-tail/next: frame			;-- append new item at tail of the list
		frame/prev: memory/s-tail			;-- link back to previous tail
		memory/s-tail: frame				;-- now tail is the new item
	]

	frame/next: null
	frame/heap: as series-buffer! (as byte-ptr! frame) + size? series-frame!
	frame/tail: (as byte-ptr! frame) + size	;-- point to last byte in frame
	frame
]

;-------------------------------------------
;-- Release a series frame buffer
;-------------------------------------------
free-series-frame: func [
	frame [series-frame!]					;-- frame to release
][
	either null? frame/prev [				;-- if frame = head
		memory/s-head: frame/next			;-- head now points to next one
	][
		either null? frame/next [			;-- if frame = tail
			memory/s-tail: frame/prev		;-- tail is now at one position back
		][
			frame/prev/next: frame/next		;-- link preceding frame to next frame
			frame/next/prev: frame/prev		;-- link back next frame to preceding frame
		]
	]
	if memory/s-active = frame [
		memory/s-active: memory/s-tail		;-- reset active frame to last one @@
	]

	assert not all [						;-- ensure that list is not empty
		null? memory/s-head
		null? memory/s-tail
	]

	free-virtual as int-ptr! frame			;-- release the memory to the OS
]

;-------------------------------------------
;-- Update moved series internal pointers
;-------------------------------------------
update-series: func [
	series	[series-buffer!]				;-- start of series region with nodes to re-sync
	offset	[integer!]
][
	until [
		;-- update the node pointer to the new series address
		series/node/value: as-integer series

		;-- update offset and tail pointers
		series/offset: as cell! (as byte-ptr! series/offset) - offset
		series/tail:   as cell! (as byte-ptr! series/tail) - offset

		;-- advance to the next series buffer
		series: as series-buffer! (as byte-ptr! series) + series/size + size? series-buffer!

		;-- exit when a freed series is met (<=> end of region)
		zero? (series/flags and series-in-use)
	]
]

;-------------------------------------------
;-- Compact a series frame by moving down in-use series buffer regions
;-------------------------------------------
#define SM1_INIT		1					;-- enter the state machine
#define SM1_GAP			2					;-- begin of contiguous region of freed buffers (hole)
#define SM1_GAP_END		3					;-- end of freed buffers region
#define SM1_USED		4					;-- begin of contiguous region of buffers in use
#define SM1_USED_END	5					;-- end of used buffers region

compact-series-frame: func [
	frame [series-frame!]					;-- series frame to compact
	/local heap series state
		free? [logic!] src [byte-ptr!] dst [byte-ptr!]
][
	series: as series-buffer! (as byte-ptr! frame) + size? series-frame! ;-- point to first series buffer
	free?: zero? (series/flags and series-in-use)  ;-- true: series is not used
	heap: frame/heap

	src: null								;-- src will point to start of buffer region to move down
	dst: null								;-- dst will point to start of free region
	state: SM1_INIT

	until [
		if all [state = SM1_INIT free?][
			dst: as byte-ptr! series		 ;-- start of gap region
			state: SM1_GAP
		]
		if all [state = SM1_GAP not free?][ ;-- search for first used series (<=> end of gap)
			state: SM1_GAP_END
		]
		if state = SM1_GAP_END [
			src: as byte-ptr! series		 ;-- start of new "alive" region
			state: SM1_USED
		]
	 	;-- point to next series buffer
		series: as series-buffer! (as byte-ptr! series) + series/size  + size? series-buffer!
		free?: zero? (series/flags and series-in-use)  ;-- true: series is not used

		if all [state = SM1_USED any [free? series >= heap]][	;-- handle both normal and "exit" states
			state: SM1_USED_END
		]
		if state = SM1_USED_END [
			assert dst < src				 ;-- regions are moved down in memory
			assert src < as byte-ptr! series ;-- src should point at least at series - series/size
			copy-memory dst	src as-integer series - src
			update-series as series-buffer! dst as-integer src - dst
			dst: dst + (as-integer series - src) ;-- points after moved region (ready for next move)
			state: SM1_GAP
		]
		series >= heap						;-- exit state machine
	]

	unless null? dst [						;-- no compaction occurred, all series were in use
		frame/heap: as series-buffer! dst	;-- set new heap after last moved region
	]
]

;-------------------------------------------
;-- Allocate a series from the active series frame, return the series
;-------------------------------------------
alloc-series-buffer: func [
	usize	[integer!]						;-- size in units
	unit	[integer!]						;-- size of atomic elements stored
	offset	[integer!]						;-- force a given offset for series buffer (in bytes)
	return: [series-buffer!]				;-- return the new series buffer
	/local series size frame sz
][
	assert positive? usize
	size: round-to usize * unit size? cell!	;-- size aligned to cell! size

	frame: memory/s-active
	sz: size + size? series-buffer!			;-- add series header size

	;-- size should not be greater than the frame capacity
	assert sz < as-integer (frame/tail - ((as byte-ptr! frame) + size? series-frame!))

	series: frame/heap
	if ((as byte-ptr! series) + sz) >= frame/tail [
		; TBD: trigger a GC pass from here and update memory/s-active
		frame: alloc-series-frame
		memory/s-active: frame				;@@ to be removed once GC implemented
		series: frame/heap
	]

	assert sz < _16MB						;-- max series size allowed in a series frame @@

	frame/heap: as series-buffer! (as byte-ptr! frame/heap) + sz

	series/size: size
	series/flags: unit
		or series-in-use 					;-- mark series as in-use
		and not flag-series-big				;-- set type bit to 0 (= series)

	either offset = default-offset [
		offset: size >> 1					;-- target middle of buffer
		series/flags: series/flags or flag-ins-both	;-- optimize for both head & tail insertions (default)
	][
		series/flags: series/flags or flag-ins-tail ;-- optimize for tail insertions only
	]

	series/offset: as cell! (as byte-ptr! series + 1) + offset
	series/tail: series/offset
	series
]

;-------------------------------------------
;-- Allocate a node and a series from the active series frame, return the node
;-------------------------------------------
alloc-series: func [
	size	[integer!]						;-- number of elements to store
	unit	[integer!]						;-- size of atomic elements stored
	offset	[integer!]						;-- force a given offset for series buffer
	return: [int-ptr!]						;-- return a new node pointer (pointing to the newly allocated series buffer)
	/local series node
][
;	#if debug? = yes [print-wide ["allocating series:" size unit offset lf]]

	series: alloc-series-buffer size unit offset
	node: alloc-node						;-- get a new node
	series/node: node						;-- link back series to node
	node/value: as-integer series ;(as byte-ptr! series) + size? series-buffer!
	node									;-- return the node pointer
]

;-------------------------------------------
;-- Wrapper on alloc-series for easy cells allocation
;-------------------------------------------
alloc-cells: func [
	size	[integer!]						;-- number of 16 bytes cells to preallocate
	return: [int-ptr!]						;-- return a new node pointer (pointing to the newly allocated series buffer)
][
	alloc-series size 16 0					;-- optimize by default for tail insertion
]

;-------------------------------------------
;-- Wrapper on alloc-series for byte buffer allocation
;-------------------------------------------
alloc-bytes: func [
	size	[integer!]						;-- number of 16 bytes cells to preallocate
	return: [int-ptr!]						;-- return a new node pointer (pointing to the newly allocated series buffer)
][
	if zero? size [size: 16]
	alloc-series size 1 0					;-- optimize by default for tail insertion
]

;-------------------------------------------
;-- Set series header flags
;-------------------------------------------
set-flag: func [
	node	[node!]
	flags	[integer!]
	/local series
][
	series: as series-buffer! node/value
	series/flags: (series/flags and not flags) or flags	;-- reset flags bits, then apply flags
]

;-------------------------------------------
;-- Release a series
;-------------------------------------------
free-series: func [
	frame	[series-frame!]					;-- frame containing the series (should be provided by the GC)
	node	[int-ptr!]						;-- series' node pointer
	/local series
][
	assert not null? frame
	assert not null? node
	assert not null? (as byte-ptr! node/value)

	series: as series-buffer! node/value
	assert not zero? (series/flags and not series-in-use) ;-- ensure that 'used bit is set
	series/flags: series/flags and series-free-mask		  ;-- clear 'used bit (enough to free the series)

	if frame/heap = as series-buffer! (		;-- test if series is on top of heap
		(as byte-ptr! node/value) +  series/size + size? series-buffer!
	) [
		frame/heap = series					;-- cheap collecting of last allocated series
	]
	free-node node
]

;-------------------------------------------
;-- Expand a series to a new size
;-------------------------------------------
expand-series: func [
	series  [series-buffer!]				;-- series to expand
	new-sz	[integer!]						;-- new size in bytes
	return: [series-buffer!]				;-- return new series with new size
	/local new units delta
][
	;#if debug? = yes [print-wide ["series expansion triggered for:" series new-sz lf]]

	assert not null? series
	assert any [
		zero? new-sz
		new-sz > series/size				;-- ensure requested size is bigger than current one
	]
	units: GET_UNIT(series)

	if zero? new-sz [
		new-sz: series/size * 2				;-- by default, alloc twice the old size
		if new-sz >= _2MB [
			--NOT_IMPLEMENTED--
			;TBD: alloc big
		]
	]

	new: alloc-series-buffer new-sz / units units 0

	series/node/value: as-integer new		;-- link node to new series buffer
	delta: as-integer series/tail - series/offset

	new/node:   series/node
	new/tail:   as cell! (as byte-ptr! new/offset) + delta

	;TBD: honor flag-ins-head and flag-ins-tail when copying!
	copy-memory 							;-- copy old series in new buffer
		as byte-ptr! new/offset
		as byte-ptr! series/offset
		series/size

	assert not zero? (series/flags and not series-in-use) ;-- ensure that 'used bit is set
	series/flags: series/flags xor series-in-use		  ;-- clear 'used bit (enough to free the series)
	new
]

;-------------------------------------------
;-- Shrink a series to a smaller size (not needed for now)
;-------------------------------------------
;shrink-series: func [
;	series  [series-buffer!]
;	return: [series-buffer!]
;][
;
;]

;-------------------------------------------
;-- Allocate a big series
;-------------------------------------------
alloc-big: func [
	size [integer!]							;-- buffer size to allocate (in bytes)
	return: [byte-ptr!]						;-- return allocated buffer pointer
	/local sz frame frm
][
	assert positive? size
	assert size >= _2MB						;-- should be bigger than a series frame

	sz: size + size? big-frame! 			;-- total required size for a big frame
	frame: as big-frame! allocate-virtual sz no ;-- R/W only

	frame/next: null
	frame/size: size

	either null? memory/b-head [
		memory/b-head: frame				;-- first item in the list
	][
		frm: memory/b-head					;-- search for tail of list (@@ might want to save it?)
		until [frm: frm/next null? frm/next]
		assert not null? frm

		frm/next: frame						;-- append new item at tail of the list
	]

	(as byte-ptr! frame) + size? big-frame!	;-- return a pointer to the requested buffer
]

;-------------------------------------------
;-- Release a big series
;-------------------------------------------
free-big: func [
	buffer	[byte-ptr!]						;-- big buffer to release
	/local frame frm
][
	assert not null? buffer

	frame: as big-frame! (buffer - size? big-frame!)  ;-- point to frame header

	either frame = memory/b-head [
		memory/b-head: null
	][
		frm: memory/b-head					;-- search for frame position in list
		while [frm/next <> frame][			;-- frm should point to one item behind frame on exit
			frm: frm/next
			assert not null? frm			;-- ensure tail of list is not passed
		]
		frm/next: frame/next				;-- remove frame from list
	]

	free-virtual as int-ptr! frame			;-- release the memory to the OS
]


FIX: use a safer way to construct the map slot.

Red/System [
	Title:   "Map! datatype runtime functions"
	Author:  "Qingtian Xie"
	File:	 %map.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2014-2015 Qingtian Xie. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
]

map: context [
	verbose: 0

	rs-length?: func [
		map 	[red-hash!]
		return: [integer!]
		/local
			s	 [series!]
			size [int-ptr!]
	][
		s: as series! map/table/value
		size: as int-ptr! s/offset
		size/value
	]

	serialize: func [
		map		[red-hash!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent?	[logic!]
		tabs	[integer!]
		mold?	[logic!]
		return: [integer!]
		/local
			s		[series!]
			value	[red-value!]
			next	[red-value!]
			s-tail	[red-value!]
			blank	[byte!]
	][
		if positive? rs-length? map [
			either flat? [
				indent?: no
				blank: space
			][
				if mold? [
					string/append-char GET_BUFFER(buffer) as-integer lf
					part: part - 1
				]
				blank: lf
			]

			s: GET_BUFFER(map)
			value: s/offset
			s-tail: s/tail
			while [value < s-tail][
				next: value + 1
				unless TYPE_OF(next) = TYPE_NONE [
					if indent? [part: object/do-indent buffer tabs part]

					part: actions/mold value buffer only? all? flat? arg part tabs
					string/append-char GET_BUFFER(buffer) as-integer space
					part: part - 1

					part: actions/mold next buffer only? all? flat? arg part tabs

					if any [indent? next + 1 < s-tail][			;-- no final LF when FORMed
						string/append-char GET_BUFFER(buffer) as-integer blank
						part: part - 1
					]
				]
				if all [OPTION?(arg) part <= 0][return part]
				value: value + 2
			]
		]
		part
	]

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

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

	make-at: func [
		slot	[red-value!]
		blk		[red-block!]
		size	[integer!]
		return:	[red-hash!]
		/local
			table [node!]
			map	  [red-hash!]
	][
		table: _hashtable/map-init size blk HASH_TABLE_MAP
		map: as red-hash! slot
		map/header: TYPE_MAP							;-- implicit reset of all header flags
		map/table: table
		map
	]

	;--- Actions ---

	make: func [
		proto		[red-value!]
		spec		[red-value!]
		return:		[red-hash!]
		/local
			map		[red-hash!]
			size	[integer!]
			int		[red-integer!]
			blk		[red-block!]
			blk?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/make"]]

		blk?: no
		size: 1
		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				int: as red-integer! spec
				size: int/value
				if negative? size [fire [TO_ERROR(script out-of-range) spec]]
			]
			TYPE_BLOCK [
				size: block/rs-length? as red-block! spec
				if size % 2 <> 0 [fire [TO_ERROR(script invalid-arg) spec]]
				blk?: yes
			]
			default [--NOT_IMPLEMENTED--]
		]
		if zero? size [size: 1]
		blk: block/make-at as red-block! stack/push* size
		if blk? [block/copy as red-block! spec blk null no null]
		make-at as red-value! blk blk size
	]

	reflect: func [
		map		[red-hash!]
		field	[integer!]
		return:	[red-block!]
		/local
			blk    [red-block!]
			s-tail [red-value!]
			value  [red-value!]
			next   [red-value!]
			size   [integer!]
			s	   [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		s: GET_BUFFER(map)
		value: s/offset
		s-tail: s/tail
		size: block/rs-length? as red-block! map
		case [
			field = words/words [
				blk/node: alloc-cells size >> 1
				while [value < s-tail][
					next: value + 1
					unless TYPE_OF(next) = TYPE_NONE [
						if TYPE_OF(value) = TYPE_SET_WORD [
							value/header: TYPE_WORD
						]
						block/rs-append blk value
					]
					value: value + 2
				]
			]
			field = words/values [
				blk/node: alloc-cells size >> 1
				while [value < s-tail][
					next: value + 1
					unless TYPE_OF(next) = TYPE_NONE [
						block/rs-append blk next
					]
					value: value + 2
				]
			]
			field = words/body [
				blk/node: alloc-cells size
				while [value < s-tail][
					next: value + 1
					unless TYPE_OF(next) = TYPE_NONE [
						block/rs-append blk value
						block/rs-append blk next
					]
					value: value + 2
				]
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		as red-block! stack/set-last as red-value! blk
	]

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

		serialize map buffer no no no arg part no 0 no
	]

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

		string/concatenate-literal buffer "#("
		part: serialize map buffer only? all? flat? arg part - 2 yes indent + 1 yes
		if indent > 0 [part: object/do-indent buffer indent part]
		string/append-char GET_BUFFER(buffer) as-integer #")"
		part - 1
	]

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

		type: TYPE_OF(map2)
		if type <> TYPE_MAP [RETURN_COMPARE_OTHER]
		switch op [
			COMP_EQUAL
			COMP_STRICT_EQUAL
			COMP_NOT_EQUAL
			COMP_SORT
			COMP_CASE_SORT [
				res: block/compare-each as red-block! map1 as red-block! map2 op
			]
			default [
				res: -2
			]
		]
		res
	]

	eval-path: func [
		parent	[red-hash!]							;-- implicit type casting
		element	[red-value!]
		value	[red-value!]
		case?	[logic!]
		return:	[red-value!]
		/local
			table	[node!]
			key		[red-value!]
			val		[red-value!]
			s		[series!]
			size	[int-ptr!]
	][
		table: parent/table
		key: _hashtable/get table element 0 0 case? no no

		either value <> null [						;-- set value
			either TYPE_OF(value) = TYPE_NONE [		;-- delete key entry
				unless key = null [
					_hashtable/delete table key
				]
				value
			][
				either key = null [
					s: as series! parent/node/value
					key: copy-cell element as cell! alloc-tail-unit s (size? cell!) << 1
					_hashtable/put table key
				][
					val: key + 1
					if TYPE_OF(val) = TYPE_NONE [	;-- increase size of keys
						s: as series! table/value
						size: as int-ptr! s/offset
						size/value: size/value + 1
					]
				]
				copy-cell value key + 1
			]
		][
			either key = null [none-value][key + 1]
		]
	]

	;--- Reading actions ---

	pick: func [
		map		[red-hash!]
		index	[red-value!]
		boxed	[red-value!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/pick"]]

		eval-path map boxed null no
	]

	;--- Modifying actions ---

	insert: func [
		map		  [red-hash!]
		value	  [red-value!]
		part-arg  [red-value!]
		only?	  [logic!]
		dup-arg	  [red-value!]
		append?	  [logic!]
		return:	  [red-value!]
		/local
			src		[red-block!]
			cell	[red-value!]
			limit	[red-value!]
			int		[red-integer!]
			s		[series!]
			cnt		[integer!]
			part	[integer!]
			size	[integer!]
			table	[node!]
			key		[red-value!]
			val		[red-value!]
			psize	[int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/insert"]]

		if TYPE_OF(value) <> TYPE_BLOCK [
			fire [TO_ERROR(script invalid-arg) value]
		]

		part: -1

		if OPTION?(part-arg) [
			if TYPE_OF(part-arg) <> TYPE_INTEGER [
				fire [TO_ERROR(script invalid-arg) part-arg]
			]
			int: as red-integer! part-arg
			part: int/value * 2
		]

		src: as red-block! value
		size: block/rs-length? src
		if any [negative? part part > size][part: size] ;-- truncate if off-range part value
		if part % 2 > 0 [part: part - 1]

		s: GET_BUFFER(map)
		size: as-integer s/tail + part - s/offset
		if size > s/size [s: expand-series s size]

		s: GET_BUFFER(src)
		cell: s/offset + src/head
		limit: cell + part								;-- /part support

		table: map/table
		while [cell < limit][
			key: _hashtable/get table cell 0 0 yes no no
			value: cell + 1
			either TYPE_OF(value) = TYPE_NONE [			;-- delete key entry
				unless key = null [
					_hashtable/delete table key
				]
			][
				either key = null [
					s: as series! map/node/value
					key: copy-cell cell as cell! alloc-tail-unit s (size? cell!) << 1
					_hashtable/put table key
				][
					val: key + 1
					if TYPE_OF(val) = TYPE_NONE [		;-- increase size of keys
						s: as series! table/value
						psize: as int-ptr! s/offset
						psize/value: psize/value + 1
					]
				]
				copy-cell value key + 1
			]
			cell: cell + 2
		]
		as red-value! map
	]

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

		s: GET_BUFFER(map)
		i: 0
		while [
			value: s/offset + i
			value < s/tail
		][
			_hashtable/delete map/table value
			i: i + 2
		]
		as red-value! map
	]

	poke: func [
		map		[red-hash!]
		index	[red-value!]
		data	[red-value!]
		boxed	[red-value!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/poke"]]

		stack/set-last eval-path map boxed data no
	]

	;--- Property reading actions ---

	length?: func [
		map		[red-hash!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/length?"]]

		rs-length? map
	]

	;--- Navigation actions ---

	select: func [
		map		 [red-hash!]
		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
			table [node!]
			key   [red-value!]
	][
		table: map/table
		key: _hashtable/get table value 0 0 case? no no
		either key = null [none-value][key + 1]
	]

	;--- Misc actions ---

	copy: func [
		map	    	[red-hash!]
		new			[red-hash!]
		part-arg	[red-value!]
		deep?		[logic!]
		types		[red-value!]
		return:		[red-hash!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/copy"]]
		new: as red-hash! block/clone as red-block! map deep? no

		new/header: TYPE_MAP
		new/table: 	_hashtable/copy map/table new/node
		new
	]

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

Red/System [
	Title:   "Map! datatype runtime functions"
	Author:  "Qingtian Xie"
	File:	 %map.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2014-2015 Qingtian Xie. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
]

map: context [
	verbose: 0

	rs-length?: func [
		map 	[red-hash!]
		return: [integer!]
		/local
			s	 [series!]
			size [int-ptr!]
	][
		s: as series! map/table/value
		size: as int-ptr! s/offset
		size/value
	]

	serialize: func [
		map		[red-hash!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent?	[logic!]
		tabs	[integer!]
		mold?	[logic!]
		return: [integer!]
		/local
			s		[series!]
			value	[red-value!]
			next	[red-value!]
			s-tail	[red-value!]
			blank	[byte!]
	][
		if positive? rs-length? map [
			either flat? [
				indent?: no
				blank: space
			][
				if mold? [
					string/append-char GET_BUFFER(buffer) as-integer lf
					part: part - 1
				]
				blank: lf
			]

			s: GET_BUFFER(map)
			value: s/offset
			s-tail: s/tail
			while [value < s-tail][
				next: value + 1
				unless TYPE_OF(next) = TYPE_NONE [
					if indent? [part: object/do-indent buffer tabs part]

					part: actions/mold value buffer only? all? flat? arg part tabs
					string/append-char GET_BUFFER(buffer) as-integer space
					part: part - 1

					part: actions/mold next buffer only? all? flat? arg part tabs

					if any [indent? next + 1 < s-tail][			;-- no final LF when FORMed
						string/append-char GET_BUFFER(buffer) as-integer blank
						part: part - 1
					]
				]
				if all [OPTION?(arg) part <= 0][return part]
				value: value + 2
			]
		]
		part
	]

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

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

	make-at: func [
		slot	[red-value!]
		blk		[red-block!]
		size	[integer!]
		return:	[red-hash!]
		/local
			map [red-hash!]
	][
		map: as red-hash! slot
		map/header: TYPE_MAP							;-- implicit reset of all header flags
		map/table: _hashtable/init size blk HASH_TABLE_MAP
		map
	]

	;--- Actions ---

	make: func [
		proto		[red-value!]
		spec		[red-value!]
		return:		[red-hash!]
		/local
			map		[red-hash!]
			size	[integer!]
			int		[red-integer!]
			blk		[red-block!]
			blk?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/make"]]

		blk?: no
		size: 1
		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				int: as red-integer! spec
				size: int/value
				if negative? size [fire [TO_ERROR(script out-of-range) spec]]
			]
			TYPE_BLOCK [
				size: block/rs-length? as red-block! spec
				if size % 2 <> 0 [fire [TO_ERROR(script invalid-arg) spec]]
				blk?: yes
			]
			default [--NOT_IMPLEMENTED--]
		]
		if zero? size [size: 1]
		blk: block/make-at as red-block! stack/push* size
		if blk? [block/copy as red-block! spec blk null no null]
		make-at as red-value! blk blk size
	]

	reflect: func [
		map		[red-hash!]
		field	[integer!]
		return:	[red-block!]
		/local
			blk    [red-block!]
			s-tail [red-value!]
			value  [red-value!]
			next   [red-value!]
			size   [integer!]
			s	   [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		s: GET_BUFFER(map)
		value: s/offset
		s-tail: s/tail
		size: block/rs-length? as red-block! map
		case [
			field = words/words [
				blk/node: alloc-cells size >> 1
				while [value < s-tail][
					next: value + 1
					unless TYPE_OF(next) = TYPE_NONE [
						if TYPE_OF(value) = TYPE_SET_WORD [
							value/header: TYPE_WORD
						]
						block/rs-append blk value
					]
					value: value + 2
				]
			]
			field = words/values [
				blk/node: alloc-cells size >> 1
				while [value < s-tail][
					next: value + 1
					unless TYPE_OF(next) = TYPE_NONE [
						block/rs-append blk next
					]
					value: value + 2
				]
			]
			field = words/body [
				blk/node: alloc-cells size
				while [value < s-tail][
					next: value + 1
					unless TYPE_OF(next) = TYPE_NONE [
						block/rs-append blk value
						block/rs-append blk next
					]
					value: value + 2
				]
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		as red-block! stack/set-last as red-value! blk
	]

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

		serialize map buffer no no no arg part no 0 no
	]

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

		string/concatenate-literal buffer "#("
		part: serialize map buffer only? all? flat? arg part - 2 yes indent + 1 yes
		if indent > 0 [part: object/do-indent buffer indent part]
		string/append-char GET_BUFFER(buffer) as-integer #")"
		part - 1
	]

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

		type: TYPE_OF(map2)
		if type <> TYPE_MAP [RETURN_COMPARE_OTHER]
		switch op [
			COMP_EQUAL
			COMP_STRICT_EQUAL
			COMP_NOT_EQUAL
			COMP_SORT
			COMP_CASE_SORT [
				res: block/compare-each as red-block! map1 as red-block! map2 op
			]
			default [
				res: -2
			]
		]
		res
	]

	eval-path: func [
		parent	[red-hash!]							;-- implicit type casting
		element	[red-value!]
		value	[red-value!]
		case?	[logic!]
		return:	[red-value!]
		/local
			table	[node!]
			key		[red-value!]
			val		[red-value!]
			s		[series!]
			size	[int-ptr!]
	][
		table: parent/table
		key: _hashtable/get table element 0 0 case? no no

		either value <> null [						;-- set value
			either TYPE_OF(value) = TYPE_NONE [		;-- delete key entry
				unless key = null [
					_hashtable/delete table key
				]
				value
			][
				either key = null [
					s: as series! parent/node/value
					key: copy-cell element as cell! alloc-tail-unit s (size? cell!) << 1
					_hashtable/put table key
				][
					val: key + 1
					if TYPE_OF(val) = TYPE_NONE [	;-- increase size of keys
						s: as series! table/value
						size: as int-ptr! s/offset
						size/value: size/value + 1
					]
				]
				copy-cell value key + 1
			]
		][
			either key = null [none-value][key + 1]
		]
	]

	;--- Reading actions ---

	pick: func [
		map		[red-hash!]
		index	[red-value!]
		boxed	[red-value!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/pick"]]

		eval-path map boxed null no
	]

	;--- Modifying actions ---

	insert: func [
		map		  [red-hash!]
		value	  [red-value!]
		part-arg  [red-value!]
		only?	  [logic!]
		dup-arg	  [red-value!]
		append?	  [logic!]
		return:	  [red-value!]
		/local
			src		[red-block!]
			cell	[red-value!]
			limit	[red-value!]
			int		[red-integer!]
			s		[series!]
			cnt		[integer!]
			part	[integer!]
			size	[integer!]
			table	[node!]
			key		[red-value!]
			val		[red-value!]
			psize	[int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/insert"]]

		if TYPE_OF(value) <> TYPE_BLOCK [
			fire [TO_ERROR(script invalid-arg) value]
		]

		part: -1

		if OPTION?(part-arg) [
			if TYPE_OF(part-arg) <> TYPE_INTEGER [
				fire [TO_ERROR(script invalid-arg) part-arg]
			]
			int: as red-integer! part-arg
			part: int/value * 2
		]

		src: as red-block! value
		size: block/rs-length? src
		if any [negative? part part > size][part: size] ;-- truncate if off-range part value
		if part % 2 > 0 [part: part - 1]

		s: GET_BUFFER(map)
		size: as-integer s/tail + part - s/offset
		if size > s/size [s: expand-series s size]

		s: GET_BUFFER(src)
		cell: s/offset + src/head
		limit: cell + part								;-- /part support

		table: map/table
		while [cell < limit][
			key: _hashtable/get table cell 0 0 yes no no
			value: cell + 1
			either TYPE_OF(value) = TYPE_NONE [			;-- delete key entry
				unless key = null [
					_hashtable/delete table key
				]
			][
				either key = null [
					s: as series! map/node/value
					key: copy-cell cell as cell! alloc-tail-unit s (size? cell!) << 1
					_hashtable/put table key
				][
					val: key + 1
					if TYPE_OF(val) = TYPE_NONE [		;-- increase size of keys
						s: as series! table/value
						psize: as int-ptr! s/offset
						psize/value: psize/value + 1
					]
				]
				copy-cell value key + 1
			]
			cell: cell + 2
		]
		as red-value! map
	]

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

		s: GET_BUFFER(map)
		i: 0
		while [
			value: s/offset + i
			value < s/tail
		][
			_hashtable/delete map/table value
			i: i + 2
		]
		as red-value! map
	]

	poke: func [
		map		[red-hash!]
		index	[red-value!]
		data	[red-value!]
		boxed	[red-value!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/poke"]]

		stack/set-last eval-path map boxed data no
	]

	;--- Property reading actions ---

	length?: func [
		map		[red-hash!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/length?"]]

		rs-length? map
	]

	;--- Navigation actions ---

	select: func [
		map		 [red-hash!]
		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
			table [node!]
			key   [red-value!]
	][
		table: map/table
		key: _hashtable/get table value 0 0 case? no no
		either key = null [none-value][key + 1]
	]

	;--- Misc actions ---

	copy: func [
		map	    	[red-hash!]
		new			[red-hash!]
		part-arg	[red-value!]
		deep?		[logic!]
		types		[red-value!]
		return:		[red-hash!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/copy"]]
		new: as red-hash! block/clone as red-block! map deep? no

		new/header: TYPE_MAP
		new/table: 	_hashtable/copy map/table new/node
		new
	]

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