FIX: word lookups in blocks using a path accessor were not working properly.

(cherry picked from commit c94f4116b5a938c1a34d64dd48818a34a4d7c191)

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

block: context [
	verbose: 0

	depth: 0											;-- used to trace nesting level for FORM/MOLD

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

	rs-next: func [
		blk 	[red-block!]
		return: [logic!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(blk)
		if (s/offset + blk/head + 1) <= s/tail [
			blk/head: blk/head + 1
		]
		s/offset + blk/head = s/tail
	]

	rs-head: func [
		blk 	[red-block!]
		return: [red-value!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(blk)
		s/offset + blk/head
	]

	rs-tail: func [
		blk 	[red-block!]
		return: [red-value!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(blk)
		s/tail
	]

	rs-tail?: func [
		blk 	[red-block!]
		return: [logic!]
		/local
			s [series!]
	][
		s: GET_BUFFER(blk)
		s/offset + blk/head = s/tail
	]

	rs-abs-at: func [
		blk 	[red-block!]
		pos		[integer!]
		return: [red-value!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(blk)
		assert s/offset + pos < s/tail
		s/offset + pos
	]

	rs-clear: func [
		blk 	[red-block!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(blk)
		s/tail: s/offset + blk/head
	]

	rs-append: func [
		blk		[red-block!]
		value	[red-value!]
		return: [red-value!]
	][
		copy-cell value ALLOC_TAIL(blk)
	]

	rs-append-block: func [
		blk		[red-block!]
		blk2	[red-block!]
		return: [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			s	  [series!]
	][
		s: GET_BUFFER(blk2)
		value: s/offset + blk2/head
		tail:  s/tail

		while [value < tail][
			copy-cell value ALLOC_TAIL(blk)
			value: value + 1
		]
		blk
	]

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

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

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

		s: GET_BUFFER(blk)

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

		offset
	]

	clone: func [
		blk 	[red-block!]
		deep?	[logic!]
		return: [red-block!]
		/local
			new	   [red-block!]
			target [series!]
			value  [red-value!]
			tail   [red-value!]
			result [red-block!]
			size   [integer!]
			empty? [logic!]
	][
		assert TYPE_OF(blk) = TYPE_BLOCK

		value: block/rs-head blk
		tail:  block/rs-tail blk
		size:  (as-integer tail - value) >> 4

		empty?: zero? size
		if empty? [size: 1]

		new: as red-block! stack/push*
		new/header: TYPE_BLOCK
		new/head:   0
		new/node:	alloc-cells size

		unless empty? [
			target: GET_BUFFER(new)
			copy-memory
				as byte-ptr! target/offset
				as byte-ptr! value
				size << 4
			target/tail: target/offset + size
		]

		if all [deep? not empty?][
			while [value < tail][
				if TYPE_OF(value) = TYPE_BLOCK [
					result: clone as red-block! value yes
					copy-cell as red-value! result value
					stack/pop 1
				]
				value: value + 1
			]
		]
		new
	]

	insert-value: func [
		blk		[red-block!]
		value	[red-value!]
		return: [red-block!]
		/local
			head   [red-value!]
			s	   [series!]
			size   [integer!]
	][
		s: GET_BUFFER(blk)
		size: as-integer s/tail + 1 - s/offset
		if size > s/size [s: expand-series s size]
		head: s/offset + blk/head

		move-memory										;-- make space
			as byte-ptr! head + 1
			as byte-ptr! head
			as-integer s/tail - head

		s/tail: s/tail + 1
		copy-cell value head
		blk/head: blk/head + 1
		blk
	]

	insert-block: func [
		blk		[red-block!]
		blk2	[red-block!]
		return: [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			s	  [series!]
	][
		s: GET_BUFFER(blk2)
		value: s/offset + blk2/head
		tail:  s/tail

		while [value < tail][
			insert-value blk value
			value: value + 1
		]
		blk
	]

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

		arg: as red-block! stack/arguments
		;assert TYPE_OF(arg) = TYPE_BLOCK				;@@ disabled until we have ANY_BLOCK check

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

		arg
	]

	select-word: func [
		blk		[red-block!]
		word	[red-word!]
		return: [red-value!]
		/local
			value [red-value!]
			tail  [red-value!]
			w	  [red-word!]
			sym	  [integer!]
	][
		value: rs-head blk
		tail:  rs-tail blk
		sym:   symbol/resolve word/symbol

		while [value < tail][
			if any [									;@@ replace with ANY_WORD?
				TYPE_OF(value) = TYPE_WORD
				TYPE_OF(value) = TYPE_SET_WORD
				TYPE_OF(value) = TYPE_GET_WORD
				TYPE_OF(value) = TYPE_LIT_WORD
			][
				w: as red-word! value
				if sym = symbol/resolve w/symbol [
					either value + 1 = tail [
						return none-value
					][
						return value + 1
					]
				]
			]
			value: value + 1
		]
		none-value
	]

	make-at: func [
		blk		[red-block!]
		size	[integer!]
		return: [red-block!]
	][
		blk/header: TYPE_BLOCK							;-- implicit reset of all header flags
		blk/head: 	0
		blk/node: 	alloc-cells size
		blk
	]

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

		blk: either null? parent [
			_root
		][
			assert TYPE_OF(parent) = TYPE_BLOCK
			as red-block! ALLOC_TAIL(parent)
		]
		make-at blk size
	]

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

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

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

		blk: make-at as red-block! ALLOC_TAIL(root) size
		push blk
		blk
	]

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

		if zero? size [size: 1]
		make-at as red-block! stack/push* size
	]

	mold-each: func [
		blk		  [red-block!]
		buffer	  [red-string!]
		only?	  [logic!]
		all?	  [logic!]
		flat?	  [logic!]
		arg		  [red-value!]
		part 	  [integer!]
		indent	  [integer!]
		return:   [integer!]
		/local
			s	  [series!]
			value [red-value!]
			i     [integer!]
	][
		s: GET_BUFFER(blk)
		i: blk/head
		while [
			value: s/offset + i
			value < s/tail
		][
			if all [OPTION?(arg) part <= 0][return part]

			depth: depth + 1
			part: actions/mold value buffer only? all? flat? arg part indent

			if positive? depth [
				string/append-char GET_BUFFER(buffer) as-integer space
				part: part - 1
			]
			depth: depth - 1
			i: i + 1
		]
		s: GET_BUFFER(buffer)
		if i <> blk/head [								;-- test if not empty block
			s/tail: as cell! (as byte-ptr! s/tail) - 1	;-- remove extra white space
			part: part + 1
		]
		part
	]

	compare-each: func [
		blk1	   [red-block!]							;-- first operand
		blk2	   [red-block!]							;-- second operand
		op		   [integer!]							;-- type of comparison
		return:	   [logic!]
		/local
			s1	   [series!]
			s2	   [series!]
			size1  [integer!]
			size2  [integer!]
			type1  [integer!]
			type2  [integer!]
			end	   [red-value!]
			value1 [red-value!]
			value2 [red-value!]
			res	   [logic!]
	][
		s1: GET_BUFFER(blk1)
		s2: GET_BUFFER(blk2)
		size1: (as-integer s1/tail - s1/offset) >> 4 - blk1/head
		size2: (as-integer s2/tail - s2/offset) >> 4 - blk2/head

		either size1 <> size2 [								;-- shortcut exit for different sizes
			if any [op = COMP_EQUAL op = COMP_STRICT_EQUAL][return false]
			if op = COMP_NOT_EQUAL [return true]
		][
			if zero? size1 [								;-- shortcut exit for empty blocks
				return any [
					op = COMP_EQUAL 		op = COMP_STRICT_EQUAL
					op = COMP_LESSER_EQUAL  op = COMP_GREATER_EQUAL
				]
			]
		]

		if op = COMP_LESSER [op: COMP_LESSER_EQUAL]
		if op = COMP_GREATER [op: COMP_GREATER_EQUAL]

		value1: s1/offset + blk1/head
		value2: s2/offset + blk2/head
		end: s1/tail										;-- only one "end" is needed

		until [
			type1: TYPE_OF(value1)
			type2: TYPE_OF(value2)
			either any [
				type1 = type2
				all [word/any-word? type1 word/any-word? type2]
				all [type1 = TYPE_INTEGER type2 = TYPE_INTEGER]	 ;@@ replace by ANY_NUMBER?
			][
				res: actions/compare value1 value2 op
				value1: value1 + 1
				value2: value2 + 1
			][
				switch op [
					COMP_EQUAL
					COMP_STRICT_EQUAL	[res: false]
					COMP_NOT_EQUAL 		[res: true]
					COMP_LESSER_EQUAL	[res: type1 <= type2]
					COMP_GREATER_EQUAL	[res: type1 >= type2]
				]
				return res
			]
			any [
				not res
				value1 >= end
			]
		]
		res
	]

	;--- Actions ---

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

		size: 1
		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				int: as red-integer! spec
				size: int/value
			]
			default [--NOT_IMPLEMENTED--]
		]
		if zero? size [size: 1]
		make-at as red-block! stack/push* size
	]

	form: func [
		blk		  [red-block!]
		buffer	  [red-string!]
		arg		  [red-value!]
		part 	  [integer!]
		return:   [integer!]
		/local
			s	  [series!]
			buf	  [series!]
			value [red-value!]
			unit  [integer!]
			prev  [integer!]
			i     [integer!]
			c	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/form"]]

		s: GET_BUFFER(blk)
		i: blk/head
		value: s/offset + i
		c: 0

		while [value < s/tail][
			if all [OPTION?(arg) part <= 0][return part]

			prev: part
			part: actions/form value buffer arg part
			i: i + 1
			value: s/offset + i

			if all [
				part <> prev
				value < s/tail
			][
				buf:  GET_BUFFER(buffer)
				unit: GET_UNIT(buf)
				c: string/get-char (as byte-ptr! buf/tail) - unit unit

				unless any [
					c = as-integer #" "
					c = as-integer #"^/"
					c = as-integer #"^M"
					c = as-integer #"^-"
				][
					string/append-char buf as-integer space
					part: part - 1
				]
			]
		]

		s: GET_BUFFER(buffer)

		if s/offset < s/tail [
			unit: GET_UNIT(s)
			i: string/get-char (as byte-ptr! s/tail) - unit unit

			if i = as-integer space [
				s/tail: as red-value! ((as byte-ptr! s/tail) - unit)  ;-- trim tail space
				part: part + 1
			]
		]
		part
	]

	mold: func [
		blk		[red-block!]
		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 "block/mold"]]

		unless only? [
			string/append-char GET_BUFFER(buffer) as-integer #"["
			part: part - 1
		]
		part: mold-each blk buffer no all? flat? arg part indent

		unless only? [
			string/append-char GET_BUFFER(buffer) as-integer #"]"
			part: part - 1
		]
		part
	]

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

		if TYPE_OF(blk2) <> TYPE_BLOCK [RETURN_COMPARE_OTHER]
		compare-each blk1 blk2 op
	]

	eval-path: func [
		parent	[red-block!]							;-- implicit type casting
		element	[red-value!]
		set?	[logic!]
		return:	[red-value!]
		/local
			int [red-integer!]
	][
		switch TYPE_OF(element) [
			TYPE_INTEGER [
				int: as red-integer! element
				either set? [
					poke parent int/value stack/arguments null
					stack/arguments
				][
					pick parent int/value null
				]
			]
			TYPE_WORD [
				either set? [
					element: find parent element null no no no null null no no no no
					actions/poke as red-series! element 2 stack/arguments null
					stack/arguments
				][
					select-word as red-block! parent as red-word! element
				]
			]
			default [
				print-line "*** Error: invalid value in path!"
				halt
				null
			]
		]
	]

	;--- Property reading actions ---

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

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

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

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

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

		s: GET_BUFFER(blk)

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

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

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

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

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

		rs-length? blk
	]

	;--- Navigation actions ---

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

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

		if blk/head >= 1 [blk/head: blk/head - 1]
		as red-value! blk
	]

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

		rs-next as red-block! stack/arguments
		stack/arguments
	]

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

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

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

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

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

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

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

	find: func [
		blk			[red-block!]
		value		[red-value!]
		part		[red-value!]
		only?		[logic!]
		case?		[logic!]
		any?		[logic!]
		with-arg	[red-string!]
		skip		[red-integer!]
		last?		[logic!]
		reverse?	[logic!]
		tail?		[logic!]
		match?		[logic!]
		return:		[red-value!]
		/local
			s		[series!]
			s2		[series!]
			slot	[red-value!]
			slot2	[red-value!]
			end		[red-value!]
			end2	[red-value!]
			result	[red-value!]
			int		[red-integer!]
			b		[red-block!]
			dt		[red-datatype!]
			values	[integer!]
			step	[integer!]
			n		[integer!]
			part?	[logic!]
			op		[integer!]
			type	[integer!]
			found?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/find"]]

		result: stack/push as red-value! blk

		s: GET_BUFFER(blk)

		if any [							;-- early exit if blk is empty or at tail
			s/offset = s/tail
			all [not reverse? s/offset + blk/head >= s/tail]
		][
			result/header: TYPE_NONE
			return result
		]
		step:  1
		part?: no

		if OPTION?(skip) [
			assert TYPE_OF(skip) = TYPE_INTEGER
			step: skip/value
		]
		if OPTION?(part) [
			part: either TYPE_OF(part) = TYPE_INTEGER [
				int: as red-integer! part
				if int/value <= 0 [						;-- early exit if part <= 0
					result/header: TYPE_NONE
					return result
				]
				s/offset + int/value - 1				;-- int argument is 1-based
			][
				b: as red-block! part
				unless all [
					TYPE_OF(b) = TYPE_OF(blk)			;-- handles ANY-BLOCK!
					b/node = blk/node
				][
					print "*** Error: invalid /part series argument"	;@@ replace with error!
					halt
				]
				s/offset + b/head
			]
			part?: yes
		]

		type: TYPE_OF(value)
		values: either only? [0][						;-- values > 0 => series comparison mode
			either any [								;@@ replace with ANY_BLOCK?
				type = TYPE_BLOCK
				type = TYPE_PAREN
				type = TYPE_PATH
				type = TYPE_GET_PATH
				type = TYPE_SET_PATH
				type = TYPE_LIT_PATH
			][
				b: as red-block! value
				s2: GET_BUFFER(b)
				value: s2/offset + b/head
				end2: s2/tail
				(as-integer s2/tail - s2/offset) >> 4 - b/head
			][0]
		]
		if negative? values [values: 0]					;-- empty value series case

		case [
			last? [
				step: 0 - step
				slot: either part? [part][s/tail - 1]
				end: s/offset
			]
			reverse? [
				step: 0 - step
				slot: either part? [part][s/offset + blk/head - 1]
				end: s/offset
				if slot < end [							;-- early exit if blk/head = 0
					result/header: TYPE_NONE
					return result
				]
			]
			true [
				slot: s/offset + blk/head
				end: either part? [part + 1][s/tail]	;-- + 1 => compensate for the '>= test
			]
		]
		op: either case? [COMP_STRICT_EQUAL][COMP_EQUAL] ;-- warning: /case <> STRICT...
		reverse?: any [reverse? last?]					;-- reduce both flags to one

		type: either type = TYPE_DATATYPE [
			dt: as red-datatype! value
			dt/value
		][-1]											;-- disable "type searching" mode

		until [
			either zero? values [
				found?: either positive? type [
					dt: as red-datatype! slot
					type = dt/value						;-- simple type comparison
				][
					actions/compare slot value op		;-- atomic comparison
				]
				if match? [slot: slot + 1]				;-- /match option returns tail of match
			][
				n: 0
				slot2: slot
				until [									;-- series comparison
					found?: actions/compare slot2 value + n op
					slot2: slot2 + 1
					n: n + 1
					any [
						not found?						;-- no match
						n = values						;-- values exhausted
						all [reverse?     slot2 <= end]	;-- block series head reached
						all [not reverse? slot2 >= end]	;-- block series tail reached
					]
				]
				if all [n < values slot2 >= end][found?: no] ;-- partial match case, make it fail
				if all [match? found?][slot: slot2]		;-- slot2 points to tail of match
			]
			slot: slot + step
			any [
				match?									;-- /match option limits to one comparison
				all [not match? found?]					;-- match found
				all [reverse? slot < end]				;-- head of block series reached
				all [not reverse? slot >= end]			;-- tail of block series reached
			]
		]
		unless all [tail? not reverse?][slot: slot - step]	;-- point before/after found value
		if all [tail? reverse?][slot: slot - step]			;-- additional step for tailed reversed search

		either found? [
			blk: as red-block! result
			blk/head: (as-integer slot - s/offset) >> 4	;-- just change the head position on stack
		][
			result/header: TYPE_NONE					;-- change the stack 1st argument to none.
		]
		result
	]

	select: func [
		blk		 [red-block!]
		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
			s	   [series!]
			p	   [red-value!]
			b	   [red-block!]
			result [red-value!]
			type   [integer!]
			offset [integer!]
	][
		result: find blk value part only? case? any? with-arg skip last? reverse? no no

		if TYPE_OF(result) <> TYPE_NONE [
			offset: either only? [1][					;-- values > 0 => series comparison mode
				type: TYPE_OF(value)
				either any [							;@@ replace with ANY_BLOCK?
					type = TYPE_BLOCK
					type = TYPE_PAREN
					type = TYPE_PATH
					type = TYPE_GET_PATH
					type = TYPE_SET_PATH
					type = TYPE_LIT_PATH
				][
					b: as red-block! value
					s: GET_BUFFER(b)
					(as-integer s/tail - s/offset) >> 4 - b/head
				][1]
			]
			blk: as red-block! result
			s: GET_BUFFER(blk)
			p: s/offset + blk/head + offset

			either p < s/tail [
				copy-cell p result
			][
				result/header: TYPE_NONE
			]
		]
		result
	]

	;--- Reading actions ---

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

		s: GET_BUFFER(blk)

		offset: blk/head + index - 1					;-- index is one-based
		if negative? index [offset: offset + 1]
		cell: s/offset + offset

		either any [
			zero? index
			cell >= s/tail
			cell < s/offset
		][
			none-value
		][
			cell
		]
	]

	;--- Modifying actions ---

	insert: func [
		blk		  [red-block!]
		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!]
			head	[red-value!]
			int		[red-integer!]
			b		[red-block!]
			s		[series!]
			cnt		[integer!]
			part	[integer!]
			size	[integer!]
			slots	[integer!]
			values?	[logic!]
			head?	[logic!]
			tail?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/insert"]]

		cnt:  1
		part: -1

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				int/value
			][
				b: as red-block! part-arg
				assert all [
					TYPE_OF(b) = TYPE_BLOCK
					b/node = blk/node
				]
				b/head + 1								;-- /head is 0-based
			]
		]
		if OPTION?(dup-arg) [
			int: as red-integer! dup-arg
			cnt: int/value
			if negative? cnt [return as red-value! blk]
		]

		values?: all [
			not only?									;-- /only support
			any [
				TYPE_OF(value) = TYPE_BLOCK				;@@ replace it with: typeset/any-block?
				TYPE_OF(value) = TYPE_PATH				;@@ replace it with: typeset/any-block?
			]
		]
		size: either values? [
			src: as red-block! value
			rs-length? src
		][
			1
		]
		if any [negative? part part > size][part: size] ;-- truncate if off-range part value

		s: GET_BUFFER(blk)
		head?: zero? blk/head
		tail?: any [(s/offset + blk/head = s/tail) append?]
		slots: part * cnt

		unless tail? [									;TBD: process head? case separately
			size: as-integer s/tail + slots - s/offset
			if size > s/size [s: expand-series s size]
			head: s/offset + blk/head
			move-memory									;-- make space
				as byte-ptr! head + slots
				as byte-ptr! head
				as-integer s/tail - head

			s/tail: s/tail + slots
		]

		while [not zero? cnt][							;-- /dup support
			either values? [
				s: GET_BUFFER(src)
				cell: s/offset + src/head
				limit: cell + part						;-- /part support

				either tail? [
					while [cell < limit][				;-- multiple values case
						copy-cell cell ALLOC_TAIL(blk)
						cell: cell + 1
					]
				][
					while [cell < limit][				;-- multiple values case
						copy-cell cell head
						head: head + 1
						cell: cell + 1
					]
				]
			][											;-- single value case
				either tail? [
					copy-cell value ALLOC_TAIL(blk)
				][
					copy-cell value head
				]
			]
			cnt: cnt - 1
		]
		unless append? [
			blk/head: blk/head + slots
			s: GET_BUFFER(blk)
			assert s/offset + blk/head <= s/tail
		]
		as red-value! blk
	]

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

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

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

		s: GET_BUFFER(blk)

		offset: blk/head + index - 1					;-- index is one-based
		if negative? index [offset: offset + 1]
		cell: s/offset + offset

		either any [
			zero? index
			cell >= s/tail
			cell < s/offset
		][
			;TBD: placeholder waiting for error! to be implemented
			stack/set-last none-value					;@@ should raise an error!
		][
			copy-cell data cell
			stack/set-last data
		]
		as red-value! data
	]

	remove: func [
		blk	 	 [red-block!]
		part-arg [red-value!]
		return:	 [red-block!]
		/local
			s		[series!]
			part	[integer!]
			head	[red-value!]
			int		[red-integer!]
			b		[red-block!]
	][
		s: GET_BUFFER(blk)
		head: s/offset + blk/head
		if head = s/tail [return blk]					;-- early exit if nothing to remove

		part: 1

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				int/value
			][
				b: as red-block! part-arg
				assert all [
					TYPE_OF(b) = TYPE_BLOCK
					b/node = blk/node
				]
				b/head - blk/head
			]
			if part <= 0 [return blk]					;-- early exit if negative /part index
		]

		either head + part < s/tail [
			move-memory
				as byte-ptr! head
				as byte-ptr! head + part
				as-integer s/tail - (head + part)
			s/tail: s/tail - part
		][
			s/tail: head
		]
		blk
	]

	reverse: func [
		blk	 	 [red-block!]
		part-arg [red-value!]
		return:	 [red-block!]
		/local
			s		[series!]
			part	[integer!]
			size	[integer!]
			head	[red-value!]
			end		[red-value!]
			tmp		[red-value!]
			int		[red-integer!]
			b		[red-block!]
	][
		s: GET_BUFFER(blk)
		head: s/offset + blk/head
		if head = s/tail [return blk]		;-- early exit if nothing to reverse
		size: rs-length? blk

		part: size

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				int/value
			][
				b: as red-block! part-arg
				assert all [
					TYPE_OF(b) = TYPE_BLOCK
					b/node = blk/node
				]
				b/head - blk/head
			]
			if part <= 0 [return blk]		;-- early exit if negative /part index
		]
		if part > size [part: size] 		;-- truncate if off-range part value

		end: head + part - 1
		tmp: stack/push*
		while [head < end][
			copy-cell head tmp
			copy-cell end head
			copy-cell tmp end
			head: head + 1
			end: end - 1
		]
		stack/pop 1
		blk
	]

	;--- Misc actions ---

	copy: func [
		blk	    	[red-block!]
		new			[red-block!]
		part-arg	[red-value!]
		deep?		[logic!]
		types		[red-value!]
		return:		[red-series!]
		/local
			int		[red-integer!]
			b		[red-block!]
			offset	[red-value!]
			slot	[red-value!]
			buffer	[series!]
			node	[node!]
			part	[integer!]
			slots	[integer!]
			type	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/copy"]]

		s: GET_BUFFER(blk)

		slots:	rs-length? blk
		offset: s/offset + blk/head
		part:   as-integer s/tail - offset				;@@ should be `part: slots`

		if OPTION?(types) [--NOT_IMPLEMENTED--]

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				case [
					int/value > (part >> 4) [part >> 4]
					positive? int/value 	[int/value]
					true					[0]
				]
			][
				b: as red-block! part-arg
				unless all [
					TYPE_OF(b) = TYPE_OF(blk)			;-- handles ANY-BLOCK!
					b/node = blk/node
				][
					print "*** Error: invalid /part series argument"	;@@ replace with error!
					halt
				]
				b/head - blk/head
			]
			slots: part
			part: part << 4
		]

		node: 	alloc-cells slots + 1
		buffer: as series! node/value

		unless zero? part [
			copy-memory
				as byte-ptr! buffer/offset
				as byte-ptr! offset
				part

			buffer/tail: buffer/offset + slots
		]

		new/header: TYPE_BLOCK
		new/node: 	node
		new/head: 	0

		if deep? [
			slot: buffer/offset
			until [
				type: TYPE_OF(slot)
				if any [								;@@ replace with ANY_SERIES?
					type = TYPE_BLOCK
					type = TYPE_PAREN
					type = TYPE_PATH
					type = TYPE_GET_PATH
					type = TYPE_SET_PATH
					type = TYPE_LIT_PATH
					type = TYPE_STRING
					type = TYPE_FILE
				][
					actions/copy
						as red-series! slot
						slot						;-- overwrite the slot value
						null
						yes
						null
				]
				slot: slot + 1
				slot >= buffer/tail
			]
		]

		as red-series! new
	]

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

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

