FIX: additional fix for #1065.

FIX: additional fix for #1065.

Red [
	Title:   "Red base environment definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %boot.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
	}
]

;; Warning: do not define any function of any kind before MAKE definition

make: make action! [[									;--	this one works!	;-)
		"Returns a new value made from a spec for that value's type"
		type	 [any-type!] "The datatype or a prototype value"
		spec	 [any-type!] "The specification	of the new value"
		return:  [any-type!] "Returns the specified datatype"
	]
	#get-definition ACT_MAKE
]

random: make action! [[
		"Returns a random value of the same datatype; or shuffles series"
		value	"Maximum value of result (modified when series)"
		/seed   "Restart or randomize"
		/secure "TBD: Returns a cryptographically secure random number"
		/only	"Pick a random value from a series"
		return:	[any-type!]
	]
	#get-definition ACT_RANDOM
]

reflect: make action! [[
		"Returns internal details about a value via reflection"
		value	[any-type!]
		field 	[word!] "spec, body, words, etc. Each datatype defines its own reflectors"
	]
	#get-definition ACT_REFLECT
]

to: make action! [[
		"Converts to a specified datatype"
		type	[any-type!] "The datatype or example value"
		spec	[any-type!] "The attributes of the new value"
	]
	#get-definition ACT_TO
]

form: make action! [[
		"Returns a user-friendly string representation of a value"
		value	  [any-type!]
		/part "Limit the length of the result"
			limit [integer!]
		return:	  [string!]
	]
	#get-definition ACT_FORM
]

mold: make action! [[
		"Returns a source format string representation of a value"
		value	  [any-type!]
		/only "Exclude outer brackets if value is a block"
		/all  "TBD: Return value in loadable format"
		/flat "TBD: Exclude all indentation"
		/part "Limit the length of the result"
			limit [integer!]
		return:	  [string!]
	]
	#get-definition ACT_MOLD
]

;-- Scalar actions --

absolute: make action! [[
		"Returns the non-negative value"
		value	 [number!]
		return:  [number!]
	]
	#get-definition ACT_ABSOLUTE
]

add: make action! [[
		"Returns the sum of the two values"
		value1	 [number! char!]
		value2	 [number! char!]
		return:  [number! char!]
	]
	#get-definition ACT_ADD
]

divide: make action! [[
		"Returns the quotient of two values"
		value1	 [number! char!] "The dividend (numerator)"
		value2	 [number! char!] "The divisor (denominator)"
		return:  [number! char!]
	]
	#get-definition ACT_DIVIDE
]

multiply: make action! [[
		"Returns the product of two values"
		value1	 [number! char!]
		value2	 [number! char!]
		return:  [number! char!]
	]
	#get-definition ACT_MULTIPLY
]

negate: make action! [[
		"Returns the opposite (additive inverse) value"
		number 	 [number! bitset!]
		return:  [number! bitset!]
	]
	#get-definition ACT_NEGATE
]

power: make action! [[
		"Returns a number raised to a given power (exponent)"
		number	 [number!] "Base value"
		exponent [number!] "The power (index) to raise the base value by"
		return:	 [number!]
	]
	#get-definition ACT_POWER
]

remainder: make action! [[
		"Returns what is left over when one value is divided by another"
		value1 	 [number! char!]
		value2 	 [number! char!]
		return:  [number! char!]
	]
	#get-definition ACT_REMAINDER
]

modulo: func [
	"Compute a nonnegative remainder of A divided by B"
	a		[number!]
	b		[number!]
	return: [number!]
	/local r
][
	b: absolute b
    all [0 > r: a % b r: r + b]
    a: absolute a
    either all [a + r = (a + b) 0 < r + r - b] [r - b] [r]
]

round: make action! [[
		"Returns the nearest integer. Halves round up (away from zero) by default"
		n		[number!]
		/to		"Return the nearest multiple of the scale parameter"
		scale	[number!] "Must be a non-zero value"
		/even		"Halves round toward even results"
		/down		"Round toward zero, ignoring discarded digits. (truncate)"
		/half-down	"Halves round toward zero"
		/floor		"Round in negative direction"
		/ceiling	"Round in positive direction"
		/half-ceiling "Halves round in positive direction"
	]
	#get-definition ACT_ROUND
]

subtract: make action! [[
		"Returns the difference between two values"
		value1	 [number! char!]
		value2	 [number! char!]
		return:  [number! char!]
	]
	#get-definition ACT_SUBTRACT
]

even?: make action! [[
		"Returns true if the number is evenly divisible by 2"
		number 	 [number! char!]
		return:  [number! char!]
	]
	#get-definition ACT_EVEN?
]

odd?: make action! [[
		"Returns true if the number has a remainder of 1 when divided by 2"
		number 	 [number! char!]
		return:  [number! char!]
	]
	#get-definition ACT_ODD?
]

;-- Bitwise actions --

and~: make action! [[
		"Returns the first value ANDed with the second"
		value1	[logic! integer! char! bitset! typeset!]
		value2	[logic! integer! char! bitset! typeset!]
		return:	[logic! integer! char! bitset! typeset!]
	]
	#get-definition ACT_AND~
]

complement: make action! [[
		"Returns the opposite (complementing) value of the input value"
		value	[logic! integer! bitset! typeset!]
		return: [logic! integer! bitset! typeset!]
	]
	#get-definition ACT_COMPLEMENT
]

or~: make action! [[
		"Returns the first value ORed with the second"
		value1	[logic! integer! char! bitset! typeset!]
		value2	[logic! integer! char! bitset! typeset!]
		return:	[logic! integer! char! bitset! typeset!]
	]
	#get-definition ACT_OR~
]

xor~: make action! [[
		"Returns the first value exclusive ORed with the second"
		value1	[logic! integer! char! bitset! typeset!]
		value2	[logic! integer! char! bitset! typeset!]
		return:	[logic! integer! char! bitset! typeset!]
	]
	#get-definition ACT_XOR~
]

;-- Series actions --

append: make action! [[
		"Inserts value(s) at series tail; returns series head"
		series	   [series! bitset!]
		value	   [any-type!]
		/part "Limit the number of values inserted"
			length [number! series!]
		/only "Insert block types as single values (overrides /part)"
		/dup  "Duplicate the inserted values"
			count  [number!]
		return:    [series! bitset!]
	]
	#get-definition ACT_APPEND
]

at: make action! [[
		"Returns a series at a given index"
		series	 [series!]
		index 	 [integer!]
		return:  [series!]
	]
	#get-definition ACT_AT
]

