FIX: not refresh series-buffer address in _context/add-with

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

_context: context [
	verbose: 0

	find-word: func [
		ctx		[red-context!]
		sym		[integer!]
		case?	[logic!]
		return:	[integer!]								;-- value > 0: success, value = -1: failure
		/local
			series	[series!]
			list	[red-word!]
			end		[red-word!]
	][
		series: as series! ctx/symbols/value
		list:   as red-word! series/offset
		end:    as red-word! series/tail

		either case? [
			sym: symbol/resolve sym
			while [list < end][
				if sym = symbol/resolve list/symbol [
					return (as-integer list - as red-word! series/offset) >> 4	;@@ log2(size? cell!) hardcoded
				]
				list: list + 1
			]
		][
			while [list < end][
				if sym = list/symbol [
					return (as-integer list - as red-word! series/offset) >> 4	;@@ log2(size? cell!) hardcoded
				]
				list: list + 1
			]
		]
		-1												;-- search failed
	]

	add-global: func [
		symbol	[integer!]
		return: [red-word!]
		/local
			ctx	  [red-context!]
			word  [red-word!]
			value [cell!]
			s  	  [series!]
			id	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/add-global"]]

		ctx: TO_CTX(global-ctx)
		id: find-word ctx symbol no
		s: as series! ctx/symbols/value

		if id <> -1 [return as red-word! s/offset + id]	;-- word already defined in global context

		s: as series! ctx/symbols/value
		id: (as-integer s/tail - s/offset) >> 4			;-- index is zero-base
		word: as red-word! alloc-tail s

		word/header: TYPE_WORD							;-- implicit reset of all header flags
		word/ctx: 	 global-ctx
		word/symbol: symbol
		word/index:  id

		value: alloc-tail as series! ctx/values/value
		value/header: TYPE_UNSET
		word
	]

	add-with: func [
		ctx		[red-context!]
		word	[red-word!]
		value	[red-value!]
		return: [red-value!]
		/local
			w	[red-word!]
			s  	[series!]
			id	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/add-with"]]

		id: find-word ctx word/symbol yes
		if id <> -1 [return null]

		s: as series! ctx/symbols/value
		id: (as-integer s/tail - s/offset) >> 4			;-- index is zero-base
		w: as red-word! alloc-tail s
		copy-cell as cell! word as cell! w
		w/ctx: ctx/self
		w/index: id

		s: as series! ctx/symbols/value					;-- refreshing pointer after alloc-tail
		copy-cell value alloc-tail as series! ctx/values/value
	]

	add: func [
		ctx		[red-context!]
		word 	[red-word!]
		return:	[integer!]
		/local
			sym	  [cell!]
			value [cell!]
			s  	  [series!]
			id	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/add"]]

		id: find-word ctx word/symbol yes
		if id <> -1 [return id]

		s: as series! ctx/symbols/value
		id: (as-integer s/tail - s/offset) >> 4			;-- index is zero-base

		sym: alloc-tail s
		copy-cell as cell! word sym
		sym/header: TYPE_WORD							;-- force word! type
		word: as red-word! sym
		word/index: id

		unless ON_STACK?(ctx) [
			value: alloc-tail as series! ctx/values/value
			value/header: TYPE_UNSET
		]
		id
	]

	set-integer: func [
		word 	[red-word!]
		value	[integer!]
		return:	[integer!]
		/local
			node	[node!]
			int 	[red-integer!]
			values	[series!]
			ctx		[red-context!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/set-integer"]]

		node: word/ctx
		ctx: TO_CTX(node)

		if word/index = -1 [
			word/index: find-word ctx word/symbol no
		]
		int: as red-integer! either ON_STACK?(ctx) [
			(as red-value! ctx/values) + word/index
		][
			values: as series! ctx/values/value
			values/offset + word/index
		]
		int/header: TYPE_INTEGER
		int/value: value
		value
	]

	set-in: func [
		word 		[red-word!]
		value		[red-value!]
		ctx			[red-context!]
		return:		[red-value!]
		/local
			values	[series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/set-in"]]

		if word/index = -1 [
			word/index: find-word ctx word/symbol no
			if word/index = -1 [add ctx word]
		]
		either ON_STACK?(ctx) [
			copy-cell value (as red-value! ctx/values) + word/index
		][
			values: as series! ctx/values/value
			copy-cell value values/offset + word/index
		]
	]

	set: func [
		word	[red-word!]
		value	[red-value!]
		return:	[red-value!]
		/local
			node [node!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/set"]]

		node: word/ctx
		set-in word value TO_CTX(node)
	]

	get-in: func [
		word	   [red-word!]
		ctx	   	   [red-context!]
		return:	   [red-value!]
		/local
			values [series!]
			sym	   [red-symbol!]
			s	   [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/get-with"]]

		if all [
			ctx/header and flag-self-mask <> 0			;-- test if context handles SELF
			word/index = -1
			word/symbol = words/self
		][
			s: as series! word/ctx/value
			return s/offset								;-- return original object value
		]
		if any [										;-- ensure word is properly bound to a context
			null? ctx
			word/index = -1
		][
			fire [TO_ERROR(script no-value) word]
		]
		if null? ctx/values [
			fire [TO_ERROR(script not-in-context) word]
		]
		either ON_STACK?(ctx) [
			(as red-value! ctx/values) + word/index
		][
			values: as series! ctx/values/value
			values/offset + word/index
		]
	]

	get: func [
		word	[red-word!]
		return:	[red-value!]
		/local
			node [node!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/get"]]

		node: word/ctx
		get-in word TO_CTX(node)
	]

	create: func [
		slots		[integer!]							;-- max number of words in the context
		stack?		[logic!]							;-- TRUE: alloc values on stack, FALSE: alloc them from heap
		self?		[logic!]
		return:		[node!]
		/local
			cell 	[red-context!]
			node	[node!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/create"]]

		if zero? slots [slots: 1]
		node: alloc-cells 1
		cell: as red-context! alloc-tail as series! node/value
		cell/header: TYPE_CONTEXT						;-- implicit reset of all header flags
		cell/symbols: alloc-series slots 16 0			;-- force offset at head of buffer
		cell/self: node

		if self? [cell/header: cell/header or set-self-mask]

		either stack? [
			cell/header: TYPE_CONTEXT or flag-series-stk
			cell/values: null							;-- will be set to stack frame dynamically
		][
			cell/values: alloc-cleared-cells slots
		]
		node
	]

	make: func [
		spec	[red-block!]
		stack?	[logic!]
		self?	[logic!]
		return:	[node!]
		/local
			new		[node!]
			symbols	[node!]
			ctx		[red-context!]
			cell	[red-value!]
			slot	[red-word!]
			s		[series!]
			type	[integer!]
			i		[integer!]
	][
		new: create block/rs-length? spec stack? self?
		ctx: TO_CTX(new)
		symbols: ctx/symbols

		s: GET_BUFFER(spec)
		cell: s/offset
		i: 0

		while [cell < s/tail][
			type: TYPE_OF(cell)
			if any [									;TBD: use typeset/any-word?
				type = TYPE_WORD
				type = TYPE_GET_WORD
				type = TYPE_LIT_WORD
				type = TYPE_REFINEMENT
			][											;-- add new word to context
				slot: as red-word! alloc-tail as series! symbols/value
				copy-cell cell as red-value! slot
				slot/header: TYPE_WORD
				slot/ctx: new
				slot/index: i
				i: i + 1
			]
			cell: cell + 1
		]
		new
	]

	get-words: func [
		/local
			blk	[red-block!]
			ctx [red-context!]
	][
		ctx: TO_CTX(global-ctx)
		blk: as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0
		blk/node: 	ctx/symbols

		copy-cell 										;-- reposition cloned block at right place
			as red-value! block/clone blk no
			as red-value! blk
	]

	bind-word: func [
		ctx		[red-context!]
		word	[red-word!]
		return:	[integer!]
		/local
			idx [integer!]
	][
		idx: find-word ctx word/symbol yes
		if idx >= 0 [
			word/ctx: ctx/self
			word/index: idx
		]
		idx
	]

	bind: func [
		body	[red-block!]
		ctx		[red-context!]
		obj		[node!]									;-- required by SELF
		self?	[logic!]
		return: [red-block!]
		/local
			value [red-value!]
			end	  [red-value!]
			w	  [red-word!]
			type  [integer!]
	][
		value: block/rs-head body
		end:   block/rs-tail body

		while [value < end][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_SET_WORD
				TYPE_LIT_WORD
				TYPE_REFINEMENT [
					w: as red-word! value
					either all [						;-- special processing of SELF word
						self?
						TYPE_OF(value) = TYPE_WORD
						w/symbol = words/self
					][
						w/ctx: obj						;-- make SELF refer to the original object
						w/index: -1						;-- make it fail if resolved out of context
					][
						bind-word ctx w
					]
				]
				TYPE_BLOCK 								;@@ replace with TYPE_ANY_BLOCK
				TYPE_PAREN
				TYPE_PATH
				TYPE_LIT_PATH
				TYPE_SET_PATH
				TYPE_GET_PATH	[
					bind as red-block! value ctx obj self?
				]
				default [0]
			]
			value: value + 1
		]
		body
	]

	set-context-each: func [
		s	 [series!]
		node [node!]
		/local
			p	 [red-word!]
			tail [red-word!]
	][
		p:	  as red-word! s/offset
		tail: as red-word! s/tail

		while [p < tail][
			p/ctx: node
			p: p + 1
		]
	]

	collect-set-words: func [
		ctx	 	[red-context!]
		spec 	[red-block!]
		return: [logic!]
		/local
			cell [red-value!]
			tail [red-value!]
			base [red-value!]
			word [red-word!]
			s	 [series!]
	][
		s: GET_BUFFER(spec)
		cell: s/offset
		tail: s/tail

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

		while [cell < tail][
			if TYPE_OF(cell) = TYPE_SET_WORD [
				add ctx as red-word! cell
			]
			cell: cell + 1
		]
		s/tail - s/offset > base						;-- TRUE: new words added
	]

	;-- Actions --

	init: does [
		datatype/register [
			TYPE_CONTEXT
			TYPE_VALUE
			"context!"
			;-- General actions --
			null			;make
			null			;random
			null			;reflect
			null			;to
			null			;form
			null			;mold
			null			;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
			null			;copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;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:   "Context! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %context.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
	}
]

_context: context [
	verbose: 0

	find-word: func [
		ctx		[red-context!]
		sym		[integer!]
		case?	[logic!]
		return:	[integer!]								;-- value > 0: success, value = -1: failure
		/local
			series	[series!]
			list	[red-word!]
			end		[red-word!]
	][
		series: as series! ctx/symbols/value
		list:   as red-word! series/offset
		end:    as red-word! series/tail

		either case? [
			sym: symbol/resolve sym
			while [list < end][
				if sym = symbol/resolve list/symbol [
					return (as-integer list - as red-word! series/offset) >> 4	;@@ log2(size? cell!) hardcoded
				]
				list: list + 1
			]
		][
			while [list < end][
				if sym = list/symbol [
					return (as-integer list - as red-word! series/offset) >> 4	;@@ log2(size? cell!) hardcoded
				]
				list: list + 1
			]
		]
		-1												;-- search failed
	]

	add-global: func [
		symbol	[integer!]
		return: [red-word!]
		/local
			ctx	  [red-context!]
			word  [red-word!]
			value [cell!]
			s  	  [series!]
			id	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/add-global"]]

		ctx: TO_CTX(global-ctx)
		id: find-word ctx symbol no
		s: as series! ctx/symbols/value

		if id <> -1 [return as red-word! s/offset + id]	;-- word already defined in global context

		s: as series! ctx/symbols/value
		word: as red-word! alloc-tail s
		s: GET_BUFFER(s)								;-- refreshing s pointer

		word/header: TYPE_WORD							;-- implicit reset of all header flags
		word/ctx: 	 global-ctx
		word/symbol: symbol
		word/index:  (as-integer s/tail - s/offset) >> 4 - 1

		value: alloc-tail as series! ctx/values/value
		value/header: TYPE_UNSET
		word
	]

	add-with: func [
		ctx		[red-context!]
		word	[red-word!]
		value	[red-value!]
		return: [red-value!]
		/local
			w	[red-word!]
			s  	[series!]
			id	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/add-with"]]

		id: find-word ctx word/symbol yes
		if id <> -1 [return null]

		s: as series! ctx/symbols/value
		w: as red-word! alloc-tail s
		copy-cell as cell! word as cell! w
		w/ctx: ctx/self
		w/index: (as-integer s/tail - s/offset) >> 4 - 1

		s: as series! ctx/symbols/value					;-- refreshing pointer after alloc-tail
		copy-cell value alloc-tail as series! ctx/values/value
	]

	add: func [
		ctx		[red-context!]
		word 	[red-word!]
		return:	[integer!]
		/local
			sym	  [cell!]
			value [cell!]
			s  	  [series!]
			id	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/add"]]

		id: find-word ctx word/symbol yes
		if id <> -1 [return id]

		s: as series! ctx/symbols/value
		id: (as-integer s/tail - s/offset) >> 4

		sym: alloc-tail s
		copy-cell as cell! word sym
		sym/header: TYPE_WORD							;-- force word! type
		word: as red-word! sym
		word/index: id

		unless ON_STACK?(ctx) [
			value: alloc-tail as series! ctx/values/value
			value/header: TYPE_UNSET
		]
		id
	]

	set-integer: func [
		word 	[red-word!]
		value	[integer!]
		return:	[integer!]
		/local
			node	[node!]
			int 	[red-integer!]
			values	[series!]
			ctx		[red-context!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/set-integer"]]

		node: word/ctx
		ctx: TO_CTX(node)

		if word/index = -1 [
			word/index: find-word ctx word/symbol no
		]
		int: as red-integer! either ON_STACK?(ctx) [
			(as red-value! ctx/values) + word/index
		][
			values: as series! ctx/values/value
			values/offset + word/index
		]
		int/header: TYPE_INTEGER
		int/value: value
		value
	]

	set-in: func [
		word 		[red-word!]
		value		[red-value!]
		ctx			[red-context!]
		return:		[red-value!]
		/local
			values	[series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/set-in"]]

		if word/index = -1 [
			word/index: find-word ctx word/symbol no
			if word/index = -1 [add ctx word]
		]
		either ON_STACK?(ctx) [
			copy-cell value (as red-value! ctx/values) + word/index
		][
			values: as series! ctx/values/value
			copy-cell value values/offset + word/index
		]
	]

	set: func [
		word	[red-word!]
		value	[red-value!]
		return:	[red-value!]
		/local
			node [node!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/set"]]

		node: word/ctx
		set-in word value TO_CTX(node)
	]

	get-in: func [
		word	   [red-word!]
		ctx	   	   [red-context!]
		return:	   [red-value!]
		/local
			values [series!]
			sym	   [red-symbol!]
			s	   [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/get-with"]]

		if all [
			ctx/header and flag-self-mask <> 0			;-- test if context handles SELF
			word/index = -1
			word/symbol = words/self
		][
			s: as series! word/ctx/value
			return s/offset								;-- return original object value
		]
		if any [										;-- ensure word is properly bound to a context
			null? ctx
			word/index = -1
		][
			fire [TO_ERROR(script no-value) word]
		]
		if null? ctx/values [
			fire [TO_ERROR(script not-in-context) word]
		]
		either ON_STACK?(ctx) [
			(as red-value! ctx/values) + word/index
		][
			values: as series! ctx/values/value
			values/offset + word/index
		]
	]

	get: func [
		word	[red-word!]
		return:	[red-value!]
		/local
			node [node!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/get"]]

		node: word/ctx
		get-in word TO_CTX(node)
	]

	create: func [
		slots		[integer!]							;-- max number of words in the context
		stack?		[logic!]							;-- TRUE: alloc values on stack, FALSE: alloc them from heap
		self?		[logic!]
		return:		[node!]
		/local
			cell 	[red-context!]
			node	[node!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_context/create"]]

		if zero? slots [slots: 1]
		node: alloc-cells 1
		cell: as red-context! alloc-tail as series! node/value
		cell/header: TYPE_CONTEXT						;-- implicit reset of all header flags
		cell/symbols: alloc-series slots 16 0			;-- force offset at head of buffer
		cell/self: node

		if self? [cell/header: cell/header or set-self-mask]

		either stack? [
			cell/header: TYPE_CONTEXT or flag-series-stk
			cell/values: null							;-- will be set to stack frame dynamically
		][
			cell/values: alloc-cleared-cells slots
		]
		node
	]

	make: func [
		spec	[red-block!]
		stack?	[logic!]
		self?	[logic!]
		return:	[node!]
		/local
			new		[node!]
			symbols	[node!]
			ctx		[red-context!]
			cell	[red-value!]
			slot	[red-word!]
			s		[series!]
			type	[integer!]
			i		[integer!]
	][
		new: create block/rs-length? spec stack? self?
		ctx: TO_CTX(new)
		symbols: ctx/symbols

		s: GET_BUFFER(spec)
		cell: s/offset
		i: 0

		while [cell < s/tail][
			type: TYPE_OF(cell)
			if any [									;TBD: use typeset/any-word?
				type = TYPE_WORD
				type = TYPE_GET_WORD
				type = TYPE_LIT_WORD
				type = TYPE_REFINEMENT
			][											;-- add new word to context
				slot: as red-word! alloc-tail as series! symbols/value
				copy-cell cell as red-value! slot
				slot/header: TYPE_WORD
				slot/ctx: new
				slot/index: i
				i: i + 1
			]
			cell: cell + 1
		]
		new
	]

	get-words: func [
		/local
			blk	[red-block!]
			ctx [red-context!]
	][
		ctx: TO_CTX(global-ctx)
		blk: as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0
		blk/node: 	ctx/symbols

		copy-cell 										;-- reposition cloned block at right place
			as red-value! block/clone blk no
			as red-value! blk
	]

	bind-word: func [
		ctx		[red-context!]
		word	[red-word!]
		return:	[integer!]
		/local
			idx [integer!]
	][
		idx: find-word ctx word/symbol yes
		if idx >= 0 [
			word/ctx: ctx/self
			word/index: idx
		]
		idx
	]

	bind: func [
		body	[red-block!]
		ctx		[red-context!]
		obj		[node!]									;-- required by SELF
		self?	[logic!]
		return: [red-block!]
		/local
			value [red-value!]
			end	  [red-value!]
			w	  [red-word!]
			type  [integer!]
	][
		value: block/rs-head body
		end:   block/rs-tail body

		while [value < end][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_SET_WORD
				TYPE_LIT_WORD
				TYPE_REFINEMENT [
					w: as red-word! value
					either all [						;-- special processing of SELF word
						self?
						TYPE_OF(value) = TYPE_WORD
						w/symbol = words/self
					][
						w/ctx: obj						;-- make SELF refer to the original object
						w/index: -1						;-- make it fail if resolved out of context
					][
						bind-word ctx w
					]
				]
				TYPE_BLOCK 								;@@ replace with TYPE_ANY_BLOCK
				TYPE_PAREN
				TYPE_PATH
				TYPE_LIT_PATH
				TYPE_SET_PATH
				TYPE_GET_PATH	[
					bind as red-block! value ctx obj self?
				]
				default [0]
			]
			value: value + 1
		]
		body
	]

	set-context-each: func [
		s	 [series!]
		node [node!]
		/local
			p	 [red-word!]
			tail [red-word!]
	][
		p:	  as red-word! s/offset
		tail: as red-word! s/tail

		while [p < tail][
			p/ctx: node
			p: p + 1
		]
	]

	collect-set-words: func [
		ctx	 	[red-context!]
		spec 	[red-block!]
		return: [logic!]
		/local
			cell [red-value!]
			tail [red-value!]
			base [red-value!]
			word [red-word!]
			s	 [series!]
	][
		s: GET_BUFFER(spec)
		cell: s/offset
		tail: s/tail

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

		while [cell < tail][
			if TYPE_OF(cell) = TYPE_SET_WORD [
				add ctx as red-word! cell
			]
			cell: cell + 1
		]
		s/tail - s/offset > base						;-- TRUE: new words added
	]

	;-- Actions --

	init: does [
		datatype/register [
			TYPE_CONTEXT
			TYPE_VALUE
			"context!"
			;-- General actions --
			null			;make
			null			;random
			null			;reflect
			null			;to
			null			;form
			null			;mold
			null			;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
			null			;copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;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
		]
	]
]


FEAT: added typeset belonging test functions. FIX: `any-series?` function replaced by `series?`.

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

comment: func [value][]

quit: func [
	"Stops evaluation and exits the program"
	/return status	[integer!] "Return an exit status"
][
	quit-return any [status 0]
]

empty?: func [
	"Returns true if a series is at its tail"
	series	[series!]
	return:	[logic!]
][
	tail? series
]

??: func [
	"Prints a word and the value it refers to (molded)"
	'value [word!]
][
	prin mold :value
	prin ": "
	probe get/any :value
]

probe: func [
	"Returns a value after printing its molded form"
	value
][
	print mold value
	value
]

quote: func [
	:value
][
	:value
]

first:	func ["Returns the first value in a series"  s [series!]] [pick s 1]	;@@ temporary definitions, should be natives ?
second:	func ["Returns the second value in a series" s [series!]] [pick s 2]
third:	func ["Returns the third value in a series"  s [series!]] [pick s 3]
fourth:	func ["Returns the fourth value in a series" s [series!]] [pick s 4]
fifth:	func ["Returns the fifth value in a series"  s [series!]] [pick s 5]

last:	func ["Returns the last value in a series"  s [series!]][pick back tail s 1]

action?:	 func ["Returns true if the value is this type" value [any-type!]] [action!		= type? :value]
bitset?:	 func ["Returns true if the value is this type" value [any-type!]] [bitset!		= type? :value]
block?:		 func ["Returns true if the value is this type" value [any-type!]] [block!		= type? :value]
char?: 		 func ["Returns true if the value is this type" value [any-type!]] [char!		= type? :value]
datatype?:	 func ["Returns true if the value is this type" value [any-type!]] [datatype!	= type? :value]
error?:		 func ["Returns true if the value is this type" value [any-type!]] [error!		= type? :value]
file?:		 func ["Returns true if the value is this type" value [any-type!]] [file!		= type? :value]
float?:		 func ["Returns true if the value is this type" value [any-type!]] [float!		= type? :value]
function?:	 func ["Returns true if the value is this type" value [any-type!]] [function!	= type? :value]
get-path?:	 func ["Returns true if the value is this type" value [any-type!]] [get-path!	= type? :value]
get-word?:	 func ["Returns true if the value is this type" value [any-type!]] [get-word!	= type? :value]
integer?:    func ["Returns true if the value is this type" value [any-type!]] [integer!	= type? :value]
issue?:    	 func ["Returns true if the value is this type" value [any-type!]] [issue!		= type? :value]
lit-path?:	 func ["Returns true if the value is this type" value [any-type!]] [lit-path!	= type? :value]
lit-word?:	 func ["Returns true if the value is this type" value [any-type!]] [lit-word!	= type? :value]
logic?:		 func ["Returns true if the value is this type" value [any-type!]] [logic!		= type? :value]
native?:	 func ["Returns true if the value is this type" value [any-type!]] [native!		= type? :value]
none?:		 func ["Returns true if the value is this type" value [any-type!]] [none!		= type? :value]
object?:	 func ["Returns true if the value is this type" value [any-type!]] [object!		= type? :value]
op?:		 func ["Returns true if the value is this type" value [any-type!]] [op!			= type? :value]
paren?:		 func ["Returns true if the value is this type" value [any-type!]] [paren!		= type? :value]
path?:		 func ["Returns true if the value is this type" value [any-type!]] [path!		= type? :value]
refinement?: func ["Returns true if the value is this type" value [any-type!]] [refinement! = type? :value]
routine?:	 func ["Returns true if the value is this type" value [any-type!]] [routine!	= type? :value]
set-path?:	 func ["Returns true if the value is this type" value [any-type!]] [set-path!	= type? :value]
set-word?:	 func ["Returns true if the value is this type" value [any-type!]] [set-word!	= type? :value]
string?:	 func ["Returns true if the value is this type" value [any-type!]] [string!		= type? :value]
typeset?:	 func ["Returns true if the value is this type" value [any-type!]] [typeset!	= type? :value]
unset?:		 func ["Returns true if the value is this type" value [any-type!]] [unset!		= type? :value]
url?:		 func ["Returns true if the value is this type" value [any-type!]] [url!		= type? :value]
word?:		 func ["Returns true if the value is this type" value [any-type!]] [word!		= type? :value]

any-block?:		func ["Returns true if the value is any type of block"	  value [any-type!]][find any-block! 	type? :value]
any-function?:	func ["Returns true if the value is any type of function" value [any-type!]][find any-function! type? :value]
any-object?:	func ["Returns true if the value is any type of object"	  value [any-type!]][find any-object!	type? :value]
any-path?:		func ["Returns true if the value is any type of path"	  value [any-type!]][find any-path!		type? :value]
any-string?:	func ["Returns true if the value is any type of string"	  value [any-type!]][find any-string!	type? :value]
any-word?:		func ["Returns true if the value is any type of word"	  value [any-type!]][find any-word!		type? :value]
series?:		func ["Returns true if the value is any type of series"	  value [any-type!]][find series!		type? :value]

spec-of: func [
	"Returns the spec of a value that supports reflection"
	value
][
	reflect :value 'spec
]

body-of: func [
	"Returns the body of a value that supports reflection"
	value
][
	reflect :value 'body
]

words-of: func [
	"Returns the list of words of a value that supports reflection"
	value
][
	reflect :value 'words
]

values-of: func [
	"Returns the list of values of a value that supports reflection"
	value
][
	reflect :value 'values
]

context: func [spec [block!]][make object! spec]

replace: func [
	series [series!]
	pattern
	value
	/all
	/local pos len
][
	len: either series? :pattern [length? pattern][1]

	either all [
		pos: series
		either series? :pattern [
			while [pos: find pos pattern][
				remove/part pos len
				pos: insert pos value
			]
		][
			while [pos: find pos pattern][pos/1: value]
		]
	][
		if pos: find series pattern [
			remove/part pos len
			insert pos value
		]
	]
	series
]

zero?: func [
	value [number!]
][
	value = 0
]

charset: func [
	spec [block! integer! char! string! binary!]
][
	make bitset! spec
]

p-indent: make string! 30								;@@ to be put in an local context

on-parse-event: func [
	event	[word!]   "Trace events: push, pop, fetch, match, iterate, paren, end"
	match?	[logic!]  "Result of last matching operation"
	rule	[block!]  "Current rule at current position"
	input	[series!] "Input series at next position to match"
	stack	[block!]  "Internal parse rules stack"
	return: [logic!]  "TRUE: continue parsing, FALSE: stop and exit parsing"
][
	switch event [
		push  [
			print [p-indent "-->"]
			append p-indent "  "
		]
		pop	  [
			clear back back tail p-indent
			print [p-indent "<--"]
		]
		fetch [
			print [
				p-indent "match:" mold/part rule  50 newline
				p-indent "input:" mold/part input 50 p-indent
			]
		]
		match [print [p-indent "==>" either match? ["matched"]["not matched"]]]
		end   [print ["return:" match?]]
	]
	true
]

parse-trace: func [
	"Wrapper for parse/trace using the default event processor"
	input [series!]
	rules [block!]
	/case
	/part
		limit [integer!]
	return: [logic! block!]
][
	either case [
		parse/case/trace input rules :on-parse-event
	][
		either part [
			parse/part/trace input rules limit :on-parse-event
		][
			parse/trace input rules :on-parse-event
		]
	]
]

load: function [
	"Returns a value or block of values by reading and evaluating a source"
	source [file! url! string! binary!]
	/header "TBD: Include Red header as a loaded value"
	/all    "TBD: Don't evaluate Red header"
	/type	"TBD:"
	/part
		length [integer! string!]
	/into "Put results in out block, instead of creating a new block"
		out [block!] "Target block for results"
][
	if part [
		case [
			zero? length [return make block! 1]
			string? length [
				if (index? length) = index? source [
					return make block! 1
				]
			]
		]
	]

	unless out [out: make block! 4]
	;switch type?/word [
	;	file!	[]
	;	url!	[]
	;	binary! []
	;]
	either part [
		system/lexer/transcode/part source out length
	][
		system/lexer/transcode source out
	]
	unless :all [if 1 = length? out [out: out/1]]
	out
]

pad: func [
	"Align a string to a given size prepending whitespaces"
	str [string!]		"String to pad"
	n	[integer!]		"Size (in characters) to align to"
	/left				"Align the string to the left side"
	return: [string!]	"Modified input string at head"
][
	head insert/dup
		any [all [left str] tail str]
		#" "
		(n - length? str)
]

;------------------------------------------
;-				Aliases					  -
;------------------------------------------

;empty?: :tail?
atan2: :arctangent2
object: :context

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

comment: func [value][]

quit: func [
	"Stops evaluation and exits the program"
	/return status	[integer!] "Return an exit status"
][
	quit-return any [status 0]
]

empty?: func [
	"Returns true if a series is at its tail"
	series	[series!]
	return:	[logic!]
][
	tail? series
]

??: func [
	"Prints a word and the value it refers to (molded)"
	'value [word!]
][
	prin mold :value
	prin ": "
	probe get/any :value
]

probe: func [
	"Returns a value after printing its molded form"
	value
][
	print mold value
	value
]

quote: func [
	:value
][
	:value
]

first:	func ["Returns the first value in a series"  s [series!]] [pick s 1]	;@@ temporary definitions, should be natives ?
second:	func ["Returns the second value in a series" s [series!]] [pick s 2]
third:	func ["Returns the third value in a series"  s [series!]] [pick s 3]
fourth:	func ["Returns the fourth value in a series" s [series!]] [pick s 4]
fifth:	func ["Returns the fifth value in a series"  s [series!]] [pick s 5]

last:	func ["Returns the last value in a series"  s [series!]][pick back tail s 1]

action?:	 func ["Returns true if the value is this type" value [any-type!]] [action!		= type? :value]
bitset?:	 func ["Returns true if the value is this type" value [any-type!]] [bitset!		= type? :value]
block?:		 func ["Returns true if the value is this type" value [any-type!]] [block!		= type? :value]
char?: 		 func ["Returns true if the value is this type" value [any-type!]] [char!		= type? :value]
datatype?:	 func ["Returns true if the value is this type" value [any-type!]] [datatype!	= type? :value]
error?:		 func ["Returns true if the value is this type" value [any-type!]] [error!		= type? :value]
file?:		 func ["Returns true if the value is this type" value [any-type!]] [file!		= type? :value]
float?:		 func ["Returns true if the value is this type" value [any-type!]] [float!		= type? :value]
function?:	 func ["Returns true if the value is this type" value [any-type!]] [function!	= type? :value]
get-path?:	 func ["Returns true if the value is this type" value [any-type!]] [get-path!	= type? :value]
get-word?:	 func ["Returns true if the value is this type" value [any-type!]] [get-word!	= type? :value]
integer?:    func ["Returns true if the value is this type" value [any-type!]] [integer!	= type? :value]
issue?:    	 func ["Returns true if the value is this type" value [any-type!]] [issue!		= type? :value]
lit-path?:	 func ["Returns true if the value is this type" value [any-type!]] [lit-path!	= type? :value]
lit-word?:	 func ["Returns true if the value is this type" value [any-type!]] [lit-word!	= type? :value]
logic?:		 func ["Returns true if the value is this type" value [any-type!]] [logic!		= type? :value]
native?:	 func ["Returns true if the value is this type" value [any-type!]] [native!		= type? :value]
none?:		 func ["Returns true if the value is this type" value [any-type!]] [none!		= type? :value]
object?:	 func ["Returns true if the value is this type" value [any-type!]] [object!		= type? :value]
op?:		 func ["Returns true if the value is this type" value [any-type!]] [op!			= type? :value]
paren?:		 func ["Returns true if the value is this type" value [any-type!]] [paren!		= type? :value]
path?:		 func ["Returns true if the value is this type" value [any-type!]] [path!		= type? :value]
refinement?: func ["Returns true if the value is this type" value [any-type!]] [refinement! = type? :value]
routine?:	 func ["Returns true if the value is this type" value [any-type!]] [routine!	= type? :value]
set-path?:	 func ["Returns true if the value is this type" value [any-type!]] [set-path!	= type? :value]
set-word?:	 func ["Returns true if the value is this type" value [any-type!]] [set-word!	= type? :value]
string?:	 func ["Returns true if the value is this type" value [any-type!]] [string!		= type? :value]
typeset?:	 func ["Returns true if the value is this type" value [any-type!]] [typeset!	= type? :value]
unset?:		 func ["Returns true if the value is this type" value [any-type!]] [unset!		= type? :value]
url?:		 func ["Returns true if the value is this type" value [any-type!]] [url!		= type? :value]
word?:		 func ["Returns true if the value is this type" value [any-type!]] [word!		= type? :value]

any-series?: func [value][
	find [												;@@ To be replaced with a typeset check
		block! paren! path! lit-path! set-path!
		get-path! string! file! url!
	] type?/word :value
]

spec-of: func [
	"Returns the spec of a value that supports reflection"
	value
][
	reflect :value 'spec
]

body-of: func [
	"Returns the body of a value that supports reflection"
	value
][
	reflect :value 'body
]

words-of: func [
	"Returns the list of words of a value that supports reflection"
	value
][
	reflect :value 'words
]

values-of: func [
	"Returns the list of values of a value that supports reflection"
	value
][
	reflect :value 'values
]

context: func [spec [block!]][make object! spec]

replace: func [
	series [series!]
	pattern
	value
	/all
	/local pos len
][
	len: either any-series? :pattern [length? pattern][1]

	either all [
		pos: series
		either any-series? :pattern [
			while [pos: find pos pattern][
				remove/part pos len
				pos: insert pos value
			]
		][
			while [pos: find pos pattern][pos/1: value]
		]
	][
		if pos: find series pattern [
			remove/part pos len
			insert pos value
		]
	]
	series
]

zero?: func [
	value [number!]
][
	value = 0
]

charset: func [
	spec [block! integer! char! string! binary!]
][
	make bitset! spec
]

p-indent: make string! 30								;@@ to be put in an local context

on-parse-event: func [
	event	[word!]   "Trace events: push, pop, fetch, match, iterate, paren, end"
	match?	[logic!]  "Result of last matching operation"
	rule	[block!]  "Current rule at current position"
	input	[series!] "Input series at next position to match"
	stack	[block!]  "Internal parse rules stack"
	return: [logic!]  "TRUE: continue parsing, FALSE: stop and exit parsing"
][
	switch event [
		push  [
			print [p-indent "-->"]
			append p-indent "  "
		]
		pop	  [
			clear back back tail p-indent
			print [p-indent "<--"]
		]
		fetch [
			print [
				p-indent "match:" mold/part rule  50 newline
				p-indent "input:" mold/part input 50 p-indent
			]
		]
		match [print [p-indent "==>" either match? ["matched"]["not matched"]]]
		end   [print ["return:" match?]]
	]
	true
]

parse-trace: func [
	"Wrapper for parse/trace using the default event processor"
	input [series!]
	rules [block!]
	/case
	/part
		limit [integer!]
	return: [logic! block!]
][
	either case [
		parse/case/trace input rules :on-parse-event
	][
		either part [
			parse/part/trace input rules limit :on-parse-event
		][
			parse/trace input rules :on-parse-event
		]
	]
]

load: function [
	"Returns a value or block of values by reading and evaluating a source"
	source [file! url! string! binary!]
	/header "TBD: Include Red header as a loaded value"
	/all    "TBD: Don't evaluate Red header"
	/type	"TBD:"
	/part
		length [integer! string!]
	/into "Put results in out block, instead of creating a new block"
		out [block!] "Target block for results"
][
	if part [
		case [
			zero? length [return make block! 1]
			string? length [
				if (index? length) = index? source [
					return make block! 1
				]
			]
		]
	]

	unless out [out: make block! 4]
	;switch type?/word [
	;	file!	[]
	;	url!	[]
	;	binary! []
	;]
	either part [
		system/lexer/transcode/part source out length
	][
		system/lexer/transcode source out
	]
	unless :all [if 1 = length? out [out: out/1]]
	out
]

pad: func [
	"Align a string to a given size prepending whitespaces"
	str [string!]		"String to pad"
	n	[integer!]		"Size (in characters) to align to"
	/left				"Align the string to the left side"
	return: [string!]	"Modified input string at head"
][
	head insert/dup
		any [all [left str] tail str]
		#" "
		(n - length? str)
]

;------------------------------------------
;-				Aliases					  -
;------------------------------------------

;empty?: :tail?
atan2: :arctangent2
object: :context


Some string tests added into the example

Red/System [
    Title:      "Red/System example file"
    Purpose:    "Just some code for testing Pygments colorizer"
    Language:   http://www.red-lang.org/
]

#include %../common/FPU-configuration.reds

; C types

#define time!                   long!
#define clock!                  long!

date!: alias struct! [
    second                      [integer!]  ; 0-61 (60?)
    minute                      [integer!]  ; 0-59
    hour                        [integer!]  ; 0-23

    day                         [integer!]  ; 1-31
    month                       [integer!]  ; 0-11
    year                        [integer!]  ; Since 1900

    weekday                     [integer!]  ; 0-6 since Sunday
    yearday                     [integer!]  ; 0-365
    daylight-saving-time?       [integer!]  ; Negative: unknown
]

#either OS = 'Windows [
    #define clocks-per-second   1000
][
    ; CLOCKS_PER_SEC value for Syllable, Linux (XSI-conformant systems)
    ; TODO: check for other systems
    #define clocks-per-second   1000'000
]

#import [LIBC-file cdecl [

    ; Error handling

    form-error: "strerror" [  ; Return error description.
        code            [integer!]
        return:         [c-string!]
    ]
    print-error: "perror" [  ; Print error to standard error output.
        string          [c-string!]
    ]

    ; Memory management

    make: "calloc" [  ; Allocate zero-filled memory.
        chunks          [size!]
        size            [size!]
        return:         [binary!]
    ]
    resize: "realloc" [  ; Resize memory allocation.
        memory          [binary!]
        size            [size!]
        return:         [binary!]
    ]
 ]

 JVM!: alias struct! [
    reserved0                   [int-ptr!]
    reserved1                   [int-ptr!]
    reserved2                   [int-ptr!]

    DestroyJavaVM               [function! [[JNICALL] vm [JVM-ptr!] return: [jint!]]]
    AttachCurrentThread         [function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] args [byte-ptr!] return: [jint!]]]
    DetachCurrentThread         [function! [[JNICALL] vm [JVM-ptr!] return: [jint!]]]
    GetEnv                      [function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] version [integer!] return: [jint!]]]
    AttachCurrentThreadAsDaemon [function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] args [byte-ptr!] return: [jint!]]]
]

 ;just some datatypes for testing:

 #some-hash
 10-1-2013
 quit

 ;binary:
 #{00FF0000}
 #{00FF0000 FF000000}
 #{00FF0000	FF000000} ;with tab instead of space
 2#{00001111}
 64#{/wAAAA==}
 64#{/wAAA A==} ;with space	 inside
 64#{/wAAA	A==} ;with tab inside

 ;string with char
 {bla ^(ff) foo}
 {bla ^(( foo}
 ;some numbers:
 12
 1'000
 1.2
 FF00FF00h

 ;some tests of hexa number notation with not common ending
 [ff00h ff00h] ff00h{} FFh"foo" 00h(1 + 2) (AEh)

;normal words:
foo char

;get-word
:foo

;lit-word:
'foo 'foo

to-integer foo
foo/(a + 1)/b

call/output reform ['which interpreter] path: copy ""

 version-1.1:   00010001h

 #if type = 'exe [
    push system/stack/frame                 ;-- save previous frame pointer
    system/stack/frame: system/stack/top    ;-- @@ reposition frame pointer just after the catch flag
]
push CATCH_ALL                              ;-- exceptions root barrier
push 0                                      ;-- keep stack aligned on 64-bit

Red/System [
    Title:      "Red/System example file"
    Purpose:    "Just some code for testing Pygments colorizer"
    Language:   http://www.red-lang.org/
]

#include %../common/FPU-configuration.reds

; C types

#define time!                   long!
#define clock!                  long!

date!: alias struct! [
    second                      [integer!]  ; 0-61 (60?)
    minute                      [integer!]  ; 0-59
    hour                        [integer!]  ; 0-23

    day                         [integer!]  ; 1-31
    month                       [integer!]  ; 0-11
    year                        [integer!]  ; Since 1900

    weekday                     [integer!]  ; 0-6 since Sunday
    yearday                     [integer!]  ; 0-365
    daylight-saving-time?       [integer!]  ; Negative: unknown
]

#either OS = 'Windows [
    #define clocks-per-second   1000
][
    ; CLOCKS_PER_SEC value for Syllable, Linux (XSI-conformant systems)
    ; TODO: check for other systems
    #define clocks-per-second   1000'000
]

#import [LIBC-file cdecl [

    ; Error handling

    form-error: "strerror" [  ; Return error description.
        code            [integer!]
        return:         [c-string!]
    ]
    print-error: "perror" [  ; Print error to standard error output.
        string          [c-string!]
    ]

    ; Memory management

    make: "calloc" [  ; Allocate zero-filled memory.
        chunks          [size!]
        size            [size!]
        return:         [binary!]
    ]
    resize: "realloc" [  ; Resize memory allocation.
        memory          [binary!]
        size            [size!]
        return:         [binary!]
    ]
 ]

 JVM!: alias struct! [
    reserved0                   [int-ptr!]
    reserved1                   [int-ptr!]
    reserved2                   [int-ptr!]

    DestroyJavaVM               [function! [[JNICALL] vm [JVM-ptr!] return: [jint!]]]
    AttachCurrentThread         [function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] args [byte-ptr!] return: [jint!]]]
    DetachCurrentThread         [function! [[JNICALL] vm [JVM-ptr!] return: [jint!]]]
    GetEnv                      [function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] version [integer!] return: [jint!]]]
    AttachCurrentThreadAsDaemon [function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] args [byte-ptr!] return: [jint!]]]
]

 ;just some datatypes for testing:

 #some-hash
 10-1-2013
 quit

 ;binary:
 #{00FF0000}
 #{00FF0000 FF000000}
 #{00FF0000	FF000000} ;with tab instead of space
 2#{00001111}
 64#{/wAAAA==}
 64#{/wAAA A==} ;with space inside
 64#{/wAAA	A==} ;with tab inside

 ;some numbers:
 12
 1'000
 1.2
 FF00FF00h

 ;some tests of hexa number notation with not common ending
 [ff00h ff00h] ff00h{} FFh"foo" 00h(1 + 2) (AEh)