block: context [
	verbose: 0

	depth: 0											;-- used to trace nesting level for FORM/MOLD

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

	rs-next: func [
		blk 	[red-block!]
		return: [logic!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(blk)
		if (s/offset + blk/head + 1) <= s/tail [
			blk/head: blk/head + 1
		]
		s/offset + blk/head = s/tail
	]

	rs-head: func [
		blk 	[red-block!]
		return: [red-value!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(blk)
		s/offset + blk/head
	]

	rs-tail: func [
		blk 	[red-block!]
		return: [red-value!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(blk)
		s/tail
	]

	rs-tail?: func [
		blk 	[red-block!]
		return: [logic!]
		/local
			s [series!]
	][
		s: GET_BUFFER(blk)
		s/offset + blk/head = s/tail
	]

	rs-abs-at: func [
		blk 	[red-block!]
		pos		[integer!]
		return: [red-value!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(blk)
		assert s/offset + pos < s/tail
		s/offset + pos
	]

	rs-clear: func [
		blk 	[red-block!]
		/local
			s	[series!]
	][
		s: GET_BUFFER(blk)
		s/tail: s/offset + blk/head
	]

	rs-append: func [
		blk		[red-block!]
		value	[red-value!]
		return: [red-value!]
	][
		copy-cell value ALLOC_TAIL(blk)
	]

	rs-append-block: func [
		blk		[red-block!]
		blk2	[red-block!]
		return: [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			s	  [series!]
	][
		s: GET_BUFFER(blk2)
		value: s/offset + blk2/head
		tail:  s/tail

		while [value < tail][
			copy-cell value ALLOC_TAIL(blk)
			value: value + 1
		]
		blk
	]

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

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

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

		s: GET_BUFFER(blk)

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

		offset
	]

	clone: func [
		blk 	[red-block!]
		deep?	[logic!]
		return: [red-block!]
		/local
			new	   [red-block!]
			target [series!]
			value  [red-value!]
			tail   [red-value!]
			result [red-block!]
			size   [integer!]
			empty? [logic!]
	][
		assert TYPE_OF(blk) = TYPE_BLOCK

		value: block/rs-head blk
		tail:  block/rs-tail blk
		size:  (as-integer tail - value) >> 4

		empty?: zero? size
		if empty? [size: 1]

		new: as red-block! stack/push*
		new/header: TYPE_BLOCK
		new/head:   0
		new/node:	alloc-cells size

		unless empty? [
			target: GET_BUFFER(new)
			copy-memory
				as byte-ptr! target/offset
				as byte-ptr! value
				size << 4
			target/tail: target/offset + size
		]

		if all [deep? not empty?][
			while [value < tail][
				if TYPE_OF(value) = TYPE_BLOCK [
					result: clone as red-block! value yes
					copy-cell as red-value! result value
					stack/pop 1
				]
				value: value + 1
			]
		]
		new
	]

	insert-value: func [
		blk		[red-block!]
		value	[red-value!]
		return: [red-block!]
		/local
			head   [red-value!]
			s	   [series!]
			size   [integer!]
	][
		s: GET_BUFFER(blk)
		size: as-integer s/tail + 1 - s/offset
		if size > s/size [s: expand-series s size]
		head: s/offset + blk/head

		move-memory										;-- make space
			as byte-ptr! head + 1
			as byte-ptr! head
			as-integer s/tail - head

		s/tail: s/tail + 1
		copy-cell value head
		blk/head: blk/head + 1
		blk
	]

	insert-block: func [
		blk		[red-block!]
		blk2	[red-block!]
		return: [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			s	  [series!]
	][
		s: GET_BUFFER(blk2)
		value: s/offset + blk2/head
		tail:  s/tail

		while [value < tail][
			insert-value blk value
			value: value + 1
		]
		blk
	]

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

		arg: as red-block! stack/arguments
		;assert TYPE_OF(arg) = TYPE_BLOCK				;@@ disabled until we have ANY_BLOCK check

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

		arg
	]

	make-at: func [
		blk		[red-block!]
		size	[integer!]
		return: [red-block!]
	][
		blk/header: TYPE_BLOCK							;-- implicit reset of all header flags
		blk/head: 	0
		blk/node: 	alloc-cells size
		blk
	]

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

		blk: either null? parent [
			_root
		][
			assert TYPE_OF(parent) = TYPE_BLOCK
			as red-block! ALLOC_TAIL(parent)
		]
		make-at blk size
	]

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

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

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

		blk: make-at as red-block! ALLOC_TAIL(root) size
		push blk
		blk
	]

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

		if zero? size [size: 1]
		make-at as red-block! stack/push* size
	]

	mold-each: func [
		blk		  [red-block!]
		buffer	  [red-string!]
		only?	  [logic!]
		all?	  [logic!]
		flat?	  [logic!]
		arg		  [red-value!]
		part 	  [integer!]
		indent	  [integer!]
		return:   [integer!]
		/local
			s	  [series!]
			value [red-value!]
			i     [integer!]
	][
		s: GET_BUFFER(blk)
		i: blk/head
		while [
			value: s/offset + i
			value < s/tail
		][
			if all [OPTION?(arg) part <= 0][return part]

			depth: depth + 1
			part: actions/mold value buffer only? all? flat? arg part indent

			if positive? depth [
				string/append-char GET_BUFFER(buffer) as-integer space
				part: part - 1
			]
			depth: depth - 1
			i: i + 1
		]
		s: GET_BUFFER(buffer)
		if i <> blk/head [								;-- test if not empty block
			s/tail: as cell! (as byte-ptr! s/tail) - 1	;-- remove extra white space
			part: part + 1
		]
		part
	]

	compare-each: func [
		blk1	   [red-block!]							;-- first operand
		blk2	   [red-block!]							;-- second operand
		op		   [integer!]							;-- type of comparison
		return:	   [logic!]
		/local
			s1	   [series!]
			s2	   [series!]
			size1  [integer!]
			size2  [integer!]
			type1  [integer!]
			type2  [integer!]
			end	   [red-value!]
			value1 [red-value!]
			value2 [red-value!]
			res	   [logic!]
	][
		s1: GET_BUFFER(blk1)
		s2: GET_BUFFER(blk2)
		size1: (as-integer s1/tail - s1/offset) >> 4 - blk1/head
		size2: (as-integer s2/tail - s2/offset) >> 4 - blk2/head

		either size1 <> size2 [								;-- shortcut exit for different sizes
			if any [op = COMP_EQUAL op = COMP_STRICT_EQUAL][return false]
			if op = COMP_NOT_EQUAL [return true]
		][
			if zero? size1 [								;-- shortcut exit for empty blocks
				return any [
					op = COMP_EQUAL 		op = COMP_STRICT_EQUAL
					op = COMP_LESSER_EQUAL  op = COMP_GREATER_EQUAL
				]
			]
		]

		if op = COMP_LESSER [op: COMP_LESSER_EQUAL]
		if op = COMP_GREATER [op: COMP_GREATER_EQUAL]

		value1: s1/offset + blk1/head
		value2: s2/offset + blk2/head
		end: s1/tail										;-- only one "end" is needed

		until [
			type1: TYPE_OF(value1)
			type2: TYPE_OF(value2)
			either any [
				type1 = type2
				all [word/any-word? type1 word/any-word? type2]
				all [type1 = TYPE_INTEGER type2 = TYPE_INTEGER]	 ;@@ replace by ANY_NUMBER?
			][
				res: actions/compare value1 value2 op
				value1: value1 + 1
				value2: value2 + 1
			][
				switch op [
					COMP_EQUAL
					COMP_STRICT_EQUAL	[res: false]
					COMP_NOT_EQUAL 		[res: true]
					COMP_LESSER_EQUAL	[res: type1 <= type2]
					COMP_GREATER_EQUAL	[res: type1 >= type2]
				]
				return res
			]
			any [
				not res
				value1 >= end
			]
		]
		res
	]

	;--- Actions ---

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

		size: 1
		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				int: as red-integer! spec
				size: int/value
			]
			default [--NOT_IMPLEMENTED--]
		]
		if zero? size [size: 1]
		make-at as red-block! stack/push* size
	]

	form: func [
		blk		  [red-block!]
		buffer	  [red-string!]
		arg		  [red-value!]
		part 	  [integer!]
		return:   [integer!]
		/local
			s	  [series!]
			buf	  [series!]
			value [red-value!]
			unit  [integer!]
			prev  [integer!]
			i     [integer!]
			c	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/form"]]

		s: GET_BUFFER(blk)
		i: blk/head
		value: s/offset + i
		c: 0

		while [value < s/tail][
			if all [OPTION?(arg) part <= 0][return part]

			prev: part
			part: actions/form value buffer arg part
			i: i + 1
			value: s/offset + i

			if all [
				part <> prev
				value < s/tail
			][
				buf:  GET_BUFFER(buffer)
				unit: GET_UNIT(buf)
				c: string/get-char (as byte-ptr! buf/tail) - unit unit

				unless any [
					c = as-integer #" "
					c = as-integer #"^/"
					c = as-integer #"^M"
					c = as-integer #"^-"
				][
					string/append-char buf as-integer space
					part: part - 1
				]
			]
		]

		s: GET_BUFFER(buffer)

		if s/offset < s/tail [
			unit: GET_UNIT(s)
			i: string/get-char (as byte-ptr! s/tail) - unit unit

			if i = as-integer space [
				s/tail: as red-value! ((as byte-ptr! s/tail) - unit)  ;-- trim tail space
				part: part + 1
			]
		]
		part
	]

	mold: func [
		blk		[red-block!]
		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 "block/mold"]]

		unless only? [
			string/append-char GET_BUFFER(buffer) as-integer #"["
			part: part - 1
		]
		part: mold-each blk buffer no all? flat? arg part indent

		unless only? [
			string/append-char GET_BUFFER(buffer) as-integer #"]"
			part: part - 1
		]
		part
	]

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

		if TYPE_OF(blk2) <> TYPE_BLOCK [RETURN_COMPARE_OTHER]
		compare-each blk1 blk2 op
	]

	eval-path: func [
		parent	[red-block!]							;-- implicit type casting
		element	[red-value!]
		set?	[logic!]
		return:	[red-value!]
		/local
			int [red-integer!]
	][
		switch TYPE_OF(element) [
			TYPE_INTEGER [
				int: as red-integer! element
				either set? [
					poke parent int/value stack/arguments null
					stack/arguments
				][
					pick parent int/value null
				]
			]
			TYPE_WORD [
				either set? [
					element: find parent element null no no no null null no no no no
					actions/poke as red-series! element 2 stack/arguments null
					stack/arguments
				][
					select parent element null no no no null null no no
				]
			]
			default [
				print-line "*** Error: invalid value in path!"
				halt
				null
			]
		]
	]

	;--- Property reading actions ---

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

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

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

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

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

		s: GET_BUFFER(blk)

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

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

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

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

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

		rs-length? blk
	]

	;--- Navigation actions ---

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

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

		if blk/head >= 1 [blk/head: blk/head - 1]
		as red-value! blk
	]

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

		rs-next as red-block! stack/arguments
		stack/arguments
	]

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

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

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

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

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

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

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

	find: func [
		blk			[red-block!]
		value		[red-value!]
		part		[red-value!]
		only?		[logic!]
		case?		[logic!]
		any?		[logic!]
		with-arg	[red-string!]
		skip		[red-integer!]
		last?		[logic!]
		reverse?	[logic!]
		tail?		[logic!]
		match?		[logic!]
		return:		[red-value!]
		/local
			s		[series!]
			s2		[series!]
			slot	[red-value!]
			slot2	[red-value!]
			end		[red-value!]
			end2	[red-value!]
			result	[red-value!]
			int		[red-integer!]
			b		[red-block!]
			dt		[red-datatype!]
			values	[integer!]
			step	[integer!]
			n		[integer!]
			part?	[logic!]
			op		[integer!]
			type	[integer!]
			found?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/find"]]

		result: stack/push as red-value! blk

		s: GET_BUFFER(blk)

		if any [							;-- early exit if blk is empty or at tail
			s/offset = s/tail
			all [not reverse? s/offset + blk/head >= s/tail]
		][
			result/header: TYPE_NONE
			return result
		]
		step:  1
		part?: no

		if OPTION?(skip) [
			assert TYPE_OF(skip) = TYPE_INTEGER
			step: skip/value
		]
		if OPTION?(part) [
			part: either TYPE_OF(part) = TYPE_INTEGER [
				int: as red-integer! part
				if int/value <= 0 [						;-- early exit if part <= 0
					result/header: TYPE_NONE
					return result
				]
				s/offset + int/value - 1				;-- int argument is 1-based
			][
				b: as red-block! part
				unless all [
					TYPE_OF(b) = TYPE_OF(blk)			;-- handles ANY-BLOCK!
					b/node = blk/node
				][
					print "*** Error: invalid /part series argument"	;@@ replace with error!
					halt
				]
				s/offset + b/head
			]
			part?: yes
		]

		type: TYPE_OF(value)
		values: either only? [0][						;-- values > 0 => series comparison mode
			either any [								;@@ replace with ANY_BLOCK?
				type = TYPE_BLOCK
				type = TYPE_PAREN
				type = TYPE_PATH
				type = TYPE_GET_PATH
				type = TYPE_SET_PATH
				type = TYPE_LIT_PATH
			][
				b: as red-block! value
				s2: GET_BUFFER(b)
				value: s2/offset + b/head
				end2: s2/tail
				(as-integer s2/tail - s2/offset) >> 4 - b/head
			][0]
		]
		if negative? values [values: 0]					;-- empty value series case

		case [
			last? [
				step: 0 - step
				slot: either part? [part][s/tail - 1]
				end: s/offset
			]
			reverse? [
				step: 0 - step
				slot: either part? [part][s/offset + blk/head - 1]
				end: s/offset
				if slot < end [							;-- early exit if blk/head = 0
					result/header: TYPE_NONE
					return result
				]
			]
			true [
				slot: s/offset + blk/head
				end: either part? [part + 1][s/tail]	;-- + 1 => compensate for the '>= test
			]
		]
		op: either case? [COMP_STRICT_EQUAL][COMP_EQUAL] ;-- warning: /case <> STRICT...
		reverse?: any [reverse? last?]					;-- reduce both flags to one

		type: either type = TYPE_DATATYPE [
			dt: as red-datatype! value
			dt/value
		][-1]											;-- disable "type searching" mode

		until [
			either zero? values [
				found?: either positive? type [
					dt: as red-datatype! slot
					type = dt/value						;-- simple type comparison
				][
					actions/compare slot value op		;-- atomic comparison
				]
				if match? [slot: slot + 1]				;-- /match option returns tail of match
			][
				n: 0
				slot2: slot
				until [									;-- series comparison
					found?: actions/compare slot2 value + n op
					slot2: slot2 + 1
					n: n + 1
					any [
						not found?						;-- no match
						n = values						;-- values exhausted
						all [reverse?     slot2 <= end]	;-- block series head reached
						all [not reverse? slot2 >= end]	;-- block series tail reached
					]
				]
				if all [n < values slot2 >= end][found?: no] ;-- partial match case, make it fail
				if all [match? found?][slot: slot2]		;-- slot2 points to tail of match
			]
			slot: slot + step
			any [
				match?									;-- /match option limits to one comparison
				all [not match? found?]					;-- match found
				all [reverse? slot < end]				;-- head of block series reached
				all [not reverse? slot >= end]			;-- tail of block series reached
			]
		]
		unless all [tail? not reverse?][slot: slot - step]	;-- point before/after found value
		if all [tail? reverse?][slot: slot - step]			;-- additional step for tailed reversed search

		either found? [
			blk: as red-block! result
			blk/head: (as-integer slot - s/offset) >> 4	;-- just change the head position on stack
		][
			result/header: TYPE_NONE					;-- change the stack 1st argument to none.
		]
		result
	]

	select: func [
		blk		 [red-block!]
		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
			s	   [series!]
			p	   [red-value!]
			b	   [red-block!]
			result [red-value!]
			type   [integer!]
			offset [integer!]
	][
		result: find blk value part only? case? any? with-arg skip last? reverse? no no

		if TYPE_OF(result) <> TYPE_NONE [
			offset: either only? [1][					;-- values > 0 => series comparison mode
				type: TYPE_OF(value)
				either any [							;@@ replace with ANY_BLOCK?
					type = TYPE_BLOCK
					type = TYPE_PAREN
					type = TYPE_PATH
					type = TYPE_GET_PATH
					type = TYPE_SET_PATH
					type = TYPE_LIT_PATH
				][
					b: as red-block! value
					s: GET_BUFFER(b)
					(as-integer s/tail - s/offset) >> 4 - b/head
				][1]
			]
			blk: as red-block! result
			s: GET_BUFFER(blk)
			p: s/offset + blk/head + offset

			either p < s/tail [
				copy-cell p result
			][
				result/header: TYPE_NONE
			]
		]
		result
	]

	;--- Reading actions ---

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

		s: GET_BUFFER(blk)

		offset: blk/head + index - 1					;-- index is one-based
		if negative? index [offset: offset + 1]
		cell: s/offset + offset

		either any [
			zero? index
			cell >= s/tail
			cell < s/offset
		][
			none-value
		][
			cell
		]
	]

	;--- Modifying actions ---

	insert: func [
		blk		  [red-block!]
		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!]
			head	[red-value!]
			int		[red-integer!]
			b		[red-block!]
			s		[series!]
			cnt		[integer!]
			part	[integer!]
			size	[integer!]
			slots	[integer!]
			values?	[logic!]
			head?	[logic!]
			tail?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/insert"]]

		cnt:  1
		part: -1

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				int/value
			][
				b: as red-block! part-arg
				assert all [
					TYPE_OF(b) = TYPE_BLOCK
					b/node = blk/node
				]
				b/head + 1								;-- /head is 0-based
			]
		]
		if OPTION?(dup-arg) [
			int: as red-integer! dup-arg
			cnt: int/value
			if negative? cnt [return as red-value! blk]
		]

		values?: all [
			not only?									;-- /only support
			any [
				TYPE_OF(value) = TYPE_BLOCK				;@@ replace it with: typeset/any-block?
				TYPE_OF(value) = TYPE_PATH				;@@ replace it with: typeset/any-block?
			]
		]
		size: either values? [
			src: as red-block! value
			rs-length? src
		][
			1
		]
		if any [negative? part part > size][part: size] ;-- truncate if off-range part value

		s: GET_BUFFER(blk)
		head?: zero? blk/head
		tail?: any [(s/offset + blk/head = s/tail) append?]
		slots: part * cnt

		unless tail? [									;TBD: process head? case separately
			size: as-integer s/tail + slots - s/offset
			if size > s/size [s: expand-series s size]
			head: s/offset + blk/head
			move-memory									;-- make space
				as byte-ptr! head + slots
				as byte-ptr! head
				as-integer s/tail - head

			s/tail: s/tail + slots
		]

		while [not zero? cnt][							;-- /dup support
			either values? [
				s: GET_BUFFER(src)
				cell: s/offset + src/head
				limit: cell + part						;-- /part support

				either tail? [
					while [cell < limit][				;-- multiple values case
						copy-cell cell ALLOC_TAIL(blk)
						cell: cell + 1
					]
				][
					while [cell < limit][				;-- multiple values case
						copy-cell cell head
						head: head + 1
						cell: cell + 1
					]
				]
			][											;-- single value case
				either tail? [
					copy-cell value ALLOC_TAIL(blk)
				][
					copy-cell value head
				]
			]
			cnt: cnt - 1
		]
		unless append? [
			blk/head: blk/head + slots
			s: GET_BUFFER(blk)
			assert s/offset + blk/head <= s/tail
		]
		as red-value! blk
	]

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

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

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

		s: GET_BUFFER(blk)

		offset: blk/head + index - 1					;-- index is one-based
		if negative? index [offset: offset + 1]
		cell: s/offset + offset

		either any [
			zero? index
			cell >= s/tail
			cell < s/offset
		][
			;TBD: placeholder waiting for error! to be implemented
			stack/set-last none-value					;@@ should raise an error!
		][
			copy-cell data cell
			stack/set-last data
		]
		as red-value! data
	]

	remove: func [
		blk	 	 [red-block!]
		part-arg [red-value!]
		return:	 [red-block!]
		/local
			s		[series!]
			part	[integer!]
			head	[red-value!]
			int		[red-integer!]
			b		[red-block!]
	][
		s: GET_BUFFER(blk)
		head: s/offset + blk/head
		if head = s/tail [return blk]					;-- early exit if nothing to remove

		part: 1

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				int/value
			][
				b: as red-block! part-arg
				assert all [
					TYPE_OF(b) = TYPE_BLOCK
					b/node = blk/node
				]
				b/head - blk/head
			]
			if part <= 0 [return blk]					;-- early exit if negative /part index
		]

		either head + part < s/tail [
			move-memory
				as byte-ptr! head
				as byte-ptr! head + part
				as-integer s/tail - (head + part)
			s/tail: s/tail - part
		][
			s/tail: head
		]
		blk
	]

	reverse: func [
		blk	 	 [red-block!]
		part-arg [red-value!]
		return:	 [red-block!]
		/local
			s		[series!]
			part	[integer!]
			size	[integer!]
			head	[red-value!]
			end		[red-value!]
			tmp		[red-value!]
			int		[red-integer!]
			b		[red-block!]
	][
		s: GET_BUFFER(blk)
		head: s/offset + blk/head
		if head = s/tail [return blk]		;-- early exit if nothing to reverse
		size: rs-length? blk

		part: size

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				int/value
			][
				b: as red-block! part-arg
				assert all [
					TYPE_OF(b) = TYPE_BLOCK
					b/node = blk/node
				]
				b/head - blk/head
			]
			if part <= 0 [return blk]		;-- early exit if negative /part index
		]
		if part > size [part: size] 		;-- truncate if off-range part value

		end: head + part - 1
		tmp: stack/push*
		while [head < end][
			copy-cell head tmp
			copy-cell end head
			copy-cell tmp end
			head: head + 1
			end: end - 1
		]
		stack/pop 1
		blk
	]

	;--- Misc actions ---

	copy: func [
		blk	    	[red-block!]
		new			[red-block!]
		part-arg	[red-value!]
		deep?		[logic!]
		types		[red-value!]
		return:		[red-series!]
		/local
			int		[red-integer!]
			b		[red-block!]
			offset	[red-value!]
			slot	[red-value!]
			buffer	[series!]
			node	[node!]
			part	[integer!]
			slots	[integer!]
			type	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/copy"]]

		s: GET_BUFFER(blk)

		slots:	rs-length? blk
		offset: s/offset + blk/head
		part:   as-integer s/tail - offset				;@@ should be `part: slots`

		if OPTION?(types) [--NOT_IMPLEMENTED--]

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				case [
					int/value > (part >> 4) [part >> 4]
					positive? int/value 	[int/value]
					true					[0]
				]
			][
				b: as red-block! part-arg
				unless all [
					TYPE_OF(b) = TYPE_OF(blk)			;-- handles ANY-BLOCK!
					b/node = blk/node
				][
					print "*** Error: invalid /part series argument"	;@@ replace with error!
					halt
				]
				b/head - blk/head
			]
			slots: part
			part: part << 4
		]

		node: 	alloc-cells slots + 1
		buffer: as series! node/value

		unless zero? part [
			copy-memory
				as byte-ptr! buffer/offset
				as byte-ptr! offset
				part

			buffer/tail: buffer/offset + slots
		]

		new/header: TYPE_BLOCK
		new/node: 	node
		new/head: 	0

		if deep? [
			slot: buffer/offset
			until [
				type: TYPE_OF(slot)
				if any [								;@@ replace with ANY_SERIES?
					type = TYPE_BLOCK
					type = TYPE_PAREN
					type = TYPE_PATH
					type = TYPE_GET_PATH
					type = TYPE_SET_PATH
					type = TYPE_LIT_PATH
					type = TYPE_STRING
					type = TYPE_FILE
				][
					actions/copy
						as red-series! slot
						slot						;-- overwrite the slot value
						null
						yes
						null
				]
				slot: slot + 1
				slot >= buffer/tail
			]
		]

		as red-series! new
	]

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