back: make action! [[
		"Returns a series at the previous index"
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_BACK
]

;change

clear: make action! [[
		"Removes series values from current index to tail; returns new tail"
		series	 [series! bitset!]
		return:  [series! bitset!]
	]
	#get-definition ACT_CLEAR
]

copy: make action! [[
		"Returns a copy of a non-scalar value"
		value	 [series! any-object! bitset!]
		/part	 "Limit the length of the result"
			length [number! series!]
		/deep	 "Copy nested values"
		/types	 "Copy only specific types of non-scalar values"
			kind [datatype!]
		return:  [series! any-object! bitset!]
	]
	#get-definition ACT_COPY
]

find: make action! [[
		"Returns the series where a value is found, or NONE"
		series	 [series! bitset! typeset! any-object! none!]
		value 	 [any-type!]
		/part "Limit the length of the search"
			length [number! series!]
		/only "Treat a series search value as a single value"
		/case "Perform a case-sensitive search"
		/any  "TBD: Use * and ? wildcards in string searches"
		/with "TBD: Use custom wildcards in place of * and ?"
			wild [string!]
		/skip "Treat the series as fixed size records"
			size [integer!]
		/last "Find the last occurrence of value, from the tail"
		/reverse "Find the last occurrence of value, from the current index"
		/tail "Return the tail of the match found, rather than the head"
		/match "Match at current index only and return tail of match"
	]
	#get-definition ACT_FIND
]

head: make action! [[
		"Returns a series at its first index"
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_HEAD
]

head?: make action! [[
		"Returns true if a series is at its first index"
		series	 [series!]
		return:  [logic!]
	]
	#get-definition ACT_HEAD?
]

index?: make action! [[
		"Returns the current series index, relative to the head"
		series	 [series!]
		return:  [integer!]
	]
	#get-definition ACT_INDEX?
]

insert: make action! [[
		"Inserts value(s) at series index; returns series head"
		series	   [series! bitset!]
		value	   [any-type!]
		/part "Limit the number of values inserted"
			length [number! series!]
		/only "Insert block types as single values (overrides /part)"
		/dup  "Duplicate the inserted values"
			count  [number!]
		return:    [series! bitset!]
	]
	#get-definition ACT_INSERT
]

length?: make action! [[
		"Returns the number of values in the series, from the current index to the tail"
		series	 [series! bitset!]
		return:  [integer!]
	]
	#get-definition ACT_LENGTH?
]

next: make action! [[
		"Returns a series at the next index"
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_NEXT
]

pick: make action! [[
		"Returns the series value at a given index"
		series	 [series! bitset!]
		index 	 [integer! logic! char!]
		return:  [any-type!]
	]
	#get-definition ACT_PICK
]

poke: make action! [[
		"Replaces the series value at a given index, and returns the new value"
		series	 [series! bitset!]
		index 	 [integer! char! logic! block!]
		value 	 [any-type!]
		return:  [series! bitset!]
	]
	#get-definition ACT_POKE
]

remove: make action! [[
		"Returns the series at the same index after removing a value"
		series	 [series! bitset! none!]
		/part "Removes a number of values, or values up to the given series index"
			length [number! char! series!]
		return:  [series! bitset! none!]
	]
	#get-definition ACT_REMOVE
]

reverse: make action! [[
		"Reverses the order of elements; returns at same position"
		series	 [series!]
		/part "Limits to a given length or position"
			length [number! series!]
		return:  [series!]
	]
	#get-definition ACT_REVERSE
]

select: make action! [[
		"Find a value in a series and return the next value, or NONE"
		series	 [series! any-object! none!]
		value 	 [any-type!]
		/part "Limit the length of the search"
			length [number! series!]
		/only "Treat a series search value as a single value"
		/case "Perform a case-sensitive search"
		/any  "TBD: Use * and ? wildcards in string searches"
		/with "TBD: Use custom wildcards in place of * and ?"
			wild [string!]
		/skip "Treat the series as fixed size records"
			size [integer!]
		/last "Find the last occurrence of value, from the tail"
		/reverse "Find the last occurrence of value, from the current index"
		return:  [any-type!]
	]
	#get-definition ACT_SELECT
]

sort: make action! [[
		"Sorts a series (modified); default sort order is ascending"
		series	 [series!]
		/case "Perform a case-sensitive sort"
		/skip "Treat the series as fixed size records"
			size [integer!]
		/compare "Comparator offset, block or function"
			comparator [integer! block! any-function!]
		/part "Sort only part of a series"
			length [number! series!]
		/all "Compare all fields"
		/reverse "Reverse sort order"
		/stable "Stable sorting"
		return:  [series!]
	]
	#get-definition ACT_SORT
]

skip: make action! [[
		"Returns the series relative to the current index"
		series	 [series!]
		offset 	 [integer!]
		return:  [series!]
	]
	#get-definition ACT_SKIP
]

swap: make action! [[
		"Swaps elements between two series or the same series"
		series1  [series!]
		series2  [series!]
		return:  [series!]
	]
	#get-definition ACT_SWAP
]

tail: make action! [[
		"Returns a series at the index after its last value"
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_TAIL
]

tail?: make action! [[
		"Returns true if a series is past its last value"
		series	 [series!]
		return:  [logic!]
	]
	#get-definition ACT_TAIL?
]

take: make action! [[
		"Removes and returns one or more elements"
		series	 [series! none!]
		/part	 "Specifies a length or end position"
			length [number! series!]
		/deep	 "Copy nested values"
		/last	 "Take it from the tail end"
	]
	#get-definition ACT_TAKE
]

trim: make action! [[
		"Removes space from a string or NONE from a block or object"
		series	[series! object! error!]
		/head	"Removes only from the head"
		/tail	"Removes only from the tail"
		/auto	"Auto indents lines relative to first line"
		/lines	"Removes all line breaks and extra spaces"
		/all	"Removes all whitespace"
		/with	"Same as /all, but removes characters in 'str'"
			str [char! string! integer!]
	]
	#get-definition ACT_TRIM
]

;-- I/O actions --

;create
;close
;delete
;modify
;open
;open?
;query
;read
;rename
;update
;write

Red [
	Title:   "Red base environment definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %boot.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
	}
]

;; Warning: do not define any function of any kind before MAKE definition

make: make action! [[									;--	this one works!	;-)
		"Returns a new value made from a spec for that value's type"
		type	 [any-type!] "The datatype or a prototype value"
		spec	 [any-type!] "The specification	of the new value"
		return:  [any-type!] "Returns the specified datatype"
	]
	#get-definition ACT_MAKE
]

random: make action! [[
		"Returns a random value of the same datatype; or shuffles series"
		value	"Maximum value of result (modified when series)"
		/seed   "Restart or randomize"
		/secure "TBD: Returns a cryptographically secure random number"
		/only	"Pick a random value from a series"
		return:	[any-type!]
	]
	#get-definition ACT_RANDOM
]

reflect: make action! [[
		"Returns internal details about a value via reflection"
		value	[any-type!]
		field 	[word!] "spec, body, words, etc. Each datatype defines its own reflectors"
	]
	#get-definition ACT_REFLECT
]

to: make action! [[
		"Converts to a specified datatype"
		type	[any-type!] "The datatype or example value"
		spec	[any-type!] "The attributes of the new value"
	]
	#get-definition ACT_TO
]

form: make action! [[
		"Returns a user-friendly string representation of a value"
		value	  [any-type!]
		/part "Limit the length of the result"
			limit [integer!]
		return:	  [string!]
	]
	#get-definition ACT_FORM
]

mold: make action! [[
		"Returns a source format string representation of a value"
		value	  [any-type!]
		/only "Exclude outer brackets if value is a block"
		/all  "TBD: Return value in loadable format"
		/flat "TBD: Exclude all indentation"
		/part "Limit the length of the result"
			limit [integer!]
		return:	  [string!]
	]
	#get-definition ACT_MOLD
]

;-- Scalar actions --

absolute: make action! [[
		"Returns the non-negative value"
		value	 [number!]
		return:  [number!]
	]
	#get-definition ACT_ABSOLUTE
]

add: make action! [[
		"Returns the sum of the two values"
		value1	 [number! char!]
		value2	 [number! char!]
		return:  [number! char!]
	]
	#get-definition ACT_ADD
]

divide: make action! [[
		"Returns the quotient of two values"
		value1	 [number! char!] "The dividend (numerator)"
		value2	 [number! char!] "The divisor (denominator)"
		return:  [number! char!]
	]
	#get-definition ACT_DIVIDE
]

multiply: make action! [[
		"Returns the product of two values"
		value1	 [number! char!]
		value2	 [number! char!]
		return:  [number! char!]
	]
	#get-definition ACT_MULTIPLY
]

negate: make action! [[
		"Returns the opposite (additive inverse) value"
		number 	 [number! bitset!]
		return:  [number! bitset!]
	]
	#get-definition ACT_NEGATE
]

power: make action! [[
		"Returns a number raised to a given power (exponent)"
		number	 [number!] "Base value"
		exponent [number!] "The power (index) to raise the base value by"
		return:	 [number!]
	]
	#get-definition ACT_POWER
]

remainder: make action! [[
		"Returns what is left over when one value is divided by another"
		value1 	 [number! char!]
		value2 	 [number! char!]
		return:  [number! char!]
	]
	#get-definition ACT_REMAINDER
]

modulo: func [
	"Compute a nonnegative remainder of A divided by B"
	a		[number!]
	b		[number!]
	return: [number!]
	/local r
][
	b: absolute b
    all [0 > r: a % b r: r + b]
    a: absolute a
    either all [a + r = (a + b) 0 < r + r - b] [r - b] [r]
]

round: make action! [[
		"Returns the nearest integer. Halves round up (away from zero) by default"
		n		[number!]
		/to		"Return the nearest multiple of the scale parameter"
		scale	[number!] "Must be a non-zero value"
		/even		"Halves round toward even results"
		/down		"Round toward zero, ignoring discarded digits. (truncate)"
		/half-down	"Halves round toward zero"
		/floor		"Round in negative direction"
		/ceiling	"Round in positive direction"
		/half-ceiling "Halves round in positive direction"
	]
	#get-definition ACT_ROUND
]

subtract: make action! [[
		"Returns the difference between two values"
		value1	 [number! char!]
		value2	 [number! char!]
		return:  [number! char!]
	]
	#get-definition ACT_SUBTRACT
]

even?: make action! [[
		"Returns true if the number is evenly divisible by 2"
		number 	 [number! char!]
		return:  [number! char!]
	]
	#get-definition ACT_EVEN?
]

odd?: make action! [[
		"Returns true if the number has a remainder of 1 when divided by 2"
		number 	 [number! char!]
		return:  [number! char!]
	]
	#get-definition ACT_ODD?
]

;-- Bitwise actions --

and~: make action! [[
		"Returns the first value ANDed with the second"
		value1	[logic! integer! char! bitset! typeset!]
		value2	[logic! integer! char! bitset! typeset!]
		return:	[logic! integer! char! bitset! typeset!]
	]
	#get-definition ACT_AND~
]

complement: make action! [[
		"Returns the opposite (complementing) value of the input value"
		value	[logic! integer! bitset! typeset!]
		return: [logic! integer! bitset! typeset!]
	]
	#get-definition ACT_COMPLEMENT
]

or~: make action! [[
		"Returns the first value ORed with the second"
		value1	[logic! integer! char! bitset! typeset!]
		value2	[logic! integer! char! bitset! typeset!]
		return:	[logic! integer! char! bitset! typeset!]
	]
	#get-definition ACT_OR~
]

xor~: make action! [[
		"Returns the first value exclusive ORed with the second"
		value1	[logic! integer! char! bitset! typeset!]
		value2	[logic! integer! char! bitset! typeset!]
		return:	[logic! integer! char! bitset! typeset!]
	]
	#get-definition ACT_XOR~
]

;-- Series actions --

append: make action! [[
		"Inserts value(s) at series tail; returns series head"
		series	   [series! bitset!]
		value	   [any-type!]
		/part "Limit the number of values inserted"
			length [number! series!]
		/only "Insert block types as single values (overrides /part)"
		/dup  "Duplicate the inserted values"
			count  [number!]
		return:    [series! bitset!]
	]
	#get-definition ACT_APPEND
]

at: make action! [[
		"Returns a series at a given index"
		series	 [series!]
		index 	 [integer!]
		return:  [series!]
	]
	#get-definition ACT_AT
]

back: make action! [[
		"Returns a series at the previous index"
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_BACK
]

;change

clear: make action! [[
		"Removes series values from current index to tail; returns new tail"
		series	 [series! bitset!]
		return:  [series! bitset!]
	]
	#get-definition ACT_CLEAR
]

copy: make action! [[
		"Returns a copy of a non-scalar value"
		value	 [series! any-object! bitset!]
		/part	 "Limit the length of the result"
			length [number! series!]
		/deep	 "Copy nested values"
		/types	 "Copy only specific types of non-scalar values"
			kind [datatype!]
		return:  [series! any-object! bitset!]
	]
	#get-definition ACT_COPY
]

find: make action! [[
		"Returns the series where a value is found, or NONE"
		series	 [series! bitset! any-object! none!]
		value 	 [any-type!]
		/part "Limit the length of the search"
			length [number! series!]
		/only "Treat a series search value as a single value"
		/case "Perform a case-sensitive search"
		/any  "TBD: Use * and ? wildcards in string searches"
		/with "TBD: Use custom wildcards in place of * and ?"
			wild [string!]
		/skip "Treat the series as fixed size records"
			size [integer!]
		/last "Find the last occurrence of value, from the tail"
		/reverse "Find the last occurrence of value, from the current index"
		/tail "Return the tail of the match found, rather than the head"
		/match "Match at current index only and return tail of match"
	]
	#get-definition ACT_FIND
]

head: make action! [[
		"Returns a series at its first index"
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_HEAD
]

head?: make action! [[
		"Returns true if a series is at its first index"
		series	 [series!]
		return:  [logic!]
	]
	#get-definition ACT_HEAD?
]

index?: make action! [[
		"Returns the current series index, relative to the head"
		series	 [series!]
		return:  [integer!]
	]
	#get-definition ACT_INDEX?
]

insert: make action! [[
		"Inserts value(s) at series index; returns series head"
		series	   [series! bitset!]
		value	   [any-type!]
		/part "Limit the number of values inserted"
			length [number! series!]
		/only "Insert block types as single values (overrides /part)"
		/dup  "Duplicate the inserted values"
			count  [number!]
		return:    [series! bitset!]
	]
	#get-definition ACT_INSERT
]

length?: make action! [[
		"Returns the number of values in the series, from the current index to the tail"
		series	 [series! bitset!]
		return:  [integer!]
	]
	#get-definition ACT_LENGTH?
]

next: make action! [[
		"Returns a series at the next index"
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_NEXT
]

pick: make action! [[
		"Returns the series value at a given index"
		series	 [series! bitset!]
		index 	 [integer! logic! char!]
		return:  [any-type!]
	]
	#get-definition ACT_PICK
]

poke: make action! [[
		"Replaces the series value at a given index, and returns the new value"
		series	 [series! bitset!]
		index 	 [integer! char! logic! block!]
		value 	 [any-type!]
		return:  [series! bitset!]
	]
	#get-definition ACT_POKE
]

remove: make action! [[
		"Returns the series at the same index after removing a value"
		series	 [series! bitset! none!]
		/part "Removes a number of values, or values up to the given series index"
			length [number! char! series!]
		return:  [series! bitset! none!]
	]
	#get-definition ACT_REMOVE
]

reverse: make action! [[
		"Reverses the order of elements; returns at same position"
		series	 [series!]
		/part "Limits to a given length or position"
			length [number! series!]
		return:  [series!]
	]
	#get-definition ACT_REVERSE
]

select: make action! [[
		"Find a value in a series and return the next value, or NONE"
		series	 [series! any-object! none!]
		value 	 [any-type!]
		/part "Limit the length of the search"
			length [number! series!]
		/only "Treat a series search value as a single value"
		/case "Perform a case-sensitive search"
		/any  "TBD: Use * and ? wildcards in string searches"
		/with "TBD: Use custom wildcards in place of * and ?"
			wild [string!]
		/skip "Treat the series as fixed size records"
			size [integer!]
		/last "Find the last occurrence of value, from the tail"
		/reverse "Find the last occurrence of value, from the current index"
		return:  [any-type!]
	]
	#get-definition ACT_SELECT
]

sort: make action! [[
		"Sorts a series (modified); default sort order is ascending"
		series	 [series!]
		/case "Perform a case-sensitive sort"
		/skip "Treat the series as fixed size records"
			size [integer!]
		/compare "Comparator offset, block or function"
			comparator [integer! block! any-function!]
		/part "Sort only part of a series"
			length [number! series!]
		/all "Compare all fields"
		/reverse "Reverse sort order"
		/stable "Stable sorting"
		return:  [series!]
	]
	#get-definition ACT_SORT
]

skip: make action! [[
		"Returns the series relative to the current index"
		series	 [series!]
		offset 	 [integer!]
		return:  [series!]
	]
	#get-definition ACT_SKIP
]

swap: make action! [[
		"Swaps elements between two series or the same series"
		series1  [series!]
		series2  [series!]
		return:  [series!]
	]
	#get-definition ACT_SWAP
]

tail: make action! [[
		"Returns a series at the index after its last value"
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_TAIL
]

tail?: make action! [[
		"Returns true if a series is past its last value"
		series	 [series!]
		return:  [logic!]
	]
	#get-definition ACT_TAIL?
]

take: make action! [[
		"Removes and returns one or more elements"
		series	 [series! none!]
		/part	 "Specifies a length or end position"
			length [number! series!]
		/deep	 "Copy nested values"
		/last	 "Take it from the tail end"
	]
	#get-definition ACT_TAKE
]

trim: make action! [[
		"Removes space from a string or NONE from a block or object"
		series	[series! object! error!]
		/head	"Removes only from the head"
		/tail	"Removes only from the tail"
		/auto	"Auto indents lines relative to first line"
		/lines	"Removes all line breaks and extra spaces"
		/all	"Removes all whitespace"
		/with	"Same as /all, but removes characters in 'str'"
			str [char! string! integer!]
	]
	#get-definition ACT_TRIM
]

;-- I/O actions --

;create
;close
;delete
;modify
;open
;open?
;query
;read
;rename
;update
;write


FEAT: Binding ti deflateInit2_ added

FEAT: Binding ti deflateInit2_ added

Red/System [
  Title:   "Red/System ZLib Binding"
  Author:  "Bruno Anselme"
  EMail:   "be.red@free.fr"
  File:    %zlibs.reds
  Rights:  "Copyright (c) 2013 Bruno Anselme"
  License: {
    Distributed under the Boost Software License, Version 1.0.
    See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
  }
  Needs: {
    Red/System >= 0.3.2
    zlib       >= 1.2.6
  }
  References: {
    http://www.zlib.net/
  }
]

#include %../stdio.reds

zlib: context [

  #import [
    LIBC-file cdecl [
      re-allocate:  "realloc" [
        base       [byte-ptr!]
        size       [integer!]
        return:    [byte-ptr!]
      ]
    ]
  ]

  #define opaque!  integer!
  #define Z_NULL  0             ; for initializing zalloc, zfree, opaque

  ; Allowed flush values.
  #define Z_NO_FLUSH       0
  #define Z_PARTIAL_FLUSH  1
  #define Z_SYNC_FLUSH     2
  #define Z_FULL_FLUSH     3
  #define Z_FINISH         4
  #define Z_BLOCK          5
  #define Z_TREES          6

  ; Return codes for the compression/decompression functions. Negative values
  ;  are errors, positive values are used for special but normal events.
  #define Z_OK             0
  #define Z_STREAM_END     1
  #define Z_NEED_DICT      2
  #define Z_ERRNO         -1
  #define Z_STREAM_ERROR  -2
  #define Z_DATA_ERROR    -3
  #define Z_MEM_ERROR     -4
  #define Z_BUF_ERROR     -5
  #define Z_VERSION_ERROR -6

  ; Compression levels
  #define Z_NO_COMPRESSION         0
  #define Z_BEST_SPEED             1
  #define Z_BEST_COMPRESSION       9
  #define Z_DEFAULT_COMPRESSION   -1

  #define CHUNK 16384                   ; Buffer size for file (de)compression

  #switch OS [
    Windows   [
      #define z-library "zlib1.dll"
    ]
    MacOSX    [
      #define z-library "libz.1.dylib"  ; TODO: check this
    ]
    #default  [
      #define z-library "libz.so.1"
    ]
  ]

  z_stream!: alias struct! [
    next_in        [byte-ptr!]     ; next input byte
    avail_in       [integer!]      ; number of bytes available at next_in
    total_in       [integer!]      ; total number of input bytes read so far

    next_out       [byte-ptr!]     ; next output byte should be put there
    avail_out      [integer!]      ; remaining free space at next_out
    total_out      [integer!]      ; total number of bytes output so far

    msg            [c-string!]     ; last error message, NULL if no error
    state          [integer!]      ; not visible by applications

    zalloc         [opaque!]       ; used to allocate the internal state (function pointer)
    zfree          [opaque!]       ; used to free the internal state (function pointer)
    opaque         [opaque!]       ; private data object passed to zalloc and zfree (function pointer)

    data_type      [integer!]      ; best guess about the data type: binary or text
    adler          [integer!]      ; adler32 value of the uncompressed data
    reserved       [integer!]      ; reserved for future use
  ]

  #import [z-library cdecl [
    version: "zlibVersion" [       ; Return zlib library version.
      return:   [c-string!]
    ]

    deflateInit_: "deflateInit_" [
      strm         [z_stream!]
      level        [integer!]
      version      [c-string!]
      stream_size  [integer!]
      return:      [integer!]
    ]

    deflateInit2_: "deflateInit2_" [
      strm         [z_stream!]
      level        [integer!]
      method       [integer!]
      windowBits   [integer!]
      memlevel     [integer!]
      strategy     [integer!]
      return:      [integer!]
    ]

    z-deflateEnd: "deflateEnd" [
      strm         [z_stream!]
      return:      [integer!]
    ]

    z-deflate: "deflate" [
      strm         [z_stream!]
      flush        [integer!]
      return:      [integer!]
    ]

    inflateInit_: "inflateInit_" [
      strm         [z_stream!]
      version      [c-string!]
      stream_size  [integer!]
      return:      [integer!]
    ]

    z-inflateEnd: "inflateEnd" [
      strm         [z_stream!]
      return:      [integer!]
    ]

    z-inflate: "inflate" [
      strm         [z_stream!]
      flush        [integer!]
      return:      [integer!]
    ]

    compressBound: "compressBound" [
      sourceLen    [integer!]
      return:      [integer!]
    ]

    z-compress: "compress2" [
      out-buf      [byte-ptr!]           "Pointer to destination data"
      out-count    [int-ptr!]            "Pointer to destination size, returns output buffer size"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      level        [integer!]            "Compression level"
      return:      [integer!]
    ]

    z-uncompress: "uncompress" [
      out-buf      [byte-ptr!]           "Pointer to destination data"
      out-count    [int-ptr!]            "Pointer to destination size, returns output buffer size"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      return:      [integer!]
    ]

  ] ; cdecl
  ] ; #import [z-library

  ; Higher level interface ---------------------------- ---------------------------------------

  with zlib [

     z-inflateInit: function [
      strm         [z_stream!]
      return:      [integer!]
    ][
      inflateInit_ strm version size? z_stream!
    ]

    z-deflateInit: function [
      strm         [z_stream!]
      level        [integer!]
      return:      [integer!]
    ][
      deflateInit_ strm level version size? z_stream!
    ]

    z-deflateInit2: function [
      strm         [z_stream!]
      level        [integer!]
      method       [integer!]
      windowBits   [integer!]
      memlevel     [integer!]
      strategy     [integer!]
      return:      [integer!]
    ][
      deflateInit2_ strm level Z_DEFLATED (15 or 32) 8 Z_DEFAULT_STRATEGY
    ]

#define END_Z_FUNC   [z-deflateEnd strm  free buf-out  free buf-in  free as byte-ptr! strm]

    deflate: function [
      src          [file!]
      dest         [file!]
      level        [integer!]
      return:      [integer!]
      /local ret have flush buf-in buf-out
             strm     [z_stream!]
    ][
      strm: as z_stream! allocate (size? z_stream!)
      if strm = NULL [
        print [ "Deflate: Memory allocation error." lf ]
        return Z_ERRNO
      ]
      buf-in: allocate CHUNK
      if buf-in = NULL [
        print [ "Deflate: Input buffer allocation error." lf ]
        free as byte-ptr! strm
        return Z_ERRNO
      ]
      buf-out: allocate CHUNK
      if buf-out = NULL [
        print [ "Deflate: Output buffer allocation error." lf ]
        free buf-in
        free as byte-ptr! strm
        return Z_ERRNO
      ]
      strm/zalloc: Z_NULL
      strm/zfree: Z_NULL
      strm/opaque: Z_NULL
      ret: z-deflateInit strm level
      if ret <> Z_OK [
        print [ "Deflate: Error deflateInit : " ret lf ]
        END_Z_FUNC
        return Z_ERRNO
      ]
      until [
        strm/avail_in: read-file buf-in 1 CHUNK src
        if file-error? src [
          print [ "Deflate: Input file error : " ret lf ]
          END_Z_FUNC
          return Z_ERRNO ; FIXME: find best error number
        ]
        either file-tail? src [ flush: Z_FINISH ][ flush: Z_NO_FLUSH ]
        strm/next_in: buf-in
        until [
          strm/avail_out: CHUNK
          strm/next_out: buf-out
          ret: z-deflate strm flush
          if ret = Z_STREAM_ERROR [
            print [ "Deflate: Data stream error" lf ]
            END_Z_FUNC
            return Z_ERRNO
          ]
          have: CHUNK - strm/avail_out
          ret: write-file buf-out 1 have dest
          if any [ (ret <> have) (file-error?  dest) ][
            END_Z_FUNC
            return Z_ERRNO
          ]
          strm/avail_out <> 0
        ]
        flush = Z_FINISH
      ]
      END_Z_FUNC
      return Z_OK
    ]

    compress: func [                     "Compress a byte array"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      out-count    [int-ptr!]            "Pointer to integer, returns output buffer size"
      level        [integer!]            "Compression level"
      return:      [byte-ptr!]           "Returns a pointer to compressed data"
      /local ret out-buf tmp
    ][
      out-count/value: compressBound in-count
      out-buf: allocate out-count/value         ; allocate the size of original buffer
      if out-buf = NULL [
        print [ "Compress Error : Output buffer allocation error." lf ]
        return NULL
      ]
      ret: z-compress out-buf out-count in-buf in-count level
      either ret = Z_OK [
        tmp: re-allocate out-buf out-count/value        ; Resize output buffer to minimum size
        either tmp = NULL [                             ; reallocation failed, uses current output buffer
          print [ "Compress Warning : Impossible to reallocate output buffer." lf ]
        ][                                              ; reallocation succeeded, uses reallocated buffer
          out-buf: tmp
        ]
        return out-buf
      ][
        case [
          ret = Z_MEM_ERROR    [ print [ "Compress Error : not enough memory." lf ] ]
          ret = Z_BUF_ERROR    [ print [ "Compress Error : not enough room in the output buffer." lf ] ]
          ret = Z_STREAM_ERROR [ print [ "Compress Error : invalid compression level parameter." lf ] ]
        ]
        free out-buf
        return NULL
      ]
    ] ; compress

    decompress: func [                   "Decompress a byte array"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      return:      [byte-ptr!]           "Return a pointer to decompressed data"
      /local ret out-buf tmp
      out-count    [integer!]
    ][
      out-count: 2 * in-count                             ; allocate twice the size of original buffer
      out-buf: allocate out-count
      if out-buf = NULL [
        print [ "Decompress Error : Output buffer allocation error." lf ]
        return NULL
      ]
      until [
        ret: z-uncompress out-buf :out-count in-buf in-count
        if ret = Z_BUF_ERROR [                            ; need to expand output buffer
          out-count: 2 * out-count                        ; double buffer size
          tmp: re-allocate out-buf out-count              ; Resize output buffer to minimum size
          either tmp = NULL [                             ; reallocation failed, uses current output buffer
            print [ "Decompress Error : Impossible to reallocate output buffer." lf ]
            ret: Z_MEM_ERROR
          ][                                              ; reallocation succeeded, uses reallocated buffer
            out-buf: tmp
          ]
        ]
        any [ (ret = Z_OK) (ret = Z_MEM_ERROR) (ret = Z_STREAM_ERROR) ]
      ]
      either ret = Z_OK [
        tmp: re-allocate out-buf out-count              ; Resize output buffer to minimum size
        either tmp = NULL [                             ; reallocation failed, uses current output buffer
          print [ "Decompress Warning : Impossible to reallocate output buffer." lf ]
        ][                                              ; reallocation succeeded, uses reallocated buffer
          out-buf: tmp
        ]
        return out-buf
      ][
        case [
          ret = Z_MEM_ERROR    [ print [ "Decompress Error : not enough memory." lf ] ]
          ret = Z_BUF_ERROR    [ print [ "Decompress Error : not enough room in the output buffer." lf ] ]
          ret = Z_STREAM_ERROR [ print [ "Decompress Error : invalid compression level parameter." lf ] ]
        ]
      ]
      return out-buf
    ]

    bin-to-str: func [             "Convert a byte array into an hex string."
      address [byte-ptr!]          "Memory address where the conversion starts"
      limit   [integer!]           "Number of bytes to convert"
      return: [c-string!]          "Return a c string"
      /local i str cnum byte major minor
    ][
      str: make-c-string (1 + (2 * limit))
      i: 0
      cnum: 0
      until [
        byte: as integer! address/value
        minor: byte // 16
        if minor > 9 [minor: minor + 7]         ;-- 7 = (#"A" - 1) - #"9"
        byte: byte >>> 4
        major: byte // 16
        if major > 9 [major: major + 7]         ;-- 7 = (#"A" - 1) - #"9"

        cnum: cnum + 1
        str/cnum: #"0" + major
        cnum: cnum + 1
        str/cnum: #"0" + minor

        address: address + 1
        i: i + 1
        i = limit
      ]
      cnum: cnum + 1
      str/cnum: #"^(00)"  ; c string ending char
      str
    ]
  ] ; with zlib
] ; context zlib

Red/System [
  Title:   "Red/System ZLib Binding"
  Author:  "Bruno Anselme"
  EMail:   "be.red@free.fr"
  File:    %zlibs.reds
  Rights:  "Copyright (c) 2013 Bruno Anselme"
  License: {
    Distributed under the Boost Software License, Version 1.0.
    See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
  }
  Needs: {
    Red/System >= 0.3.2
    zlib       >= 1.2.6
  }
  References: {
    http://www.zlib.net/
  }
]

#include %../stdio.reds

zlib: context [

  #import [
    LIBC-file cdecl [
      re-allocate:  "realloc" [
        base       [byte-ptr!]
        size       [integer!]
        return:    [byte-ptr!]
      ]
    ]
  ]

  #define opaque!  integer!
  #define Z_NULL  0             ; for initializing zalloc, zfree, opaque

  ; Allowed flush values.
  #define Z_NO_FLUSH       0
  #define Z_PARTIAL_FLUSH  1
  #define Z_SYNC_FLUSH     2
  #define Z_FULL_FLUSH     3
  #define Z_FINISH         4
  #define Z_BLOCK          5
  #define Z_TREES          6

  ; Return codes for the compression/decompression functions. Negative values
  ;  are errors, positive values are used for special but normal events.
  #define Z_OK             0
  #define Z_STREAM_END     1
  #define Z_NEED_DICT      2
  #define Z_ERRNO         -1
  #define Z_STREAM_ERROR  -2
  #define Z_DATA_ERROR    -3
  #define Z_MEM_ERROR     -4
  #define Z_BUF_ERROR     -5
  #define Z_VERSION_ERROR -6

  ; Compression levels
  #define Z_NO_COMPRESSION         0
  #define Z_BEST_SPEED             1
  #define Z_BEST_COMPRESSION       9
  #define Z_DEFAULT_COMPRESSION   -1

  #define CHUNK 16384                   ; Buffer size for file (de)compression

  #switch OS [
    Windows   [
      #define z-library "zlib1.dll"
    ]
    MacOSX    [
      #define z-library "libz.1.dylib"  ; TODO: check this
    ]
    #default  [
      #define z-library "libz.so.1"
    ]
  ]

  z_stream!: alias struct! [
    next_in        [byte-ptr!]     ; next input byte
    avail_in       [integer!]      ; number of bytes available at next_in
    total_in       [integer!]      ; total number of input bytes read so far

    next_out       [byte-ptr!]     ; next output byte should be put there
    avail_out      [integer!]      ; remaining free space at next_out
    total_out      [integer!]      ; total number of bytes output so far

    msg            [c-string!]     ; last error message, NULL if no error
    state          [integer!]      ; not visible by applications

    zalloc         [opaque!]       ; used to allocate the internal state (function pointer)
    zfree          [opaque!]       ; used to free the internal state (function pointer)
    opaque         [opaque!]       ; private data object passed to zalloc and zfree (function pointer)

    data_type      [integer!]      ; best guess about the data type: binary or text
    adler          [integer!]      ; adler32 value of the uncompressed data
    reserved       [integer!]      ; reserved for future use
  ]

  #import [z-library cdecl [
    version: "zlibVersion" [       ; Return zlib library version.
      return:   [c-string!]
    ]

    deflateInit_: "deflateInit_" [
      strm         [z_stream!]
      level        [integer!]
      version      [c-string!]
      stream_size  [integer!]
      return:      [integer!]
    ]

    z-deflateEnd: "deflateEnd" [
      strm         [z_stream!]
      return:      [integer!]
    ]

    z-deflate: "deflate" [
      strm         [z_stream!]
      flush        [integer!]
      return:      [integer!]
    ]

    inflateInit_: "inflateInit_" [
      strm         [z_stream!]
      version      [c-string!]
      stream_size  [integer!]
      return:      [integer!]
    ]

    z-inflateEnd: "inflateEnd" [
      strm         [z_stream!]
      return:      [integer!]
    ]

    z-inflate: "inflate" [
      strm         [z_stream!]
      flush        [integer!]
      return:      [integer!]
    ]

    compressBound: "compressBound" [
      sourceLen    [integer!]
      return:      [integer!]
    ]

    z-compress: "compress2" [
      out-buf      [byte-ptr!]           "Pointer to destination data"
      out-count    [int-ptr!]            "Pointer to destination size, returns output buffer size"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      level        [integer!]            "Compression level"
      return:      [integer!]
    ]

    z-uncompress: "uncompress" [
      out-buf      [byte-ptr!]           "Pointer to destination data"
      out-count    [int-ptr!]            "Pointer to destination size, returns output buffer size"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      return:      [integer!]
    ]

  ] ; cdecl
  ] ; #import [z-library

  ; Higher level interface ---------------------------- ---------------------------------------

  with zlib [

     z-inflateInit: function [
      strm         [z_stream!]
      return:      [integer!]
    ][
      inflateInit_ strm version size? z_stream!
    ]

    z-deflateInit: function [
      strm         [z_stream!]
      level        [integer!]
      return:      [integer!]
    ][
      deflateInit_ strm level version size? z_stream!
    ]

#define END_Z_FUNC   [z-deflateEnd strm  free buf-out  free buf-in  free as byte-ptr! strm]

    deflate: function [
      src          [file!]
      dest         [file!]
      level        [integer!]
      return:      [integer!]
      /local ret have flush buf-in buf-out
             strm     [z_stream!]
    ][
      strm: as z_stream! allocate (size? z_stream!)
      if strm = NULL [
        print [ "Deflate: Memory allocation error." lf ]
        return Z_ERRNO
      ]
      buf-in: allocate CHUNK
      if buf-in = NULL [
        print [ "Deflate: Input buffer allocation error." lf ]
        free as byte-ptr! strm
        return Z_ERRNO
      ]
      buf-out: allocate CHUNK
      if buf-out = NULL [
        print [ "Deflate: Output buffer allocation error." lf ]
        free buf-in
        free as byte-ptr! strm
        return Z_ERRNO
      ]
      strm/zalloc: Z_NULL
      strm/zfree: Z_NULL
      strm/opaque: Z_NULL
      ret: z-deflateInit strm level
      if ret <> Z_OK [
        print [ "Deflate: Error deflateInit : " ret lf ]
        END_Z_FUNC
        return Z_ERRNO
      ]
      until [
        strm/avail_in: read-file buf-in 1 CHUNK src
        if file-error? src [
          print [ "Deflate: Input file error : " ret lf ]
          END_Z_FUNC
          return Z_ERRNO ; FIXME: find best error number
        ]
        either file-tail? src [ flush: Z_FINISH ][ flush: Z_NO_FLUSH ]
        strm/next_in: buf-in
        until [
          strm/avail_out: CHUNK
          strm/next_out: buf-out
          ret: z-deflate strm flush
          if ret = Z_STREAM_ERROR [
            print [ "Deflate: Data stream error" lf ]
            END_Z_FUNC
            return Z_ERRNO
          ]
          have: CHUNK - strm/avail_out
          ret: write-file buf-out 1 have dest
          if any [ (ret <> have) (file-error?  dest) ][
            END_Z_FUNC
            return Z_ERRNO
          ]
          strm/avail_out <> 0
        ]
        flush = Z_FINISH
      ]
      END_Z_FUNC
      return Z_OK
    ]

    compress: func [                     "Compress a byte array"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      out-count    [int-ptr!]            "Pointer to integer, returns output buffer size"
      level        [integer!]            "Compression level"
      return:      [byte-ptr!]           "Returns a pointer to compressed data"
      /local ret out-buf tmp
    ][
      out-count/value: compressBound in-count
      out-buf: allocate out-count/value         ; allocate the size of original buffer
      if out-buf = NULL [
        print [ "Compress Error : Output buffer allocation error." lf ]
        return NULL
      ]
      ret: z-compress out-buf out-count in-buf in-count level
      either ret = Z_OK [
        tmp: re-allocate out-buf out-count/value        ; Resize output buffer to minimum size
        either tmp = NULL [                             ; reallocation failed, uses current output buffer
          print [ "Compress Warning : Impossible to reallocate output buffer." lf ]
        ][                                              ; reallocation succeeded, uses reallocated buffer
          out-buf: tmp
        ]
        return out-buf
      ][
        case [
          ret = Z_MEM_ERROR    [ print [ "Compress Error : not enough memory." lf ] ]
          ret = Z_BUF_ERROR    [ print [ "Compress Error : not enough room in the output buffer." lf ] ]
          ret = Z_STREAM_ERROR [ print [ "Compress Error : invalid compression level parameter." lf ] ]
        ]
        free out-buf
        return NULL
      ]
    ] ; compress

    decompress: func [                   "Decompress a byte array"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      return:      [byte-ptr!]           "Return a pointer to decompressed data"
      /local ret out-buf tmp
      out-count    [integer!]
    ][
      out-count: 2 * in-count                             ; allocate twice the size of original buffer
      out-buf: allocate out-count
      if out-buf = NULL [
        print [ "Decompress Error : Output buffer allocation error." lf ]
        return NULL
      ]
      until [
        ret: z-uncompress out-buf :out-count in-buf in-count
        if ret = Z_BUF_ERROR [                            ; need to expand output buffer
          out-count: 2 * out-count                        ; double buffer size
          tmp: re-allocate out-buf out-count              ; Resize output buffer to minimum size
          either tmp = NULL [                             ; reallocation failed, uses current output buffer
            print [ "Decompress Error : Impossible to reallocate output buffer." lf ]
            ret: Z_MEM_ERROR
          ][                                              ; reallocation succeeded, uses reallocated buffer
            out-buf: tmp
          ]
        ]
        any [ (ret = Z_OK) (ret = Z_MEM_ERROR) (ret = Z_STREAM_ERROR) ]
      ]
      either ret = Z_OK [
        tmp: re-allocate out-buf out-count              ; Resize output buffer to minimum size
        either tmp = NULL [                             ; reallocation failed, uses current output buffer
          print [ "Decompress Warning : Impossible to reallocate output buffer." lf ]
        ][                                              ; reallocation succeeded, uses reallocated buffer
          out-buf: tmp
        ]
        return out-buf
      ][
        case [
          ret = Z_MEM_ERROR    [ print [ "Decompress Error : not enough memory." lf ] ]
          ret = Z_BUF_ERROR    [ print [ "Decompress Error : not enough room in the output buffer." lf ] ]
          ret = Z_STREAM_ERROR [ print [ "Decompress Error : invalid compression level parameter." lf ] ]
        ]
      ]
      return out-buf
    ]

    bin-to-str: func [             "Convert a byte array into an hex string."
      address [byte-ptr!]          "Memory address where the conversion starts"
      limit   [integer!]           "Number of bytes to convert"
      return: [c-string!]          "Return a c string"
      /local i str cnum byte major minor
    ][
      str: make-c-string (1 + (2 * limit))
      i: 0
      cnum: 0
      until [
        byte: as integer! address/value
        minor: byte // 16
        if minor > 9 [minor: minor + 7]         ;-- 7 = (#"A" - 1) - #"9"
        byte: byte >>> 4
        major: byte // 16
        if major > 9 [major: major + 7]         ;-- 7 = (#"A" - 1) - #"9"

        cnum: cnum + 1
        str/cnum: #"0" + major
        cnum: cnum + 1
        str/cnum: #"0" + minor

        address: address + 1
        i: i + 1
        i = limit
      ]
      cnum: cnum + 1
      str/cnum: #"^(00)"  ; c string ending char
      str
    ]
  ] ; with zlib
] ; context zlib


FEAT: added colors to hello.reds script for Mac and UNIX platforms

Red/System [
	Title:   "Red/System small demo app"
	Author:  "Nenad Rakocevic"
	File: 	 %hello.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt"
]

#either OS = 'Windows [
	#import [
		"kernel32.dll" stdcall [
			SetConsoleTextAttribute: "SetConsoleTextAttribute" [
				handle 		[integer!]
				attributes  [integer!]
				return:		[integer!]
			]
		]
	]

	set-pen-color: func [color [integer!]][
		SetConsoleTextAttribute stdout color
	]

	black:   0
	blue: 	 1
	green:	 2
	red:	 4
][
	set-pen-color: func [color [integer!]][
		either color = white [
			prin "^[[0m"
		][
			prin "^[["
			prin-int either color >= 7 [1][0]
			prin ";3"
			prin-int color and 7	;-- mask only right 3 bits for color
			prin "m"
		]
	]

	black:   0
	red: 	 1
	green:	 2
	blue:	 4
]

