FIX: not working comparison operators on any-block! series with offset.

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!]
	][
		series: GET_BUFFER(blk)
		(as-integer (series/tail - series/offset)) >> 4 - blk/head
	]

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

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

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

		s: GET_BUFFER(blk)

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

		offset
	]

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

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

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

		arg
	]

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

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

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

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

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

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

	mold-each: func [
		blk		  [red-block!]
		buffer	  [red-string!]
		only?	  [logic!]
		all?	  [logic!]
		flat?	  [logic!]
		arg		  [red-value!]
		part 	  [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
		][
			depth: depth + 1
			part: actions/mold value buffer only? all? flat? arg part
			if all [OPTION?(arg) part <= 0][return part]

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

		if 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]
		]

		value1: s1/offset + blk1/head
		value2: s2/offset + blk2/head
		end: s1/tail									;-- only one "end" is needed
		until [
			res: actions/compare value1 value2 op
			value1: value1 + 1
			value2: value2 + 1
			any [
				not res
				value1 >= end
			]
		]
		if op = COMP_NOT_EQUAL [res: not res]
		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--]
		]
		blk: as red-block! stack/push*
		blk/header: TYPE_BLOCK							;-- implicit reset of all header flags
		blk/head: 	0
		blk/node: 	alloc-cells size
		blk
	]

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

		i: blk/head
		while [
			s: GET_BUFFER(blk)
			value: s/offset + i
			value < s/tail
		][
			part: actions/form value buffer arg part
			if all [OPTION?(arg) part <= 0][return part]
			i: i + 1

			if TYPE_OF(value) <> TYPE_BLOCK [
				string/append-char GET_BUFFER(buffer) as-integer #" "
				part: part - 1
			]
		]
		part
	]

	mold: func [
		blk		  [red-block!]
		buffer	  [red-string!]
		only?	  [logic!]
		all?	  [logic!]
		flat?	  [logic!]
		arg		  [red-value!]
		part 	  [integer!]
		return:   [integer!]
		/local
			s	  [series!]
			value [red-value!]
			i     [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 only? all? flat? arg part

		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
	]

	;--- 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 [
		return: [red-value!]
		/local
			blk	[red-block!]
			int [red-integer!]
			s	[series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/length?"]]

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

	;--- Navigation actions ---

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

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

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

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

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

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

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

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

	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!]
			int		[red-integer!]
			b		[red-block!]
			values	[integer!]
			step	[integer!]
			n		[integer!]
			part?	[logic!]
			op		[integer!]
			found?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/find"]]

		s: GET_BUFFER(blk)
		if s/offset = s/tail [							;-- early exit if blk is empty
			blk/header: TYPE_NONE
			return s/offset
		]
		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
				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
		]

		values: either only? [0][						;-- values > 0 => series comparison mode
			either any [								;@@ replace with ANY_BLOCK?
				TYPE_OF(value) = TYPE_BLOCK
				TYPE_OF(value) = TYPE_PAREN
				TYPE_OF(value) = TYPE_PATH
				TYPE_OF(value) = TYPE_GET_PATH
				TYPE_OF(value) = TYPE_SET_PATH
				TYPE_OF(value) = 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 - 1 ;-- -1 => adjusted for loop comparison
			][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]
				end: s/offset
			]
			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
		if match? [tail?: yes]

		until [
			either zero? values [
				found?: actions/compare slot value op	;-- atomic comparison
			][
				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
						slot2 >= end2					;-- block series tail reached
					]
				]
				if all [match? found?][slot: slot2 + 1]
			]
			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 tail? [slot: slot - step]				;-- point before/after found value

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

	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!]
		tail?	 [logic!]
		match?	 [logic!]
		return:	 [red-value!]
		/local
			s	 [series!]
			p	 [red-value!]
	][
		p: find blk value part only? case? any? with-arg skip last? reverse? no no

		if TYPE_OF(blk) <> TYPE_NONE [
			s: GET_BUFFER(blk)
			p: s/offset + blk/head + 1
			either p < s/tail [
				stack/set-last p
			][
				blk/header: TYPE_NONE
			]
		]
		p
	]

	;--- Reading actions ---

	pick: func [
		blk	       [red-block!]
		index  	   [integer!]
		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 ---

	append: func [
		blk		  [red-block!]
		value	  [red-value!]
		part-arg  [red-value!]
		only?	  [logic!]
		dup-arg	  [red-value!]
		return:	  [red-value!]
		/local
			src	  [red-block!]
			cell  [red-value!]
			limit [red-value!]
			int	  [red-integer!]
			b	  [red-block!]
			s	  [series!]
			cnt	  [integer!]
			part  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/append"]]

		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
		]

		while [not zero? cnt][							;-- /dup support
			either 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?
				]
			][
				src: as red-block! value
				if negative? part [part: rs-length? src] ;-- if not /part, use whole value length
				s: GET_BUFFER(src)
				cell: s/offset + src/head
				limit: cell + part						;-- /part support

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

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

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

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

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

		index: as red-integer! blk + 1
		idx: index/value

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

		either any [
			zero? idx
			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
				as red-value! blk + 2
				cell
		]
		as red-value! blk
	]

	;--- Misc actions ---

	copy: func [
		blk	    	[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!]
			new		[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

		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
			]
			slots: part
			part: part << 4
		]

		new: 	alloc-cells slots
		buffer: as series! new/value

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

			buffer/tail: buffer/offset + slots
		]
		blk/node: new									;-- reuse the block slot
		blk/head: 0										;-- reset head offset

		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
				][
					actions/copy as red-series! slot null yes null
				]
				slot: slot + 1
				slot >= buffer/tail
			]
		]

		as red-series! blk
	]

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