FIX: remove useless extra EXIT call.

FIX: remove useless extra EXIT call.

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, 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
	}
]

help: func [
	"Get help for functions"
	'word [any-type!] "Word you are looking for"
	/local func-name desc spec tab tab4 tab8 type start attributs info fun w ref block
][
	tab: tab4: "    "
	tab8: "        "

	case [
		unset? :word [								;-- HELP with no arguments
			print {Use HELP or ? to see built-in info:

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other debug functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
}
		]
		datatype? get :word [						;-- HELP <datatype!>
			type: get :word
			foreach w system/words [
				if type = type? get w [
					either any [function? get w native? get w action? get w][
						prin [tab w]
						spec: spec-of get w

						either any [
							string? desc: spec/1
							string? desc: spec/2					;-- attributs block case
						][
							print ["^-=> " desc]
						][
							prin lf
						]
					][
						print [tab :w "^-: " mold get w]
					]
				]
			]
		]
		'else [
			func-name: :word

			argument-rule: [
				set word [word! | lit-word! | get-word!]
				(prin [tab mold word])
				opt [set type block!  (prin [#" " mold type])]
				opt [set info string! (prin [" =>" append form info dot])]
				(prin lf)
			]

			either all [
				word? func-name
				fun: get func-name
				any [action? :fun function? :fun native? :fun]
			][
		;		print ["^/" func-name "is of type" type? :fun newline]
				prin ["^/USAGE:^/" tab func-name]

				parse spec-of :fun [
					start: any [						;-- 1st pass
						/local to end
						| set w word! (prin [" " w])
						| set w [lit-word! | refinement!] (prin [" " mold w])
						| skip
					]

					:start								;-- 2nd pass
					opt [set attributs block! (prin ["^/^/ATTRIBUTS:^/" tab mold attributs])]
					opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot])]

					(print "^/ARGUMENTS:")
					any [argument-rule (prin lf)]

					(print "REFINEMENTS:")
					any [
						/local [
							to ahead set-word! 'return set block block!
							(print ["^/RETURN:^/" mold block])
							| to end
						]
						| [
							set ref refinement! (prin [tab mold ref])
							opt [set info string! (prin [" =>" append form info dot])]
							(tab: tab8 prin lf)
							any [argument-rule]
							(tab: tab4)
						]
					]
				]
			][
				print [
					func-name "is of type"
					mold type? either word? :func-name [:fun][:func-name]
					"^/No more help available."
				]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

what: function [
	"Lists all functions, or words of a given type"
][
	foreach w system/words [
		if any [function? get w native? get w action? get w][
			prin w
			spec: spec-of get w

			either any [
				string? desc: spec/1
				string? desc: spec/2					;-- attributs block case
			][
				print [tab "=> " desc]
			][
				prin lf
			]
		]
	]
	exit												;-- return unset value
]

source: function [
	"Print the source of a function"
	'func-name [any-word!] "The name of the function"
][
	print either function? get func-name [
		[append mold func-name #":" mold get func-name]
	][
		["Sorry," func-name "is a" type? :func-name "so no source is available"]
	]
]

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, 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
	}
]

help: func [
	"Get help for functions"
	'word [any-type!] "Word you are looking for"
	/local func-name desc spec tab tab4 tab8 type start attributs info fun w ref block
][
	tab: tab4: "    "
	tab8: "        "

	case [
		unset? :word [								;-- HELP with no arguments
			print {Use HELP or ? to see built-in info:

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other debug functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
}
		]
		datatype? get :word [						;-- HELP <datatype!>
			type: get :word
			foreach w system/words [
				if type = type? get w [
					either any [function? get w native? get w action? get w][
						prin [tab w]
						spec: spec-of get w

						either any [
							string? desc: spec/1
							string? desc: spec/2					;-- attributs block case
						][
							print ["^-=> " desc]
						][
							prin lf
						]
					][
						print [tab :w "^-: " mold get w]
					]
				]
			]
		]
		'else [
			func-name: :word

			argument-rule: [
				set word [word! | lit-word! | get-word!]
				(prin [tab mold word])
				opt [set type block!  (prin [#" " mold type])]
				opt [set info string! (prin [" =>" append form info dot])]
				(prin lf)
			]

			either all [
				word? func-name
				fun: get func-name
				any [action? :fun function? :fun native? :fun]
			][
		;		print ["^/" func-name "is of type" type? :fun newline]
				prin ["^/USAGE:^/" tab func-name]

				parse spec-of :fun [
					start: any [						;-- 1st pass
						/local to end
						| set w word! (prin [" " w])
						| set w [lit-word! | refinement!] (prin [" " mold w])
						| skip
					]

					:start								;-- 2nd pass
					opt [set attributs block! (prin ["^/^/ATTRIBUTS:^/" tab mold attributs])]
					opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot])]

					(print "^/ARGUMENTS:")
					any [argument-rule (prin lf)]

					(print "REFINEMENTS:")
					any [
						/local [
							to ahead set-word! 'return set block block!
							(print ["^/RETURN:^/" mold block])
							| to end
						]
						| [
							set ref refinement! (prin [tab mold ref])
							opt [set info string! (prin [" =>" append form info dot])]
							(tab: tab8 prin lf)
							any [argument-rule]
							(tab: tab4)
						]
					]
				]
			][
				print [
					func-name "is of type"
					mold type? either word? :func-name [:fun][:func-name]
					"^/No more help available."
				]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

what: function [
	"Lists all functions, or words of a given type"
][
	foreach w system/words [
		if any [function? get w native? get w action? get w][
			prin w
			spec: spec-of get w

			either any [
				string? desc: spec/1
				string? desc: spec/2					;-- attributs block case
			][
				print [tab "=> " desc]
			][
				prin lf
			]
		]
	]
	exit												;-- return unset value
]

source: function [
	"Print the source of a function"
	'func-name [any-word!] "The name of the function"
][
	print either function? get func-name [
		[append mold func-name #":" mold get func-name]
	][
		["Sorry," func-name "is a" type? :func-name "so no source is available"]
	]
	exit												;-- return unset value
]


FEAT: populated system/catalag/errors.

FEAT: populated system/catalag/errors.

Error specification copied from Rebol3 for sake of compatibility (at least for starting, Red will diverge to cover its specific needs).

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

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

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

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

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

	]

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

		last-error: none
	]

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

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

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

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

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

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

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

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

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

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

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

	lexer: none
	console: none
]

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

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

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

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

	catalog: context [
		datatypes:
		actions:
		natives:
		errors: none
	]

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

		last-error: none
	]

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

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

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

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

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

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

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

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

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

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

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

	lexer: none
	console: none
]


TESTS: corrected test in path-test.red

TESTS: corrected test in path-test.red

Red [
	Title:   "Red/System path! datatype test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %char-test.red
	Version: "0.1.0"
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

#include  %../../../quick-test/quick-test.red

~~~start-file~~~ "path"

===start-group=== "block access"
	blk: [a b c [d] e]

	--test-- "blk-1"
		--assert blk/1 = 'a
		--assert blk/2 = 'b
		--assert blk/3 = 'c
		--assert blk/4 = [d]
		--assert blk/4/1 = 'd

	--test-- "blk-2"
		blk/1: 99
		--assert blk/1 = 99
		blk/2: 'z
		--assert blk/2 = 'z
		blk/4/1: -1
		--assert blk/4 = [-1]
		--assert blk = [99 z c [-1] e]

	--test-- "blk-3"
		idx: 1
		--assert blk/:idx = 99
		--assert blk/4/:idx = -1
		idx: 4
		--assert blk/:idx/1 = -1
		idx: 1
		blk/:idx: 0
		--assert blk/:idx = 0
		--assert blk/1 = 0

	--test-- "blk-4"
	idx: 'z
	--assert blk/:idx = 'c

	--test-- "blk-5"
	--assert blk/z = 'c

	--test-- "blk-6"
		blk: [4 5 6 ["o"]]
		idx: 2
		--assert blk/(1) = 4
		--assert blk/(1 + 2) = 6
		--assert blk/(idx) = 5

		--test-- "blk-7"
		--assert blk/(idx + 2)/(1) = "o"
		--assert blk/(idx + 2)/(1)/(idx - 1) = #"o"

	--test-- "blk-8"
		blk/(1): 99
		idx: 2
		--assert blk/1 = 99
		blk/(idx + 2)/(1)/(idx - 1): #"z"
		--assert blk/4/1/1 = #"z"

		--test-- "blk-9"
		inc: func [a][a + 1]
		--assert blk/(inc 1) = 5

===end-group===

===start-group=== "string access"
	str: "abcde"

	--test-- "str-1"
		--assert str/1 = #"a"
		--assert str/2 = #"b"
		--assert str/3 = #"c"
		--assert str/4 = #"d"

	--test-- "str-2"
		str/1: #"9"
		--assert str/1 = #"9"
		str/2: #"z"
		--assert str/2 = #"z"
		--assert str = "9zcde"

	--test-- "str-3"
		idx: 1
		--assert str/:idx = #"9"
		idx: 4
		--assert str/:idx = #"d"
		idx: 1
		str/:idx: #"0"
		--assert str/:idx = #"0"
		--assert str/1 = #"0"

	--test-- "str-4"
		str: "456o"
		idx: 2
		--assert str/(1) = #"4"
		--assert str/(1 + 2) = #"6"
		--assert str/(idx) = #"5"

	--test-- "str-5"
		str/(1): #"9"
		--assert str/1 = #"9"
		idx: 2
		str/(idx + 2): #"z"
		--assert str/4 = #"z"

	--test-- "str-6"
		inc: func [a][a + 1]
		--assert str/(inc 1) = #"5"

	--test-- "str-7 - issue #1113"
		s7-a: "abcz"
		s7-b: 5
		--assert none = s7-a/5
		--assert none = s7-a/:s7-b

===end-group===

~~~end-file~~~

Red [
	Title:   "Red/System path! datatype test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %char-test.red
	Version: "0.1.0"
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

#include  %../../../quick-test/quick-test.red

~~~start-file~~~ "path"

===start-group=== "block access"
	blk: [a b c [d] e]

	--test-- "blk-1"
		--assert blk/1 = 'a
		--assert blk/2 = 'b
		--assert blk/3 = 'c
		--assert blk/4 = [d]
		--assert blk/4/1 = 'd

	--test-- "blk-2"
		blk/1: 99
		--assert blk/1 = 99
		blk/2: 'z
		--assert blk/2 = 'z
		blk/4/1: -1
		--assert blk/4 = [-1]
		--assert blk = [99 z c [-1] e]

	--test-- "blk-3"
		idx: 1
		--assert blk/:idx = 99
		--assert blk/4/:idx = -1
		idx: 4
		--assert blk/:idx/1 = -1
		idx: 1
		blk/:idx: 0
		--assert blk/:idx = 0
		--assert blk/1 = 0

	--test-- "blk-4"
	idx: 'z
	--assert blk/:idx = 'c

	--test-- "blk-5"
	--assert blk/z = 'c

	--test-- "blk-6"
		blk: [4 5 6 ["o"]]
		idx: 2
		--assert blk/(1) = 4
		--assert blk/(1 + 2) = 6
		--assert blk/(idx) = 5

		--test-- "blk-7"
		--assert blk/(idx + 2)/(1) = "o"
		--assert blk/(idx + 2)/(1)/(idx - 1) = #"o"

	--test-- "blk-8"
		blk/(1): 99
		idx: 2
		--assert blk/1 = 99
		blk/(idx + 2)/(1)/(idx - 1): #"z"
		--assert blk/4/1/1 = #"z"

		--test-- "blk-9"
		inc: func [a][a + 1]
		--assert blk/(inc 1) = 5

===end-group===

===start-group=== "string access"
	str: "abcde"

	--test-- "str-1"
		--assert str/1 = #"a"
		--assert str/2 = #"b"
		--assert str/3 = #"c"
		--assert str/4 = #"d"

	--test-- "str-2"
		str/1: #"9"
		--assert str/1 = #"9"
		str/2: #"z"
		--assert str/2 = #"z"
		--assert str = "9zcde"

	--test-- "str-3"
		idx: 1
		--assert str/:idx = #"9"
		idx: 4
		--assert str/:idx = #"d"
		idx: 1
		str/:idx: #"0"
		--assert str/:idx = #"0"
		--assert str/1 = #"0"

	--test-- "str-4"
		str: "456o"
		idx: 2
		--assert str/(1) = #"4"
		--assert str/(1 + 2) = #"6"
		--assert str/(idx) = #"5"

	--test-- "str-5"
		str/(1): #"9"
		--assert str/1 = #"9"
		idx: 2
		str/(idx + 2): #"z"
		--assert str/4 = #"z"

	--test-- "str-6"
		inc: func [a][a + 1]
		--assert str/(inc 1) = #"5"

	--test-- "str-7 - issue #1113"
		s7-a: "abcz"
		s7-b: 5
		--assert none = s7-a/5
		--assert none = s7-a/:s7-b
		--assert none = s7-a/s7-b

===end-group===

~~~end-file~~~


FIX: broken HELP on words, minor improvement of HELP <datatype>.

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, 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
	}
]

help: function [
	"Display helping information about words and other values"
	'word [any-type!] "Word you are looking for"
	/local word type info w attributes block ref
][
	tab: tab4: "    "
	tab8: "        "

	case [
		unset? :word [									;-- HELP with no arguments
			print {Use HELP or ? to see built-in info:

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other useful functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
    about - display version number and build date
    q or quit - leave the Red console
}
			exit
		]
		all [word? :word datatype? get :word] [			;-- HELP <datatype!>
			type: get :word
			found?: no
			foreach w system/words [
				if type = type? get w [
					found?: yes
					case [
						any [function? get w native? get w action? get w op? get w routine? get w][
							prin [tab w]
							spec: spec-of get w

							either any [
								string? desc: spec/1
								string? desc: spec/2	;-- attributes block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
			unless found? [print "No value of that type found in global space."]
			exit
		]
		string? :word [
			foreach w system/words [
				if any [function? get w native? get w action? get w op? get w routine? get w][
					spec: spec-of get w
					if any [find form w word find form spec word] [
						prin [tab w]

						either any [
							string? desc: spec/1
							string? desc: spec/2		;-- attributes block case
						][
							print ["^-=> " desc]
						][
							prin lf
						]
					]
				]
			]
			exit
		]
		not word? :word [								;-- all others except word!
			type: type? :word
			print [mold :word "is" a-an form type type]
			exit
		]
	]

	func-name: :word

	argument-rule: [
		set word [word! | lit-word! | get-word!]
		(prin [tab mold :word])
		opt [set type block!  (prin [#" " mold type])]
		opt [set info string! (prin [" =>" append form info dot])]
		(prin lf)
	]

	case [
		unset? get/any :word [
			print ["Word" :word "is not defined"]
		]
		all [
			any [word? func-name path? func-name]
			fun: get func-name
			any [action? :fun function? :fun native? :fun op? :fun routine? :fun]
		][
			prin ["^/USAGE:^/" tab ]

			parse spec-of :fun [
				start: [									;-- 1st pass
					any [block! | string! ]
					opt [set w [word! | lit-word! | get-word!] (either op? :fun [prin [mold w func-name]][prin [func-name mold w]])]
					any [
						/local to end
						| set w [word! | lit-word! | get-word!] (prin [" " w])
						| set w refinement! (prin [" " mold w])
						| skip
					]
				]

				:start										;-- 2nd pass
				opt [set attributes block! (prin ["^/^/ATTRIBUTES:^/" tab mold attributes])]
				opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot lf tab func-name "is of type:" mold type? :fun])]

				(print "^/ARGUMENTS:")
				any [argument-rule]; (prin lf)]

				(print "^/REFINEMENTS:")
				any [
					/local [
						to ahead set-word! 'return set block block!
						(print ["^/RETURN:^/" mold block])
						| to end
					]
					| [
						set ref refinement! (prin [tab mold ref])
						opt [set info string! (prin [" =>" append form info dot])]
						(tab: tab8 prin lf)
						any [argument-rule]
						(tab: tab4)
					]
				]
			]
		]
		all [any [word? word path? word] object? get word][
			prin #"`"
			prin form word
			print "` is an object! of value:"

			foreach w words-of get word [
				value: get/any in get word w

				desc: case [
					object? :value  [words-of value]
					find [op! action! native! function! routine!] type?/word :value [
						spec: spec-of :value
						if string? spec/1 [spec: spec/1]
						spec
					]
					'else [:value]
				]

				desc: either string? desc [copy/part desc 47][mold/part/flat desc 47]

				if 47 = length? desc [					;-- optimized for width = 78
					clear skip tail desc -3
					append desc "..."
				]
				print [
					tab
					pad form/part w 16 16
					pad mold type? get/any w 9
					desc
				]
			]
		]
		'else [
			value: get :word
			print [
				word "is a"
				mold type? :value
				"of value:"
				mold either path? :value [get :value][:value]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

a-an: function [s [string!]][
	pick ["an" "a"] make logic! find "aeiou" s/1
]

what: function [
	"Lists all functions, or words of a given type"
][
	foreach w system/words [
		if any [function? get w native? get w action? get w op? get w routine? get w][
			prin pad form w 15
			spec: spec-of get w

			either any [
				string? desc: spec/1
				string? desc: spec/2					;-- attributes block case
			][
				print [#":" desc]
			][
				prin lf
			]
		]
	]
	exit												;-- return unset value
]

source: function [
	"Print the source of a function"
	'func-name [any-word!] "The name of the function"
][
	print either function? get func-name [
		[append mold func-name #":" mold get func-name]
	][
		type: mold type? get func-name
		["Sorry," func-name "is" a-an type "so no source is available"]
	]
]

about: function [
	"Print Red version information"
][
	print ["Red" system/version #"-" system/build]
]

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, 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
	}
]

help: function [
	"Display helping information about words and other values"
	'word [any-type!] "Word you are looking for"
	/local word type info w attributes block ref
][
	tab: tab4: "    "
	tab8: "        "

	case [
		unset? :word [									;-- HELP with no arguments
			print {Use HELP or ? to see built-in info:

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other useful functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
    about - display version number and build date
    q or quit - leave the Red console
}
			exit
		]
		all [word? :word datatype? get :word] [			;-- HELP <datatype!>
			type: get :word
			foreach w system/words [
				if type = type? get w [
					case [
						any [function? get w native? get w action? get w op? get w routine? get w][
							prin [tab w]
							spec: spec-of get w

							either any [
								string? desc: spec/1
								string? desc: spec/2	;-- attributes block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
			exit
		]
		string? :word [
			foreach w system/words [
				if any [function? get w native? get w action? get w op? get w routine? get w][
					spec: spec-of get w
					if any [find form w word find form spec word] [
						prin [tab w]

						either any [
							string? desc: spec/1
							string? desc: spec/2		;-- attributes block case
						][
							print ["^-=> " desc]
						][
							prin lf
						]
					]
				]
			]
			exit
		]
		'else [
			type: type? :word
			print [mold :word "is" a-an form type type]
			exit
		]
	]

	func-name: :word

	argument-rule: [
		set word [word! | lit-word! | get-word!]
		(prin [tab mold :word])
		opt [set type block!  (prin [#" " mold type])]
		opt [set info string! (prin [" =>" append form info dot])]
		(prin lf)
	]

	case [
		unset? get/any :word [
			print ["Word" :word "is not defined"]
		]
		all [
			any [word? func-name path? func-name]
			fun: get func-name
			any [action? :fun function? :fun native? :fun op? :fun routine? :fun]
		][
			prin ["^/USAGE:^/" tab ]

			parse spec-of :fun [
				start: [									;-- 1st pass
					any [block! | string! ]
					opt [set w [word! | lit-word! | get-word!] (either op? :fun [prin [mold w func-name]][prin [func-name mold w]])]
					any [
						/local to end
						| set w [word! | lit-word! | get-word!] (prin [" " w])
						| set w refinement! (prin [" " mold w])
						| skip
					]
				]

				:start										;-- 2nd pass
				opt [set attributes block! (prin ["^/^/ATTRIBUTES:^/" tab mold attributes])]
				opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot lf tab func-name "is of type:" mold type? :fun])]

				(print "^/ARGUMENTS:")
				any [argument-rule]; (prin lf)]

				(print "^/REFINEMENTS:")
				any [
					/local [
						to ahead set-word! 'return set block block!
						(print ["^/RETURN:^/" mold block])
						| to end
					]
					| [
						set ref refinement! (prin [tab mold ref])
						opt [set info string! (prin [" =>" append form info dot])]
						(tab: tab8 prin lf)
						any [argument-rule]
						(tab: tab4)
					]
				]
			]
		]
		all [any [word? word path? word] object? get word][
			prin #"`"
			prin form word
			print "` is an object! of value:"

			foreach w words-of get word [
				value: get/any in get word w

				desc: case [
					object? :value  [words-of value]
					find [op! action! native! function! routine!] type?/word :value [
						spec: spec-of :value
						if string? spec/1 [spec: spec/1]
						spec
					]
					'else [:value]
				]

				desc: either string? desc [copy/part desc 47][mold/part/flat desc 47]

				if 47 = length? desc [					;-- optimized for width = 78
					clear skip tail desc -3
					append desc "..."
				]
				print [
					tab
					pad form/part w 16 16
					pad mold type? get/any w 9
					desc
				]
			]
		]
		'else [
			value: get :word
			print [
				word "is a"
				mold type? :value
				"of value:"
				mold either path? :value [get :value][:value]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

a-an: function [s [string!]][
	pick ["an" "a"] make logic! find "aeiou" s/1
]

what: function [
	"Lists all functions, or words of a given type"
][
	foreach w system/words [
		if any [function? get w native? get w action? get w op? get w routine? get w][
			prin pad form w 15
			spec: spec-of get w

			either any [
				string? desc: spec/1
				string? desc: spec/2					;-- attributes block case
			][
				print [#":" desc]
			][
				prin lf
			]
		]
	]
	exit												;-- return unset value
]

source: function [
	"Print the source of a function"
	'func-name [any-word!] "The name of the function"
][
	print either function? get func-name [
		[append mold func-name #":" mold get func-name]
	][
		type: mold type? get func-name
		["Sorry," func-name "is" a-an type "so no source is available"]
	]
]

about: function [
	"Print Red version information"
][
	print ["Red" system/version #"-" system/build]
]