cyan:  	 blue or green
magenta: blue or red
yellow:  green or red
white:   blue or green or red

light-blue:  blue  or 8
light-green: green or 8
light-red: 	 red   or 8

prin-logo: does [
	set-pen-color light-red
	prin "R"
	set-pen-color white
	prin "ed"
]

draw-hline: func [size [integer!] alt [integer!] /local c [integer!]][
	c: size							;-- local variable is not necessary, just for the demo
	until [
		either positive? alt [		;-- print * and - alternatively
			alt: either alt = 1 [
				prin "*"
				2
			][
				prin "-"
				1
			]
		][
			prin "-"				;-- print - only
		]
		c: c - 1
		zero? c
	]
	prin "^/"
]

draw-vline: does [prin "|"]

pad: func [n [integer!]][
	while [n > 0][prin " " n: n - 1] ;-- could have used UNTIL, just for the demo
]

banner: func [width [integer!]][
	draw-hline width 1
	draw-vline
	pad (width - 16) / 2 - 1
	prin "Hello "
	prin-logo
	prin " World!"
	pad ((width - 16) / 2) - 1		;-- just showing nested parenthesis support
	draw-vline
	prin newline
	draw-hline width 0
]

prin-logo
print "/System v0.2.0 beta^/"

size: 20
until [
	banner size
	size: size + 2
	size = 40
]