Red/System [
	Title:   "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!]
	][
		series: GET_BUFFER(blk)
		(as-integer (series/tail - series/offset)) >> 4 - blk/head
	]

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

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

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

		s: GET_BUFFER(blk)

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

		offset
	]

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

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

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

		arg
	]

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

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

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

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

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

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

	mold-each: func [
		blk		  [red-block!]
		buffer	  [red-string!]
		only?	  [logic!]
		all?	  [logic!]
		flat?	  [logic!]
		arg		  [red-value!]
		part 	  [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
		][
			depth: depth + 1
			part: actions/mold value buffer only? all? flat? arg part
			if all [OPTION?(arg) part <= 0][return part]

			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!]
			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) - blk1/head
		size2: (as-integer s2/tail - s2/offset) - blk2/head

		if 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]
		]

		value1: s1/offset + blk1/head
		value2: s2/offset + blk2/head
		end: s1/tail									;-- only one "end" is needed
		until [
			res: actions/compare value1 value2 op
			value1: value1 + 1
			value2: value2 + 1
			any [
				not res
				value1 >= end
			]
		]
		if op = COMP_NOT_EQUAL [res: not res]
		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--]
		]
		blk: as red-block! stack/push*
		blk/header: TYPE_BLOCK							;-- implicit reset of all header flags
		blk/head: 	0
		blk/node: 	alloc-cells size
		blk
	]

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

		i: blk/head
		while [
			s: GET_BUFFER(blk)
			value: s/offset + i
			value < s/tail
		][
			part: actions/form value buffer arg part
			if all [OPTION?(arg) part <= 0][return part]
			i: i + 1

			if TYPE_OF(value) <> TYPE_BLOCK [
				string/append-char GET_BUFFER(buffer) as-integer #" "
				part: part - 1
			]
		]
		part
	]

	mold: func [
		blk		  [red-block!]
		buffer	  [red-string!]
		only?	  [logic!]
		all?	  [logic!]
		flat?	  [logic!]
		arg		  [red-value!]
		part 	  [integer!]
		return:   [integer!]
		/local
			s	  [series!]
			value [red-value!]
			i     [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 only? all? flat? arg part

		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
	]

	;--- 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 [
		return: [red-value!]
		/local
			blk	[red-block!]
			int [red-integer!]
			s	[series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/length?"]]

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

	;--- Navigation actions ---

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

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

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

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

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

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

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

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

	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!]
			int		[red-integer!]
			b		[red-block!]
			values	[integer!]
			step	[integer!]
			n		[integer!]
			part?	[logic!]
			op		[integer!]
			found?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/find"]]

		s: GET_BUFFER(blk)
		if s/offset = s/tail [							;-- early exit if blk is empty
			blk/header: TYPE_NONE
			return s/offset
		]
		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
				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
		]

		values: either only? [0][						;-- values > 0 => series comparison mode
			either any [								;@@ replace with ANY_BLOCK?
				TYPE_OF(value) = TYPE_BLOCK
				TYPE_OF(value) = TYPE_PAREN
				TYPE_OF(value) = TYPE_PATH
				TYPE_OF(value) = TYPE_GET_PATH
				TYPE_OF(value) = TYPE_SET_PATH
				TYPE_OF(value) = 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 - 1 ;-- -1 => adjusted for loop comparison
			][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]
				end: s/offset
			]
			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
		if match? [tail?: yes]

		until [
			either zero? values [
				found?: actions/compare slot value op	;-- atomic comparison
			][
				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
						slot2 >= end2					;-- block series tail reached
					]
				]
				if all [match? found?][slot: slot2 + 1]
			]
			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 tail? [slot: slot - step]				;-- point before/after found value

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

	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!]
		tail?	 [logic!]
		match?	 [logic!]
		return:	 [red-value!]
		/local
			s	 [series!]
			p	 [red-value!]
	][
		p: find blk value part only? case? any? with-arg skip last? reverse? no no

		if TYPE_OF(blk) <> TYPE_NONE [
			s: GET_BUFFER(blk)
			p: s/offset + blk/head + 1
			either p < s/tail [
				stack/set-last p
			][
				blk/header: TYPE_NONE
			]
		]
		p
	]

	;--- Reading actions ---

	pick: func [
		blk	       [red-block!]
		index  	   [integer!]
		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 ---

	append: func [
		blk		  [red-block!]
		value	  [red-value!]
		part-arg  [red-value!]
		only?	  [logic!]
		dup-arg	  [red-value!]
		return:	  [red-value!]
		/local
			src	  [red-block!]
			cell  [red-value!]
			limit [red-value!]
			int	  [red-integer!]
			b	  [red-block!]
			s	  [series!]
			cnt	  [integer!]
			part  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "block/append"]]

		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
		]

		while [not zero? cnt][							;-- /dup support
			either 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?
				]
			][
				src: as red-block! value
				if negative? part [part: rs-length? src] ;-- if not /part, use whole value length
				s: GET_BUFFER(src)
				cell: s/offset + src/head
				limit: cell + part						;-- /part support

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

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

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

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

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

		index: as red-integer! blk + 1
		idx: index/value

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

		either any [
			zero? idx
			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
				as red-value! blk + 2
				cell
		]
		as red-value! blk
	]

	;--- Misc actions ---

	copy: func [
		blk	    	[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!]
			new		[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

		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
			]
			slots: part
			part: part << 4
		]

		new: 	alloc-cells slots
		buffer: as series! new/value

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

			buffer/tail: buffer/offset + slots
		]
		blk/node: new									;-- reuse the block slot
		blk/head: 0										;-- reset head offset

		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
				][
					actions/copy as red-series! slot null yes null
				]
				slot: slot + 1
				slot >= buffer/tail
			]
		]

		as red-series! blk
	]

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


TESTS: enables LOOP+CATCH tests and adds new ones.

