FIX: now /flat refinement of MOLD on objects is honored.

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

object: context [
	verbose: 0

	class-id: 1'000'000									;-- base ID for dynamically created objects

	get-new-id: func [return: [integer!]][				;@@ protect from concurrent accesses
		class-id: class-id + 1
		class-id
	]

	unchanged?: func [
		word	[red-word!]
		id		[integer!]
		return: [logic!]
		/local
			obj [red-object!]
	][
		obj: as red-object! _context/get word
		all [
			TYPE_OF(obj) = TYPE_OBJECT
			obj/class = id
		]
	]

	unchanged2?: func [
		node	[node!]
		index	[integer!]
		id		[integer!]
		return: [logic!]
		/local
			obj	   [red-object!]
			ctx	   [red-context!]
			values [series!]
	][
		ctx: TO_CTX(node)
		values: as series! ctx/values/value
		obj: as red-object! values/offset + index
		all [
			TYPE_OF(obj) = TYPE_OBJECT
			obj/class = id
		]
	]

	do-indent: func [
		buffer	[red-string!]
		tabs	[integer!]
		part	[integer!]
		return:	[integer!]
		/local
			n [integer!]
	][
		n: tabs
		until [
			string/concatenate-literal buffer "    "
			n: n - 1
			zero? n
		]
		part - (4 * tabs)
	]

	serialize: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent?	[logic!]
		tabs	[integer!]
		return: [integer!]
		/local
			ctx		[red-context!]
			syms	[series!]
			values	[series!]
			sym		[red-value!]
			s-tail	[red-value!]
			value	[red-value!]
			blank	[byte!]
	][
		ctx: 	GET_CTX(obj)
		syms:   as series! ctx/symbols/value
		values: as series! ctx/values/value

		sym:	syms/offset
		s-tail: syms/tail
		value: 	values/offset

		if sym = s-tail [return part]					;-- exit if empty

		either flat? [
			indent?: no
			blank: space
		][
			string/append-char GET_BUFFER(buffer) as-integer lf
			part: part -1
			blank: lf
		]

		while [sym < s-tail][
			if indent? [part: do-indent buffer tabs part]

			part: word/mold as red-word! sym buffer no no flat? arg part tabs
			string/concatenate-literal buffer ": "
			part: part - 2

			if TYPE_OF(value) = TYPE_VALUE [value/header: TYPE_NONE] ;-- force uninitialized slot to NONE
			part: actions/mold value buffer only? all? flat? arg part tabs

			if any [indent? sym + 1 < s-tail][			;-- no final LF when FORMed
				string/append-char GET_BUFFER(buffer) as-integer blank
				part: part - 1
			]
			sym: sym + 1
			value: value + 1
		]
		part
	]

	transfer: func [
		src    [node!]									;-- src context
		dst	   [node!]									;-- dst context (extension of src)
		/local
			from   [red-context!]
			to	   [red-context!]
			word   [red-word!]
			symbol [red-value!]
			value  [red-value!]
			tail   [red-value!]
			target [red-value!]
			s	   [series!]
			idx	   [integer!]
			type   [integer!]
	][
		from: TO_CTX(src)
		to:	  TO_CTX(dst)

		s: as series! from/symbols/value
		symbol: s/offset
		tail: s/tail

		s: as series! from/values/value
		value: s/offset

		s: as series! to/values/value
		target: s/offset

		while [symbol < tail][
			word: as red-word! symbol
			idx: _context/find-word to word/symbol no

			type: TYPE_OF(value)
			either ANY_SERIES?(type) [					s;-- copy series value in extended object
				actions/copy
					as red-series! value
					target + idx
					null
					yes
					null
			][
				copy-cell value target + idx			;-- just propagate the old value by default
			]
			symbol: symbol + 1
			value: value + 1
		]
	]

	duplicate: func [
		src    [node!]									;-- src context
		dst	   [node!]									;-- dst context (extension of src)
		/local
			from   [red-context!]
			to	   [red-context!]
			value  [red-value!]
			tail   [red-value!]
			target [red-value!]
			s	   [series!]
			type   [integer!]
	][
		from: TO_CTX(src)
		to:	  TO_CTX(dst)

		s: as series! from/values/value
		value: s/offset
		tail:  s/tail

		s: as series! to/values/value
		target: s/offset

		while [value < tail][
			type: TYPE_OF(value)
			either ANY_SERIES?(type) [					;-- copy series value in extended object
				actions/copy
					as red-series! value
					target
					null
					yes
					null
			][
				copy-cell value target					;-- just propagate the old value by default
			]
			value: value + 1
			target: target + 1
		]
	]

	extend: func [
		ctx		[red-context!]
		spec	[red-context!]
		return: [logic!]
		/local
			syms  [red-value!]
			tail  [red-value!]
			vals  [red-value!]
			value [red-value!]
			base  [red-value!]
			type  [integer!]
			s	  [series!]
	][
		s: as series! spec/symbols/value
		syms: s/offset
		tail: s/tail

		s: as series! spec/values/value
		vals: s/offset

		s: as series! ctx/symbols/value
		base: s/tail - s/offset

		while [syms < tail][
			value: _context/add-with ctx as red-word! syms vals

			unless null? value [
				type: TYPE_OF(value)
				case [
					ANY_SERIES?(type) [
						actions/copy
							as red-series! value
							value						;-- overwrite the value
							null
							yes
							null
					]
					type = TYPE_FUNCTION [
						rebind as red-function! value ctx
					]
					true [0]
				]
			]
			syms: syms + 1
			vals: vals + 1
		]
		s: as series! ctx/symbols/value					;-- refreshing pointer
		s/tail - s/offset > base						;-- TRUE: new words added
	]

	rebind: func [
		fun		[red-function!]
		ctx 	[red-context!]
		/local
			s	 [series!]
			more [red-value!]
			blk  [red-block!]
			spec [red-block!]
	][
		s: as series! fun/more/value
		more: s/offset

		if TYPE_OF(more) = TYPE_NONE [
			print-line "*** Error: rebinding stuck on missing function's body block"
			halt
		]
		spec: as red-block! stack/push*
		spec/head: 0
		spec/node: fun/spec

		blk: block/clone as red-block! more yes
		_context/bind blk ctx yes						;-- rebind new body to object
		_function/push spec blk	fun/ctx null			;-- recreate function
		copy-cell stack/top - 1	as red-value! fun		;-- overwrite function slot in object
		stack/pop 2										;-- remove extra stack slots (block/clone and _function/push)

		s: as series! fun/more/value
		more: s/offset + 2
		more/header: TYPE_UNSET							;-- invalidate compiled body
	]

	push: func [
		ctx		[node!]
		class	[integer!]
		return: [red-object!]
		/local
			obj	[red-object!]
	][
		obj: as red-object! stack/push*
		obj/header: TYPE_OBJECT
		obj/ctx:	ctx
		obj/class:	class
		obj
	]

	init-push: func [
		node	[node!]
		class	[integer!]
		return: [red-object!]
		/local
			ctx [red-context!]
	][
		ctx: TO_CTX(node)
		s: as series! ctx/values/value
		if s/offset = s/tail [
			s/tail: s/offset + (s/size >> 4)			;-- (late) set of 'values right tail pointer
		]
		push node class
	]

	make-at: func [
		obj		[red-object!]
		slots	[integer!]
		return: [red-object!]
	][
		obj/header: TYPE_OBJECT
		obj/ctx:	_context/create slots no yes
		obj/class:	0
		obj
	]

	;-- Actions --

	make: func [
		proto	[red-object!]
		spec	[red-value!]
		return:	[red-object!]
		/local
			obj	 [red-object!]
			obj2 [red-object!]
			ctx  [red-context!]
			blk  [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/make"]]

		obj: as red-object! stack/push*

		either TYPE_OF(proto) = TYPE_OBJECT [
			copy proto obj null yes null				;-- /deep
		][
			make-at obj 4								;-- arbitrary value
		]
		ctx: GET_CTX(obj)

		switch TYPE_OF(spec) [
			TYPE_OBJECT [
				obj2: as red-object! spec
				obj/class: either extend ctx GET_CTX(obj2) [get-new-id][proto/class]
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				_context/collect-set-words ctx blk
				_context/bind blk ctx yes
				interpreter/eval blk no
				obj/class: get-new-id
			]
			default [
				print-line "*** Error: invalid spec value for object construction"
				halt
			]
		]
		obj
	]

	reflect: func [
		obj		[red-object!]
		field	[integer!]
		return:	[red-block!]
		/local
			ctx	  [red-context!]
			blk   [red-block!]
			syms  [red-value!]
			vals  [red-value!]
			tail  [red-value!]
			value [red-value!]
			s	  [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		ctx: GET_CTX(obj)

		case [
			field = words/words [
				blk/node: ctx/symbols
				blk: block/clone blk no
			]
			field = words/values [
				blk/node: ctx/values
				blk: block/clone blk no
			]
			field = words/body [
				blk/node: ctx/symbols
				blk/node: alloc-cells block/rs-length? blk

				s: as series! ctx/symbols/value
				syms: s/offset
				tail: s/tail

				s: as series! ctx/values/value
				vals: s/offset

				while [syms < tail][
					value: block/rs-append blk syms
					value/header: TYPE_SET_WORD
					block/rs-append blk vals
					syms: syms + 1
					vals: vals + 1
				]
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		as red-block! stack/set-last as red-value! blk
	]

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

		serialize obj buffer no no no arg part no 0
	]

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

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

	eval-path: func [
		parent	[red-object!]							;-- implicit type casting
		element	[red-value!]
		set?	[logic!]
		return:	[red-value!]
		/local
			word [red-word!]
			ctx  [red-context!]
	][
		word: as red-word! element
		ctx:  GET_CTX(parent)

		if word/ctx <> parent/ctx [						;-- bind the word to object's context
			word/index: _context/find-word ctx word/symbol no
			word/ctx: parent/ctx
		]
		either set? [
			_context/set-in word stack/arguments ctx
			stack/arguments
		][
			_context/get-in word ctx
		]
	]

	copy: func [
		obj      [red-object!]
		new	  	 [red-object!]
		part-arg [red-value!]
		deep?	 [logic!]
		types	 [red-value!]
		return:	 [red-object!]
		/local
			ctx	  [red-context!]
			nctx  [red-context!]
			value [red-value!]
			tail  [red-value!]
			src	  [series!]
			dst	  [series!]
			size  [integer!]
			slots [integer!]
			type  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/copy"]]

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

		if OPTION?(part-arg) [
			print-line "***Error: copy/part is not supported on objects"
			halt
		]

		ctx:	GET_CTX(obj)
		src:	as series! ctx/symbols/value
		size:   as-integer src/tail - src/offset
		slots:	size >> 4

		new: make-at new slots
		new/class: obj/class
		nctx: GET_CTX(new)

		;-- process SYMBOLS
		dst: as series! nctx/symbols/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots
		_context/set-context-each dst new/ctx

		;-- process VALUES
		src: as series! ctx/values/value
		dst: as series! nctx/values/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots

		if deep? [
			value: dst/offset
			tail:  dst/tail

			while [value < tail][
				type: TYPE_OF(value)
				case [
					ANY_SERIES?(type) [
						actions/copy
							as red-series! value
							value						;-- overwrite the value
							null
							yes
							null
					]
					type = TYPE_FUNCTION [
						rebind as red-function! value nctx
					]
					true [0]
				]
				value: value + 1
			]
		]

		new
	]

	find: func [
		obj		 [red-object!]
		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
			word [red-word!]
			ctx	 [node!]
			id	 [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/find"]]

		assert any [									;@@ replace with ANY_WORD?
			TYPE_OF(value) = TYPE_WORD
			TYPE_OF(value) = TYPE_LIT_WORD
			TYPE_OF(value) = TYPE_GET_WORD
			TYPE_OF(value) = TYPE_SET_WORD
		]
		word: as red-word! value
		ctx: obj/ctx
		id: _context/find-word TO_CTX(ctx) word/symbol yes
		as red-value! either id = -1 [none-value][true-value]
	]

	select: func [
		obj		 [red-object!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		return:	 [red-value!]
		/local
			word   [red-word!]
			ctx	   [red-context!]
			values [series!]
			node   [node!]
			id	   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/select"]]

		assert any [									;@@ replace with ANY_WORD?
			TYPE_OF(value) = TYPE_WORD
			TYPE_OF(value) = TYPE_LIT_WORD
			TYPE_OF(value) = TYPE_GET_WORD
			TYPE_OF(value) = TYPE_SET_WORD
		]
		word: as red-word! value
		node: obj/ctx
		ctx: TO_CTX(node)
		id: _context/find-word ctx word/symbol yes
		if id = -1 [return as red-value! none-value]

		values: as series! ctx/values/value
		values/offset + id
	]

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

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

object: context [
	verbose: 0

	class-id: 1'000'000									;-- base ID for dynamically created objects

	get-new-id: func [return: [integer!]][				;@@ protect from concurrent accesses
		class-id: class-id + 1
		class-id
	]

	unchanged?: func [
		word	[red-word!]
		id		[integer!]
		return: [logic!]
		/local
			obj [red-object!]
	][
		obj: as red-object! _context/get word
		all [
			TYPE_OF(obj) = TYPE_OBJECT
			obj/class = id
		]
	]

	unchanged2?: func [
		node	[node!]
		index	[integer!]
		id		[integer!]
		return: [logic!]
		/local
			obj	   [red-object!]
			ctx	   [red-context!]
			values [series!]
	][
		ctx: TO_CTX(node)
		values: as series! ctx/values/value
		obj: as red-object! values/offset + index
		all [
			TYPE_OF(obj) = TYPE_OBJECT
			obj/class = id
		]
	]

	do-indent: func [
		buffer	[red-string!]
		tabs	[integer!]
		part	[integer!]
		return:	[integer!]
		/local
			n [integer!]
	][
		n: tabs
		until [
			string/concatenate-literal buffer "    "
			n: n - 1
			zero? n
		]
		part - (4 * tabs)
	]

	serialize: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent?	[logic!]
		tabs	[integer!]
		return: [integer!]
		/local
			ctx		[red-context!]
			syms	[series!]
			values	[series!]
			sym		[red-value!]
			s-tail	[red-value!]
			value	[red-value!]
	][
		ctx: 	GET_CTX(obj)
		syms:   as series! ctx/symbols/value
		values: as series! ctx/values/value

		sym:	syms/offset
		s-tail: syms/tail
		value: 	values/offset

		if sym = s-tail [return part]					;-- exit if empty
		string/append-char GET_BUFFER(buffer) as-integer lf

		while [sym < s-tail][
			if indent? [part: do-indent buffer tabs part]

			part: word/mold as red-word! sym buffer no no flat? arg part tabs
			string/concatenate-literal buffer ": "
			part: part - 2

			if TYPE_OF(value) = TYPE_VALUE [value/header: TYPE_NONE] ;-- force uninitialized slot to NONE
			part: actions/mold value buffer only? all? flat? arg part tabs

			if any [indent? sym + 1 < s-tail][			;-- no final LF when FORMed
				string/append-char GET_BUFFER(buffer) as-integer lf
				part: part - 1
			]
			sym: sym + 1
			value: value + 1
		]
		part
	]

	transfer: func [
		src    [node!]									;-- src context
		dst	   [node!]									;-- dst context (extension of src)
		/local
			from   [red-context!]
			to	   [red-context!]
			word   [red-word!]
			symbol [red-value!]
			value  [red-value!]
			tail   [red-value!]
			target [red-value!]
			s	   [series!]
			idx	   [integer!]
			type   [integer!]
	][
		from: TO_CTX(src)
		to:	  TO_CTX(dst)

		s: as series! from/symbols/value
		symbol: s/offset
		tail: s/tail

		s: as series! from/values/value
		value: s/offset

		s: as series! to/values/value
		target: s/offset

		while [symbol < tail][
			word: as red-word! symbol
			idx: _context/find-word to word/symbol no

			type: TYPE_OF(value)
			either ANY_SERIES?(type) [					s;-- copy series value in extended object
				actions/copy
					as red-series! value
					target + idx
					null
					yes
					null
			][
				copy-cell value target + idx			;-- just propagate the old value by default
			]
			symbol: symbol + 1
			value: value + 1
		]
	]

	duplicate: func [
		src    [node!]									;-- src context
		dst	   [node!]									;-- dst context (extension of src)
		/local
			from   [red-context!]
			to	   [red-context!]
			value  [red-value!]
			tail   [red-value!]
			target [red-value!]
			s	   [series!]
			type   [integer!]
	][
		from: TO_CTX(src)
		to:	  TO_CTX(dst)

		s: as series! from/values/value
		value: s/offset
		tail:  s/tail

		s: as series! to/values/value
		target: s/offset

		while [value < tail][
			type: TYPE_OF(value)
			either ANY_SERIES?(type) [					;-- copy series value in extended object
				actions/copy
					as red-series! value
					target
					null
					yes
					null
			][
				copy-cell value target					;-- just propagate the old value by default
			]
			value: value + 1
			target: target + 1
		]
	]

	extend: func [
		ctx		[red-context!]
		spec	[red-context!]
		return: [logic!]
		/local
			syms  [red-value!]
			tail  [red-value!]
			vals  [red-value!]
			value [red-value!]
			base  [red-value!]
			type  [integer!]
			s	  [series!]
	][
		s: as series! spec/symbols/value
		syms: s/offset
		tail: s/tail

		s: as series! spec/values/value
		vals: s/offset

		s: as series! ctx/symbols/value
		base: s/tail - s/offset

		while [syms < tail][
			value: _context/add-with ctx as red-word! syms vals

			unless null? value [
				type: TYPE_OF(value)
				case [
					ANY_SERIES?(type) [
						actions/copy
							as red-series! value
							value						;-- overwrite the value
							null
							yes
							null
					]
					type = TYPE_FUNCTION [
						rebind as red-function! value ctx
					]
					true [0]
				]
			]
			syms: syms + 1
			vals: vals + 1
		]
		s: as series! ctx/symbols/value					;-- refreshing pointer
		s/tail - s/offset > base						;-- TRUE: new words added
	]

	rebind: func [
		fun		[red-function!]
		ctx 	[red-context!]
		/local
			s	 [series!]
			more [red-value!]
			blk  [red-block!]
			spec [red-block!]
	][
		s: as series! fun/more/value
		more: s/offset

		if TYPE_OF(more) = TYPE_NONE [
			print-line "*** Error: rebinding stuck on missing function's body block"
			halt
		]
		spec: as red-block! stack/push*
		spec/head: 0
		spec/node: fun/spec

		blk: block/clone as red-block! more yes
		_context/bind blk ctx yes						;-- rebind new body to object
		_function/push spec blk	fun/ctx null			;-- recreate function
		copy-cell stack/top - 1	as red-value! fun		;-- overwrite function slot in object
		stack/pop 2										;-- remove extra stack slots (block/clone and _function/push)

		s: as series! fun/more/value
		more: s/offset + 2
		more/header: TYPE_UNSET							;-- invalidate compiled body
	]

	push: func [
		ctx		[node!]
		class	[integer!]
		return: [red-object!]
		/local
			obj	[red-object!]
	][
		obj: as red-object! stack/push*
		obj/header: TYPE_OBJECT
		obj/ctx:	ctx
		obj/class:	class
		obj
	]

	init-push: func [
		node	[node!]
		class	[integer!]
		return: [red-object!]
		/local
			ctx [red-context!]
	][
		ctx: TO_CTX(node)
		s: as series! ctx/values/value
		if s/offset = s/tail [
			s/tail: s/offset + (s/size >> 4)			;-- (late) set of 'values right tail pointer
		]
		push node class
	]

	make-at: func [
		obj		[red-object!]
		slots	[integer!]
		return: [red-object!]
	][
		obj/header: TYPE_OBJECT
		obj/ctx:	_context/create slots no yes
		obj/class:	0
		obj
	]

	;-- Actions --

	make: func [
		proto	[red-object!]
		spec	[red-value!]
		return:	[red-object!]
		/local
			obj	 [red-object!]
			obj2 [red-object!]
			ctx  [red-context!]
			blk  [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/make"]]

		obj: as red-object! stack/push*

		either TYPE_OF(proto) = TYPE_OBJECT [
			copy proto obj null yes null				;-- /deep
		][
			make-at obj 4								;-- arbitrary value
		]
		ctx: GET_CTX(obj)

		switch TYPE_OF(spec) [
			TYPE_OBJECT [
				obj2: as red-object! spec
				obj/class: either extend ctx GET_CTX(obj2) [get-new-id][proto/class]
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				_context/collect-set-words ctx blk
				_context/bind blk ctx yes
				interpreter/eval blk no
				obj/class: get-new-id
			]
			default [
				print-line "*** Error: invalid spec value for object construction"
				halt
			]
		]
		obj
	]

	reflect: func [
		obj		[red-object!]
		field	[integer!]
		return:	[red-block!]
		/local
			ctx	  [red-context!]
			blk   [red-block!]
			syms  [red-value!]
			vals  [red-value!]
			tail  [red-value!]
			value [red-value!]
			s	  [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		ctx: GET_CTX(obj)

		case [
			field = words/words [
				blk/node: ctx/symbols
				blk: block/clone blk no
			]
			field = words/values [
				blk/node: ctx/values
				blk: block/clone blk no
			]
			field = words/body [
				blk/node: ctx/symbols
				blk/node: alloc-cells block/rs-length? blk

				s: as series! ctx/symbols/value
				syms: s/offset
				tail: s/tail

				s: as series! ctx/values/value
				vals: s/offset

				while [syms < tail][
					value: block/rs-append blk syms
					value/header: TYPE_SET_WORD
					block/rs-append blk vals
					syms: syms + 1
					vals: vals + 1
				]
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		as red-block! stack/set-last as red-value! blk
	]

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

		serialize obj buffer no no no arg part no 0
	]

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

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

	eval-path: func [
		parent	[red-object!]							;-- implicit type casting
		element	[red-value!]
		set?	[logic!]
		return:	[red-value!]
		/local
			word [red-word!]
			ctx  [red-context!]
	][
		word: as red-word! element
		ctx:  GET_CTX(parent)

		if word/ctx <> parent/ctx [						;-- bind the word to object's context
			word/index: _context/find-word ctx word/symbol no
			word/ctx: parent/ctx
		]
		either set? [
			_context/set-in word stack/arguments ctx
			stack/arguments
		][
			_context/get-in word ctx
		]
	]

	copy: func [
		obj      [red-object!]
		new	  	 [red-object!]
		part-arg [red-value!]
		deep?	 [logic!]
		types	 [red-value!]
		return:	 [red-object!]
		/local
			ctx	  [red-context!]
			nctx  [red-context!]
			value [red-value!]
			tail  [red-value!]
			src	  [series!]
			dst	  [series!]
			size  [integer!]
			slots [integer!]
			type  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/copy"]]

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

		if OPTION?(part-arg) [
			print-line "***Error: copy/part is not supported on objects"
			halt
		]

		ctx:	GET_CTX(obj)
		src:	as series! ctx/symbols/value
		size:   as-integer src/tail - src/offset
		slots:	size >> 4

		new: make-at new slots
		new/class: obj/class
		nctx: GET_CTX(new)

		;-- process SYMBOLS
		dst: as series! nctx/symbols/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots
		_context/set-context-each dst new/ctx

		;-- process VALUES
		src: as series! ctx/values/value
		dst: as series! nctx/values/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots

		if deep? [
			value: dst/offset
			tail:  dst/tail

			while [value < tail][
				type: TYPE_OF(value)
				case [
					ANY_SERIES?(type) [
						actions/copy
							as red-series! value
							value						;-- overwrite the value
							null
							yes
							null
					]
					type = TYPE_FUNCTION [
						rebind as red-function! value nctx
					]
					true [0]
				]
				value: value + 1
			]
		]

		new
	]

	find: func [
		obj		 [red-object!]
		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
			word [red-word!]
			ctx	 [node!]
			id	 [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/find"]]

		assert any [									;@@ replace with ANY_WORD?
			TYPE_OF(value) = TYPE_WORD
			TYPE_OF(value) = TYPE_LIT_WORD
			TYPE_OF(value) = TYPE_GET_WORD
			TYPE_OF(value) = TYPE_SET_WORD
		]
		word: as red-word! value
		ctx: obj/ctx
		id: _context/find-word TO_CTX(ctx) word/symbol yes
		as red-value! either id = -1 [none-value][true-value]
	]

	select: func [
		obj		 [red-object!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		return:	 [red-value!]
		/local
			word   [red-word!]
			ctx	   [red-context!]
			values [series!]
			node   [node!]
			id	   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/select"]]

		assert any [									;@@ replace with ANY_WORD?
			TYPE_OF(value) = TYPE_WORD
			TYPE_OF(value) = TYPE_LIT_WORD
			TYPE_OF(value) = TYPE_GET_WORD
			TYPE_OF(value) = TYPE_SET_WORD
		]
		word: as red-word! value
		node: obj/ctx
		ctx: TO_CTX(node)
		id: _context/find-word ctx word/symbol yes
		if id = -1 [return as red-value! none-value]

		values: as series! ctx/values/value
		values/offset + id
	]

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


TESTS: reformat cast-test.reds

TESTS: reformat cast-test.reds

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

	--test-- "byte-cast-12"							;-- issue #161
		  a: as-byte 1
		  b: as-byte 2
		  c: (as-integer b) << 16 or as-integer a
		  --assert 00020001h = c

	--test-- "byte-cast-13"							;-- issue #162
		sb: declare struct! [
			a   [byte!]
			b   [byte!]
		]
		sb/a: as-byte 0
		sb/b: as-byte 1
		--assert not as-logic sb/a

	--test-- "byte-cast-13"							;-- issue #150
		s!: alias struct! [
			a   [byte!]
			b   [byte!]
			c   [byte!]
			d   [byte!]
		]
		t: declare s!
		t/a: as-byte 1
		t/b: as-byte 1
		t/c: as-byte 0
		t/d: as-byte 0
		h: as-integer t/a
		--assert h = 1

	--test-- "byte-cast-14"              ;-- issue 317
		bc14-a: as byte! 1
		bc14-b: as byte! 2
		bc14-c: as byte! 3
		bc14-d: as byte! 4
		bc14-e: as byte! 5
		bc14-a: as byte! 0
		--assert #"^(00)" = bc14-a
		--assert #"^(02)" = bc14-b
		--assert #"^(03)" = bc14-c
		--assert #"^(04)" = bc14-d
		--assert #"^(05)" = bc14-e

===end-group===

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

	--test-- "int-cast-1"
		--assert #"^(00)" = as byte! 0

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

===end-group===

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

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

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

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

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

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

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

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

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

===end-group===

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

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

	--test-- "c-string-cast-3"
		csc3-str: ""
		--assert true = as logic! csc3-str

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

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

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

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

===end-group===

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

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

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

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

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

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

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

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

===end-group===

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

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

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

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

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

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

===end-group===

===start-group=== "byte-integer-cast"

	--test-- "bic-1"
		bic-a: as-byte 1
		--assert 1 = as-integer bic-a

	--test-- "bic-2"
		bic-a: as-byte 1
		--assert 65536 = ((as-integer bic-a) << 16)

	--test-- "bic-3"
		bic-a: as-byte 2
		--assert 131072 = ((as-integer bic-a) << 16)

	--test-- "bic-4"
		bic-a: #"^(01)"
		--assert 65537 = (65536 or (as-integer bic-a))

	--test-- "bic-5"
		bic-a: #"^(01)"
		bic-b: #"^(02)"
		--assert 131073 = ((as-integer bic-b) << 16 or as-integer bic-a)

	--test-- "bic-6"
		bic-a: #"^(01)"
		bic-b: #"^(02)"
		--assert 131073 = ((as-integer bic-b) << 16 or as-integer bic-a)

	--test-- "bic-7"
		bic-a: #"^(01)"
		bic-b: #"^(02)"
		--assert (as byte-ptr! 131073) = as byte-ptr! ((as-integer bic-b) << 16 or as-integer bic-a)

	--test-- "bic-8"
		bic-a: as-byte 1
		bic-b: as-byte 2
		--assert 131073 = ((as-integer bic-b) << 16 or as-integer bic-a)

	--test-- "bic-9"
		bic-a: as-byte 1
		bic-b: as-byte 2
		--assert (as byte-ptr! 131073) = as byte-ptr! ((as-integer bic-b) << 16 or as-integer bic-a)

	--test-- "bic-10"
		bic-s: declare struct! [
			bic-a [byte!]
			bic-b [byte!]
			bic-c [integer!]
			bic-d [byte!]
			bic-e [byte!]
			bic-f [integer!]
		]
		bic-s/bic-a: as-byte 0
		bic-s/bic-b: as-byte 1
		bic-s/bic-c: 2
		bic-s/bic-d: as-byte 3
		bic-s/bic-e: as-byte 255
		bic-s/bic-f: 255
		--assert false = as-logic bic-s/bic-a
		--assert true = as-logic bic-s/bic-b
		--assert bic-s/bic-e = as-byte bic-s/bic-f
		--assert bic-s/bic-f = as-integer bic-s/bic-e

===end-group===

===start-group=== "Cast in conditional tests"
		cic-r: false
	--test-- "cic-1"
		cic-d: as-byte 0
		either as-logic cic-d [cic-r: false] [cic-r: true]
		--assert cic-r

	--test-- "cic-2"
		cic-s: declare struct! [
			a   [byte!]
			b   [byte!]
		]
		cic-s/a: as-byte 0
		cic-s/b: as-byte 1
		either as-logic cic-s/a [cic-r: false] [cic-r: true]
		--assert cic-r

===end-group===

~~~end-file~~~

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

	--test-- "byte-cast-12"							;-- issue #161
	  a: as-byte 1
	  b: as-byte 2
	  c: (as-integer b) << 16 or as-integer a
	  --assert 00020001h = c

	--test-- "byte-cast-13"							;-- issue #162
	  sb: declare struct! [
	      a   [byte!]
	      b   [byte!]
	  ]
	  sb/a: as-byte 0
	  sb/b: as-byte 1
	  --assert not as-logic sb/a

	--test-- "byte-cast-13"							;-- issue #150
	 s!: alias struct! [
	     a   [byte!]
	     b   [byte!]
	     c   [byte!]
	     d   [byte!]
	 ]
	 t: declare s!
	 t/a: as-byte 1
	 t/b: as-byte 1
	 t/c: as-byte 0
	 t/d: as-byte 0
	 h: as-integer t/a
	 --assert h = 1

	 --test-- "byte-cast-14"              ;-- issue 317
	   bc14-a: as byte! 1
	   bc14-b: as byte! 2
	   bc14-c: as byte! 3
	   bc14-d: as byte! 4
	   bc14-e: as byte! 5
	   bc14-a: as byte! 0
	 --assert #"^(00)" = bc14-a
	 --assert #"^(02)" = bc14-b
	 --assert #"^(03)" = bc14-c
	 --assert #"^(04)" = bc14-d
	 --assert #"^(05)" = bc14-e

===end-group===

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

===end-group===

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

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

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

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

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

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

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

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

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

===end-group===

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

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

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

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

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

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

===end-group===

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

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

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

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

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

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

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

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

===end-group===

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

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

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

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

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

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

===end-group===

===start-group=== "byte-integer-cast"

  --test-- "bic-1"
    bic-a: as-byte 1
  --assert 1 = as-integer bic-a

  --test-- "bic-2"
    bic-a: as-byte 1
  --assert 65536 = ((as-integer bic-a) << 16)

  --test-- "bic-3"
    bic-a: as-byte 2
  --assert 131072 = ((as-integer bic-a) << 16)

  --test-- "bic-4"
    bic-a: #"^(01)"
  --assert 65537 = (65536 or (as-integer bic-a))

  --test-- "bic-5"
    bic-a: #"^(01)"
    bic-b: #"^(02)"
  --assert 131073 = ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-6"
    bic-a: #"^(01)"
    bic-b: #"^(02)"
  --assert 131073 = ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-7"
    bic-a: #"^(01)"
    bic-b: #"^(02)"
  --assert (as byte-ptr! 131073) = as byte-ptr! ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-8"
    bic-a: as-byte 1
    bic-b: as-byte 2
  --assert 131073 = ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-9"
    bic-a: as-byte 1
    bic-b: as-byte 2
  --assert (as byte-ptr! 131073) = as byte-ptr! ((as-integer bic-b) << 16 or as-integer bic-a)

  --test-- "bic-10"
    bic-s: declare struct! [
      bic-a [byte!]
      bic-b [byte!]
      bic-c [integer!]
      bic-d [byte!]
      bic-e [byte!]
      bic-f [integer!]
    ]
    bic-s/bic-a: as-byte 0
    bic-s/bic-b: as-byte 1
    bic-s/bic-c: 2
    bic-s/bic-d: as-byte 3
    bic-s/bic-e: as-byte 255
    bic-s/bic-f: 255
  --assert false = as-logic bic-s/bic-a
  --assert true = as-logic bic-s/bic-b
  --assert bic-s/bic-e = as-byte bic-s/bic-f
  --assert bic-s/bic-f = as-integer bic-s/bic-e

===end-group===

===start-group=== "Cast in conditional tests"
    cic-r: false
  --test-- "cic-1"
    cic-d: as-byte 0
    either as-logic cic-d [cic-r: false] [cic-r: true]
  --assert cic-r

  --test-- "cic-2"
    cic-s: declare struct! [
      a   [byte!]
      b   [byte!]
    ]
    cic-s/a: as-byte 0
    cic-s/b: as-byte 1
    either as-logic cic-s/a [cic-r: false] [cic-r: true]
  --assert cic-r

===end-group===

~~~end-file~~~


Fix two compilations errors

Fix two compilations errors

With the last versions of Red, the compiler detect two errors.

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

#include %../ansi.reds

zlib: context [
	#define opaque!  integer!
	#define gzfile!  integer!
	#define Z_NULL  0								;-- for initializing zalloc, zfree, opaque

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

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

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

	;-- Possible values of the data_type field
	#define Z_BINARY     0
	#define Z_TEXT       1
	#define Z_ASCII      1							;-- For compatibility with 1.2.2 and earlier
	#define Z_UNKNOWN    2

	;-- The deflate compression method (the only one supported in this version)
	#define Z_DEFLATED   8

	;-- Compression strategy
	#define Z_FILTERED            1
	#define Z_HUFFMAN_ONLY        2
	#define Z_RLE                 3
	#define Z_FIXED               4
	#define Z_DEFAULT_STRATEGY    0

	#define WINDOW_BITS      15
	#define ENABLE_ZLIB_GZIP 32

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

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

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

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

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

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

		gzopen: "gzopen" [
			filename     [c-string!]
			mode         [c-string!]
			return:      [gzfile!]
		]

		gzclose: "gzclose" [
			file         [gzfile!]
			return:      [integer!]
		]

		gzread: "gzread" [
			file         [gzfile!]
			buffer       [byte-ptr!]
			length       [integer!]
			return:      [integer!]
		]

		gzwrite: "gzwrite" [
			file         [gzfile!]
			buffer       [byte-ptr!]
			length       [integer!]
			return:      [integer!]
		]

		gzeof: "gzeof" [
			file         [gzfile!]
			return:      [integer!]
		]

		gzerror: "gzerror" [
			file         [gzfile!]
			errnum       [int-ptr!]
			return:      [c-string!]
		]

	] ; cdecl
	] ; #import [z-library

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

	gunzip: function [ "Gunzip a file into another file"
		file-in      [c-string!] "Name of the file to be unzipped"
		file-out     [c-string!] "Name of the output unzipped file"
		return:      [integer!]
		/local
			file       [file!]
			zfile      [gzfile!]
			error      [integer!]
			buffer     [byte-ptr!]
			bytes-read [integer!]

	][
		zfile: gzopen file-in "rb"
		if zfile = 0 [
			print [ "gunzip: gzopen of " file-in " failed." lf ]
			return Z_ERRNO
		]
		file: open file-out "wb"
		if file-error? file [
			print [ "gunzip: Error opening " file-out lf ]
			return Z_ERRNO
		]
		buffer: allocate CHUNK
		if buffer = NULL [
			print [ "gunzip: Buffer allocation error." lf ]
			return Z_ERRNO
		]
		until [
			bytes-read: gzread zfile buffer (CHUNK - 1)
			_write-array (as handle! buffer) bytes-read 1 file
			0 <> (gzeof zfile)
		]
		close-file file
		gzclose zfile
		free buffer
		return Z_OK
	]

	gzip: function [ "Gzip a file into another file"
		file-in      [c-string!] "Name of the file to be zipped"
		file-out     [c-string!] "Name of the output zipped file"
		return:      [integer!]
		/local
			file       [file!]
			zfile      [gzfile!]
			error      [integer!]
			buffer     [byte-ptr!]
			bytes-read [integer!]
	][
		file: open file-in "rb"
		if file-error? file [
			print [ "gzip: Error opening " file-in lf ]
			return Z_ERRNO
		]
		zfile: gzopen file-out "wb"
		if zfile = 0 [
			print [ "gzip: Error opening " file-out lf ]
			return Z_ERRNO
		]
		buffer: allocate CHUNK
		if buffer = NULL [
			print [ "gzip: Buffer allocation error." lf ]
			return Z_ERRNO
		]
		until [
			bytes-read: read-array (as handle! buffer) 1 CHUNK file
			gzwrite zfile buffer bytes-read
			file-tail? file
		]
		close-file file
		gzclose zfile
		free buffer
		return Z_OK
	]

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

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

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

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

			address: address + 1
			i: i + 1
			i = limit
		]
		cnum: cnum + 1
		str/cnum: null-byte							;-- c string ending char
		str
	]
] ; context zlib

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

#include %../ansi.reds

zlib: context [
	#define opaque!  integer!
	#define gzfile!  integer!
	#define Z_NULL  0								;-- for initializing zalloc, zfree, opaque

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

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

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

	;-- Possible values of the data_type field
	#define Z_BINARY     0
	#define Z_TEXT       1
	#define Z_ASCII      1							;-- For compatibility with 1.2.2 and earlier
	#define Z_UNKNOWN    2

	;-- The deflate compression method (the only one supported in this version)
	#define Z_DEFLATED   8

	;-- Compression strategy
	#define Z_FILTERED            1
	#define Z_HUFFMAN_ONLY        2
	#define Z_RLE                 3
	#define Z_FIXED               4
	#define Z_DEFAULT_STRATEGY    0

	#define WINDOW_BITS      15
	#define ENABLE_ZLIB_GZIP 32

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

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

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

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

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

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

		gzopen: "gzopen" [
			filename     [c-string!]
			mode         [c-string!]
			return:      [gzfile!]
		]

		gzclose: "gzclose" [
			file         [gzfile!]
			return:      [integer!]
		]

		gzread: "gzread" [
			file         [gzfile!]
			buffer       [byte-ptr!]
			length       [integer!]
			return:      [integer!]
		]

		gzwrite: "gzwrite" [
			file         [gzfile!]
			buffer       [byte-ptr!]
			length       [integer!]
			return:      [integer!]
		]

		gzeof: "gzeof" [
			file         [gzfile!]
			return:      [integer!]
		]

		gzerror: "gzerror" [
			file         [gzfile!]
			errnum       [int-ptr!]
			return:      [c-string!]
		]

	] ; cdecl
	] ; #import [z-library

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

	gunzip: function [ "Gunzip a file into another file"
		file-in      [c-string!] "Name of the file to be unzipped"
		file-out     [c-string!] "Name of the output unzipped file"
		return:      [integer!]
		/local
			file       [file!]
			zfile      [gzfile!]
			error      [integer!]
			buffer     [byte-ptr!]
			bytes-read [integer!]

	][
		zfile: gzopen file-in "rb"
		if zfile = 0 [
			print [ "gunzip: gzopen of " file-in " failed." lf ]
			return Z_ERRNO
		]
		file: open file-out "wb"
		if file = 0 [
			print [ "gunzip: Error opening " file-out lf ]
			return Z_ERRNO
		]
		buffer: allocate CHUNK
		if buffer = NULL [
			print [ "gunzip: Buffer allocation error." lf ]
			return Z_ERRNO
		]
		until [
			bytes-read: gzread zfile buffer (CHUNK - 1)
			_write-array buffer bytes-read 1 file
			0 <> (gzeof zfile)
		]
		close-file file
		gzclose zfile
		free buffer
		return Z_OK
	]

	gzip: function [ "Gzip a file into another file"
		file-in      [c-string!] "Name of the file to be zipped"
		file-out     [c-string!] "Name of the output zipped file"
		return:      [integer!]
		/local
			file       [file!]
			zfile      [gzfile!]
			error      [integer!]
			buffer     [byte-ptr!]
			bytes-read [integer!]
	][
		file: open file-in "rb"
		if file = 0 [
			print [ "gzip: Error opening " file-in lf ]
			return Z_ERRNO
		]
		zfile: gzopen file-out "wb"
		if zfile = 0 [
			print [ "gzip: Error opening " file-out lf ]
			return Z_ERRNO
		]
		buffer: allocate CHUNK
		if buffer = NULL [
			print [ "gzip: Buffer allocation error." lf ]
			return Z_ERRNO
		]
		until [
			bytes-read: read-array buffer 1 CHUNK file
			gzwrite zfile buffer bytes-read
			file-tail? file
		]
		close-file file
		gzclose zfile
		free buffer
		return Z_OK
	]

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

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

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

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

			address: address + 1
			i: i + 1
			i = limit
		]
		cnum: cnum + 1
		str/cnum: null-byte							;-- c string ending char
		str
	]
] ; context zlib


FIX: badly named imported function argument.

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

#import [
	LIBC-file cdecl [
		allocate:	 "malloc" [
			size		[integer!]
			return:		[byte-ptr!]
		]
		free:		 "free" [
			block		[byte-ptr!]
		]
		set-memory:	 "memset" [
			target		[byte-ptr!]
			filler		[byte!]
			size		[integer!]
			return:		[byte-ptr!]
		]
		copy-memory: "memmove" [
			target		[byte-ptr!]
			source		[byte-ptr!]
			size		[integer!]
			return:		[byte-ptr!]
		]
		length?:	 "strlen" [
			buffer		[c-string!]
			return:		[integer!]
		]
		quit:		 "exit" [
			status		[integer!]
		]
		putchar: 	 "putchar" [
			char		[byte!]
		]
		printf: 	 "printf" [[variadic]]
	]
]

prin: func [s [c-string!] return: [c-string!] /local p][
	p: s
	while [p/1 <> null-byte][
		putchar p/1
		p: p + 1
	]
	s
]

prin-int: func [i [integer!] return: [integer!]][
	printf ["%i" i]
	i
]

prin-hex: func [i [integer!] return: [integer!]][
	printf ["%08X" i]
	i
]

prin-float: func [f [float!] return: [float!]][
	printf ["%.14g" f]
	f
]

prin-float32: func [f [float32!] return: [float32!]][
	printf ["%.7g" as-float f]
	f
]

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

#import [
	LIBC-file cdecl [
		allocate:	 "malloc" [
			size		[integer!]
			return:		[byte-ptr!]
		]
		free:		 "free" [
			block		[byte-ptr!]
		]
		set-memory:	 "memset" [
			target		[byte-ptr!]
			filler		[byte!]
			size		[integer!]
			return:		[byte-ptr!]
		]
		copy-memory: "memmove" [
			target		[byte-ptr!]
			source		[byte-ptr!]
			size		[integer!]
			return:		[byte-ptr!]
		]
		length?:	 "strlen" [
			command		[c-string!]
			return:		[integer!]
		]
		quit:		 "exit" [
			status		[integer!]
		]
		putchar: 	 "putchar" [
			char		[byte!]
		]
		printf: 	 "printf" [[variadic]]
	]
]

prin: func [s [c-string!] return: [c-string!] /local p][
	p: s
	while [p/1 <> null-byte][
		putchar p/1
		p: p + 1
	]
	s
]

prin-int: func [i [integer!] return: [integer!]][
	printf ["%i" i]
	i
]

prin-hex: func [i [integer!] return: [integer!]][
	printf ["%08X" i]
	i
]

prin-float: func [f [float!] return: [float!]][
	printf ["%.14g" f]
	f
]

prin-float32: func [f [float32!] return: [float32!]][
	printf ["%.7g" as-float f]
	f
]