Red/System [
	Title:   "Red/System small demo app"
	Author:  "Nenad Rakocevic"
	File: 	 %hello.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt"
]

#either OS = 'Windows [
	#import [
		"kernel32.dll" stdcall [
			SetConsoleTextAttribute: "SetConsoleTextAttribute" [
				handle 		[integer!]
				attributes  [integer!]
				return:		[integer!]
			]
		]
	]

	set-pen-color: func [color [integer!]][
		SetConsoleTextAttribute stdout color
	]

	set-colors: func [pen [integer!] bg [integer!]][
		SetConsoleTextAttribute stdout bg * 16 or pen
	]
][
	set-pen-color: func [color [integer!]][
		;-- not supported for now
	]

	set-colors: func [pen [integer!] bg [integer!]][
		;-- not supported for now
	]
]

black:   0
blue: 	 1
green:	 2
red:	 4
cyan:  	 blue or green
magenta: blue or red
yellow:  green or red
white:   blue or green or red

light-blue:  blue  or 8
light-green: green or 8
light-red: 	 red   or 8

prin-logo: does [
	set-pen-color light-red
	prin "R"
	set-pen-color white
	prin "ed"
]

draw-hline: func [size [integer!] alt [integer!] /local c [integer!]][
	c: size							;-- local variable is not necessary, just for the demo
	until [
		either positive? alt [			;-- print * and - alternatively
			alt: either alt = 1 [
				prin "*"
				2
			][
				prin "-"
				1
			]
		][
			prin "-"				;-- print - only
		]
		c: c - 1
		zero? c
	]
	prin "^/"
]