;normal words:
foo char

;get-word
:foo

;lit-word:
'foo 'foo

to-integer foo
foo/(a + 1)/b

call/output reform ['which interpreter] path: copy ""

 version-1.1:   00010001h

 #if type = 'exe [
    push system/stack/frame                 ;-- save previous frame pointer
    system/stack/frame: system/stack/top    ;-- @@ reposition frame pointer just after the catch flag
]
push CATCH_ALL                              ;-- exceptions root barrier
push 0                                      ;-- keep stack aligned on 64-bit


TESTS: additional CASE/SWITCH tests fixes.

Red [
	Title:   "Red case function test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %case-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012, 2012 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "case"

===start-group=== "case basics"

	--test-- "case-basic-1"
	ci:  0
	cia: 1
	case [true [0]]
	--assert cia = 1

	--test-- "case-basic-2"
	ci:  1
	cia: 2
	case [ci = 1 [cia: 2]]
	--assert cia = 2

	--test-- "case-basic-3"
	ci:  1
	cia: 2
	case [true [cia: 3]]
	--assert cia = 3

	--test-- "case-basic-4"
	ci:  0
	cia: 2
	case [ci <> 0 [cia: 0] true [cia: 3]]
	--assert cia = 3

	--test-- "case-basic-5"
	ci:  99
	cia: 2
	case [ci = 1 [cia: 2] true [cia: 3]]
	--assert cia = 3

	--test-- "case-basic-6"
	ci:  0
	cia: 1
	cia: case [true [2]]
	--assert cia = 2

	--test-- "case-basic-7"
	ci:  0
	cia: 2
	cia: case [ci <> 0 [0] true [3]]
	--assert cia = 3

	--test-- "case-basic-8"
	ci:  1
	cia: 2
	cia: case [ci = 1 [3]]
	--assert cia = 3

	--test-- "case-basic-9"
	ci:  1
	cia: 2
	case [ci = 1 [case [ci <> 0 [cia: 3] true [cia: 4]]]]
	--assert cia = 3

	--test-- "case-basic-10"
	ci:  1
	cia: 2
	cia: case [ci = 1 [case [ci <> 0 [3] true [4]]]]
	--assert cia = 3

	--test-- "case-basic-11"
	ci:  1
	cia: 2
	cia: case [ci = 1 [switch/default ci [1 [3]][4]]]
	--assert cia = 3

===end-group===

===start-group=== "case basics local"

	case-fun: func [/local ci cia][
		--test-- "case-loc-1"
		ci:  0
		cia: 1
		case [true [0]]
		--assert cia = 1

		--test-- "case-loc-2"
		ci:  1
		cia: 2
		case [ci = 1 [cia: 2]]
		--assert cia = 2

		--test-- "case-loc-3"
		ci:  1
		cia: 2
		case [true [cia: 3]]
		--assert cia = 3

		--test-- "case-loc-4"
		ci:  0
		cia: 2
		case [ci <> 0 [cia: 0] true [cia: 3]]
		--assert cia = 3

		--test-- "case-loc-5"
		ci:  99
		cia: 2
		case [ci = 1 [cia: 2] true [cia: 3]]
		--assert cia = 3

		--test-- "case-loc-6"
		ci:  0
		cia: 1
		cia: case [true [2]]
		--assert cia = 2

		--test-- "case-loc-7"
		ci:  0
		cia: 2
		cia: case [ci <> 0 [0] true [3]]
		--assert cia = 3

		--test-- "case-loc-8"
		ci:  1
		cia: 2
		cia: case [ci = 1 [3]]
		--assert cia = 3

		--test-- "case-loc-9"
		ci:  1
		cia: 2
		case [ci = 1 [case [ci <> 0 [cia: 3] true [cia: 4]]]]
		--assert cia = 3

		--test-- "case-loc-10"
		ci:  1
		cia: 2
		cia: case [ci = 1 [case [ci <> 0 [3] true [4]]]]
		--assert cia = 3

		--test-- "case-loc-11"
		ci:  1
		cia: 2
		cia: case [ci = 1 [switch/default ci [1 [3]][4]]]
		--assert cia = 3
	]
	case-fun

===end-group===

===start-group=== "case integer!"

	--test-- "case-int-1"
	  ci: 1
	  cia: 0
	  case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 1 = cia

	--test-- "case-int-2"
	  ci: 2
	  cia: 0
	  case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 2 = cia

	--test-- "case-int-3"
	  ci: 3
	  cia: 0
	  case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 3 = cia

	--test-- "case-int-4"
	  ci: 9
	  cia: 0
	  case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	  --assert 3 = cia

	--test-- "case-int-5"
	  ci: 1
	--assert 1 = case [ ci = 1 [1] ci = 2 [2] true [3]]

	--test-- "case-int-6"
	  ci: 1
	  cres: case [ ci = 1 [1] ci = 2 [2] true [3]]
	--assert 1 = cres

	--test-- "case-int-7"
	  ci: 2
	--assert 2 = case [ ci = 1 [1] ci = 2 [2] true [3]]

	--test-- "case-int-8"
	  ci: 2
	  cres: case [ ci = 1 [1] ci = 2 [2] true [3]]
	--assert 2 = cres

	--test-- "case-int-9"
	  ci: 3
	--assert 3 = case [ ci = 1 [1] ci = 2 [2] true [3]]

	--test-- "case-int-10"
	  ci: 3
	  cres: case [ ci = 1 [1] ci = 2 [2] true [3]]
	--assert 3 = cres

	--test-- "case-int-11"
	  ci: 10
	--assert 3 = case [ ci = 1 [1] ci = 2 [2] true [3]]

	--test-- "case-int-12"
	  ci: 10
	  cres: case [ ci = 1 [1] ci = 2 [2] true [3]]
	--assert 3 = cres

	case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]

	--test-- "case-int-13"
	  ci: 1
	  cia: 0
	--assert 1 = case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]

	--test-- "case-int-14"
	  ci: 1
	  cia: 0
	  cres: case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 1 = cres

	--test-- "case-int-15"
	  ci: 2
	  cia: 0
	--assert 2 = case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]

	--test-- "case-int-16"
	  ci: 2
	  cia: 0
	  cres: case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 2 = cres

	--test-- "case-int-17"
	  ci: 3
	  cia: 0
	--assert 3 = case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]

	--test-- "case-int-18"
	  ci: 3
	  cia: 0
	  cres: case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 3 = cres

	--test-- "case-int-19"
	  ci: 9
	  cia: 0
	--assert 3 = case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]

	--test-- "case-int-20"
	  ci: 9
	  cia: 0
	  cres: case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 3 = cres