Red [
  Title:   "Red CATCH/THROW test script"
  Author:  "Nenad Rakocevic"
  File: 	 %throw-test.reds
  Tabs:    4
  Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. 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~~~ "catch/throw"

===start-group=== "Anonymous THROW"

	--test-- "an1" --assert 1  = catch [throw 1 --assert no]
	--test-- "an2" --assert 2  = catch [if true [throw 2 --assert no] --assert no]
	--test-- "an3" --assert 3  = catch [loop 1 [throw 3 --assert no] --assert no]
	--test-- "an4" --assert 4  = catch [while [true][throw 4 --assert no] --assert no]
	--test-- "an5" --assert 5  = catch [until [throw 5 --assert no] --assert no]
	--test-- "an6" --assert 6  = catch [6]
	--test-- "an7" --assert 7  = catch [4 + 3]
	--test-- "an8" --assert 8  = catch [do [throw 8 --assert no] --assert no]

	--test-- "an9"
		f: does [throw 9 --assert no]
		--assert 9 = catch [f]

	--test-- "an10"
		f: does [throw 10 --assert no]
		g: does [f --assert no]
		--assert 10 = catch [g]

	--test-- "an11" --assert 11 = catch [parse "1" [(throw 11 --assert no)] --assert no]

===end-group===

===start-group=== "Named THROW"

	--test-- "name1" --assert 1  = catch [throw/name 1 'a --assert no]
	--test-- "name2" --assert 2  = catch/name [if true [throw/name 2 'a --assert no] --assert no] 'a
	--test-- "name3" --assert 3  = catch/name [loop 1 [throw/name 3 'b --assert no] --assert no] 'b
	--test-- "name4" --assert 4  = catch/name [while [true][throw/name 4 'c --assert no] --assert no] 'c
	--test-- "name5" --assert 5  = catch/name [until [throw/name 5 'd --assert no] --assert no] 'd
	--test-- "name6" --assert 6  = catch/name [do [throw/name 6 'e --assert no] --assert no] 'e

	--test-- "name7"
		f: does [throw/name 7 'i --assert no]
		--assert 7 = catch/name [f] 'i

	--test-- "name8"
		f: does [throw/name 10 'j --assert no]
		g: does [f --assert no]
		--assert 10 = catch/name [g] 'j

	--test-- "name9"
		--assert 1 = catch/name [
			catch/name [throw/name 1 'hello	--assert no] 'world
			--assert no
		] 'hello

	--test-- "name10"
		--assert 123 = catch/name [
			--assert 2 = catch [throw/name 2 'hello --assert no]
			123
		] 'hello

	--test-- "name9"
		--assert 1 = catch [
			catch/name [throw/name 1 'hello	--assert no] 'world
			--assert yes
		]

===end-group===

~~~end-file~~~

Red [
  Title:   "Red CATCH/THROW test script"
  Author:  "Nenad Rakocevic"
  File: 	 %throw-test.reds
  Tabs:    4
  Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. 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~~~ "catch/throw"

===start-group=== "Anonymous THROW"

	--test-- "an1" --assert 1  = catch [throw 1 --assert no]
	--test-- "an2" --assert 2  = catch [if true [throw 2 --assert no] --assert no]
	;--test-- "an3" --assert 3  = catch [loop 1 [throw 3 --assert no] --assert no]
	--test-- "an4" --assert 4  = catch [while [true][throw 4 --assert no] --assert no]
	--test-- "an5" --assert 5  = catch [until [throw 5 --assert no] --assert no]
	--test-- "an6" --assert 6  = catch [6]
	--test-- "an7" --assert 7  = catch [4 + 3]
	--test-- "an8" --assert 8  = catch [do [throw 8 --assert no] --assert no]

	--test-- "an9"
		f: does [throw 9 --assert no]
		--assert 9 = catch [f]

	--test-- "an10"
		f: does [throw 10 --assert no]
		g: does [f --assert no]
		--assert 10 = catch [g]

===end-group===

===start-group=== "Named THROW"

	--test-- "name1" --assert 1  = catch [throw/name 1 'a --assert no]
	--test-- "name2" --assert 2  = catch/name [if true [throw/name 2 'a --assert no] --assert no] 'a
	;--test-- "name3" --assert 3  = catch/name [loop 1 [throw/name 3 'b --assert no] --assert no] 'b
	--test-- "name4" --assert 4  = catch/name [while [true][throw/name 4 'c --assert no] --assert no] 'c
	--test-- "name5" --assert 5  = catch/name [until [throw/name 5 'd --assert no] --assert no] 'd
	--test-- "name6" --assert 6  = catch/name [do [throw/name 6 'e --assert no] --assert no] 'e

	--test-- "name7"
		f: does [throw/name 7 'i --assert no]
		--assert 7 = catch/name [f] 'i

	--test-- "name8"
		f: does [throw/name 10 'j --assert no]
		g: does [f --assert no]
		--assert 10 = catch/name [g] 'j

	--test-- "name9"
		--assert 1 = catch/name [
			catch/name [throw/name 1 'hello	--assert no] 'world
			--assert no
		] 'hello

	--test-- "name10"
		--assert 123 = catch/name [
			--assert 2 = catch [throw/name 2 'hello --assert no]
			123
		] 'hello

	--test-- "name9"
		--assert 1 = catch [
			catch/name [throw/name 1 'hello	--assert no] 'world
			--assert yes
		]

===end-group===

~~~end-file~~~


FIX: wrong `stat` struct layout for MacOSX.

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

simple-io: context [

	#either OS = 'Windows [

		#define GENERIC_READ 			80000000h
		#define FILE_SHARE_READ			00000001h
		#define OPEN_EXISTING			00000003h
		#define FILE_ATTRIBUTE_NORMAL	00000080h

		#import [
			"kernel32.dll" stdcall [
				CreateFile:	"CreateFileA" [
					filename	[c-string!]
					access		[integer!]
					share		[integer!]
					security	[int-ptr!]
					disposition	[integer!]
					flags		[integer!]
					template	[int-ptr!]
					return:		[integer!]
				]
				ReadFile:	"ReadFile" [
					file		[integer!]
					buffer		[byte-ptr!]
					bytes		[integer!]
					read		[int-ptr!]
					overlapped	[int-ptr!]
					return:		[integer!]
				]
				GetFileSize: "GetFileSize" [
					file		[integer!]
					high-size	[integer!]
					return:		[integer!]
				]
				CloseHandle:	"CloseHandle" [
					obj			[integer!]
					return:		[integer!]
				]
			]
		]
	][
		#define O_RDONLY	0

		#import [
			LIBC-file cdecl [
				_open:	"open" [
					filename	[c-string!]
					flags		[integer!]
					mode		[integer!]
					return:		[integer!]
				]
				_read:	"read" [
					file		[integer!]
					buffer		[byte-ptr!]
					bytes		[integer!]
					return:		[integer!]
				]
				_close:	"close" [
					file		[integer!]
					return:		[integer!]
				]
			]
		]

		#either OS = 'MacOSX [
			stat!: alias struct! [
				st_dev		[integer!]
				st_ino		[integer!]
				st_modelink	[integer!]					;-- st_mode & st_link are both 16bit fields
				st_uid		[integer!]
				st_gid		[integer!]
				st_rdev		[integer!]
				atv_sec		[integer!]					;-- struct timespec inlined
				atv_msec	[integer!]
				mtv_sec		[integer!]					;-- struct timespec inlined
				mtv_msec	[integer!]
				ctv_sec		[integer!]					;-- struct timespec inlined
				ctv_msec	[integer!]
				st_size		[integer!]
				st_blocks	[integer!]
				st_blksize	[integer!]
				st_flags	[integer!]
				st_gen		[integer!]
			]
			#import [
				LIBC-file cdecl [
					;--- https://developer.apple.com/library/mac/documentation/Darwin/Reference/ManPages/10.6/man2/stat.2.html?useVersion=10.6
					_stat:	"fstat" [
						file		[integer!]
						restrict	[stat!]
						return:		[integer!]
					]
				]
			]
		][
			stat!: alias struct! [
				st_dev		[integer!]
				st_ino		[integer!]
				st_mode		[integer!]
				st_nlink	[integer!]
				st_uid		[integer!]
				st_gid		[integer!]
				st_rdev		[integer!]
				st_size		[integer!]
				st_blksize	[integer!]
				st_blocks	[integer!]
				st_atime	[integer!]
				st_mtime	[integer!]
				st_ctime	[integer!]
			]
			#import [
				LIBC-file cdecl [
					;--- http://refspecs.linuxbase.org/LSB_3.0.0/LSB-Core-generic/LSB-Core-generic/baselib-xstat-1.html
					_stat:	"__xstat" [
						version		[integer!]
						filename	[c-string!]
						restrict	[stat!]
						return:		[integer!]
					]
				]
			]
		]
	]

	open-file: func [
		filename [c-string!]
		return:	 [integer!]
		/local
			file [integer!]
	][
		#either OS = 'Windows [
			file: CreateFile
				filename
				GENERIC_READ
				FILE_SHARE_READ
				null
				OPEN_EXISTING
				FILE_ATTRIBUTE_NORMAL
				null
		][
			file: _open filename O_RDONLY 0
		]
		if file = -1 [
			print-line "*** Error: File not found"
			quit -1
		]
		file
	]

	file-size?: func [
		file	 [integer!]
		filename [c-string!]
		return:	 [integer!]
		/local s
	][
		#switch OS [
			Windows [
				GetFileSize file null
			]
			MacOSX [
				s: declare stat!
				_stat file s
				s/st_size
			]
			#default [
				s: declare stat!
				_stat 3 filename s
				s/st_size
			]
		]
	]

	read-file: func [
		file	[integer!]
		buffer	[byte-ptr!]
		size	[integer!]
		return:	[integer!]
		/local
			read-sz [integer!]
			res		[integer!]
			error?	[logic!]
	][
		#either OS = 'Windows [
			read-sz: -1
			res: ReadFile file buffer size :read-sz null
			error?: any [zero? res read-sz <> size]
		][
			res: _read file buffer size
			error?: res <= 0
		]
		if error? [
			print-line "*** Error: cannot read file"
			quit -3
		]
		res
	]

	close-file: func [
		file	[integer!]
		return:	[integer!]
	][
		#either OS = 'Windows [
			CloseHandle file
		][
			_close file
		]
	]

	read-txt: func [
		filename [c-string!]
		return:	 [red-string!]
		/local
			buffer	[byte-ptr!]
			file	[integer!]
			size	[integer!]
			str		[red-string!]
	][
		file: open-file filename
		size: file-size? file filename
		if size <= 0 [
			print-line "*** Error: empty file"
			quit -2
		]

		buffer: allocate size + 1						;-- account for terminal NUL
		read-file file buffer size
		close-file file

		size: size + 1
		buffer/size: null-byte
		str: string/load as-c-string buffer size
		free buffer
		str
	]
]

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

simple-io: context [

	#either OS = 'Windows [

		#define GENERIC_READ 			80000000h
		#define FILE_SHARE_READ			00000001h
		#define OPEN_EXISTING			00000003h
		#define FILE_ATTRIBUTE_NORMAL	00000080h

		#import [
			"kernel32.dll" stdcall [
				CreateFile:	"CreateFileA" [
					filename	[c-string!]
					access		[integer!]
					share		[integer!]
					security	[int-ptr!]
					disposition	[integer!]
					flags		[integer!]
					template	[int-ptr!]
					return:		[integer!]
				]
				ReadFile:	"ReadFile" [
					file		[integer!]
					buffer		[byte-ptr!]
					bytes		[integer!]
					read		[int-ptr!]
					overlapped	[int-ptr!]
					return:		[integer!]
				]
				GetFileSize: "GetFileSize" [
					file		[integer!]
					high-size	[integer!]
					return:		[integer!]
				]
				CloseHandle:	"CloseHandle" [
					obj			[integer!]
					return:		[integer!]
				]
			]
		]
	][
		#define O_RDONLY	0

		#import [
			LIBC-file cdecl [
				_open:	"open" [
					filename	[c-string!]
					flags		[integer!]
					mode		[integer!]
					return:		[integer!]
				]
				_read:	"read" [
					file		[integer!]
					buffer		[byte-ptr!]
					bytes		[integer!]
					return:		[integer!]
				]
				_close:	"close" [
					file		[integer!]
					return:		[integer!]
				]
			]
		]

		#either OS = 'MacOSX [
			stat!: alias struct! [
				st_dev		[integer!]
				st_ino		[integer!]
				st_mode		[integer!]
				st_nlink	[integer!]
				st_uid		[integer!]
				st_gid		[integer!]
				st_rdev		[integer!]
				st_atime	[integer!]					;-- struct timespec
				st_mtime	[integer!]					;-- struct timespec
				st_ctime	[integer!]					;-- struct timespec
				st_size		[integer!]
				st_blocks	[integer!]
				st_blksize	[integer!]
				st_flags	[integer!]
				st_gen		[integer!]
			]
			#import [
				LIBC-file cdecl [
					;--- https://developer.apple.com/library/mac/documentation/Darwin/Reference/ManPages/10.6/man2/stat.2.html?useVersion=10.6
					_stat:	"stat" [
						filename	[c-string!]
						restrict	[stat!]
						return:		[integer!]
					]
				]
			]
		][
			stat!: alias struct! [
				st_dev		[integer!]
				st_ino		[integer!]
				st_mode		[integer!]
				st_nlink	[integer!]
				st_uid		[integer!]
				st_gid		[integer!]
				st_rdev		[integer!]
				st_size		[integer!]
				st_blksize	[integer!]
				st_blocks	[integer!]
				st_atime	[integer!]
				st_mtime	[integer!]
				st_ctime	[integer!]
			]
			#import [
				LIBC-file cdecl [
					;--- http://refspecs.linuxbase.org/LSB_3.0.0/LSB-Core-generic/LSB-Core-generic/baselib-xstat-1.html
					_stat:	"__xstat" [
						version		[integer!]
						filename	[c-string!]
						restrict	[stat!]
						return:		[integer!]
					]
				]
			]
		]
	]

	open-file: func [
		filename [c-string!]
		return:	 [integer!]
		/local
			file [integer!]
	][
		#either OS = 'Windows [
			file: CreateFile
				filename
				GENERIC_READ
				FILE_SHARE_READ
				null
				OPEN_EXISTING
				FILE_ATTRIBUTE_NORMAL
				null
		][
			file: _open filename O_RDONLY 0
		]
		if file = -1 [
			print-line "*** Error: File not found"
			quit -1
		]
		file
	]

	file-size?: func [
		file	 [integer!]
		filename [c-string!]
		return:	 [integer!]
		/local s
	][
		#switch OS [
			Windows [
				GetFileSize file null
			]
			MacOSX [
				s: declare stat!
				_stat filename s
				s/st_size
			]
			#default [
				s: declare stat!
				_stat 3 filename s
				s/st_size
			]
		]
	]

	read-file: func [
		file	[integer!]
		buffer	[byte-ptr!]
		size	[integer!]
		return:	[integer!]
		/local
			read-sz [integer!]
			res		[integer!]
			error?	[logic!]
	][
		#either OS = 'Windows [
			read-sz: -1
			res: ReadFile file buffer size :read-sz null
			error?: any [zero? res read-sz <> size]
		][
			res: _read file buffer size
			error?: res <= 0
		]
		if error? [
			print-line "*** Error: cannot read file"
			quit -3
		]
		res
	]

	close-file: func [
		file	[integer!]
		return:	[integer!]
	][
		#either OS = 'Windows [
			CloseHandle file
		][
			_close file
		]
	]

	read-txt: func [
		filename [c-string!]
		return:	 [red-string!]
		/local
			buffer	[byte-ptr!]
			file	[integer!]
			size	[integer!]
			str		[red-string!]
	][
		file: open-file filename
		size: file-size? file filename
		if size <= 0 [
			print-line "*** Error: empty file"
			quit -2
		]

		buffer: allocate size + 1						;-- account for terminal NUL
		read-file file buffer size
		close-file file

		size: size + 1
		buffer/size: null-byte
		str: string/load as-c-string buffer size
		free buffer
		str
	]
]


TESTS: new regression test for issue #160

Red/System [
	Title:   "Red/System datatype casting test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %cast-test.reds
	Rights:  "Copyright (C) 2011 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.reds

~~~start-file~~~ "cast"

===start-group=== "cast from byte!"

	--test-- "byte-cast-1"
	--assert 65 = as integer! #"A"

	--test-- "byte-cast-2"
	  cast-b: #"A"
	  cast-i: 65
	--assert cast-i = as integer! cast-b

	--test-- "byte-cast-3"
	--assert false = as logic! #"^(00)"

	--test-- "byte-cast-4"
    cast-b: #"^(00)"
	  l: false
	--assert l = as logic! cast-b

	--test-- "byte-cast-5"
	--assert true = as logic! #"A"

	--test-- "byte-cast-6"
	  cast-b: #"A"
	  l: true
	--assert l = as logic! cast-b

	--test-- "byte-cast-7"
	--assert true = as logic! #"^(FF)"

	--test-- "byte-cast-8"
	  cast-b: #"^(FF)"
	  l: true
	--assert l = as logic! cast-b

	--test-- "byte-cast-9"							;-- issue #158
	  a: as-byte 10h
	  b: as-byte 80h
	--assert 10h = as-integer a

	--test-- "byte-cast-10"							;-- issue #159
	  a: as-byte 10h
	  b: as-byte 80h
	  c: as-integer a
	--assert 10h = c

	--test-- "byte-cast-11"							;-- issue #160
	  a: as-byte 1
	  b: as-byte 2
	  --assert (as byte-ptr! (as-integer a) * 2) = (as byte-ptr! 2)
	  --assert (as byte-ptr! (as-integer a) << 2) = (as byte-ptr! 4)

===end-group===

===start-group=== "cast from integer!"
comment {
  --test-- "int-cast-1"
  --assert #"^(00)" = as byte! 0
}
  --test-- "int-cast-2"
    i: 0
    cast-test-b: #"^(00)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-3"
  --assert #"^(01)" = as byte! 1

  --test-- "int-cast-4"
    i: 1
    cast-test-b: #"^(01)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-5"
  --assert #"^(FF)" = as byte! 255

  --test-- "int-cast-6"
    i: 255
    cast-test-b: #"^(FF)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-7"
  --assert #"^(00)" = as byte! 256

  --test-- "int-cast-8"
    i: 256
    cast-test-b: #"^(00)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-9"
  --assert false = as logic! 0

  --test-- "int-cast-10"
    i: 0
    l: false
  --assert l = as logic! i

  --test-- "int-cast-11"
  --assert true = as logic! FFFFFFFFh

  --test-- "int-cast-12"
    i: FFFFFFFFh
    l: true
  --assert l = as logic! i

  --test-- "int-cast-13"
  --assert true = as logic! 1

  --test-- "int-cast-14"
    i: 1
    l: true
  --assert l = as logic! i

  --test-- "int-cast-15"
    cs: "Hello"
    cs2: ""
    i: as integer! cs
    i: i + 1
    cs2: as c-string! i
  --assert cs2/1 = #"e"
  --assert 4 = length? cs2

  --test-- "int-cast-16"           ;; This test assumes 32-bit target
    i: 1
    p: declare pointer! [integer!]
    p: as [pointer! [integer!]] i
    P: P + 1
    i2: as integer! p
  --assert i2 = 5

  --test-- "int-cast-17"           ;; This test assumes 32-bit target
    ;; currently fails as p-int-cast is not declared
    i: 1
    p-int-cast-17: as [pointer! [integer!]] i
    P-int-cast-17: P-int-cast-17 + 1
    i2: as integer! p-int-cast-17
  --assert i2 = 5

  --test-- "int-cast-18"
    i: 1
    s: declare struct! [
      a [integer!]
      b [integer!]
    ]
    s: as [struct! [a [integer!] b [integer!]]] i
    s: s + 1
    i2: as integer! s
  --assert i2 = 9

  --test-- "int-cast-19"
    ic19-logic: either as-logic 0 [
      false
    ][
      true
    ]
  --assert ic19-logic

  --test-- "int-cast-20"
    ic20-dummy: func [return: [integer!]][0]
    ic20-logic: either as-logic ic20-dummy [
       false
    ][
      true
    ]
  --assert ic20-logic

===end-group===

===start-group=== "cast from logic!"

  --test-- "logic-cast-1"
  --assert #"^(01)" = as byte! true

  --test-- "logic-cast-2"
    cast-test-b: #"^(01)"
    l: true
  --assert cast-test-b = as byte! l

  --test-- "logic-cast-3"
  --assert #"^(00)" = as byte! false

  --test-- "logic-cast-4"
    cast-test-b: #"^(00)"
    l: false
  --assert cast-test-b = as byte! l

    --test-- "logic-cast-5"
  --assert 1 = as integer! true

  --test-- "logic-cast-6"
    i: 1
    l: true
  --assert i = as integer! l

  --test-- "logic-cast-7"
  --assert 0 = as integer! false

  --test-- "logic-cast-8"
    i: 0
    l: false
  --assert i = as integer! l

===end-group===

===start-group=== "cast c-string! tests"

  --test-- "c-string-cast-1"
    csc1-str: "Hello, Nenad"
    i: 0
    i: as integer! csc1-str
    i: i + 7
    csc1-str: as c-string! i
  --assert csc1-str/1 = #"N"
  --assert csc1-str/2 = #"e"
  --assert csc1-str/3 = #"n"
  --assert csc1-str/4 = #"a"
  --assert csc1-str/5 = #"d"
  comment {
  --test-- "c-string-cast-2"
  --assert false = as logic! ""
  }
    --test-- "c-string-cast-3"
    csc3-str: ""
  --assert false = as logic! csc3-str

  --test-- "c-string-cast-4"
  --assert true = as logic! "Any old iron, any old iron"

  --test-- "c-string-cast-5"
    csc5-str: "Why not?"
  --assert true = as logic! csc5-str

  --test-- "c-string-cast-6"
    csc6-str: "Tour de France"
    csc6-p: declare pointer! [integer!]
    csc6-p: as [pointer! [integer!]] csc6-str
    csc6-p: csc6-p + 2
    csc6-str2: as c-string! csc6-p
  --assert csc6-str2/1 = #"F"
  --assert csc6-str2/2 = #"r"
  --assert csc6-str2/3 = #"a"
  --assert csc6-str2/4 = #"n"
  --assert csc6-str2/5 = #"c"
  --assert csc6-str2/6 = #"e"

  --test-- "C-string-cast-7"
    csc7-struct: declare struct! [
      c1 [byte!]
      c2 [byte!]
      c3 [byte!]
      c4 [byte!]
      c5 [byte!]
    ]
    csc7-str: "Peter"
    csc7-struct: as [struct! [
      c1 [byte!] c2 [byte!] c3 [byte!] c4 [byte!] c5 [byte!]
    ]] csc7-str
  --assert csc7-struct/c1 = #"P"
  --assert csc7-struct/c2 = #"e"
  --assert csc7-struct/c3 = #"t"
  --assert csc7-struct/c4 = #"e"
  --assert csc7-struct/c5 = #"r"

===end-group===

===start-group=== "cast from pointer!"

  --test-- "csp-1"
    csp1-p: declare pointer! [integer!]
    csp1-p: as [pointer! [integer!]] 256
    i: 0
    i: as integer! csp1-p
  --assert i = 256

  --test-- "csp-2"
    csp2-p: declare pointer! [integer!]
    csp2-p: as [pointer! [integer!]] 0
  --assert false = as logic! csp2-p

  --test-- "csp-3"
    csp3-p: declare pointer! [integer!]
    csp3-p: as [pointer! [integer!]] 1
  --assert true = as logic! csp3-p

  --test-- "csp-4"
    csp4-p: declare pointer! [integer!]
    csp4-p: as [pointer! [integer!]] FFFFFFFFh
  --assert true = as logic! csp4-p

  --test-- "csp-5"
    csp5-p: declare pointer! [integer!]
    csp5-p: as [pointer! [integer!]] 7FFFFFFFh
  --assert true = as logic! csp5-p

  ;; No test for pointer! to c-string! as it would simply
  ;;  duplicate the one of c-string! to pointer!

  --test-- "csp-6"
    csp6-p: declare pointer! [integer!]
    csp6-s: declare struct! [
      a [integer!]
      b [integer!]
    ]
    csp6-s/a: 1
    csp6-s/b: 2
    csp6-p: as [pointer! [integer!]] csp6-s
  --assert csp6-p/value = 1
    csp6-p: csp6-p + 1
  --assert csp6-p/value = 2
    csp6-p: csp6-p - 1
    csp6-s: as [struct! [a [integer!] b [integer!]]] csp6-p
  --assert csp6-s/a = 1
    csp6-p: csp6-p + 1
    csp6-s: as [struct! [a [integer!] b [integer!]]] csp6-p
  --assert csp6-s/a = 2

===end-group===

===start-group=== "cast from struct!"

  ;; no test for cast to integer as it would simply
  ;;  duplicate the test from integer! to struct!

  --test-- "cfstruc-1"
    cfs1-struct: declare struct! [
      a [integer!]
      b [integer!]
    ]
    cfs1-struct: as [struct! [a [integer!] b [integer!]]] 0
  --assert false = as logic! cfs1-struct

  --test-- "cfstruc-2"
    cfs2-struct: declare struct! [
      a [integer!]
      b [integer!]
    ]
  --assert true = as logic! cfs2-struct

  ;; no test for cast to c-string! as it would simply
  ;;  duplicate the test from c-string! to struct!

  ;; no test for cast to pointer! as it would simply
  ;;  duplicate the test from pointer! to struct!

===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System datatype casting test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %cast-test.reds
	Rights:  "Copyright (C) 2011 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.reds

~~~start-file~~~ "cast"

===start-group=== "cast from byte!"

	--test-- "byte-cast-1"
	--assert 65 = as integer! #"A"

	--test-- "byte-cast-2"
	  cast-b: #"A"
	  cast-i: 65
	--assert cast-i = as integer! cast-b

	--test-- "byte-cast-3"
	--assert false = as logic! #"^(00)"

	--test-- "byte-cast-4"
    cast-b: #"^(00)"
	  l: false
	--assert l = as logic! cast-b

	--test-- "byte-cast-5"
	--assert true = as logic! #"A"

	--test-- "byte-cast-6"
	  cast-b: #"A"
	  l: true
	--assert l = as logic! cast-b

	--test-- "byte-cast-7"
	--assert true = as logic! #"^(FF)"

	--test-- "byte-cast-8"
	  cast-b: #"^(FF)"
	  l: true
	--assert l = as logic! cast-b

	--test-- "byte-cast-9"							;-- issue #158
	  a: as-byte 10h
	  b: as-byte 80h
	--assert 10h = as-integer a

	--test-- "byte-cast-9"							;-- issue #159
	  a: as-byte 10h
	  b: as-byte 80h
	  c: as-integer a
	--assert 10h = c

===end-group===

===start-group=== "cast from integer!"
comment {
  --test-- "int-cast-1"
  --assert #"^(00)" = as byte! 0
}
  --test-- "int-cast-2"
    i: 0
    cast-test-b: #"^(00)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-3"
  --assert #"^(01)" = as byte! 1

  --test-- "int-cast-4"
    i: 1
    cast-test-b: #"^(01)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-5"
  --assert #"^(FF)" = as byte! 255

  --test-- "int-cast-6"
    i: 255
    cast-test-b: #"^(FF)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-7"
  --assert #"^(00)" = as byte! 256

  --test-- "int-cast-8"
    i: 256
    cast-test-b: #"^(00)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-9"
  --assert false = as logic! 0

  --test-- "int-cast-10"
    i: 0
    l: false
  --assert l = as logic! i

  --test-- "int-cast-11"
  --assert true = as logic! FFFFFFFFh

  --test-- "int-cast-12"
    i: FFFFFFFFh
    l: true
  --assert l = as logic! i

  --test-- "int-cast-13"
  --assert true = as logic! 1

  --test-- "int-cast-14"
    i: 1
    l: true
  --assert l = as logic! i

  --test-- "int-cast-15"
    cs: "Hello"
    cs2: ""
    i: as integer! cs
    i: i + 1
    cs2: as c-string! i
  --assert cs2/1 = #"e"
  --assert 4 = length? cs2

  --test-- "int-cast-16"           ;; This test assumes 32-bit target
    i: 1
    p: declare pointer! [integer!]
    p: as [pointer! [integer!]] i
    P: P + 1
    i2: as integer! p
  --assert i2 = 5

  --test-- "int-cast-17"           ;; This test assumes 32-bit target
    ;; currently fails as p-int-cast is not declared
    i: 1
    p-int-cast-17: as [pointer! [integer!]] i
    P-int-cast-17: P-int-cast-17 + 1
    i2: as integer! p-int-cast-17
  --assert i2 = 5

  --test-- "int-cast-18"
    i: 1
    s: declare struct! [
      a [integer!]
      b [integer!]
    ]
    s: as [struct! [a [integer!] b [integer!]]] i
    s: s + 1
    i2: as integer! s
  --assert i2 = 9

  --test-- "int-cast-19"
    ic19-logic: either as-logic 0 [
      false
    ][
      true
    ]
  --assert ic19-logic

  --test-- "int-cast-20"
    ic20-dummy: func [return: [integer!]][0]
    ic20-logic: either as-logic ic20-dummy [
       false
    ][
      true
    ]
  --assert ic20-logic

===end-group===

===start-group=== "cast from logic!"

  --test-- "logic-cast-1"
  --assert #"^(01)" = as byte! true

  --test-- "logic-cast-2"
    cast-test-b: #"^(01)"
    l: true
  --assert cast-test-b = as byte! l

  --test-- "logic-cast-3"
  --assert #"^(00)" = as byte! false

  --test-- "logic-cast-4"
    cast-test-b: #"^(00)"
    l: false
  --assert cast-test-b = as byte! l

    --test-- "logic-cast-5"
  --assert 1 = as integer! true

  --test-- "logic-cast-6"
    i: 1
    l: true
  --assert i = as integer! l

  --test-- "logic-cast-7"
  --assert 0 = as integer! false

  --test-- "logic-cast-8"
    i: 0
    l: false
  --assert i = as integer! l

===end-group===

===start-group=== "cast c-string! tests"

  --test-- "c-string-cast-1"
    csc1-str: "Hello, Nenad"
    i: 0
    i: as integer! csc1-str
    i: i + 7
    csc1-str: as c-string! i
  --assert csc1-str/1 = #"N"
  --assert csc1-str/2 = #"e"
  --assert csc1-str/3 = #"n"
  --assert csc1-str/4 = #"a"
  --assert csc1-str/5 = #"d"
  comment {
  --test-- "c-string-cast-2"
  --assert false = as logic! ""
  }
    --test-- "c-string-cast-3"
    csc3-str: ""
  --assert false = as logic! csc3-str

  --test-- "c-string-cast-4"
  --assert true = as logic! "Any old iron, any old iron"

  --test-- "c-string-cast-5"
    csc5-str: "Why not?"
  --assert true = as logic! csc5-str

  --test-- "c-string-cast-6"
    csc6-str: "Tour de France"
    csc6-p: declare pointer! [integer!]
    csc6-p: as [pointer! [integer!]] csc6-str
    csc6-p: csc6-p + 2
    csc6-str2: as c-string! csc6-p
  --assert csc6-str2/1 = #"F"
  --assert csc6-str2/2 = #"r"
  --assert csc6-str2/3 = #"a"
  --assert csc6-str2/4 = #"n"
  --assert csc6-str2/5 = #"c"
  --assert csc6-str2/6 = #"e"

  --test-- "C-string-cast-7"
    csc7-struct: declare struct! [
      c1 [byte!]
      c2 [byte!]
      c3 [byte!]
      c4 [byte!]
      c5 [byte!]
    ]
    csc7-str: "Peter"
    csc7-struct: as [struct! [
      c1 [byte!] c2 [byte!] c3 [byte!] c4 [byte!] c5 [byte!]
    ]] csc7-str
  --assert csc7-struct/c1 = #"P"
  --assert csc7-struct/c2 = #"e"
  --assert csc7-struct/c3 = #"t"
  --assert csc7-struct/c4 = #"e"
  --assert csc7-struct/c5 = #"r"

===end-group===

===start-group=== "cast from pointer!"

  --test-- "csp-1"
    csp1-p: declare pointer! [integer!]
    csp1-p: as [pointer! [integer!]] 256
    i: 0
    i: as integer! csp1-p
  --assert i = 256

  --test-- "csp-2"
    csp2-p: declare pointer! [integer!]
    csp2-p: as [pointer! [integer!]] 0
  --assert false = as logic! csp2-p

  --test-- "csp-3"
    csp3-p: declare pointer! [integer!]
    csp3-p: as [pointer! [integer!]] 1
  --assert true = as logic! csp3-p

  --test-- "csp-4"
    csp4-p: declare pointer! [integer!]
    csp4-p: as [pointer! [integer!]] FFFFFFFFh
  --assert true = as logic! csp4-p

  --test-- "csp-5"
    csp5-p: declare pointer! [integer!]
    csp5-p: as [pointer! [integer!]] 7FFFFFFFh
  --assert true = as logic! csp5-p

  ;; No test for pointer! to c-string! as it would simply
  ;;  duplicate the one of c-string! to pointer!

  --test-- "csp-6"
    csp6-p: declare pointer! [integer!]
    csp6-s: declare struct! [
      a [integer!]
      b [integer!]
    ]
    csp6-s/a: 1
    csp6-s/b: 2
    csp6-p: as [pointer! [integer!]] csp6-s
  --assert csp6-p/value = 1
    csp6-p: csp6-p + 1
  --assert csp6-p/value = 2
    csp6-p: csp6-p - 1
    csp6-s: as [struct! [a [integer!] b [integer!]]] csp6-p
  --assert csp6-s/a = 1
    csp6-p: csp6-p + 1
    csp6-s: as [struct! [a [integer!] b [integer!]]] csp6-p
  --assert csp6-s/a = 2

===end-group===

===start-group=== "cast from struct!"

  ;; no test for cast to integer as it would simply
  ;;  duplicate the test from integer! to struct!

  --test-- "cfstruc-1"
    cfs1-struct: declare struct! [
      a [integer!]
      b [integer!]
    ]
    cfs1-struct: as [struct! [a [integer!] b [integer!]]] 0
  --assert false = as logic! cfs1-struct

  --test-- "cfstruc-2"
    cfs2-struct: declare struct! [
      a [integer!]
      b [integer!]
    ]
  --assert true = as logic! cfs2-struct

  ;; no test for cast to c-string! as it would simply
  ;;  duplicate the test from c-string! to struct!

  ;; no test for cast to pointer! as it would simply
  ;;  duplicate the test from pointer! to struct!

===end-group===

~~~end-file~~~


Add FreeBSD stat struct to simple-io.

Add FreeBSD stat struct to simple-io.

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

simple-io: context [

	#either OS = 'Windows [

		#define GENERIC_READ 			80000000h
		#define FILE_SHARE_READ			00000001h
		#define OPEN_EXISTING			00000003h
		#define FILE_ATTRIBUTE_NORMAL	00000080h

		#import [
			"kernel32.dll" stdcall [
				CreateFile:	"CreateFileA" [
					filename	[c-string!]
					access		[integer!]
					share		[integer!]
					security	[int-ptr!]
					disposition	[integer!]
					flags		[integer!]
					template	[int-ptr!]
					return:		[integer!]
				]
				ReadFile:	"ReadFile" [
					file		[integer!]
					buffer		[byte-ptr!]
					bytes		[integer!]
					read		[int-ptr!]
					overlapped	[int-ptr!]
					return:		[integer!]
				]
				GetFileSize: "GetFileSize" [
					file		[integer!]
					high-size	[integer!]
					return:		[integer!]
				]
				CloseHandle:	"CloseHandle" [
					obj			[integer!]
					return:		[integer!]
				]
			]
		]
	][
		#define O_RDONLY	0

		#import [
			LIBC-file cdecl [
				_open:	"open" [
					filename	[c-string!]
					flags		[integer!]
					mode		[integer!]
					return:		[integer!]
				]
				_read:	"read" [
					file		[integer!]
					buffer		[byte-ptr!]
					bytes		[integer!]
					return:		[integer!]
				]
				_close:	"close" [
					file		[integer!]
					return:		[integer!]
				]
			]
		]

		#case [
			OS = 'FreeBSD [
				;-- http://fxr.watson.org/fxr/source/sys/stat.h?v=FREEBSD10
				stat!: alias struct! [
					st_dev		[integer!]
					st_ino		[integer!]
					st_modelink	[integer!]					;-- st_mode & st_link are both 16bit fields
					st_uid		[integer!]
					st_gid		[integer!]
					st_rdev		[integer!]
					atv_sec		[integer!]					;-- struct timespec inlined
					atv_msec	[integer!]
					mtv_sec		[integer!]					;-- struct timespec inlined
					mtv_msec	[integer!]
					ctv_sec		[integer!]					;-- struct timespec inlined
					ctv_msec	[integer!]
					st_size		[integer!]
					st_size_h	[integer!]
					st_blocks_l	[integer!]
					st_blocks_h	[integer!]
					st_blksize	[integer!]
					st_flags	[integer!]
					st_gen		[integer!]
					st_lspare	[integer!]
					btm_sec     [integer!]
					btm_msec    [integer!]                  ;-- struct timespec inlined
					pad0		[integer!]
					pad1		[integer!]
				]
			]
			OS = 'MacOSX [
				stat!: alias struct! [
					st_dev		[integer!]
					st_ino		[integer!]
					st_modelink	[integer!]					;-- st_mode & st_link are both 16bit fields
					st_uid		[integer!]
					st_gid		[integer!]
					st_rdev		[integer!]
					atv_sec		[integer!]					;-- struct timespec inlined
					atv_msec	[integer!]
					mtv_sec		[integer!]					;-- struct timespec inlined
					mtv_msec	[integer!]
					ctv_sec		[integer!]					;-- struct timespec inlined
					ctv_msec	[integer!]
					st_size		[integer!]
					st_blocks	[integer!]
					st_blksize	[integer!]
					st_flags	[integer!]
					st_gen		[integer!]
				]
			]
			OS = 'Syllable [
				;-- http://glibc.sourcearchive.com/documentation/2.7-18lenny7/glibc-2_87_2bits_2stat_8h_source.html
				stat!: alias struct! [
					st_mode		[integer!]
					st_ino		[integer!]
					st_dev		[integer!]
					st_nlink	[integer!]
					st_uid		[integer!]
					st_gid		[integer!]
					filler1		[integer!]				;-- not in spec above...
					filler2		[integer!]				;-- not in spec above...
					st_size		[integer!]
					;...incomplete...
				]
			]
			all [legacy find legacy 'stat32] [
				stat!: alias struct! [
					st_dev		[integer!]
					st_ino		[integer!]
					st_mode		[integer!]
					st_nlink	[integer!]
					st_uid		[integer!]
					st_gid		[integer!]
					st_rdev		[integer!]
					st_size		[integer!]
					st_blksize	[integer!]
					st_blocks	[integer!]
					st_atime	[integer!]
					st_mtime	[integer!]
					st_ctime	[integer!]
				]
			]
			true [ ; else
				;-- http://lxr.free-electrons.com/source/arch/x86/include/uapi/asm/stat.h
				stat!: alias struct! [				;-- stat64 struct
					st_dev_l	  [integer!]
					st_dev_h	  [integer!]
					pad0		  [integer!]
					__st_ino	  [integer!]
					st_mode		  [integer!]
					st_nlink	  [integer!]
					st_uid		  [integer!]
					st_gid		  [integer!]
					st_rdev_l	  [integer!]
					st_rdev_h	  [integer!]
					pad1		  [integer!]
					st_size		  [integer!]
					st_size_h	  [integer!]
					st_blksize	  [integer!]
					st_blocks	  [integer!]
					st_atime	  [integer!]
					st_atime_nsec [integer!]
					st_mtime	  [integer!]
					st_mtime_nsec [integer!]
					st_ctime	  [integer!]
					st_ctime_nsec [integer!]
					st_ino_h	  [integer!]
					st_ino_l	  [integer!]
					;...optional padding skipped
				]
			]
		]

		#case [
			any [OS = 'MacOSX OS = 'FreeBSD] [
				#import [
					LIBC-file cdecl [
						;-- https://developer.apple.com/library/mac/documentation/Darwin/Reference/ManPages/10.6/man2/stat.2.html?useVersion=10.6
						_stat:	"fstat" [
							file		[integer!]
							restrict	[stat!]
							return:		[integer!]
						]
					]
				]
			]
			true [
				#import [
					LIBC-file cdecl [
						;-- http://refspecs.linuxbase.org/LSB_3.0.0/LSB-Core-generic/LSB-Core-generic/baselib-xstat-1.html
						_stat:	"__fxstat" [
							version		[integer!]
							file		[integer!]
							restrict	[stat!]
							return:		[integer!]
						]
					]
				]
			]

		]
	]

	open-file: func [
		filename [c-string!]
		return:	 [integer!]
		/local
			file [integer!]
	][
		#either OS = 'Windows [
			file: CreateFile
				filename
				GENERIC_READ
				FILE_SHARE_READ
				null
				OPEN_EXISTING
				FILE_ATTRIBUTE_NORMAL
				null
		][
			file: _open filename O_RDONLY 0
		]
		if file = -1 [
			print-line "*** Error: File not found"
			quit -1
		]
		file
	]

	file-size?: func [
		file	 [integer!]
		return:	 [integer!]
		/local s
	][
		#case [
			OS = 'Windows [
				GetFileSize file null
			]
			any [OS = 'MacOSX OS = 'FreeBSD] [
				s: declare stat!
				_stat file s
				s/st_size
			]
			true [ ; else
				s: declare stat!
				_stat 3 file s
				s/st_size
			]
		]
	]

	read-file: func [
		file	[integer!]
		buffer	[byte-ptr!]
		size	[integer!]
		return:	[integer!]
		/local
			read-sz [integer!]
			res		[integer!]
			error?	[logic!]
	][
		#either OS = 'Windows [
			read-sz: -1
			res: ReadFile file buffer size :read-sz null
			error?: any [zero? res read-sz <> size]
		][
			res: _read file buffer size
			error?: res <= 0
		]
		if error? [
			print-line "*** Error: cannot read file"
			quit -3
		]
		res
	]

	close-file: func [
		file	[integer!]
		return:	[integer!]
	][
		#either OS = 'Windows [
			CloseHandle file
		][
			_close file
		]
	]

	read-txt: func [
		filename [c-string!]
		return:	 [red-string!]
		/local
			buffer	[byte-ptr!]
			file	[integer!]
			size	[integer!]
			str		[red-string!]
	][
		file: open-file filename
		size: file-size? file
		if size <= 0 [
			print-line "*** Error: empty file"
			quit -2
		]

		buffer: allocate size + 1						;-- account for terminal NUL
		read-file file buffer size
		close-file file

		size: size + 1
		buffer/size: null-byte
		str: string/load as-c-string buffer size UTF-8
		free buffer
		str
	]
]

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