draw-vline: does [prin "|"]

pad: func [n [integer!]][
	while [n > 0][prin " " n: n - 1]	;-- could have used UNTIL, just for the demo
]

banner: func [width [integer!]][
	draw-hline width 1
	draw-vline
	pad (width - 16) / 2 - 1
	prin "Hello "
	prin-logo
	prin " World!"
	pad ((width - 16) / 2) - 1		;-- just showing nested parenthesis support
	draw-vline
	prin newline
	draw-hline width 0
]

prin-logo
print "/System v0.2.0 beta^/"

size: 20
until [
	banner size
	size: size + 2
	size = 40
]


FEAT: datatypes macros extended and re-ordered (order is just cosmetic)

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

#define RED_TYPE_UNSET			0
#define RED_TYPE_NONE			1
#define RED_TYPE_LOGIC			2
#define RED_TYPE_BLOCK			3
#define RED_TYPE_INTEGER		4
#define RED_TYPE_WORD			5
#define RED_TYPE_SET_WORD		6
#define RED_TYPE_GET_WORD		7
#define RED_TYPE_LIT_WORD		8
#define RED_TYPE_REFINEMENT		9
#define RED_TYPE_BINARY			10
#define RED_TYPE_STRING			11
#define RED_TYPE_CHAR			12
#define RED_TYPE_BITSET			13
#define RED_TYPE_PATH			14
#define RED_TYPE_SET_PATH		15
#define RED_TYPE_GET_PATH		16
#define RED_TYPE_LIT_PATH		17
#define RED_TYPE_FLOAT			18

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

#define RED_TYPE_UNSET			0
#define RED_TYPE_BLOCK			1
#define RED_TYPE_INTEGER		2
#define RED_TYPE_WORD			3
#define RED_TYPE_SET_WORD		4
#define RED_TYPE_GET_WORD		5
#define RED_TYPE_LIT_WORD		6
#define RED_TYPE_INTEGER		7
#define RED_TYPE_FLOAT			8
#define RED_TYPE_BINARY			10
#define RED_TYPE_STRING			11
#define RED_TYPE_CHAR			12
#define RED_TYPE_BITSET			13


TESTS: added simple test of implicit type casting of float! literals to float32! for function arguments

Red/System [
	Title:   "Red/System integer! datatype tests"
	Author:  "Peter W A Wood"
	File: 	 %float32-test.reds
	Version: 0.1.0
	Rights:  "Copyright (C) 2012 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~~~ "float32"

===start-group=== "float32 assignment"
  --test-- "float32-1"
    f: as float32! 100.0
  --assert f = as float32! 100.0
  --test-- "float32-2"
    f: as float32! 1.222090944E+33
  --assert f = as float32! 1.222090944E+33
  --test-- "float32-3"
    f: as float32! 9.99999E-25
  --assert f = as float32! 9.99999E-25
  --test-- "float32-4"
    f: as float32! 1.0
    f1: f
  --assert f1 = as float32! 1.0
===end-group===

===start-group=== "float argument to external function"

	#import [
		LIBM-file cdecl [
			sin: "sin" [
				x 		[float!]
				return: [float!]
			]
			cos: "cos" [
				x 		[float!]
				return: [float!]
			]
		]
	]
	pi32: 3.1415927

	--test-- "float32-ext-1"
	--assert (as float32! -1.0) = as-float32 cos pi32

	;--test-- "float32-ext-2"
	;--assert  (as float32! 0.0) = (as float32! sin pi32)		; not working, because of rounding error.

	--test-- "float32-ext-3"
	--assert (as float32! -1.0) = as-float32 cos 3.1415927

===end-group===

===start-group=== "float32 function arguments"
    ff: func [
      fff     [float32!]
      ffg     [float32!]
      return: [integer!]
      /local
      ffl [float32!]
    ][
       ffl: fff
       if ffl <> fff [return 1]
       ffl: ffg
       if ffl <> ffg [return 2]
       1
    ]

  --test-- "float32-func-args-1"
  --assert 1 = ff as float32! 1.0 as float32! 2.0

  --test-- "float32-func-args-2"
  --assert 1 = ff as float32! 1.222090944E+33 as float32! 9.99999E-25

===end-group===

===start-group=== "float32 locals"

	local-float: func [n [float32!] return: [float32!] /local p][p: n p]

	--test-- "float32-loc-1"
	pi64: 3.14159265358979
	pi: local-float as float32! 3.1415927
	--assert pi =  as float32! 3.1415927
	--assert (as float32! -1.0) = as-float32 cos pi64
	--assert (as float32! -1.0) = local-float as-float32 cos pi64

	--test-- "float32-loc-2"
	f: local-float pi
	--assert pi = local-float f

	--test-- "float32-loc-3"
	local-float2: func [n [float32!] return: [float32!] /local p][p: n local-float p]

	pi: local-float2 as float32! 3.1415927
	--assert (as float32! 3.1415927) = local-float2 pi
	--assert (as float32! -1.0) = local-float2 as-float32 cos pi64
	f: local-float2 pi
	--assert pi = local-float2 f

	--test-- "float32-loc-4"
	local-float3: func [n [float32!] return: [float32!] /local p [float32!]][p: n local-float p]

	pi: local-float3 as float32! 3.1415927
	--assert (as float32! 3.1415927) = local-float3 pi
	--assert (as float32! -1.0) = local-float3 as-float32 cos pi64
	f: local-float3 pi
	--assert pi = local-float3 f

	--test-- "float32-loc-5"
	local-float4: func [n [float32!] return: [float32!] /local r p][p: n p]
	--assert (as float32! 3.1415927) = local-float4 pi
	--assert (as float32! -1.0) = local-float4 as-float32 cos pi64
	f: local-float4 pi
	--assert pi = local-float4 f

	--test-- "float32-loc-6"
	local-float5: func [n [float32!] return: [float32!] /local r p][p: n local-float p]
	--assert (as float32! 3.1415927) = local-float5 pi
	--assert (as float32! -1.0) = local-float5 as-float32 cos pi64
	f: local-float5 pi
	--assert pi = local-float5 f

===end-group===

