FIX: removed bitset! and typeset! from UNIQUE spec block.

These values are already sets, so UNIQUE would have no effect on them.

Red [
	Title:   "Red base environment definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %natives.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-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
	}
]

if: make native! [[
		"If condition is true, evaluate block; else return NONE"
		cond  	 [any-type!]
		then-blk [block!]
	]
	#get-definition NAT_IF
]

unless: make native! [[
		"If condition is not true, evaluate block; else return NONE"
		cond  	 [any-type!]
		then-blk [block!]
	]
	#get-definition NAT_UNLESS
]

either: make native! [[
		"If condition is true, eval true-block; else eval false-blk"
		cond  	  [any-type!]
		true-blk  [block!]
		false-blk [block!]
	]
	#get-definition NAT_EITHER
]

any: make native! [[
		"Evaluates, returning at the first that is true"
		conds [block!]
	]
	#get-definition NAT_ANY
]

all: make native! [[
		"Evaluates, returning at the first that is not true"
		conds [block!]
	]
	#get-definition NAT_ALL
]

while: make native! [[
		"Evaluates body as long as condition is true"
		cond [block!]
		body [block!]
	]
	#get-definition NAT_WHILE
]

until: make native! [[
		"Evaluates body until it is true"
		body [block!]
	]
	#get-definition NAT_UNTIL
]

loop: make native! [[
		"Evaluates body a number of times"
		count [integer!]
		body  [block!]
	]
	#get-definition NAT_LOOP
]

repeat: make native! [[
		"Evaluates body a number of times, tracking iteration count"
		'word [word!]    "Iteration counter; not local to loop"
		value [integer!] "Number of times to evaluate body"
		body  [block!]
	]
	#get-definition NAT_REPEAT
]

forever: make native! [[
		"Evaluates body repeatedly forever"
		body   [block!]
	]
	#get-definition NAT_FOREVER
]

foreach: make native! [[
		"Evaluates body for each value in a series"
		'word  [word! block!]   "Word, or words, to set on each iteration"
		series [series!]
		body   [block!]
	]
	#get-definition NAT_FOREACH
]

forall: make native! [[
		"Evaluates body for all values in a series"
		'word [word!]   "Word referring to series to iterate over"
		body  [block!]
	]
	#get-definition NAT_FORALL
]

func: make native! [[
		"Defines a function with a given spec and body"
		spec [block!]
		body [block!]
	]
	#get-definition NAT_FUNC
]

function: make native! [[
		"Defines a function, making all words found in body local"
		spec [block!]
		body [block!]
		/extern	"Exclude words that follow this refinement"
	]
	#get-definition NAT_FUNCTION
]

does: make native! [[
		"Defines a function with no arguments or local variables"
		body [block!]
	]
	#get-definition NAT_DOES
]

has: make native! [[
		"Defines a function with local variables, but no arguments"
		vars [block!]
		body [block!]
	]
	#get-definition NAT_HAS
]

switch: make native! [[
		"Evaluates the first block following the value found in cases"
		value [any-type!] "The value to match"
		cases [block!]
		/default "Specify a default block, if value is not found in cases"
			case [block!] "Default block to evaluate"
	]
	#get-definition NAT_SWITCH
]

case: make native! [[
		"Evaluates the block following the first true condition"
		cases [block!] "Block of condition-block pairs"
		/all "Test all conditions, evaluating the block following each true condition"
	]
	#get-definition NAT_CASE
]

do: make native! [[
		"Evaluates a value, returning the last evaluation result"
		value [any-type!]
	]
	#get-definition NAT_DO
]

reduce: make native! [[
		"Returns a copy of a block, evaluating all expressions"
		value [any-type!]
		/into "Put results in out block, instead of creating a new block"
			out [any-block!] "Target block for results, when /into is used"
	]
	#get-definition NAT_REDUCE
]

compose: make native! [[
		"Returns a copy of a block, evaluating only parens"
		value
		/deep "Compose nested blocks"
		/only "Compose nested blocks as blocks containing their values"
		/into "Put results in out block, instead of creating a new block"
			out [any-block!] "Target block for results, when /into is used"
	]
	#get-definition NAT_COMPOSE
]

get: make native! [[
		"Returns the value a word refers to"
		word	[word! path!]
		/any "If word has no value, return UNSET rather than causing an error"
		/case "Use case-sensitive comparison (path only)"
		return: [any-type!]
	]
	#get-definition NAT_GET
]

set: make native! [[
		"Sets the value(s) one or more words refer to"
		word	[any-word! block! object! path! map!] "Word, object, map or block of words to set"
		value	[any-type!] "Value or block of values to assign to words"
		/any "Allow UNSET as a value rather than causing an error"
		/case "Use case-sensitive comparison (path only)"
		return: [any-type!]
	]
	#get-definition NAT_SET
]

print: make native! [[
		"Outputs a value followed by a newline"
		value	[any-type!]
	]
	#get-definition NAT_PRINT
]

prin: make native! [[
		"Outputs a value"
		value	[any-type!]
	]
	#get-definition NAT_PRIN
]