simple-io: context [

	#either OS = 'Windows [

		#define GENERIC_READ 			80000000h
		#define FILE_SHARE_READ			00000001h
		#define OPEN_EXISTING			00000003h
		#define FILE_ATTRIBUTE_NORMAL	00000080h

		#import [
			"kernel32.dll" stdcall [
				CreateFile:	"CreateFileA" [
					filename	[c-string!]
					access		[integer!]
					share		[integer!]
					security	[int-ptr!]
					disposition	[integer!]
					flags		[integer!]
					template	[int-ptr!]
					return:		[integer!]
				]
				ReadFile:	"ReadFile" [
					file		[integer!]
					buffer		[byte-ptr!]
					bytes		[integer!]
					read		[int-ptr!]
					overlapped	[int-ptr!]
					return:		[integer!]
				]
				GetFileSize: "GetFileSize" [
					file		[integer!]
					high-size	[integer!]
					return:		[integer!]
				]
				CloseHandle:	"CloseHandle" [
					obj			[integer!]
					return:		[integer!]
				]
			]
		]
	][
		#define O_RDONLY	0

		#import [
			LIBC-file cdecl [
				_open:	"open" [
					filename	[c-string!]
					flags		[integer!]
					mode		[integer!]
					return:		[integer!]
				]
				_read:	"read" [
					file		[integer!]
					buffer		[byte-ptr!]
					bytes		[integer!]
					return:		[integer!]
				]
				_close:	"close" [
					file		[integer!]
					return:		[integer!]
				]
			]
		]

		#case [
			OS = 'MacOSX [
				stat!: alias struct! [
					st_dev		[integer!]
					st_ino		[integer!]
					st_modelink	[integer!]					;-- st_mode & st_link are both 16bit fields
					st_uid		[integer!]
					st_gid		[integer!]
					st_rdev		[integer!]
					atv_sec		[integer!]					;-- struct timespec inlined
					atv_msec	[integer!]
					mtv_sec		[integer!]					;-- struct timespec inlined
					mtv_msec	[integer!]
					ctv_sec		[integer!]					;-- struct timespec inlined
					ctv_msec	[integer!]
					st_size		[integer!]
					st_blocks	[integer!]
					st_blksize	[integer!]
					st_flags	[integer!]
					st_gen		[integer!]
				]
			]
			OS = 'Syllable [
				;-- http://glibc.sourcearchive.com/documentation/2.7-18lenny7/glibc-2_87_2bits_2stat_8h_source.html
				stat!: alias struct! [
					st_mode		[integer!]
					st_ino		[integer!]
					st_dev		[integer!]
					st_nlink	[integer!]
					st_uid		[integer!]
					st_gid		[integer!]
					filler1		[integer!]				;-- not in spec above...
					filler2		[integer!]				;-- not in spec above...
					st_size		[integer!]
					;...incomplete...
				]
			]
			all [legacy find legacy 'stat32] [
				stat!: alias struct! [
					st_dev		[integer!]
					st_ino		[integer!]
					st_mode		[integer!]
					st_nlink	[integer!]
					st_uid		[integer!]
					st_gid		[integer!]
					st_rdev		[integer!]
					st_size		[integer!]
					st_blksize	[integer!]
					st_blocks	[integer!]
					st_atime	[integer!]
					st_mtime	[integer!]
					st_ctime	[integer!]
				]
			]
			true [ ; else
				;-- http://lxr.free-electrons.com/source/arch/x86/include/uapi/asm/stat.h
				stat!: alias struct! [				;-- stat64 struct
					st_dev_l	  [integer!]
					st_dev_h	  [integer!]
					pad0		  [integer!]
					__st_ino	  [integer!]
					st_mode		  [integer!]
					st_nlink	  [integer!]
					st_uid		  [integer!]
					st_gid		  [integer!]
					st_rdev_l	  [integer!]
					st_rdev_h	  [integer!]
					pad1		  [integer!]
					st_size		  [integer!]
					st_size_h	  [integer!]
					st_blksize	  [integer!]
					st_blocks	  [integer!]
					st_atime	  [integer!]
					st_atime_nsec [integer!]
					st_mtime	  [integer!]
					st_mtime_nsec [integer!]
					st_ctime	  [integer!]
					st_ctime_nsec [integer!]
					st_ino_h	  [integer!]
					st_ino_l	  [integer!]
					;...optional padding skipped
				]
			]
		]

		#case [
			any [OS = 'MacOSX OS = 'FreeBSD] [
				#import [
					LIBC-file cdecl [
						;-- https://developer.apple.com/library/mac/documentation/Darwin/Reference/ManPages/10.6/man2/stat.2.html?useVersion=10.6
						_stat:	"fstat" [
							file		[integer!]
							restrict	[stat!]
							return:		[integer!]
						]
					]
				]
			]
			true [
				#import [
					LIBC-file cdecl [
						;-- http://refspecs.linuxbase.org/LSB_3.0.0/LSB-Core-generic/LSB-Core-generic/baselib-xstat-1.html
						_stat:	"__fxstat" [
							version		[integer!]
							file		[integer!]
							restrict	[stat!]
							return:		[integer!]
						]
					]
				]
			]

		]
	]

	open-file: func [
		filename [c-string!]
		return:	 [integer!]
		/local
			file [integer!]
	][
		#either OS = 'Windows [
			file: CreateFile
				filename
				GENERIC_READ
				FILE_SHARE_READ
				null
				OPEN_EXISTING
				FILE_ATTRIBUTE_NORMAL
				null
		][
			file: _open filename O_RDONLY 0
		]
		if file = -1 [
			print-line "*** Error: File not found"
			quit -1
		]
		file
	]

	file-size?: func [
		file	 [integer!]
		return:	 [integer!]
		/local s
	][
		#case [
			OS = 'Windows [
				GetFileSize file null
			]
			any [OS = 'MacOSX OS = 'FreeBSD] [
				s: declare stat!
				_stat file s
				s/st_size
			]
			true [ ; else
				s: declare stat!
				_stat 3 file s
				s/st_size
			]
		]
	]

	read-file: func [
		file	[integer!]
		buffer	[byte-ptr!]
		size	[integer!]
		return:	[integer!]
		/local
			read-sz [integer!]
			res		[integer!]
			error?	[logic!]
	][
		#either OS = 'Windows [
			read-sz: -1
			res: ReadFile file buffer size :read-sz null
			error?: any [zero? res read-sz <> size]
		][
			res: _read file buffer size
			error?: res <= 0
		]
		if error? [
			print-line "*** Error: cannot read file"
			quit -3
		]
		res
	]

	close-file: func [
		file	[integer!]
		return:	[integer!]
	][
		#either OS = 'Windows [
			CloseHandle file
		][
			_close file
		]
	]

	read-txt: func [
		filename [c-string!]
		return:	 [red-string!]
		/local
			buffer	[byte-ptr!]
			file	[integer!]
			size	[integer!]
			str		[red-string!]
	][
		file: open-file filename
		size: file-size? file
		if size <= 0 [
			print-line "*** Error: empty file"
			quit -2
		]

		buffer: allocate size + 1						;-- account for terminal NUL
		read-file file buffer size
		close-file file

		size: size + 1
		buffer/size: null-byte
		str: string/load as-c-string buffer size UTF-8
		free buffer
		str
	]
]