===start-group=== "float32 function return"

    ff1: func [
      ff1i      [integer!]
      return:   [float32!]
    ][
      as float32! switch ff1i [
        1 [1.0]
        2 [1.222090944E+33]
        3 [9.99999E-30]
      ]
    ]
  --test-- "float32 return 1"
  --assert (as float32! 1.0) = ff1 1
  --test-- "float32 return 2"
  --assert (as float32! 1.222090944E+33) = ff1 2
  --test-- "float32 return 3"
  --assert (as float32! 9.99999E-30) = ff1 3

===end-group===

===start-group=== "float32 struct!"

  --test-- "float32-struct-1"
    sf1: declare struct! [
      a   [float32!]
    ]
  --assert (as float32! 0.0) = sf1/a

  --test-- "float32-struct-2"
    sf2: declare struct! [
      a   [float32!]
    ]
    sf2/a: as float32! 1.222090944E+33
  --assert (as float32! 1.222090944E+33) = sf2/a

    sf3: declare struct! [
      a   [float32!]
      b   [float32!]
    ]

  --test-- "float32-struct-3"
    sf3/a: as float32! 1.222090944E+33
    sf3/b: as float32! 9.99999E-25

  --assert (as float32! 1.222090944E+33) = sf3/a
  --assert (as float32! 9.99999E-25) = sf3/b

  --test-- "float32-struct-4"
    sf4: declare struct! [
      c   [byte!]
      a   [float32!]
      l   [logic!]
      b   [float32!]
    ]
    sf4/a: as float32! 1.222090944E+33
    sf4/b: as float32! 9.99999E-25
  --assert (as float32! 1.222090944E+33) = sf4/a
  --assert (as float32! 9.99999E-25) = sf4/b

===end-group===

===start-group=== "float32 pointers"

  --test-- "float32-point-1"
  pi: as float32! 3.1415927
  p: declare pointer! [float32!]
  p/value: as float32! 3.1415927
  --assert pi = p/value

 ;TBD: add more float pointer tests in %pointer-test.reds.

===end-group===

===start-group=== "expressions with returned float values"

    fe1: function [
      return: [float32!]
    ][
      as float32! 1.0
    ]
    fe2: function [
      return: [float32!]
    ][
      as float32! 2.0
    ]

  --test-- "ewrfv0"
  --assertf32~= as float32! 1.0 (fe1 * as float32! 1.0) as float32! 0.1E-3

  --test-- "ewrfv1"
  --assertf32~= as float32! 1.0 (as float32! 1.0) * fe1 as float32! 0.1E-3

  --test-- "ewrfv2"
  --assertf32~= as float32! 0.5 (fe1 / fe2) as float32! 0.1E-3

===end-group===

===start-group=== "float32 arguments to typed functions"
    fatf1: function [
      [typed]
      count [integer!]
      list [typed-value!]
      return: [float32!]
      /local
        a [float32!]
    ][
      a: as float32! list/value
      a
    ]

    fatf2: function [
      [typed]
      count [integer!]
      list [typed-value!]
      return: [float32!]
      /local
        a [float32!]
        b [float32!]
    ][
      a: as float32! list/value
      list: list + 1
      b: as float32! list/value
      a + b
    ]

  --test-- "fatf-1"
  --assert (as float32! 2.0) = (fatf1 as float32! 2.0)

  --test-- "fatf-2"
  --assert (as float32! 2.0) = ((fatf1 as float32! 1.0) + (fatf1 as float32! 1.0))

  --test-- "fatf-3"
  --assert (as float32! 3.0) = fatf2 [as float32! 1.0 as float32! 2.0]

===end-group===

===start-group=== "Casting float! arguments to float32!"

    cfaf1: function [
        a   [float!]
        return: [float32!]
    ][
      as float32! a
    ]
    cfaf2: function [
        a   [float!]
        b   [float!]
        return: [float32!]
    ][
      (as float32! a) + (as float32! b)
    ]

  --test-- "cfaf1"
  --assert (as float32! 1.0) = cfaf1 1.0

  --test-- "cfaf2"
  --assertf32~= (as float32! 3.0) (cfaf2 1.0 2.0) (as float32! 0.1e-7)

===end-group===

===start-group=== "calculations"

	fcfoo: func [a [float32!] return: [float32!]][a]

	fcptr: declare struct! [a [float32!]]
	fcptr/a: as float32! 3.0

	fc2: as float32! 3.0

	--test-- "fc-1"
		fc1: as float32! 2.0
		fc1: fc1 / (fc1 - as float32! 1.0)
	--assertf32~= as float32! 2.0 fc1 as float32! 0.1E-7

	--test-- "fc-2"
	--assert (as float32! 5.0) - (as float32! 3.0) = as float32! 2.0			;-- imm/imm

	--test-- "fc-3"
	--assert (as float32! 5.0) - fc2 = as float32! 2.0							;-- imm/ref

	--test-- "fc-4"
	--assert (as float32! 5.0) - (fcfoo as float32! 3.0) = as float32! 2.0		;-- imm/reg(block!)

	--test-- "fc-5"
	--assertf32~= (as float32! 5.0) - fcptr/a as float32! 2.0 as float32! 1E-10		;-- imm/reg(path!)

	--test-- "fc-6"
	--assert fc2 - (as float32! 5.0) = as float32! -2.0							;-- ref/imm

	--test-- "fc-7"
	--assert fc2 - (fcfoo as float32! 5.0) = as float32! -2.0					;-- ref/reg(block!)

	--test-- "fc-8"
	--assert fc2 - fcptr/a = as float32! 0.0									;-- ref/reg(path!)

	--test-- "fc-9"
	--assertf32~= (fcfoo as float32! 5.0) - as float32! 3.0 as float32! 2.0 as float32! 1E-10	;-- reg(block!)/imm

	--test-- "fc-10"
	--assert (fcfoo as float32! 5.0) - (fcfoo as float32! 3.0) = as float32! 2.0	;-- reg(block!)/reg(block!)

	--test-- "fc-11"
	--assert (fcfoo as float32! 5.0) - fcptr/a = as float32! 2.0				;-- reg(block!)/reg(path!)

	--test-- "fc-12"
	--assert fcptr/a - (fcfoo as float32! 5.0) = as float32! 2.0				;-- reg(path!)/reg(block!)

===end-group===

===start-group=== "implicit literal type casting of function arguments"
  --test-- "fiitc1"
    flitc1-f: function [
      x       [float32!]
      y       [float!]
      z       [float32!]
      return: [float32!]
    ][
      x + z
    ]
  --assert (as float32! 4.00) = flitc1-f 1.00 2.00 3.00
===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System integer! datatype tests"
	Author:  "Peter W A Wood"
	File: 	 %float32-test.reds
	Version: 0.1.0
	Rights:  "Copyright (C) 2012 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~~~ "float32"

===start-group=== "float32 assignment"
  --test-- "float32-1"
    f: as float32! 100.0
  --assert f = as float32! 100.0
  --test-- "float32-2"
    f: as float32! 1.222090944E+33
  --assert f = as float32! 1.222090944E+33
  --test-- "float32-3"
    f: as float32! 9.99999E-25
  --assert f = as float32! 9.99999E-25
  --test-- "float32-4"
    f: as float32! 1.0
    f1: f
  --assert f1 = as float32! 1.0
===end-group===

===start-group=== "float argument to external function"

	#import [
		LIBM-file cdecl [
			sin: "sin" [
				x 		[float!]
				return: [float!]
			]
			cos: "cos" [
				x 		[float!]
				return: [float!]
			]
		]
	]
	pi32: 3.1415927

	--test-- "float32-ext-1"
	--assert (as float32! -1.0) = as-float32 cos pi32

	;--test-- "float32-ext-2"
	;--assert  (as float32! 0.0) = (as float32! sin pi32)		; not working, because of rounding error.

	--test-- "float32-ext-3"
	--assert (as float32! -1.0) = as-float32 cos 3.1415927

===end-group===

===start-group=== "float32 function arguments"
    ff: func [
      fff     [float32!]
      ffg     [float32!]
      return: [integer!]
      /local
      ffl [float32!]
    ][
       ffl: fff
       if ffl <> fff [return 1]
       ffl: ffg
       if ffl <> ffg [return 2]
       1
    ]

  --test-- "float32-func-args-1"
  --assert 1 = ff as float32! 1.0 as float32! 2.0

  --test-- "float32-func-args-2"
  --assert 1 = ff as float32! 1.222090944E+33 as float32! 9.99999E-25

===end-group===

===start-group=== "float32 locals"

	local-float: func [n [float32!] return: [float32!] /local p][p: n p]

	--test-- "float32-loc-1"
	pi64: 3.14159265358979
	pi: local-float as float32! 3.1415927
	--assert pi =  as float32! 3.1415927
	--assert (as float32! -1.0) = as-float32 cos pi64
	--assert (as float32! -1.0) = local-float as-float32 cos pi64

	--test-- "float32-loc-2"
	f: local-float pi
	--assert pi = local-float f

	--test-- "float32-loc-3"
	local-float2: func [n [float32!] return: [float32!] /local p][p: n local-float p]

	pi: local-float2 as float32! 3.1415927
	--assert (as float32! 3.1415927) = local-float2 pi
	--assert (as float32! -1.0) = local-float2 as-float32 cos pi64
	f: local-float2 pi
	--assert pi = local-float2 f

	--test-- "float32-loc-4"
	local-float3: func [n [float32!] return: [float32!] /local p [float32!]][p: n local-float p]

	pi: local-float3 as float32! 3.1415927
	--assert (as float32! 3.1415927) = local-float3 pi
	--assert (as float32! -1.0) = local-float3 as-float32 cos pi64
	f: local-float3 pi
	--assert pi = local-float3 f

	--test-- "float32-loc-5"
	local-float4: func [n [float32!] return: [float32!] /local r p][p: n p]
	--assert (as float32! 3.1415927) = local-float4 pi
	--assert (as float32! -1.0) = local-float4 as-float32 cos pi64
	f: local-float4 pi
	--assert pi = local-float4 f

	--test-- "float32-loc-6"
	local-float5: func [n [float32!] return: [float32!] /local r p][p: n local-float p]
	--assert (as float32! 3.1415927) = local-float5 pi
	--assert (as float32! -1.0) = local-float5 as-float32 cos pi64
	f: local-float5 pi
	--assert pi = local-float5 f

===end-group===

===start-group=== "float32 function return"

    ff1: func [
      ff1i      [integer!]
      return:   [float32!]
    ][
      as float32! switch ff1i [
        1 [1.0]
        2 [1.222090944E+33]
        3 [9.99999E-30]
      ]
    ]
  --test-- "float32 return 1"
  --assert (as float32! 1.0) = ff1 1
  --test-- "float32 return 2"
  --assert (as float32! 1.222090944E+33) = ff1 2
  --test-- "float32 return 3"
  --assert (as float32! 9.99999E-30) = ff1 3

===end-group===

===start-group=== "float32 struct!"

  --test-- "float32-struct-1"
    sf1: declare struct! [
      a   [float32!]
    ]
  --assert (as float32! 0.0) = sf1/a

  --test-- "float32-struct-2"
    sf2: declare struct! [
      a   [float32!]
    ]
    sf2/a: as float32! 1.222090944E+33
  --assert (as float32! 1.222090944E+33) = sf2/a

    sf3: declare struct! [
      a   [float32!]
      b   [float32!]
    ]

  --test-- "float32-struct-3"
    sf3/a: as float32! 1.222090944E+33
    sf3/b: as float32! 9.99999E-25

  --assert (as float32! 1.222090944E+33) = sf3/a
  --assert (as float32! 9.99999E-25) = sf3/b

  --test-- "float32-struct-4"
    sf4: declare struct! [
      c   [byte!]
      a   [float32!]
      l   [logic!]
      b   [float32!]
    ]
    sf4/a: as float32! 1.222090944E+33
    sf4/b: as float32! 9.99999E-25
  --assert (as float32! 1.222090944E+33) = sf4/a
  --assert (as float32! 9.99999E-25) = sf4/b