equal?: make native! [[
		"Returns true if two values are equal"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_EQUAL?
]

not-equal?: make native! [[
		"Returns true if two values are not equal"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_NOT_EQUAL?
]

strict-equal?: make native! [[
		"Returns true if two values are equal, and also the same datatype"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_STRICT_EQUAL?
]

lesser?: make native! [[
		"Returns true if the first value is less than the second"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_LESSER?
]

greater?: make native! [[
		"Returns true if the first value is greater than the second"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_GREATER?
]

lesser-or-equal?: make native! [[
		"Returns true if the first value is less than or equal to the second"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_LESSER_OR_EQUAL?
]

greater-or-equal?: make native! [[
		"Returns true if the first value is greater than or equal to the second"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_GREATER_OR_EQUAL?
]

same?: make native! [[
		"Returns true if two values have the same identity"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_SAME?
]

not: make native! [[
		"Returns the negation (logical complement) of a value"
		value [any-type!]
	]
	#get-definition NAT_NOT
]

halt: make native! [[
		"Stops evaluation"
	]
	#get-definition NAT_HALT
]

type?: make native! [[
		"Returns the datatype of a value"
		value [any-type!]
		/word "Return a word value, rather than a datatype value"
	]
	#get-definition NAT_TYPE?
]

stats: make native! [[
		"Returns interpreter statistics"
		/show "TBD:"
		/info "Output formatted results"
		return: [integer! block!]
	]
	#get-definition NAT_STATS
]

bind: make native! [[
		word 	[block! any-word!]
		context [any-word! any-object! function!]
		/copy
		return: [block! any-word!]
	]
	#get-definition NAT_BIND
]

in: make native! [[
		object [any-object!]
		word   [any-word! block! paren!]
	]
	#get-definition NAT_IN
]

parse: make native! [[
		input [series!]
		rules [block!]
		/case
		;/strict
		/part
			length [number! series!]
		/trace
			callback [function! [
				event	[word!]
				match?	[logic!]
				rule	[block!]
				input	[series!]
				stack	[block!]
				return: [logic!]
			]]
		return: [logic! block!]
	]
	#get-definition NAT_PARSE
]

union: make native! [[
		"Returns the union of two data sets"
		set1 [block! string! bitset! typeset!]
		set2 [block! string! bitset! typeset!]
		/case "Use case-sensitive comparison"
		/skip "Treat the series as fixed size records"
			size [integer!]
		return: [block! string! bitset! typeset!]
	]
	#get-definition NAT_UNION
]

unique: make native! [[
		"Returns the data set with duplicates removed"
		set [block! string!]
		/case "Use case-sensitive comparison"
		/skip "Treat the series as fixed size records"
			size [integer!]
		return: [block! string!]
	]
	#get-definition NAT_UNIQUE
]

intersect: make native! [[
		"Returns the intersection of two data sets"
		set1 [block! string! bitset! typeset!]
		set2 [block! string! bitset! typeset!]
		/case "Use case-sensitive comparison"
		/skip "Treat the series as fixed size records"
			size [integer!]
		return: [block! string! bitset! typeset!]
	]
	#get-definition NAT_INTERSECT
]

difference: make native! [[
		"Returns the special difference of two data sets"
		set1 [block! string! bitset! typeset!]
		set2 [block! string! bitset! typeset!]
		/case "Use case-sensitive comparison"
		/skip "Treat the series as fixed size records"
			size [integer!]
		return: [block! string! bitset! typeset!]
	]
	#get-definition NAT_DIFFERENCE
]

exclude: make native! [[
		"Returns the first data set less the second data set"
		set1 [block! string! bitset! typeset!]
		set2 [block! string! bitset! typeset!]
		/case "Use case-sensitive comparison"
		/skip "Treat the series as fixed size records"
			size [integer!]
		return: [block! string! bitset! typeset!]
	]
	#get-definition NAT_EXCLUDE
]

complement?: make native! [[
		"Returns true if the bitset is complemented"
		bits [bitset!]
	]
	#get-definition NAT_COMPLEMENT?
]

dehex: make native! [[
		"Converts URL-style hex encoded (%xx) strings"
		value [string! file!]							;@@ replace with any-string!
	]
	#get-definition NAT_DEHEX
]

negative?: make native! [[
		"Returns TRUE if the number is negative"
		number [number!]
	]
	#get-definition NAT_NEGATIVE?
]

positive?: make native! [[
		"Returns TRUE if the number is positive"
		number [number!]
	]
	#get-definition NAT_POSITIVE?
]

max: make native! [[
		"Returns the greater of the two values"
		value1 [number! series! char!]
		value2 [number! series! char!]
	]
	#get-definition NAT_MAX
]

min: make native! [[
		"Returns the lesser of the two values"
		value1 [number! series! char!]
		value2 [number! series! char!]
	]
	#get-definition NAT_MIN
]

shift: make native! [[
		"Perform a bit shift operation. Right shift (decreasing) by default"
		data	[integer!]
		bits	[integer!]
		/left	 "Shift bits to the left (increasing)"
		/logical "Use logical shift (unsigned, fill with zero)"
		return: [integer!]
	]
	#get-definition NAT_SHIFT
]

to-hex: make native! [[
		"Converts numeric value to a hex issue! datatype (with leading # and 0's)"
		value	[integer!]
		/size "Specify number of hex digits in result"
			length [integer!]
		return: [issue!]
	]
	#get-definition NAT_TO_HEX
]

sine: make native! [[
		"Returns the trigonometric sine"
		angle	[number!]
		/radians "Angle is specified in radians"
		return: [float!]
	]
	#get-definition NAT_SINE
]

cosine: make native! [[
		"Returns the trigonometric cosine"
		angle	[number!]
		/radians "Angle is specified in radians"
		return: [float!]
	]
	#get-definition NAT_COSINE
]

tangent: make native! [[
		"Returns the trigonometric tangent"
		angle	[number!]
		/radians "Angle is specified in radians"
		return: [float!]
	]
	#get-definition NAT_TANGENT
]

arcsine: make native! [[
		"Returns the trigonometric arcsine (in degrees by default)"
		angle	[number!]
		/radians "Angle is specified in radians"
		return: [float!]
	]
	#get-definition NAT_ARCSINE
]

arccosine: make native! [[
		"Returns the trigonometric arccosine (in degrees by default)"
		angle	[number!]
		/radians "Angle is specified in radians"
		return: [float!]
	]
	#get-definition NAT_ARCCOSINE
]

arctangent: make native! [[
		"Returns the trigonometric arctangent (in degrees by default)"
		angle	[number!]
		/radians "Angle is specified in radians"
		return: [float!]
	]
	#get-definition NAT_ARCTANGENT
]
arctangent2: make native! [[
		"Returns the angle of the point y/x in radians, when measured counterclockwise from a circle's x axis (where 0x0 represents the center of the circle). The return value is between -pi and +pi."
		y       [number!]
		x       [number!]
		return: [float!]
	]
	#get-definition NAT_ARCTANGENT2
]

NaN?: make native! [[
		"Returns TRUE if the number is Not-a-Number"
		value	[number!]
		return: [logic!]
	]
	#get-definition NAT_NAN?
]

log-2: make native! [[
		"Return the base-2 logarithm"
		value	[number!]
		return: [float!]
	]
	#get-definition NAT_LOG_2
]

log-10: make native! [[
		"Returns the base-10 logarithm"
		value	[number!]
		return: [float!]
	]
	#get-definition NAT_LOG_10
]

log-e: make native! [[
		"Returns the natural (base-E) logarithm of the given value"
		value	[number!]
		return: [float!]
	]
	#get-definition NAT_LOG_E
]

exp: make native! [[
		"Raises E (the base of natural logarithm) to the power specified"
		value	[number!]
		return: [float!]
	]
	#get-definition NAT_EXP
]

square-root: make native! [[
		"Returns the square root of a number"
		value	[number!]
		return: [float!]
	]
	#get-definition NAT_SQUARE_ROOT
]

construct: make native! [[
		block [block!]
		/with
			object [object!]
		/only
	]
	#get-definition NAT_CONSTRUCT
]

value?: make native! [[
		"Returns TRUE if the word has a value"
		value
		return: [logic!]
	]
	#get-definition NAT_VALUE?
]

try: make native! [[
		"Tries to DO a block and returns its value or an error"
		block	[block!]
		/all "Catch also BREAK, CONTINUE, RETURN, EXIT and THROW exceptions"
	]
	#get-definition NAT_TRY
]

uppercase: make native! [[
		"Converts string of characters to uppercase"
		string		[any-string! char!]
		/part "Limits to a given length or position"
			limit	[number! any-string!]
		return: 	[any-string! char!]
	]
	#get-definition NAT_UPPERCASE
]

lowercase: make native! [[
		"Converts string of characters to lowercase"
		string		[any-string! char!]
		/part "Limits to a given length or position"
			limit	[number! any-string!]
		return:		[any-string! char!]
	]
	#get-definition NAT_LOWERCASE
]

as-pair: make native! [[
		"Combine X and Y values into a pair"
		x [integer!]
		y [integer!]
	]
	#get-definition NAT_AS_PAIR
]

break: make native! [[
		"Breaks out of a loop, while, until, repeat, foreach, etc"
		/return "Forces the loop function to return a value"
			value [any-type!]
	]
	#get-definition NAT_BREAK
]

continue: make native! [[
		"Throws control back to top of loop"
	]
	#get-definition NAT_CONTINUE
]

exit: make native! [[
		"Exits a function, returning no value"
	]
	#get-definition NAT_EXIT
]

return: make native! [[
		"Returns a value from a function"
		value [any-type!]
	]
	#get-definition NAT_RETURN
]

throw: make native! [[
		"Throws control back to a previous catch"
		value [any-type!] "Value returned from catch"
		/name "Throws to a named catch"
			word [word!]
	]
	#get-definition NAT_THROW
]

catch: make native! [[
		"Catches a throw from a block and returns its value"
		block [block!] "Block to evaluate"
		/name "Catches a named throw"
			word [word! block!] "One or more names"
	]
	#get-definition NAT_CATCH
]

extend: make native! [[
		"Extend an object or map value with list of key and value pairs"
		obj  [object! map!]
		spec [block! hash! map!]
		/case "Use case-sensitive comparison"
	]
	#get-definition NAT_EXTEND
]

Red [
	Title:   "Red base environment definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %natives.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-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
	}
]

if: make native! [[
		"If condition is true, evaluate block; else return NONE"
		cond  	 [any-type!]
		then-blk [block!]
	]
	#get-definition NAT_IF
]

unless: make native! [[
		"If condition is not true, evaluate block; else return NONE"
		cond  	 [any-type!]
		then-blk [block!]
	]
	#get-definition NAT_UNLESS
]

either: make native! [[
		"If condition is true, eval true-block; else eval false-blk"
		cond  	  [any-type!]
		true-blk  [block!]
		false-blk [block!]
	]
	#get-definition NAT_EITHER
]

any: make native! [[
		"Evaluates, returning at the first that is true"
		conds [block!]
	]
	#get-definition NAT_ANY
]

all: make native! [[
		"Evaluates, returning at the first that is not true"
		conds [block!]
	]
	#get-definition NAT_ALL
]

while: make native! [[
		"Evaluates body as long as condition is true"
		cond [block!]
		body [block!]
	]
	#get-definition NAT_WHILE
]

until: make native! [[
		"Evaluates body until it is true"
		body [block!]
	]
	#get-definition NAT_UNTIL
]

loop: make native! [[
		"Evaluates body a number of times"
		count [integer!]
		body  [block!]
	]
	#get-definition NAT_LOOP
]

repeat: make native! [[
		"Evaluates body a number of times, tracking iteration count"
		'word [word!]    "Iteration counter; not local to loop"
		value [integer!] "Number of times to evaluate body"
		body  [block!]
	]
	#get-definition NAT_REPEAT
]

forever: make native! [[
		"Evaluates body repeatedly forever"
		body   [block!]
	]
	#get-definition NAT_FOREVER
]

foreach: make native! [[
		"Evaluates body for each value in a series"
		'word  [word! block!]   "Word, or words, to set on each iteration"
		series [series!]
		body   [block!]
	]
	#get-definition NAT_FOREACH
]

forall: make native! [[
		"Evaluates body for all values in a series"
		'word [word!]   "Word referring to series to iterate over"
		body  [block!]
	]
	#get-definition NAT_FORALL
]

func: make native! [[
		"Defines a function with a given spec and body"
		spec [block!]
		body [block!]
	]
	#get-definition NAT_FUNC
]

function: make native! [[
		"Defines a function, making all words found in body local"
		spec [block!]
		body [block!]
		/extern	"Exclude words that follow this refinement"
	]
	#get-definition NAT_FUNCTION
]

does: make native! [[
		"Defines a function with no arguments or local variables"
		body [block!]
	]
	#get-definition NAT_DOES
]

has: make native! [[
		"Defines a function with local variables, but no arguments"
		vars [block!]
		body [block!]
	]
	#get-definition NAT_HAS
]

switch: make native! [[
		"Evaluates the first block following the value found in cases"
		value [any-type!] "The value to match"
		cases [block!]
		/default "Specify a default block, if value is not found in cases"
			case [block!] "Default block to evaluate"
	]
	#get-definition NAT_SWITCH
]

case: make native! [[
		"Evaluates the block following the first true condition"
		cases [block!] "Block of condition-block pairs"
		/all "Test all conditions, evaluating the block following each true condition"
	]
	#get-definition NAT_CASE
]

do: make native! [[
		"Evaluates a value, returning the last evaluation result"
		value [any-type!]
	]
	#get-definition NAT_DO
]

reduce: make native! [[
		"Returns a copy of a block, evaluating all expressions"
		value [any-type!]
		/into "Put results in out block, instead of creating a new block"
			out [any-block!] "Target block for results, when /into is used"
	]
	#get-definition NAT_REDUCE
]

compose: make native! [[
		"Returns a copy of a block, evaluating only parens"
		value
		/deep "Compose nested blocks"
		/only "Compose nested blocks as blocks containing their values"
		/into "Put results in out block, instead of creating a new block"
			out [any-block!] "Target block for results, when /into is used"
	]
	#get-definition NAT_COMPOSE
]

get: make native! [[
		"Returns the value a word refers to"
		word	[word! path!]
		/any "If word has no value, return UNSET rather than causing an error"
		/case "Use case-sensitive comparison (path only)"
		return: [any-type!]
	]
	#get-definition NAT_GET
]

set: make native! [[
		"Sets the value(s) one or more words refer to"
		word	[any-word! block! object! path! map!] "Word, object, map or block of words to set"
		value	[any-type!] "Value or block of values to assign to words"
		/any "Allow UNSET as a value rather than causing an error"
		/case "Use case-sensitive comparison (path only)"
		return: [any-type!]
	]
	#get-definition NAT_SET
]

print: make native! [[
		"Outputs a value followed by a newline"
		value	[any-type!]
	]
	#get-definition NAT_PRINT
]

prin: make native! [[
		"Outputs a value"
		value	[any-type!]
	]
	#get-definition NAT_PRIN
]

equal?: make native! [[
		"Returns true if two values are equal"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_EQUAL?
]

not-equal?: make native! [[
		"Returns true if two values are not equal"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_NOT_EQUAL?
]

strict-equal?: make native! [[
		"Returns true if two values are equal, and also the same datatype"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_STRICT_EQUAL?
]

lesser?: make native! [[
		"Returns true if the first value is less than the second"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_LESSER?
]

greater?: make native! [[
		"Returns true if the first value is greater than the second"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_GREATER?
]

lesser-or-equal?: make native! [[
		"Returns true if the first value is less than or equal to the second"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_LESSER_OR_EQUAL?
]

greater-or-equal?: make native! [[
		"Returns true if the first value is greater than or equal to the second"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_GREATER_OR_EQUAL?
]

same?: make native! [[
		"Returns true if two values have the same identity"
		value1 [any-type!]
		value2 [any-type!]
	]
	#get-definition NAT_SAME?
]

not: make native! [[
		"Returns the negation (logical complement) of a value"
		value [any-type!]
	]
	#get-definition NAT_NOT
]

halt: make native! [[
		"Stops evaluation"
	]
	#get-definition NAT_HALT
]

type?: make native! [[
		"Returns the datatype of a value"
		value [any-type!]
		/word "Return a word value, rather than a datatype value"
	]
	#get-definition NAT_TYPE?
]

stats: make native! [[
		"Returns interpreter statistics"
		/show "TBD:"
		/info "Output formatted results"
		return: [integer! block!]
	]
	#get-definition NAT_STATS
]

bind: make native! [[
		word 	[block! any-word!]
		context [any-word! any-object! function!]
		/copy
		return: [block! any-word!]
	]
	#get-definition NAT_BIND
]

in: make native! [[
		object [any-object!]
		word   [any-word! block! paren!]
	]
	#get-definition NAT_IN
]

parse: make native! [[
		input [series!]
		rules [block!]
		/case
		;/strict
		/part
			length [number! series!]
		/trace
			callback [function! [
				event	[word!]
				match?	[logic!]
				rule	[block!]
				input	[series!]
				stack	[block!]
				return: [logic!]
			]]
		return: [logic! block!]
	]
	#get-definition NAT_PARSE
]

union: make native! [[
		"Returns the union of two data sets"
		set1 [block! string! bitset! typeset!]
		set2 [block! string! bitset! typeset!]
		/case "Use case-sensitive comparison"
		/skip "Treat the series as fixed size records"
			size [integer!]
		return: [block! string! bitset! typeset!]
	]
	#get-definition NAT_UNION
]

unique: make native! [[
		"Returns the data set with duplicates removed"
		set [block! string! bitset! typeset!]
		/case "Use case-sensitive comparison"
		/skip "Treat the series as fixed size records"
			size [integer!]
		return: [block! string! bitset! typeset!]
	]
	#get-definition NAT_UNIQUE
]

intersect: make native! [[
		"Returns the intersection of two data sets"
		set1 [block! string! bitset! typeset!]
		set2 [block! string! bitset! typeset!]
		/case "Use case-sensitive comparison"
		/skip "Treat the series as fixed size records"
			size [integer!]
		return: [block! string! bitset! typeset!]
	]
	#get-definition NAT_INTERSECT
]

difference: make native! [[
		"Returns the special difference of two data sets"
		set1 [block! string! bitset! typeset!]
		set2 [block! string! bitset! typeset!]
		/case "Use case-sensitive comparison"
		/skip "Treat the series as fixed size records"
			size [integer!]
		return: [block! string! bitset! typeset!]
	]
	#get-definition NAT_DIFFERENCE
]

exclude: make native! [[
		"Returns the first data set less the second data set"
		set1 [block! string! bitset! typeset!]
		set2 [block! string! bitset! typeset!]
		/case "Use case-sensitive comparison"
		/skip "Treat the series as fixed size records"
			size [integer!]
		return: [block! string! bitset! typeset!]
	]
	#get-definition NAT_EXCLUDE
]

complement?: make native! [[
		"Returns true if the bitset is complemented"
		bits [bitset!]
	]
	#get-definition NAT_COMPLEMENT?
]

dehex: make native! [[
		"Converts URL-style hex encoded (%xx) strings"
		value [string! file!]							;@@ replace with any-string!
	]
	#get-definition NAT_DEHEX
]

negative?: make native! [[
		"Returns TRUE if the number is negative"
		number [number!]
	]
	#get-definition NAT_NEGATIVE?
]

positive?: make native! [[
		"Returns TRUE if the number is positive"
		number [number!]
	]
	#get-definition NAT_POSITIVE?
]

max: make native! [[
		"Returns the greater of the two values"
		value1 [number! series! char!]
		value2 [number! series! char!]
	]
	#get-definition NAT_MAX
]

min: make native! [[
		"Returns the lesser of the two values"
		value1 [number! series! char!]
		value2 [number! series! char!]
	]
	#get-definition NAT_MIN
]

shift: make native! [[
		"Perform a bit shift operation. Right shift (decreasing) by default"
		data	[integer!]
		bits	[integer!]
		/left	 "Shift bits to the left (increasing)"
		/logical "Use logical shift (unsigned, fill with zero)"
		return: [integer!]
	]
	#get-definition NAT_SHIFT
]

to-hex: make native! [[
		"Converts numeric value to a hex issue! datatype (with leading # and 0's)"
		value	[integer!]
		/size "Specify number of hex digits in result"
			length [integer!]
		return: [issue!]
	]
	#get-definition NAT_TO_HEX
]

sine: make native! [[
		"Returns the trigonometric sine"
		angle	[number!]
		/radians "Angle is specified in radians"
		return: [float!]
	]
	#get-definition NAT_SINE
]

cosine: make native! [[
		"Returns the trigonometric cosine"
		angle	[number!]
		/radians "Angle is specified in radians"
		return: [float!]
	]
	#get-definition NAT_COSINE
]

tangent: make native! [[
		"Returns the trigonometric tangent"
		angle	[number!]
		/radians "Angle is specified in radians"
		return: [float!]
	]
	#get-definition NAT_TANGENT
]

arcsine: make native! [[
		"Returns the trigonometric arcsine (in degrees by default)"
		angle	[number!]
		/radians "Angle is specified in radians"
		return: [float!]
	]
	#get-definition NAT_ARCSINE
]

arccosine: make native! [[
		"Returns the trigonometric arccosine (in degrees by default)"
		angle	[number!]
		/radians "Angle is specified in radians"
		return: [float!]
	]
	#get-definition NAT_ARCCOSINE
]

arctangent: make native! [[
		"Returns the trigonometric arctangent (in degrees by default)"
		angle	[number!]
		/radians "Angle is specified in radians"
		return: [float!]
	]
	#get-definition NAT_ARCTANGENT
]
arctangent2: make native! [[
		"Returns the angle of the point y/x in radians, when measured counterclockwise from a circle's x axis (where 0x0 represents the center of the circle). The return value is between -pi and +pi."
		y       [number!]
		x       [number!]
		return: [float!]
	]
	#get-definition NAT_ARCTANGENT2
]

NaN?: make native! [[
		"Returns TRUE if the number is Not-a-Number"
		value	[number!]
		return: [logic!]
	]
	#get-definition NAT_NAN?
]

log-2: make native! [[
		"Return the base-2 logarithm"
		value	[number!]
		return: [float!]
	]
	#get-definition NAT_LOG_2
]

log-10: make native! [[
		"Returns the base-10 logarithm"
		value	[number!]
		return: [float!]
	]
	#get-definition NAT_LOG_10
]

log-e: make native! [[
		"Returns the natural (base-E) logarithm of the given value"
		value	[number!]
		return: [float!]
	]
	#get-definition NAT_LOG_E
]

exp: make native! [[
		"Raises E (the base of natural logarithm) to the power specified"
		value	[number!]
		return: [float!]
	]
	#get-definition NAT_EXP
]

square-root: make native! [[
		"Returns the square root of a number"
		value	[number!]
		return: [float!]
	]
	#get-definition NAT_SQUARE_ROOT
]

construct: make native! [[
		block [block!]
		/with
			object [object!]
		/only
	]
	#get-definition NAT_CONSTRUCT
]

value?: make native! [[
		"Returns TRUE if the word has a value"
		value
		return: [logic!]
	]
	#get-definition NAT_VALUE?
]

try: make native! [[
		"Tries to DO a block and returns its value or an error"
		block	[block!]
		/all "Catch also BREAK, CONTINUE, RETURN, EXIT and THROW exceptions"
	]
	#get-definition NAT_TRY
]

uppercase: make native! [[
		"Converts string of characters to uppercase"
		string		[any-string! char!]
		/part "Limits to a given length or position"
			limit	[number! any-string!]
		return: 	[any-string! char!]
	]
	#get-definition NAT_UPPERCASE
]

lowercase: make native! [[
		"Converts string of characters to lowercase"
		string		[any-string! char!]
		/part "Limits to a given length or position"
			limit	[number! any-string!]
		return:		[any-string! char!]
	]
	#get-definition NAT_LOWERCASE
]

as-pair: make native! [[
		"Combine X and Y values into a pair"
		x [integer!]
		y [integer!]
	]
	#get-definition NAT_AS_PAIR
]

break: make native! [[
		"Breaks out of a loop, while, until, repeat, foreach, etc"
		/return "Forces the loop function to return a value"
			value [any-type!]
	]
	#get-definition NAT_BREAK
]

continue: make native! [[
		"Throws control back to top of loop"
	]
	#get-definition NAT_CONTINUE
]

exit: make native! [[
		"Exits a function, returning no value"
	]
	#get-definition NAT_EXIT
]

return: make native! [[
		"Returns a value from a function"
		value [any-type!]
	]
	#get-definition NAT_RETURN
]

throw: make native! [[
		"Throws control back to a previous catch"
		value [any-type!] "Value returned from catch"
		/name "Throws to a named catch"
			word [word!]
	]
	#get-definition NAT_THROW
]

catch: make native! [[
		"Catches a throw from a block and returns its value"
		block [block!] "Block to evaluate"
		/name "Catches a named throw"
			word [word! block!] "One or more names"
	]
	#get-definition NAT_CATCH
]

extend: make native! [[
		"Extend an object or map value with list of key and value pairs"
		obj  [object! map!]
		spec [block! hash! map!]
		/case "Use case-sensitive comparison"
	]
	#get-definition NAT_EXTEND
]


FIX: block/rs-head not taking block offset into account. FEAT: added various 'append functions to block! internal API.

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

block: context [
	verbose: 0

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

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

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

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

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

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

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

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

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

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

		s: GET_BUFFER(blk)

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

		offset
	]

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

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

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

		arg
	]

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

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

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

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

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

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

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

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

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

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

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

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

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

		value1: s1/offset + blk1/head
		value2: s2/offset + blk2/head
		end: s1/tail									;-- only one "end" is needed
		until [
			res: actions/compare value1 value2 op
			value1: value1 + 1
			value2: value2 + 1
			any [
				not res
				value1 >= end
			]
		]
		res
	]

	;--- Actions ---

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

		size: 1
		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				int: as red-integer! spec
				size: int/value
			]
			default [--NOT_IMPLEMENTED--]
		]
		blk: as red-block! stack/push*
		blk/header: TYPE_BLOCK							;-- implicit reset of all header flags
		blk/head: 	0
		blk/node: 	alloc-cells size
		blk
	]

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

		s: GET_BUFFER(blk)
		i: blk/head

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

			part: actions/form value buffer arg part
			i: i + 1

			if 	s/offset + i < s/tail [
				string/append-char GET_BUFFER(buffer) as-integer space
				part: part - 1
			]
		]
		part
	]

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

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

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

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

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

	;--- Property reading actions ---

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

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

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

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

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

		s: GET_BUFFER(blk)

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

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

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

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

	;--- Navigation actions ---

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

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

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

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

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

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

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

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

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

		result: stack/push as red-value! blk

		s: GET_BUFFER(blk)
		if s/offset = s/tail [							;-- early exit if blk is empty
			result/header: TYPE_NONE
			return result
		]
		step:  1
		part?: no

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

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

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

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

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

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

	select: func [
		blk		 [red-block!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		tail?	 [logic!]
		match?	 [logic!]
		return:	 [red-value!]
		/local
			s	   [series!]
			p	   [red-value!]
			b	   [red-block!]
			result [red-value!]
			type   [integer!]
			offset [integer!]
	][
		result: find blk value part only? case? any? with-arg skip last? reverse? no no

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

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

	;--- Reading actions ---

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

		s: GET_BUFFER(blk)

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

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

	;--- Modifying actions ---

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

		cnt:  1
		part: -1

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

		while [not zero? cnt][							;-- /dup support
			either all [
				not only?								;-- /only support
				any [
					TYPE_OF(value) = TYPE_BLOCK			;@@ replace it with: typeset/any-block?
					TYPE_OF(value) = TYPE_PATH			;@@ replace it with: typeset/any-block?
				]
			][
				src: as red-block! value
				if negative? part [part: rs-length? src] ;-- if not /part, use whole value length
				s: GET_BUFFER(src)
				cell: s/offset + src/head
				limit: cell + part						;-- /part support

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

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

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

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

		s: GET_BUFFER(blk)

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

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

	;--- Misc actions ---

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

		s: GET_BUFFER(blk)

		slots:	rs-length? blk
		offset: s/offset + blk/head
		part:   as-integer s/tail - offset

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

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

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

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

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

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

		as red-series! blk
	]

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

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

block: context [
	verbose: 0

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

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

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

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

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

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

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

		s: GET_BUFFER(blk)

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

		offset
	]

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

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

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

		arg
	]

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

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

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

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

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

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

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

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

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

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

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

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

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

		value1: s1/offset + blk1/head
		value2: s2/offset + blk2/head
		end: s1/tail									;-- only one "end" is needed
		until [
			res: actions/compare value1 value2 op
			value1: value1 + 1
			value2: value2 + 1
			any [
				not res
				value1 >= end
			]
		]
		res
	]

	;--- Actions ---

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

		size: 1
		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				int: as red-integer! spec
				size: int/value
			]
			default [--NOT_IMPLEMENTED--]
		]
		blk: as red-block! stack/push*
		blk/header: TYPE_BLOCK							;-- implicit reset of all header flags
		blk/head: 	0
		blk/node: 	alloc-cells size
		blk
	]

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

		s: GET_BUFFER(blk)
		i: blk/head

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

			part: actions/form value buffer arg part
			i: i + 1

			if 	s/offset + i < s/tail [
				string/append-char GET_BUFFER(buffer) as-integer space
				part: part - 1
			]
		]
		part
	]

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

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

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

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

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

	;--- Property reading actions ---

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

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

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

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

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

		s: GET_BUFFER(blk)

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

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

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

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

	;--- Navigation actions ---

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

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

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

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

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

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

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

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

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

		result: stack/push as red-value! blk

		s: GET_BUFFER(blk)
		if s/offset = s/tail [							;-- early exit if blk is empty
			result/header: TYPE_NONE
			return result
		]
		step:  1
		part?: no

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

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

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

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

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

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

	select: func [
		blk		 [red-block!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		tail?	 [logic!]
		match?	 [logic!]
		return:	 [red-value!]
		/local
			s	   [series!]
			p	   [red-value!]
			b	   [red-block!]
			result [red-value!]
			type   [integer!]
			offset [integer!]
	][
		result: find blk value part only? case? any? with-arg skip last? reverse? no no

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

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

	;--- Reading actions ---

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

		s: GET_BUFFER(blk)

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

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

	;--- Modifying actions ---

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

		cnt:  1
		part: -1

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

		while [not zero? cnt][							;-- /dup support
			either all [
				not only?								;-- /only support
				any [
					TYPE_OF(value) = TYPE_BLOCK			;@@ replace it with: typeset/any-block?
					TYPE_OF(value) = TYPE_PATH			;@@ replace it with: typeset/any-block?
				]
			][
				src: as red-block! value
				if negative? part [part: rs-length? src] ;-- if not /part, use whole value length
				s: GET_BUFFER(src)
				cell: s/offset + src/head
				limit: cell + part						;-- /part support

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

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

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

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

		s: GET_BUFFER(blk)

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

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

	;--- Misc actions ---

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

		s: GET_BUFFER(blk)

		slots:	rs-length? blk
		offset: s/offset + blk/head
		part:   as-integer s/tail - offset

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

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

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

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

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

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

		as red-series! blk
	]

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


FIX: avoided copy memory in crush compressor.

Red/System [
	Title:   "Compress and decompress algorithms for Red runtime"
	Author:  "Qingtian Xie"
	File: 	 %crush.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2015 Nenad Rakocevic & Xie Qingtian. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
	Notes: {
		Thanks for Ilya Muravyov making it in the Public Domain.
		http://sourceforge.net/projects/crush/
	}
]

crush: context [							;-- LZ77

	#define CRUSH_W_BITS 		21			;-- window size (17..23)
	#define CRUSH_W_SIZE 		2097152		;-- 1 << CRUSH_W_BITS
	#define CRUSH_W_MASK 		2097151		;-- CRUSH_W_SIZE - 1
	#define CRUSH_SLOT_BITS 	4
	#define CRUSH_NUM_SLOTS 	16			;-- 1 << CRUSH_SLOT_BITS

	#define CRUSH_A_BITS		2			;-- 1 xx
	#define CRUSH_B_BITS		2			;-- 01 xx
	#define CRUSH_C_BITS		2			;-- 001 xx
	#define CRUSH_D_BITS		3			;-- 0001 xxx
	#define CRUSH_E_BITS		5			;-- 00001 xxxxx
	#define CRUSH_F_BITS		9			;-- 00000 xxxxxxxxx
	#define CRUSH_A				4			;-- 1 << A_BITS;
	#define CRUSH_B				8			;-- (1 << B_BITS) + A
	#define CRUSH_C				12			;-- (1 << C_BITS) + B
	#define CRUSH_D				20			;-- (1 << D_BITS) + C
	#define CRUSH_E				52			;-- (1 << E_BITS) + D
	#define CRUSH_F				564			;-- (1 << F_BITS) + E
	#define CRUSH_MIN_MATCH 	3
	#define CRUSH_MAX_MATCH 	566			;-- (CRUSH_F - 1) + CRUSH_MIN_MATCH

	#define CRUSH_BUF_SIZE		67108864	;-- 1 << 26

	#define CRUSH_TOO_FAR		65536		;-- 1 << 16

	#define CRUSH_HASH1_LEN		3			;-- CRUSH_MIN_MATCH
	#define CRUSH_HASH2_LEN		4			;-- CRUSH_MIN_MATCH + 1
	#define CRUSH_HASH1_BITS	21
	#define CRUSH_HASH2_BITS	24
	#define CRUSH_HASH1_SIZE	2097152		;-- 1 << CRUSH_HASH1_BITS
	#define CRUSH_HASH2_SIZE	16777216    ;-- 1 << CRUSH_HASH2_BITS
	#define CRUSH_HASH1_MASK	2097151     ;-- CRUSH_HASH1_SIZE - 1
	#define CRUSH_HASH2_MASK	16777215    ;-- CRUSH_HASH2_SIZE - 1
	#define CRUSH_HASH1_SHIFT	7           ;-- (CRUSH_HASH1_BITS + (CRUSH_HASH1_LEN - 1)) / CRUSH_HASH1_LEN
	#define CRUSH_HASH2_SHIFT	6           ;-- (CRUSH_HASH2_BITS + (CRUSH_HASH2_LEN - 1)) / CRUSH_HASH2_LEN

	crush!: alias struct! [
		bit-buf		[integer!]
		bit-count	[integer!]
		input		[byte-ptr!]
		buf			[byte-ptr!]
		buf-size	[integer!]
		index		[integer!]
	]

	init: func [
		crush	[crush!]
		size	[integer!]
		input	[byte-ptr!]
	][
		crush/input: input
		crush/bit-buf: 0
		crush/bit-count: 0
		crush/index: 0
		crush/buf-size: either input = null [size][size * 6]
		if input <> null [crush/buf: allocate crush/buf-size no]
	]

	get-buf: func [
		crush	[crush!]
		size	[integer!]
		return: [byte-ptr!]
		/local
			buf			[byte-ptr!]
			index		[integer!]
			buf-size	[integer!]
	][
		buf: crush/buf
		buf-size: crush/buf-size
		index: crush/index

		if index >= buf-size [
			buf-size: buf-size + 4194304
			buf: allocate buf-size no
			move-memory buf crush/buf crush/buf-size
			free crush/buf
			crush/buf: buf
			crush/buf-size: buf-size
		]

		crush/index: index + size
		buf + index
	]

	put-bits: func [
		n		[integer!]
		x		[integer!]
		crush	[crush!]
		/local
			bit-buf		[integer!]
			bit-count	[integer!]
			buf			[byte-ptr!]
	][
		bit-buf: crush/bit-buf
		bit-count: crush/bit-count

		bit-buf: x << bit-count or bit-buf
		bit-count: bit-count + n
		while [bit-count >= 8][
			buf: get-buf crush 1
			buf/value: as byte! bit-buf
			bit-buf: bit-buf >> 8
			bit-count: bit-count - 8
		]
		crush/bit-buf: bit-buf
		crush/bit-count: bit-count
	]

	get-bits: func [
		n		[integer!]
		crush	[crush!]
		return: [integer!]
		/local
			input		[byte-ptr!]
			data		[integer!]
			bit-buf		[integer!]
			bit-count	[integer!]
	][
		input: crush/input
		bit-buf: crush/bit-buf
		bit-count: crush/bit-count

		while [bit-count < n][
			data: as-integer input/value
			input: input + 1
			bit-buf: data << bit-count or bit-buf
			bit-count: bit-count + 8
		]
		data: 1 << n - 1 and bit-buf
		crush/input: input
		crush/bit-buf: bit-buf >> n
		crush/bit-count: bit-count - n
		data
	]

	update-hash1: func [
		h		[integer!]
		c		[integer!]
		return: [integer!]
	][
		h << CRUSH_HASH1_SHIFT + c and CRUSH_HASH1_MASK
	]

	update-hash2: func [
		h		[integer!]
		c		[integer!]
		return: [integer!]
	][
		h << CRUSH_HASH2_SHIFT + c and CRUSH_HASH2_MASK
	]

	get-penalty: func [
		a		[integer!]
		b		[integer!]
		return: [integer!]
		/local
			p	[integer!]
	][
		p: 0
		while [a > b][
			a: a >> 3
			p: p + 1
		]
		p
	]

	compress: func [
		data	[byte-ptr!]
		length	[integer!]
		outbuf	[byte-ptr!]
		return: [integer!]
		/local
			i			[integer!]
			s			[integer!]
			ss			[integer!]
			l			[integer!]
			p			[integer!]
			pp			[integer!]
			h1			[integer!]
			h2			[integer!]
			len			[integer!]
			log			[integer!]
			size		[integer!]
			offset		[integer!]
			max-match	[integer!]
			chain-len	[integer!]
			limit		[integer!]
			hash-size	[integer!]
			head		[int-ptr!]
			prev		[int-ptr!]
			output		[int-ptr!]
			buf			[byte-ptr!]
			continue?	[logic!]
			crush		[crush!]
	][
		hash-size: CRUSH_HASH1_SIZE + CRUSH_HASH2_SIZE
		head: as int-ptr! allocate hash-size * size? integer! no
		prev: as int-ptr! allocate CRUSH_W_SIZE * size? integer! no
		buf: allocate CRUSH_BUF_SIZE no

		crush: declare crush!
		init crush length null
		crush/buf: outbuf

		size: CRUSH_BUF_SIZE
		while [length > 0][
			if length < CRUSH_BUF_SIZE [size: length]
			copy-memory buf data size
			output: as int-ptr! get-buf crush 4
			output/value: size

			i: 1
			until [
				head/i: -1
				i: i + 1
				i > hash-size
			]

			h1: 0
			h2: 0
			i: 1
			until [
				h1: update-hash1 h1 as-integer buf/i
				i: i + 1
				i > CRUSH_HASH1_LEN
			]
			h1: h1 + 1
			i: 1
			until [
				h2: update-hash2 h2 as-integer buf/i
				i: i + 1
				i > CRUSH_HASH2_LEN
			]
			h2: h2 + 1

			crush/bit-buf: 0
			crush/bit-count: 0

			p: 0
			while [p < size][
				len: CRUSH_MIN_MATCH - 1
				offset: CRUSH_W_SIZE
				max-match: either CRUSH_MAX_MATCH < (size - p) [CRUSH_MAX_MATCH][size - p]
				limit: either 0 < (p - CRUSH_W_SIZE) [p - CRUSH_W_SIZE][0]

				if head/h1 >= limit [
					s: head/h1
					ss: s + 1
					pp: p + 1
					if buf/ss = buf/pp [
						l: 1
						continue?: yes
						while [all [continue? l < max-match]][
							l: l + 1
							ss: s + l
							pp: p + l
							if buf/ss <> buf/pp [l: l - 1 continue?: no]
						]
						if l > len [
							len: l
							offset: p - s
						]
					]
				]

				if len < CRUSH_MAX_MATCH [
					chain-len: 256
					ss: h2 + CRUSH_HASH1_SIZE
					s: head/ss

					while [all [chain-len <> 0 s >= limit]][
						chain-len: chain-len - 1
						ss: s + len + 1
						pp: p + len + 1
						if buf/ss = buf/pp [
							ss: s + 1
							pp: p + 1
							if buf/ss = buf/pp [
								l: 1
								continue?: yes
								while [all [continue? l < max-match]][
									l: l + 1
									ss: s + l
									pp: p + l
									if buf/ss <> buf/pp [l: l - 1 continue?: no]
								]
								if l > (len + get-penalty p - s >> 4 offset) [
									len: l
									offset: p - s
								]
								if l = max-match [chain-len: 0]
							]
						]
						ss: s and CRUSH_W_MASK + 1
						s: prev/ss
					]
				]

				if all [len = CRUSH_MIN_MATCH offset > CRUSH_TOO_FAR][len: 0]

				either len >= CRUSH_MIN_MATCH [			;-- Match
					put-bits 1 1 crush

					l: len - CRUSH_MIN_MATCH
					case [
						l < CRUSH_A [
							put-bits 1 1 crush
							put-bits CRUSH_A_BITS l crush
						]
						l < CRUSH_B [
							put-bits 2 1 << 1 crush
							put-bits CRUSH_B_BITS l - CRUSH_A crush
						]
						l < CRUSH_C [
							put-bits 3 1 << 2 crush
							put-bits CRUSH_C_BITS l - CRUSH_B crush
						]
						l < CRUSH_D [
							put-bits 4 1 << 3 crush
							put-bits CRUSH_D_BITS l - CRUSH_C crush
						]
						l < CRUSH_E [
							put-bits 5 1 << 4 crush
							put-bits CRUSH_E_BITS l - CRUSH_D crush
						]
						true [
							put-bits 5 0 crush
							put-bits CRUSH_F_BITS l - CRUSH_E crush
						]
					]

					offset: offset - 1
					log: CRUSH_W_BITS - CRUSH_NUM_SLOTS
					while [ss: 2 << log offset >= ss][log: log + 1]
					ss: CRUSH_W_BITS - CRUSH_NUM_SLOTS
					put-bits CRUSH_SLOT_BITS log - ss crush
					either log > ss [
						put-bits log offset - (1 << log) crush
					][
						ss: CRUSH_W_BITS - (CRUSH_NUM_SLOTS - 1)
						put-bits ss offset crush
					]
				][
					len: 1
					pp: p + 1
					put-bits 9 (as-integer buf/pp) << 1 crush
				]

				while [len <> 0][
					len: len - 1
					head/h1: p
					pp: p and CRUSH_W_MASK + 1
					ss: h2 + CRUSH_HASH1_SIZE
					prev/pp: head/ss
					head/ss: p
					p: p + 1
					pp: p + CRUSH_HASH1_LEN
					h1: 1 + update-hash1 h1 - 1 as-integer buf/pp
					pp: p + CRUSH_HASH2_LEN
					h2: 1 + update-hash2 h2 - 1 as-integer buf/pp
				]
			]

			put-bits 7 0 crush
			data: data + size
			length: length - CRUSH_BUF_SIZE
		]

		free as byte-ptr! head
		free as byte-ptr! prev
		free buf

		crush/index
	]

	decompress: func [
		data	[byte-ptr!]
		length	[integer!]
		written [int-ptr!]
		return: [byte-ptr!]
		/local
			i			[integer!]
			s			[integer!]
			ss			[integer!]
			p			[integer!]
			pp			[integer!]
			len			[integer!]
			log			[integer!]
			size		[integer!]
			buf			[byte-ptr!]
			head		[int-ptr!]
			p4			[int-ptr!]
			crush		[crush!]
	][
		crush: declare crush!
		init crush length data

		head: as int-ptr! crush/input
		while [
			p4: as int-ptr! crush/input
			size: p4/value
			crush/input: as byte-ptr! p4 + 1
			(as-integer p4 - head) < length
		][
			if any [size < 1 size > CRUSH_BUF_SIZE][
				print-line ["File corrupted: size = " size]
				return null
			]

			crush/bit-buf: 0
			crush/bit-count: 0

			buf: get-buf crush size
			p: 0
			while [p < size][
				either 0 <> get-bits 1 crush [
					len: either 0 <> get-bits 1 crush [
						get-bits CRUSH_A_BITS crush
					][
						either 0 <> get-bits 1 crush [
							CRUSH_A + get-bits CRUSH_B_BITS crush
						][
							either 0 <> get-bits 1 crush [
								CRUSH_B + get-bits CRUSH_C_BITS crush
							][
								either 0 <> get-bits 1 crush [
									CRUSH_C + get-bits CRUSH_D_BITS crush
								][
									either 0 <> get-bits 1 crush [
										CRUSH_D + get-bits CRUSH_E_BITS crush
									][
										CRUSH_E + get-bits CRUSH_F_BITS crush
									]
								]
							]
						]
					]

					ss: CRUSH_W_BITS - CRUSH_NUM_SLOTS
					log: ss + get-bits CRUSH_SLOT_BITS crush
					pp: either log > ss [
						1 << log + get-bits log crush
					][
						get-bits ss + 1 crush
					]
					s: p + not pp
					if s < 0 [
						print-line ["File corrupted: s = " s]
						return null
					]

					p: p + 1
					s: s + 1
					buf/p: buf/s
					p: p + 1
					s: s + 1
					buf/p: buf/s
					p: p + 1
					s: s + 1
					buf/p: buf/s
					while [len <> 0] [
						len: len - 1
						p: p + 1
						s: s + 1
						buf/p: buf/s
					]
				][
					p: p + 1
					buf/p: as byte! get-bits 8 crush
				]
			]
		]

		written/value: crush/index
		crush/buf
	]
]

Red/System [
	Title:   "Compress and decompress algorithms for Red runtime"
	Author:  "Qingtian Xie"
	File: 	 %crush.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2015 Nenad Rakocevic & Xie Qingtian. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
	Notes: {
		Thanks for Ilya Muravyov making it in the Public Domain.
		http://sourceforge.net/projects/crush/
	}
]

crush: context [							;-- LZ77

	#define CRUSH_W_BITS 		21			;-- window size (17..23)
	#define CRUSH_W_SIZE 		2097152		;-- 1 << CRUSH_W_BITS
	#define CRUSH_W_MASK 		2097151		;-- CRUSH_W_SIZE - 1
	#define CRUSH_SLOT_BITS 	4
	#define CRUSH_NUM_SLOTS 	16			;-- 1 << CRUSH_SLOT_BITS

	#define CRUSH_A_BITS		2			;-- 1 xx
	#define CRUSH_B_BITS		2			;-- 01 xx
	#define CRUSH_C_BITS		2			;-- 001 xx
	#define CRUSH_D_BITS		3			;-- 0001 xxx
	#define CRUSH_E_BITS		5			;-- 00001 xxxxx
	#define CRUSH_F_BITS		9			;-- 00000 xxxxxxxxx
	#define CRUSH_A				4			;-- 1 << A_BITS;
	#define CRUSH_B				8			;-- (1 << B_BITS) + A
	#define CRUSH_C				12			;-- (1 << C_BITS) + B
	#define CRUSH_D				20			;-- (1 << D_BITS) + C
	#define CRUSH_E				52			;-- (1 << E_BITS) + D
	#define CRUSH_F				564			;-- (1 << F_BITS) + E
	#define CRUSH_MIN_MATCH 	3
	#define CRUSH_MAX_MATCH 	566			;-- (CRUSH_F - 1) + CRUSH_MIN_MATCH

	#define CRUSH_BUF_SIZE		67108864	;-- 1 << 26

	#define CRUSH_TOO_FAR		65536		;-- 1 << 16

	#define CRUSH_HASH1_LEN		3			;-- CRUSH_MIN_MATCH
	#define CRUSH_HASH2_LEN		4			;-- CRUSH_MIN_MATCH + 1
	#define CRUSH_HASH1_BITS	21
	#define CRUSH_HASH2_BITS	24
	#define CRUSH_HASH1_SIZE	2097152		;-- 1 << CRUSH_HASH1_BITS
	#define CRUSH_HASH2_SIZE	16777216    ;-- 1 << CRUSH_HASH2_BITS
	#define CRUSH_HASH1_MASK	2097151     ;-- CRUSH_HASH1_SIZE - 1
	#define CRUSH_HASH2_MASK	16777215    ;-- CRUSH_HASH2_SIZE - 1
	#define CRUSH_HASH1_SHIFT	7           ;-- (CRUSH_HASH1_BITS + (CRUSH_HASH1_LEN - 1)) / CRUSH_HASH1_LEN
	#define CRUSH_HASH2_SHIFT	6           ;-- (CRUSH_HASH2_BITS + (CRUSH_HASH2_LEN - 1)) / CRUSH_HASH2_LEN

	crush!: alias struct! [
		bit-buf		[integer!]
		bit-count	[integer!]
		input		[byte-ptr!]
		buf			[byte-ptr!]
		buf-size	[integer!]
		index		[integer!]
	]

	init: func [
		crush	[crush!]
		size	[integer!]
		input	[byte-ptr!]
	][
		crush/input: input
		crush/bit-buf: 0
		crush/bit-count: 0
		crush/index: 0
		crush/buf-size: either input = null [size / 4][size * 6]
		crush/buf: allocate crush/buf-size no
	]

	get-buf: func [
		crush	[crush!]
		size	[integer!]
		return: [byte-ptr!]
		/local
			buf			[byte-ptr!]
			index		[integer!]
			buf-size	[integer!]
	][
		buf: crush/buf
		buf-size: crush/buf-size
		index: crush/index

		if index >= buf-size [
			buf-size: buf-size + 4194304
			buf: allocate buf-size no
			move-memory buf crush/buf crush/buf-size
			free crush/buf
			crush/buf: buf
			crush/buf-size: buf-size
		]

		crush/index: index + size
		buf + index
	]

	put-bits: func [
		n		[integer!]
		x		[integer!]
		crush	[crush!]
		/local
			bit-buf		[integer!]
			bit-count	[integer!]
			buf			[byte-ptr!]
	][
		bit-buf: crush/bit-buf
		bit-count: crush/bit-count

		bit-buf: x << bit-count or bit-buf
		bit-count: bit-count + n
		while [bit-count >= 8][
			buf: get-buf crush 1
			buf/value: as byte! bit-buf
			bit-buf: bit-buf >> 8
			bit-count: bit-count - 8
		]
		crush/bit-buf: bit-buf
		crush/bit-count: bit-count
	]

	get-bits: func [
		n		[integer!]
		crush	[crush!]
		return: [integer!]
		/local
			input		[byte-ptr!]
			data		[integer!]
			bit-buf		[integer!]
			bit-count	[integer!]
	][
		input: crush/input
		bit-buf: crush/bit-buf
		bit-count: crush/bit-count

		while [bit-count < n][
			data: as-integer input/value
			input: input + 1
			bit-buf: data << bit-count or bit-buf
			bit-count: bit-count + 8
		]
		data: 1 << n - 1 and bit-buf
		crush/input: input
		crush/bit-buf: bit-buf >> n
		crush/bit-count: bit-count - n
		data
	]

	update-hash1: func [
		h		[integer!]
		c		[integer!]
		return: [integer!]
	][
		h << CRUSH_HASH1_SHIFT + c and CRUSH_HASH1_MASK
	]

	update-hash2: func [
		h		[integer!]
		c		[integer!]
		return: [integer!]
	][
		h << CRUSH_HASH2_SHIFT + c and CRUSH_HASH2_MASK
	]

	get-penalty: func [
		a		[integer!]
		b		[integer!]
		return: [integer!]
		/local
			p	[integer!]
	][
		p: 0
		while [a > b][
			a: a >> 3
			p: p + 1
		]
		p
	]

	compress: func [
		data	[byte-ptr!]
		length	[integer!]
		outbuf	[byte-ptr!]
		return: [integer!]
		/local
			i			[integer!]
			s			[integer!]
			ss			[integer!]
			l			[integer!]
			p			[integer!]
			pp			[integer!]
			h1			[integer!]
			h2			[integer!]
			len			[integer!]
			log			[integer!]
			size		[integer!]
			offset		[integer!]
			max-match	[integer!]
			chain-len	[integer!]
			limit		[integer!]
			hash-size	[integer!]
			head		[int-ptr!]
			prev		[int-ptr!]
			output		[int-ptr!]
			buf			[byte-ptr!]
			continue?	[logic!]
			crush		[crush!]
	][
		hash-size: CRUSH_HASH1_SIZE + CRUSH_HASH2_SIZE
		head: as int-ptr! allocate hash-size * size? integer! no
		prev: as int-ptr! allocate CRUSH_W_SIZE * size? integer! no
		buf: allocate CRUSH_BUF_SIZE no

		crush: declare crush!
		init crush length null

		size: CRUSH_BUF_SIZE
		while [length > 0][
			if length < CRUSH_BUF_SIZE [size: length]
			copy-memory buf data size
			output: as int-ptr! get-buf crush 4
			output/value: size

			i: 1
			until [
				head/i: -1
				i: i + 1
				i > hash-size
			]

			h1: 0
			h2: 0
			i: 1
			until [
				h1: update-hash1 h1 as-integer buf/i
				i: i + 1
				i > CRUSH_HASH1_LEN
			]
			h1: h1 + 1
			i: 1
			until [
				h2: update-hash2 h2 as-integer buf/i
				i: i + 1
				i > CRUSH_HASH2_LEN
			]
			h2: h2 + 1

			crush/bit-buf: 0
			crush/bit-count: 0

			p: 0
			while [p < size][
				len: CRUSH_MIN_MATCH - 1
				offset: CRUSH_W_SIZE
				max-match: either CRUSH_MAX_MATCH < (size - p) [CRUSH_MAX_MATCH][size - p]
				limit: either 0 < (p - CRUSH_W_SIZE) [p - CRUSH_W_SIZE][0]

				if head/h1 >= limit [
					s: head/h1
					ss: s + 1
					pp: p + 1
					if buf/ss = buf/pp [
						l: 1
						continue?: yes
						while [all [continue? l < max-match]][
							l: l + 1
							ss: s + l
							pp: p + l
							if buf/ss <> buf/pp [l: l - 1 continue?: no]
						]
						if l > len [
							len: l
							offset: p - s
						]
					]
				]

				if len < CRUSH_MAX_MATCH [
					chain-len: 256
					ss: h2 + CRUSH_HASH1_SIZE
					s: head/ss

					while [all [chain-len <> 0 s >= limit]][
						chain-len: chain-len - 1
						ss: s + len + 1
						pp: p + len + 1
						if buf/ss = buf/pp [
							ss: s + 1
							pp: p + 1
							if buf/ss = buf/pp [
								l: 1
								continue?: yes
								while [all [continue? l < max-match]][
									l: l + 1
									ss: s + l
									pp: p + l
									if buf/ss <> buf/pp [l: l - 1 continue?: no]
								]
								if l > (len + get-penalty p - s >> 4 offset) [
									len: l
									offset: p - s
								]
								if l = max-match [chain-len: 0]
							]
						]
						ss: s and CRUSH_W_MASK + 1
						s: prev/ss
					]
				]

				if all [len = CRUSH_MIN_MATCH offset > CRUSH_TOO_FAR][len: 0]

				either len >= CRUSH_MIN_MATCH [			;-- Match
					put-bits 1 1 crush

					l: len - CRUSH_MIN_MATCH
					case [
						l < CRUSH_A [
							put-bits 1 1 crush
							put-bits CRUSH_A_BITS l crush
						]
						l < CRUSH_B [
							put-bits 2 1 << 1 crush
							put-bits CRUSH_B_BITS l - CRUSH_A crush
						]
						l < CRUSH_C [
							put-bits 3 1 << 2 crush
							put-bits CRUSH_C_BITS l - CRUSH_B crush
						]
						l < CRUSH_D [
							put-bits 4 1 << 3 crush
							put-bits CRUSH_D_BITS l - CRUSH_C crush
						]
						l < CRUSH_E [
							put-bits 5 1 << 4 crush
							put-bits CRUSH_E_BITS l - CRUSH_D crush
						]
						true [
							put-bits 5 0 crush
							put-bits CRUSH_F_BITS l - CRUSH_E crush
						]
					]

					offset: offset - 1
					log: CRUSH_W_BITS - CRUSH_NUM_SLOTS
					while [ss: 2 << log offset >= ss][log: log + 1]
					ss: CRUSH_W_BITS - CRUSH_NUM_SLOTS
					put-bits CRUSH_SLOT_BITS log - ss crush
					either log > ss [
						put-bits log offset - (1 << log) crush
					][
						ss: CRUSH_W_BITS - (CRUSH_NUM_SLOTS - 1)
						put-bits ss offset crush
					]
				][
					len: 1
					pp: p + 1
					put-bits 9 (as-integer buf/pp) << 1 crush
				]

				while [len <> 0][
					len: len - 1
					head/h1: p
					pp: p and CRUSH_W_MASK + 1
					ss: h2 + CRUSH_HASH1_SIZE
					prev/pp: head/ss
					head/ss: p
					p: p + 1
					pp: p + CRUSH_HASH1_LEN
					h1: 1 + update-hash1 h1 - 1 as-integer buf/pp
					pp: p + CRUSH_HASH2_LEN
					h2: 1 + update-hash2 h2 - 1 as-integer buf/pp
				]
			]

			put-bits 7 0 crush
			data: data + size
			length: length - CRUSH_BUF_SIZE
		]

		copy-memory outbuf crush/buf crush/index
		free crush/buf
		free as byte-ptr! head
		free as byte-ptr! prev
		free buf

		crush/index
	]

	decompress: func [
		data	[byte-ptr!]
		length	[integer!]
		written [int-ptr!]
		return: [byte-ptr!]
		/local
			i			[integer!]
			s			[integer!]
			ss			[integer!]
			p			[integer!]
			pp			[integer!]
			len			[integer!]
			log			[integer!]
			size		[integer!]
			buf			[byte-ptr!]
			head		[int-ptr!]
			p4			[int-ptr!]
			crush		[crush!]
	][
		crush: declare crush!
		init crush length data

		head: as int-ptr! crush/input
		while [
			p4: as int-ptr! crush/input
			size: p4/value
			crush/input: as byte-ptr! p4 + 1
			(as-integer p4 - head) < length
		][
			if any [size < 1 size > CRUSH_BUF_SIZE][
				print-line ["File corrupted: size = " size]
				return null
			]

			crush/bit-buf: 0
			crush/bit-count: 0

			buf: get-buf crush size
			p: 0
			while [p < size][
				either 0 <> get-bits 1 crush [
					len: either 0 <> get-bits 1 crush [
						get-bits CRUSH_A_BITS crush
					][
						either 0 <> get-bits 1 crush [
							CRUSH_A + get-bits CRUSH_B_BITS crush
						][
							either 0 <> get-bits 1 crush [
								CRUSH_B + get-bits CRUSH_C_BITS crush
							][
								either 0 <> get-bits 1 crush [
									CRUSH_C + get-bits CRUSH_D_BITS crush
								][
									either 0 <> get-bits 1 crush [
										CRUSH_D + get-bits CRUSH_E_BITS crush
									][
										CRUSH_E + get-bits CRUSH_F_BITS crush
									]
								]
							]
						]
					]

					ss: CRUSH_W_BITS - CRUSH_NUM_SLOTS
					log: ss + get-bits CRUSH_SLOT_BITS crush
					pp: either log > ss [
						1 << log + get-bits log crush
					][
						get-bits ss + 1 crush
					]
					s: p + not pp
					if s < 0 [
						print-line ["File corrupted: s = " s]
						return null
					]

					p: p + 1
					s: s + 1
					buf/p: buf/s
					p: p + 1
					s: s + 1
					buf/p: buf/s
					p: p + 1
					s: s + 1
					buf/p: buf/s
					while [len <> 0] [
						len: len - 1
						p: p + 1
						s: s + 1
						buf/p: buf/s
					]
				][
					p: p + 1
					buf/p: as byte! get-bits 8 crush
				]
			]
		]

		written/value: crush/index
		crush/buf
	]
]