===end-group===

===start-group=== "case logic!"

  --test-- "case-logic-1"
    cl: true
  --assert case [ cl = true [true] cl = false [false] true [false]]

  --test-- "case-logic-2"
    cl: false
  --assert false = case [ cl = true [true] cl = false [false] true [true]]

===end-group===

~~~end-file~~~

Red [
	Title:   "Red case function test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %case-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012, 2012 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "case"

===start-group=== "case basics"

	--test-- "case-basic-1"
	ci:  0
	cia: 1
	case [true [0]]
	--assert cia = 1

	--test-- "case-basic-2"
	ci:  1
	cia: 2
	case [ci = 1 [cia: 2]]
	--assert cia = 2

	--test-- "case-basic-3"
	ci:  1
	cia: 2
	case [true [cia: 3]]
	--assert cia = 3

	--test-- "case-basic-4"
	ci:  0
	cia: 2
	case [ci <> 0 [cia: 0] true [cia: 3]]
	--assert cia = 3

	--test-- "case-basic-5"
	ci:  99
	cia: 2
	case [ci = 1 [cia: 2] true [cia: 3]]
	--assert cia = 3

	--test-- "case-basic-6"
	ci:  0
	cia: 1
	cia: case [true [2]]
	--assert cia = 2

	--test-- "case-basic-7"
	ci:  0
	cia: 2
	cia: case [ci <> 0 [0] true [3]]
	--assert cia = 3

	--test-- "case-basic-8"
	ci:  1
	cia: 2
	cia: case [ci = 1 [3]]
	--assert cia = 3

	--test-- "case-basic-9"
	ci:  1
	cia: 2
	case [ci = 1 [case [ci <> 0 [cia: 3] true [cia: 4]]]]
	--assert cia = 3

	--test-- "case-basic-10"
	ci:  1
	cia: 2
	cia: case [ci = 1 [case [ci <> 0 [3] true [4]]]]
	--assert cia = 3

	--test-- "case-basic-11"
	ci:  1
	cia: 2
	cia: case [ci = 1 [switch ci [1 [3] true [4]]]]
	--assert cia = 3

===end-group===

===start-group=== "case basics local"

	case-fun: func [/local ci cia][
		--test-- "case-loc-1"
		ci:  0
		cia: 1
		case [true [0]]
		--assert cia = 1

		--test-- "case-loc-2"
		ci:  1
		cia: 2
		case [ci = 1 [cia: 2]]
		--assert cia = 2

		--test-- "case-loc-3"
		ci:  1
		cia: 2
		case [true [cia: 3]]
		--assert cia = 3

		--test-- "case-loc-4"
		ci:  0
		cia: 2
		case [ci <> 0 [cia: 0] true [cia: 3]]
		--assert cia = 3

		--test-- "case-loc-5"
		ci:  99
		cia: 2
		case [ci = 1 [cia: 2] true [cia: 3]]
		--assert cia = 3

		--test-- "case-loc-6"
		ci:  0
		cia: 1
		cia: case [true [2]]
		--assert cia = 2

		--test-- "case-loc-7"
		ci:  0
		cia: 2
		cia: case [ci <> 0 [0] true [3]]
		--assert cia = 3

		--test-- "case-loc-8"
		ci:  1
		cia: 2
		cia: case [ci = 1 [3]]
		--assert cia = 3

		--test-- "case-loc-9"
		ci:  1
		cia: 2
		case [ci = 1 [case [ci <> 0 [cia: 3] true [cia: 4]]]]
		--assert cia = 3

		--test-- "case-loc-10"
		ci:  1
		cia: 2
		cia: case [ci = 1 [case [ci <> 0 [3] true [4]]]]
		--assert cia = 3

		--test-- "case-loc-11"
		ci:  1
		cia: 2
		cia: case [ci = 1 [switch ci [1 [3] default [4]]]]
		--assert cia = 3
	]
	case-fun

===end-group===

===start-group=== "case integer!"

	--test-- "case-int-1"
	  ci: 1
	  cia: 0
	  case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 1 = cia

	--test-- "case-int-2"
	  ci: 2
	  cia: 0
	  case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 2 = cia

	--test-- "case-int-3"
	  ci: 3
	  cia: 0
	  case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 3 = cia

	--test-- "case-int-4"
	  ci: 9
	  cia: 0
	  case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	  --assert 3 = cia

	--test-- "case-int-5"
	  ci: 1
	--assert 1 = case [ ci = 1 [1] ci = 2 [2] true [3]]

	--test-- "case-int-6"
	  ci: 1
	  cres: case [ ci = 1 [1] ci = 2 [2] true [3]]
	--assert 1 = cres

	--test-- "case-int-7"
	  ci: 2
	--assert 2 = case [ ci = 1 [1] ci = 2 [2] true [3]]

	--test-- "case-int-8"
	  ci: 2
	  cres: case [ ci = 1 [1] ci = 2 [2] true [3]]
	--assert 2 = cres

	--test-- "case-int-9"
	  ci: 3
	--assert 3 = case [ ci = 1 [1] ci = 2 [2] true [3]]

	--test-- "case-int-10"
	  ci: 3
	  cres: case [ ci = 1 [1] ci = 2 [2] true [3]]
	--assert 3 = cres

	--test-- "case-int-11"
	  ci: 10
	--assert 3 = case [ ci = 1 [1] ci = 2 [2] true [3]]

	--test-- "case-int-12"
	  ci: 10
	  cres: case [ ci = 1 [1] ci = 2 [2] true [3]]
	--assert 3 = cres

	case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]

	--test-- "case-int-13"
	  ci: 1
	  cia: 0
	--assert 1 = case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]

	--test-- "case-int-14"
	  ci: 1
	  cia: 0
	  cres: case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 1 = cres

	--test-- "case-int-15"
	  ci: 2
	  cia: 0
	--assert 2 = case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]

	--test-- "case-int-16"
	  ci: 2
	  cia: 0
	  cres: case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 2 = cres

	--test-- "case-int-17"
	  ci: 3
	  cia: 0
	--assert 3 = case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]

	--test-- "case-int-18"
	  ci: 3
	  cia: 0
	  cres: case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 3 = cres

	--test-- "case-int-19"
	  ci: 9
	  cia: 0
	--assert 3 = case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]

	--test-- "case-int-20"
	  ci: 9
	  cia: 0
	  cres: case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]
	--assert 3 = cres

===end-group===

===start-group=== "case logic!"

  --test-- "case-logic-1"
    cl: true
  --assert case [ cl = true [true] cl = false [false] true [false]]

  --test-- "case-logic-2"
    cl: false
  --assert false = case [ cl = true [true] cl = false [false] true [true]]

===end-group===

~~~end-file~~~