===end-group===

===start-group=== "float32 pointers"

  --test-- "float32-point-1"
  pi: as float32! 3.1415927
  p: declare pointer! [float32!]
  p/value: as float32! 3.1415927
  --assert pi = p/value

 ;TBD: add more float pointer tests in %pointer-test.reds.

===end-group===

===start-group=== "expressions with returned float values"

    fe1: function [
      return: [float32!]
    ][
      as float32! 1.0
    ]
    fe2: function [
      return: [float32!]
    ][
      as float32! 2.0
    ]

  --test-- "ewrfv0"
  --assertf32~= as float32! 1.0 (fe1 * as float32! 1.0) as float32! 0.1E-3

  --test-- "ewrfv1"
  --assertf32~= as float32! 1.0 (as float32! 1.0) * fe1 as float32! 0.1E-3

  --test-- "ewrfv2"
  --assertf32~= as float32! 0.5 (fe1 / fe2) as float32! 0.1E-3

===end-group===

===start-group=== "float32 arguments to typed functions"
    fatf1: function [
      [typed]
      count [integer!]
      list [typed-value!]
      return: [float32!]
      /local
        a [float32!]
    ][
      a: as float32! list/value
      a
    ]

    fatf2: function [
      [typed]
      count [integer!]
      list [typed-value!]
      return: [float32!]
      /local
        a [float32!]
        b [float32!]
    ][
      a: as float32! list/value
      list: list + 1
      b: as float32! list/value
      a + b
    ]

  --test-- "fatf-1"
  --assert (as float32! 2.0) = (fatf1 as float32! 2.0)

  --test-- "fatf-2"
  --assert (as float32! 2.0) = ((fatf1 as float32! 1.0) + (fatf1 as float32! 1.0))

  --test-- "fatf-3"
  --assert (as float32! 3.0) = fatf2 [as float32! 1.0 as float32! 2.0]

===end-group===

===start-group=== "Casting float! arguments to float32!"

    cfaf1: function [
        a   [float!]
        return: [float32!]
    ][
      as float32! a
    ]
    cfaf2: function [
        a   [float!]
        b   [float!]
        return: [float32!]
    ][
      (as float32! a) + (as float32! b)
    ]

  --test-- "cfaf1"
  --assert (as float32! 1.0) = cfaf1 1.0

  --test-- "cfaf2"
  --assertf32~= (as float32! 3.0) (cfaf2 1.0 2.0) (as float32! 0.1e-7)

===end-group===

===start-group=== "calculations"

	fcfoo: func [a [float32!] return: [float32!]][a]

	fcptr: declare struct! [a [float32!]]
	fcptr/a: as float32! 3.0

	fc2: as float32! 3.0

	--test-- "fc-1"
		fc1: as float32! 2.0
		fc1: fc1 / (fc1 - as float32! 1.0)
	--assertf32~= as float32! 2.0 fc1 as float32! 0.1E-7

	--test-- "fc-2"
	--assert (as float32! 5.0) - (as float32! 3.0) = as float32! 2.0			;-- imm/imm

	--test-- "fc-3"
	--assert (as float32! 5.0) - fc2 = as float32! 2.0							;-- imm/ref

	--test-- "fc-4"
	--assert (as float32! 5.0) - (fcfoo as float32! 3.0) = as float32! 2.0		;-- imm/reg(block!)

	--test-- "fc-5"
	--assertf32~= (as float32! 5.0) - fcptr/a as float32! 2.0 as float32! 1E-10		;-- imm/reg(path!)

	--test-- "fc-6"
	--assert fc2 - (as float32! 5.0) = as float32! -2.0							;-- ref/imm

	--test-- "fc-7"
	--assert fc2 - (fcfoo as float32! 5.0) = as float32! -2.0					;-- ref/reg(block!)

	--test-- "fc-8"
	--assert fc2 - fcptr/a = as float32! 0.0									;-- ref/reg(path!)

	--test-- "fc-9"
	--assertf32~= (fcfoo as float32! 5.0) - as float32! 3.0 as float32! 2.0 as float32! 1E-10	;-- reg(block!)/imm

	--test-- "fc-10"
	--assert (fcfoo as float32! 5.0) - (fcfoo as float32! 3.0) = as float32! 2.0	;-- reg(block!)/reg(block!)

	--test-- "fc-11"
	--assert (fcfoo as float32! 5.0) - fcptr/a = as float32! 2.0				;-- reg(block!)/reg(path!)

	--test-- "fc-12"
	--assert fcptr/a - (fcfoo as float32! 5.0) = as float32! 2.0				;-- reg(path!)/reg(block!)

===end-group===

~~~end-file~~~


FIX: issue #1246 (Console: latest nightly broken on osx and linux)

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

;;@@ Temporary patch to allow inclusion in user code.
unless system/console [
	system/console: context [
        	history: make block! 200
	]
]
;; End patch

complete-from-path: func [
	str [string!]
	/local s result word w1 ptr words first? sys-word w
][
	result: make block! 4
	first?: yes
	s: ptr: str
	while [ptr: find str #"/"][
		word: attempt [to word! copy/part str ptr]
		if none? word [return result]
		either first? [
			if value? word [
				w1: get word
				first?: no
			]
		][
			w1: get in w1 word
		]
		str: either object? w1 [next ptr][""]
	]
	if any [function? w1 action? w1 native? w1 routine? w1] [
		word: find/last/tail s #"/"
		words: make block! 4
		foreach w spec-of w1 [
			if refinement? w [append words w]
		]
	]
	if object? w1 [
		word: str
		words: words-of w1
	]
	if words [
		foreach w words [
			sys-word: form w
			if any [empty? word find/match sys-word word] [
				append result sys-word
			]
		]
	]

	if 1 = length? result [
		poke result 1 append copy/part s word result/1
	]
	result
]

default-input-completer: func [
	str  [string!]
	/local word ptr result sys-word delim? len insert? start end delimiters d w
][
	result: make block! 4
	delimiters: [#" " #"[" #"(" #":" #"'" #"{"]
	delim?: no
	insert?: not tail? str
	len: (index? str) - 1
	end: str
	ptr: str: head str
	foreach d delimiters [
		word: find/last/tail/part str d len
		if all [word (index? ptr) < (index? word)] [ptr: word]
	]
	either head? ptr [start: str][start: ptr delim?: yes]
	word: copy/part start end
	unless empty? word [
		either all [
			#"/" <> word/1
			ptr: find word #"/"
			#" " <> pick ptr -1
		][
			result: complete-from-path word
		][
			foreach w words-of system/words [
				if value? w [
					sys-word: mold w
					if find/match sys-word word [
						append result sys-word
					]
				]
			]
		]
	]
	if 1 = length? result [
		either word = result/1 [
			clear result
		][
			either any [insert? delim?] [
				str: append copy/part str start result/1
				poke result 1 tail str
				if insert? [append str end]
			][
				poke result 1 tail result/1
			]
		]
	]
	result
]

#system [
	terminal: context [

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

		#define KEY_CTRL_A		1
		#define KEY_CTRL_B		2
		#define KEY_CTRL_C		3
		#define KEY_CTRL_D		4
		#define KEY_CTRL_E		5
		#define KEY_CTRL_F		6
		#define KEY_CTRL_H		8
		#define KEY_TAB			9
		#define KEY_CTRL_K		11
		#define KEY_CTRL_L		12
		#define KEY_ENTER		13
		#define KEY_CTRL_N		14
		#define KEY_CTRL_P		16
		#define KEY_CTRL_T		20
		#define KEY_CTRL_U		21
		#define KEY_CTRL_W		23
		#define KEY_ESCAPE		27
		#define KEY_BACKSPACE	127

		#include %wcwidth.reds

		#either OS = 'Windows [
			#include %win32.reds
		][
			#include %POSIX.reds
		]

		buffer:		declare byte-ptr!
		pbuffer:	declare byte-ptr!
		input-line: declare red-string!
		saved-line:	declare red-string!
		prompt:		declare	red-string!
		history:	declare red-block!
		buf-size:	128
		columns:	-1
		rows:		-1
		output?:	yes
		init?:		no

		string/rs-make-at as cell! saved-line 1

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

		on-resize: func [[cdecl] sig [integer!]][
			get-window-size
			refresh
		]

		complete-line: func [
			str			[red-string!]
			return:		[integer!]
			/local
				line	[red-string!]
				result	[red-block!]
				num		[integer!]
				str2	[red-string!]
				head	[integer!]
		][
			#call [default-input-completer str]
			result: as red-block! stack/arguments
			num: block/rs-length? result
			unless zero? num [
				head: str/head
				str/head: 0
				string/copy str saved-line stack/arguments yes stack/arguments
				saved-line/head: head
				line: input-line
				string/rs-reset line

				either num = 1 [
					str2: as red-string! block/rs-head result
					head: str2/head
					str2/head: 0
					string/concatenate line str2 -1 0 yes no
					line/head: head
				][
					until [
						string/concatenate line as red-string! block/rs-head result -1 0 yes no
						string/append-char GET_BUFFER(line) 32
						block/rs-next result
						block/rs-tail? result
					]
					line/head: string/get-length line yes
				]
				refresh
			]
			num
		]

		add-history: func [
			str			[red-string!]
			/local
				saved	[integer!]
		][
			str/head: 0
			unless zero? string/rs-length? str [
				block/rs-append history as red-value! str		;TBD Don't add duplicated lines.
			]
		]

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

		init-buffer: func [
			str			[red-string!]
			prompt		[red-string!]
			/local
				unit	[integer!]
				s		[series!]
				size	[integer!]
		][
			s: GET_BUFFER(str)
			unit: GET_UNIT(s)
			if unit < 2 [unit: 2]			;-- always treat string as widechar string
			size: (string/get-length str yes) << (unit >> 1)
			size: size + (string/get-length prompt yes) << (unit >> 1)
			if size > buf-size [
				buf-size: size
				free buffer
				buffer: allocate size
			]
			pbuffer: buffer
		]

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

		refresh: func [
			/local
				line   [red-string!]
				offset [integer!]
				bytes  [integer!]
				psize  [integer!]
		][
			line: input-line

			either output? [					;-- erase down to the bottom of the screen
				reset-cursor-pos
				erase-to-bottom
			][
				#if OS <> 'Windows [reset-cursor-pos][0]
			]
			init-buffer line prompt
			bytes: emit-red-string prompt columns no

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

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

			either output? [
				output-to-screen
			][
				#if OS <> 'Windows [
					if all [
						bytes > columns
						positive? (bytes // columns)
					][
						psize: bytes / columns
						emit-string-int "^[[" psize  #"B"
					]
				][0]
			]
			set-cursor-pos line offset bytes
		]

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

			get-window-size
			unless zero? string/get-length saved-line yes [
				head: saved-line/head
				saved-line/head: 0
				string/concatenate line saved-line -1 0 yes no
				line/head: head
			]
			refresh

			while [true][
				output?: yes
				c: fd-read
				n: 0

				if c = KEY_TAB [
					n: complete-line line
					if n > 1 [
						string/rs-reset line
						exit
					]
					if zero? n [
						c: 32							;-- convert TAB to SPACE
					]
				]

				#if OS <> 'Windows [if c = 27 [c: check-special]]

				switch c [
					KEY_ENTER [
						add-history line
						string/rs-reset saved-line
						exit
					]
					KEY_CTRL_H
					KEY_BACKSPACE [
						unless zero? line/head [
							line/head: line/head - 1
							string/remove-char line line/head
							if string/rs-tail? line [output?: no]
							refresh
							unless output? [erase-to-bottom]
						]
					]
					KEY_CTRL_B
					KEY_LEFT [
						unless zero? line/head [
							line/head: line/head - 1
							output?: no
							refresh
						]
					]
					KEY_CTRL_F
					KEY_RIGHT [
						if 0 < string/rs-length? line [
							line/head: line/head + 1
							output?: no
							refresh
						]
					]
					KEY_CTRL_P
					KEY_UP [
						unless zero? history/head [
							history/head: history/head - 1
							fetch-history
							line/head: string/get-length line yes
							refresh
						]
					]
					KEY_CTRL_N
					KEY_DOWN [
						unless block/rs-tail? history [
							history/head: history/head + 1
							either block/rs-tail? history [
								string/rs-reset line
							][
								fetch-history
							]
							refresh
						]
					]
					KEY_CTRL_A
					KEY_HOME [
						line/head: 0
						refresh
					]
					KEY_CTRL_E
					KEY_END [
						line/head: string/get-length line yes
						refresh
					]
					KEY_DELETE [
						unless string/rs-tail? line [
							string/remove-char line line/head
							refresh
						]
					]
					KEY_CTRL_C
					KEY_CTRL_D [
						string/rs-reset line
						string/append-char GET_BUFFER(line) as-integer #"q"
						exit
					]
					KEY_ESCAPE [
						string/append-char GET_BUFFER(line) c
						exit
					]
					default [
						if c > 31 [
							either string/rs-tail? line [
								string/append-char GET_BUFFER(line) c
								#if OS = 'Windows [					;-- optimize for Windows
									pbuffer: buffer
									emit-red-char c
									output-to-screen
									pbuffer: buffer
									output?: no
								]
							][
								string/insert-char GET_BUFFER(line) line/head c
							]
							line/head: line/head + 1
							refresh
						]
					]
				]
			]
			line/head: 0
		]

		setup: func [
			line [red-string!]
			hist [red-block!]
		][
			copy-cell as red-value! line as red-value! input-line
			copy-cell as red-value! hist as red-value! history

			init line hist					;-- enter raw mode
		]
	]
]