FEAT: added ASK function and removed prompt handling from INPUT.

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

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				ReadConsole: 	 "ReadConsoleW" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
		line-buffer-size: 15 * 1024
		line-buffer: allocate line-buffer-size * 2 + 1
	][
		#switch OS [
			MacOSX [
				#define ReadLine-library "libreadline.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
				rl-bind-key: "rl_bind_key" [
					key				[integer!]
					command			[integer!]
					return:			[integer!]
				]
				rl-insert:	 "rl_insert" [
					count			[integer!]
					key				[integer!]
					return:			[integer!]
				]
			]
			#if OS <> 'MacOSX [
				History-library cdecl [
					add-history: "add_history" [  ; Add line to the history.
						line		[c-string!]
					]
				]
			]
		]

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

input: routine [
	/local
		len ret str buffer line pos
][
	#either OS = 'Windows [
		len: 0
		ret: ReadConsole stdin line-buffer line-buffer-size :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		pos: (len * 2) - 3								;-- position at lower 8bits of CR character
		line-buffer/pos: null-byte						;-- overwrite CR with NUL
		str: string/load as-c-string line-buffer len - 1 UTF-16LE
	][
		line: read-line null
		if line = null [halt]  ; EOF

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

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

ask: func [prompt [string!]][
	prin prompt
	input
]

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

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				ReadConsole: 	 "ReadConsoleW" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
		line-buffer-size: 15 * 1024
		line-buffer: allocate line-buffer-size * 2 + 1
	][
		#switch OS [
			MacOSX [
				#define ReadLine-library "libreadline.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
				rl-bind-key: "rl_bind_key" [
					key				[integer!]
					command			[integer!]
					return:			[integer!]
				]
				rl-insert:	 "rl_insert" [
					count			[integer!]
					key				[integer!]
					return:			[integer!]
				]
			]
			#if OS <> 'MacOSX [
				History-library cdecl [
					add-history: "add_history" [  ; Add line to the history.
						line		[c-string!]
					]
				]
			]
		]

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

input: routine [
	prompt [string!]
	/local
		len ret str buffer line pos
][
	#either OS = 'Windows [
		len: 0
		print as c-string! string/rs-head prompt
		ret: ReadConsole stdin line-buffer line-buffer-size :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		pos: (len * 2) - 3								;-- position at lower 8bits of CR character
		line-buffer/pos: null-byte						;-- overwrite CR with NUL
		str: string/load as-c-string line-buffer len - 1 UTF-16LE
	][
		line: read-line as-c-string string/rs-head prompt
		if line = null [halt]  ; EOF

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

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