_set-buffer-history: routine [line [string!] hist [block!]][
	terminal/setup line hist
]

_read-input: routine [prompt [string!]][
	terminal/edit prompt
	terminal/restore
	print-line ""
]

ask: function [
	question [string!]
	return:  [string!]
][
	buffer: make string! 1
	_set-buffer-history buffer head system/console/history
	_read-input question
	buffer
]

input: does [ask ""]

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

;;@@ Temporary patch to allow inclusion in user code.
unless system/console [
	system/console: context [
        	history: make block! 200
	]
]
;; End patch

complete-from-path: func [
	str [string!]
	/local s result word w1 ptr words first? sys-word w
][
	result: make block! 4
	first?: yes
	s: ptr: str
	while [ptr: find str #"/"][
		word: attempt [to word! copy/part str ptr]
		if none? word [return result]
		either first? [
			if value? word [
				w1: get word
				first?: no
			]
		][
			w1: get in w1 word
		]
		str: either object? w1 [next ptr][""]
	]
	if any [function? w1 action? w1 native? w1 routine? w1] [
		word: find/last/tail s #"/"
		words: make block! 4
		foreach w spec-of w1 [
			if refinement? w [append words w]
		]
	]
	if object? w1 [
		word: str
		words: words-of w1
	]
	if words [
		foreach w words [
			sys-word: form w
			if any [empty? word find/match sys-word word] [
				append result sys-word
			]
		]
	]

	if 1 = length? result [
		poke result 1 append copy/part s word result/1
	]
	result
]

default-input-completer: func [
	str  [string!]
	/local word ptr result sys-word delim? len insert? start end delimiters d w
][
	result: make block! 4
	delimiters: [#" " #"[" #"(" #":" #"'" #"{"]
	delim?: no
	insert?: not tail? str
	len: (index? str) - 1
	end: str
	ptr: str: head str
	foreach d delimiters [
		word: find/last/tail/part str d len
		if all [word (index? ptr) < (index? word)] [ptr: word]
	]
	either head? ptr [start: str][start: ptr delim?: yes]
	word: copy/part start end
	unless empty? word [
		either all [
			#"/" <> word/1
			ptr: find word #"/"
			#" " <> pick ptr -1
		][
			result: complete-from-path word
		][
			foreach w words-of system/words [
				if value? w [
					sys-word: mold w
					if find/match sys-word word [
						append result sys-word
					]
				]
			]
		]
	]
	if 1 = length? result [
		either word = result/1 [
			clear result
		][
			either any [insert? delim?] [
				str: append copy/part str start result/1
				poke result 1 tail str
				if insert? [append str end]
			][
				poke result 1 tail result/1
			]
		]
	]
	result
]

#system [
	terminal: context [

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

		#define KEY_CTRL_A		1
		#define KEY_CTRL_B		2
		#define KEY_CTRL_C		3
		#define KEY_CTRL_D		4
		#define KEY_CTRL_E		5
		#define KEY_CTRL_F		6
		#define KEY_CTRL_H		8
		#define KEY_TAB			9
		#define KEY_CTRL_K		11
		#define KEY_CTRL_L		12
		#define KEY_ENTER		13
		#define KEY_CTRL_N		14
		#define KEY_CTRL_P		16
		#define KEY_CTRL_T		20
		#define KEY_CTRL_U		21
		#define KEY_CTRL_W		23
		#define KEY_ESCAPE		27
		#define KEY_BACKSPACE	127

		#include %wcwidth.reds

		#either OS = 'Windows [
			#include %win32.reds
		][
			#include %POSIX.reds
		]

		buffer:		declare byte-ptr!
		pbuffer:	declare byte-ptr!
		input-line: declare red-string!
		saved-line:	declare red-string!
		prompt:		declare	red-string!
		history:	declare red-block!
		buf-size:	128
		columns:	-1
		rows:		-1
		output?:	yes
		init?:		no

		string/rs-make-at as cell! saved-line 1

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

		on-resize: func [[cdecl] sig [integer!]][
			get-window-size
			refresh
		]

		complete-line: func [
			str			[red-string!]
			return:		[integer!]
			/local
				line	[red-string!]
				result	[red-block!]
				num		[integer!]
				str2	[red-string!]
				head	[integer!]
		][
			#call [default-input-completer str]
			result: as red-block! stack/arguments
			num: block/rs-length? result
			unless zero? num [
				head: str/head
				str/head: 0
				string/copy str saved-line stack/arguments yes stack/arguments
				saved-line/head: head
				line: input-line
				string/rs-reset line

				either num = 1 [
					str2: as red-string! block/rs-head result
					head: str2/head
					str2/head: 0
					string/concatenate line str2 -1 0 yes no
					line/head: head
				][
					until [
						string/concatenate line as red-string! block/rs-head result -1 0 yes no
						string/append-char GET_BUFFER(line) 32
						block/rs-next result
						block/rs-tail? result
					]
					line/head: string/get-length line yes
				]
				refresh
			]
			num
		]

		add-history: func [
			str			[red-string!]
			/local
				saved	[integer!]
		][
			str/head: 0
			unless zero? string/rs-length? str [
				block/rs-append history as red-value! str		;TBD Don't add duplicated lines.
			]
		]

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

		init-buffer: func [
			str			[red-string!]
			prompt		[red-string!]
			/local
				unit	[integer!]
				s		[series!]
				size	[integer!]
		][
			s: GET_BUFFER(str)
			unit: GET_UNIT(s)
			if unit < 2 [unit: 2]			;-- always treat string as widechar string
			size: (string/get-length str yes) << (unit >> 1)
			size: size + (string/get-length prompt yes) << (unit >> 1)
			if size > buf-size [
				buf-size: size
				free buffer
				buffer: allocate size
			]
			pbuffer: buffer
		]

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

		refresh: func [
			/local
				line   [red-string!]
				offset [integer!]
				bytes  [integer!]
				psize  [integer!]
		][
			line: input-line

			either output? [					;-- erase down to the bottom of the screen
				reset-cursor-pos
				erase-to-bottom
			][
				#if OS <> 'Windows [reset-cursor-pos][0]
			]
			init-buffer line prompt
			bytes: emit-red-string prompt columns no

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

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

			either output? [
				output-to-screen
			][
				#if OS <> 'Windows [
					if all [
						bytes > columns
						positive? (bytes // columns)
					][
						psize: bytes / columns
						emit-string-int "^[[" psize  #"B"
					]
				][0]
			]
			set-cursor-pos line offset bytes
		]

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

			get-window-size
			unless zero? string/get-length saved-line yes [
				head: saved-line/head
				saved-line/head: 0
				string/concatenate line saved-line -1 0 yes no
				line/head: head
			]
			refresh

			while [true][
				output?: yes
				c: fd-read
				n: 0

				if c = KEY_TAB [
					n: complete-line line
					if n > 1 [
						string/rs-reset line
						exit
					]
					if zero? n [
						c: 32							;-- convert TAB to SPACE
					]
				]

				#if OS <> 'Windows [if c = 27 [c: check-special]]

				switch c [
					KEY_ENTER [
						add-history line
						string/rs-reset saved-line
						exit
					]
					KEY_CTRL_H
					KEY_BACKSPACE [
						unless zero? line/head [
							line/head: line/head - 1
							string/remove-char line line/head
							if string/rs-tail? line [output?: no]
							refresh
							unless output? [erase-to-bottom]
						]
					]
					KEY_CTRL_B
					KEY_LEFT [
						unless zero? line/head [
							line/head: line/head - 1
							output?: no
							refresh
						]
					]
					KEY_CTRL_F
					KEY_RIGHT [
						if 0 < string/rs-length? line [
							line/head: line/head + 1
							output?: no
							refresh
						]
					]
					KEY_CTRL_P
					KEY_UP [
						unless zero? history/head [
							history/head: history/head - 1
							fetch-history
							line/head: string/get-length line yes
							refresh
						]
					]
					KEY_CTRL_N
					KEY_DOWN [
						unless block/rs-tail? history [
							history/head: history/head + 1
							either block/rs-tail? history [
								string/rs-reset line
							][
								fetch-history
							]
							refresh
						]
					]
					KEY_CTRL_A
					KEY_HOME [
						line/head: 0
						refresh
					]
					KEY_CTRL_E
					KEY_END [
						line/head: string/get-length line yes
						refresh
					]
					KEY_DELETE [
						unless string/rs-tail? line [
							string/remove-char line line/head
							refresh
						]
					]
					KEY_CTRL_C
					KEY_CTRL_D [
						string/rs-reset line
						string/append-char GET_BUFFER(line) as-integer #"q"
						exit
					]
					KEY_ESCAPE [
						string/append-char GET_BUFFER(line) c
						exit
					]
					default [
						if c > 31 [
							either string/rs-tail? line [
								string/append-char GET_BUFFER(line) c
								#if OS = 'Windows [					;-- optimize for Windows
									pbuffer: buffer
									emit-red-char c
									output-to-screen
									pbuffer: buffer
									output?: no
								]
							][
								string/insert-char GET_BUFFER(line) line/head c
							]
							line/head: line/head + 1
							refresh
						]
					]
				]
			]
			line/head: 0
		]

		setup: func [
			line [red-string!]
			hist [red-block!]
		][
			copy-cell as red-value! line as red-value! input-line
			copy-cell as red-value! hist as red-value! history

			unless init? [
				init line hist
				init?: yes
			]
		]
	]
]

_set-buffer-history: routine [line [string!] hist [block!]][
	terminal/setup line hist
]

_read-input: routine [prompt [string!]][
	terminal/edit prompt
	terminal/restore
	print-line ""
]

ask: function [
	question [string!]
	return:  [string!]
][
	buffer: make string! 1
	_set-buffer-history buffer head system/console/history
	_read-input question
	buffer
]

input: does [ask ""]