Missing comment

Missing comment

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

sigaction!: alias struct! [
	handler		[integer!]					;-- Warning: compiled as union on most UNIX
	mask0		[integer!]					;-- glibc/Hurd insane inheritage...
	mask1		[integer!]
	mask2		[integer!]
	mask3		[integer!]
	mask4		[integer!]
	mask5		[integer!]
	mask6		[integer!]
	mask7		[integer!]
	mask8		[integer!]
	mask9		[integer!]
	mask10		[integer!]
	mask11		[integer!]
	mask12		[integer!]
	mask13		[integer!]
	mask14		[integer!]
	mask15		[integer!]
	mask16		[integer!]
	mask17		[integer!]
	mask18		[integer!]
	mask19		[integer!]
	mask20		[integer!]
	mask21		[integer!]
	mask22		[integer!]
	mask23		[integer!]
	mask24		[integer!]
	mask25		[integer!]
	mask26		[integer!]
	mask27		[integer!]
	mask28		[integer!]
	mask29		[integer!]
	mask30		[integer!]
	mask31		[integer!]
	flags		[integer!]
]

siginfo!: alias struct! [
	signal		[integer!]
	error		[integer!]
	code		[integer!]
	address		[integer!]					;-- this field is a C union, dependent on signal
]

#import [									;-- mandatory C bindings
	LIBC-file cdecl [
		sigaction: "sigaction" [
			signum	[integer!]
			action	[sigaction!]
			oldact	[sigaction!]
			return: [integer!]
		]
	]
]

stdin:  0
stdout: 1
stderr: 2

#if use-natives? = yes [
	prin: func [s [c-string!] return: [integer!]][
		write stdout s length? s
	]
]

;-- Catching runtime errors --

;; sources:
;;		http://www.kernel.org/doc/man-pages/online/pages/man2/sigaction.2.html
;; 		http://fxr.watson.org/fxr/source/include/asm-generic/siginfo.h?v=linux-2.6;im=excerpts#L161

#define	SIGILL		 4						;-- Illegal instruction
#define SIGBUS		 7						;-- Bus access error
#define	SIGFPE		 8						;-- Floating point error
#define	SIGSEGV		11						;-- Segmentation violation

_ucontext!: alias struct! [					;@@ CPU-dependent
	flags 		[integer!]
	link		[_ucontext!]
	ss_sp		[byte-ptr!]					;-- stack_t struct inlined
	ss_flags	[integer!]
	ss_size		[integer!]
	gs			[integer!]					;-- sigcontext struct inlined
	fs			[integer!]
	es			[integer!]
	ds			[integer!]
	edi			[integer!]
	esi			[integer!]
	ebp			[integer!]
	esp			[integer!]
	ebx			[integer!]
	edx			[integer!]
	ecx			[integer!]
	eax			[integer!]
	trapno		[integer!]
	err			[integer!]
	eip			[integer!]
	cs			[integer!]
	eflags		[integer!]
	esp_at_sig	[integer!]
	ss			[integer!]
	fpstate		[int-ptr!]
	oldmask		[integer!]
	cr2			[integer!]
	;sigmask	[...]						;-- 128 byte array ignored
]

***-on-signal: func [
	[callback]
	signal	[integer!]
	info	[siginfo!]
	ctx		[_ucontext!]
	/local code error
][
	error: 99								;-- default unknown error
	code: info/code

	if signal = SIGILL [
		if code = 1 [error: 17]				;-- illegal opcode
		if code = 2 [error: 23]				;-- illegal operand
		if code = 3 [error: 24]				;-- illegal addressing mode
		if code = 4 [error: 25]				;-- illegal trap
		if code = 5 [error: 15]				;-- privileged opcode
		if code = 6 [error: 31]				;-- privileged register
		if code = 7 [error: 26]				;-- coprocessor error
		if code = 8 [error: 19]				;-- internal stack error
	]
	if signal = SIGBUS [
		if code = 1 [error:  2]				;-- invalid address alignment
		if code = 2 [error: 27]				;-- non-existant physical address
		if code = 3 [error: 28]				;-- object specific hardware error
		if code = 4 [error: 29]				;-- hardware memory error consumed (action required)
		if code = 5 [error: 30]				;-- hardware memory error consumed (action optional)
	]
	if signal = SIGFPE [
		if code = 1 [error: 13]				;-- integer divide by zero
		if code = 2 [error: 14]				;-- integer overflow
		if code = 3 [error:  7]				;-- floating point divide by zero
		if code = 4 [error: 10]				;-- floating point overflow
		if code = 5 [error: 12]				;-- floating point underflow
		if code = 6 [error:  8]				;-- floating point inexact result
		if code = 7 [error:  9]				;-- floating point invalid operation
		if code = 8 [error:  5]				;-- subscript out of range
	]
	if signal = SIGSEGV [
		if code = 1 [error:  1]				;-- address not mapped to object
		if code = 2 [error: 16]				;-- invalid permissions for mapped object
	]

	***-on-quit error ctx/eip
]

__sigaction-options: declare sigaction!

__sigaction-options/handler: 	as-integer :***-on-signal
__sigaction-options/flags: 		SA_SIGINFO ;or SA_RESTART

sigaction SIGILL  __sigaction-options as sigaction! 0
sigaction SIGBUS  __sigaction-options as sigaction! 0
sigaction SIGFPE  __sigaction-options as sigaction! 0
sigaction SIGSEGV __sigaction-options as sigaction! 0

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

sigaction!: alias struct! [
	handler		[integer!]					;-- Warning: compiled as union on most UNIX
	mask0		[integer!]					;-- glibc/Hurd insane inheritage...
	mask1		[integer!]
	mask2		[integer!]
	mask3		[integer!]
	mask4		[integer!]
	mask5		[integer!]
	mask6		[integer!]
	mask7		[integer!]
	mask8		[integer!]
	mask9		[integer!]
	mask10		[integer!]
	mask11		[integer!]
	mask12		[integer!]
	mask13		[integer!]
	mask14		[integer!]
	mask15		[integer!]
	mask16		[integer!]
	mask17		[integer!]
	mask18		[integer!]
	mask19		[integer!]
	mask20		[integer!]
	mask21		[integer!]
	mask22		[integer!]
	mask23		[integer!]
	mask24		[integer!]
	mask25		[integer!]
	mask26		[integer!]
	mask27		[integer!]
	mask28		[integer!]
	mask29		[integer!]
	mask30		[integer!]
	mask31		[integer!]
	flags		[integer!]
]

siginfo!: alias struct! [
	signal		[integer!]
	error		[integer!]
	code		[integer!]
	address		[integer!]					;-- this field is a C union, dependent on signal
]

#import [									;-- mandatory C bindings
	LIBC-file cdecl [
		sigaction: "sigaction" [
			signum	[integer!]
			action	[sigaction!]
			oldact	[sigaction!]
			return: [integer!]
		]
	]
]

stdin:  0
stdout: 1
stderr: 2

#if use-natives? = yes [
	prin: func [s [c-string!] return: [integer!]][
		write stdout s length? s
	]
]

;-- Catching runtime errors --

;; sources:
;;		http://www.kernel.org/doc/man-pages/online/pages/man2/sigaction.2.html
;; 		http://fxr.watson.org/fxr/source/include/asm-generic/siginfo.h?v=linux-2.6;im=excerpts#L161

#define	SIGILL		 4						;-- Illegal instruction
#define SIGBUS		 7						;-- Bus access error
#define	SIGFPE		 8						;-- Floating point error
#define	SIGSEGV		11						;-- Segmentation violation

_ucontext!: alias struct! [
	flags 		[integer!]
	link		[_ucontext!]
	ss_sp		[byte-ptr!]					;-- stack_t struct inlined
	ss_flags	[integer!]
	ss_size		[integer!]
	gs			[integer!]					;-- sigcontext struct inlined
	fs			[integer!]
	es			[integer!]
	ds			[integer!]
	edi			[integer!]
	esi			[integer!]
	ebp			[integer!]
	esp			[integer!]
	ebx			[integer!]
	edx			[integer!]
	ecx			[integer!]
	eax			[integer!]
	trapno		[integer!]
	err			[integer!]
	eip			[integer!]
	cs			[integer!]
	eflags		[integer!]
	esp_at_sig	[integer!]
	ss			[integer!]
	fpstate		[int-ptr!]
	oldmask		[integer!]
	cr2			[integer!]
	;sigmask	[...]						;-- 128 byte array ignored
]

***-on-signal: func [
	[callback]
	signal	[integer!]
	info	[siginfo!]
	ctx		[_ucontext!]
	/local code error
][
	error: 99								;-- default unknown error
	code: info/code

	if signal = SIGILL [
		if code = 1 [error: 17]				;-- illegal opcode
		if code = 2 [error: 23]				;-- illegal operand
		if code = 3 [error: 24]				;-- illegal addressing mode
		if code = 4 [error: 25]				;-- illegal trap
		if code = 5 [error: 15]				;-- privileged opcode
		if code = 6 [error: 31]				;-- privileged register
		if code = 7 [error: 26]				;-- coprocessor error
		if code = 8 [error: 19]				;-- internal stack error
	]
	if signal = SIGBUS [
		if code = 1 [error:  2]				;-- invalid address alignment
		if code = 2 [error: 27]				;-- non-existant physical address
		if code = 3 [error: 28]				;-- object specific hardware error
		if code = 4 [error: 29]				;-- hardware memory error consumed (action required)
		if code = 5 [error: 30]				;-- hardware memory error consumed (action optional)
	]
	if signal = SIGFPE [
		if code = 1 [error: 13]				;-- integer divide by zero
		if code = 2 [error: 14]				;-- integer overflow
		if code = 3 [error:  7]				;-- floating point divide by zero
		if code = 4 [error: 10]				;-- floating point overflow
		if code = 5 [error: 12]				;-- floating point underflow
		if code = 6 [error:  8]				;-- floating point inexact result
		if code = 7 [error:  9]				;-- floating point invalid operation
		if code = 8 [error:  5]				;-- subscript out of range
	]
	if signal = SIGSEGV [
		if code = 1 [error:  1]				;-- address not mapped to object
		if code = 2 [error: 16]				;-- invalid permissions for mapped object
	]

	***-on-quit error ctx/eip
]

__sigaction-options: declare sigaction!

__sigaction-options/handler: 	as-integer :***-on-signal
__sigaction-options/flags: 		SA_SIGINFO ;or SA_RESTART

sigaction SIGILL  __sigaction-options as sigaction! 0
sigaction SIGBUS  __sigaction-options as sigaction! 0
sigaction SIGFPE  __sigaction-options as sigaction! 0
sigaction SIGSEGV __sigaction-options as sigaction! 0


FIX: PICK fixed to return none value if bounds are passed.

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

block: context [
	verbose: 0

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

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

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

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

		s: GET_BUFFER(blk)

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

		offset
	]

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

		arg: as red-block! stack/arguments
		assert TYPE_OF(arg) = TYPE_BLOCK

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

		arg
	]

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

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

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

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

	;--- Actions ---

	make: func [

	][

	]

	append: func [
		return: [red-block!]
		/local
			blk	[red-block!]
	][
		;@@ implement /part and /only support
		blk: as red-block! stack/arguments

		copy-cell
			stack/arguments + 1
			ALLOC_TAIL(blk)
		blk
	]

	mold: func [
		part	[integer!]
	][

	]

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

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

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

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

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

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

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

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

		blk: as red-block! stack/arguments
		index: as red-integer! blk + 1
		s: GET_BUFFER(blk)

		offset: blk/head + index/value - 1				;-- index is one-based
		stack/push-last either any [
			negative? offset
			s/offset + offset > s/tail
		][
			 none-value
		][
			s/offset + offset
		]
	]

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

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

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

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

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

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

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

		s: GET_BUFFER(blk)

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

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

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

block: context [
	verbose: 0

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

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

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

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

		s: GET_BUFFER(blk)

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

		offset
	]

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

		arg: as red-block! stack/arguments
		assert TYPE_OF(arg) = TYPE_BLOCK

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

		arg
	]

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

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

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

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

	;--- Actions ---

	make: func [

	][

	]

	append: func [
		return: [red-block!]
		/local
			blk	[red-block!]
	][
		;@@ implement /part and /only support
		blk: as red-block! stack/arguments

		copy-cell
			stack/arguments + 1
			ALLOC_TAIL(blk)
		blk
	]

	mold: func [
		part	[integer!]
	][

	]

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

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

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

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

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

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

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

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

		blk: as red-block! stack/arguments

		s: GET_BUFFER(blk)

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

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

		blk: as red-block! stack/arguments
		s: GET_BUFFER(blk)
		stack/push-last s/offset + get-position 1
	]

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

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

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

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

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

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

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

		s: GET_BUFFER(blk)

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

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


FIX: issue #274 (Inlined PRINT broken)

FIX: issue #274 (Inlined PRINT broken)

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

#define __LC_CTYPE 0
#define __LC_ALL   6

#import [
	LIBC-file cdecl [
		wprintf: "wprintf" [
			[variadic]
			return: 	[integer!]
		]
		setlocale: "setlocale" [
			category	[integer!]
			locale		[c-string!]
			return:		[c-string!]
		]
	]
]

;-------------------------------------------
;-- Print a UCS-4 string to console
;-------------------------------------------
print-UCS4: func [
	str 	[int-ptr!]									;-- zero-terminated UCS-4 string
	/local
		cp [integer!]
][
	assert str <> null

	while [cp: str/value not zero? cp][
		case [
			cp <= 7Fh [
				putchar as-byte cp
			]
			cp <= 07FFh [
				putchar as-byte cp >> 6 or C0h
				putchar as-byte cp and 3Fh or 80h
			]
			cp <= FFFFh [
				putchar as-byte cp >> 12 or E0h
				putchar as-byte cp >> 6 and 3Fh or 80h
				putchar as-byte cp and 3Fh or 80h
			]
			cp <= 001FFFFFh [
				putchar as-byte cp >> 18 or F0h
				putchar as-byte cp >> 12 and 3Fh or 80h
				putchar as-byte cp >>  6 and 3Fh or 80h
				putchar as-byte cp and 3Fh or 80h
			]
			true [
				print-line "Error in print-UCS4: codepoint > 1FFFFFh"
			]
		]
		str: str + 2
	]
]

;-------------------------------------------
;-- Print a UCS-4 string to console
;-------------------------------------------
print-line-UCS4: func [
	str    [int-ptr!]									;-- zero-terminated UCS-4 string
	/local
		cp [integer!]									;-- codepoint
][
	assert str <> null

	print-UCS4 str										;@@ throw an error on failure
	putchar as-byte 10									;-- newline
]

;-------------------------------------------
;-- Print a UCS-2 string to console
;-------------------------------------------
print-UCS2: func [
	str 	[byte-ptr!]									;-- zero-terminated UCS-2 string
	/local
		cp [integer!]
][
	assert str <> null

	while [
		cp: as-integer str/2
		cp: cp << 8 + str/1
		not zero? cp
	][
		case [
			cp <= 7Fh [
				putchar as-byte cp
			]
			cp <= 07FFh [
				putchar as-byte cp >> 6 or C0h
				putchar as-byte cp and 3Fh or 80h
			]
			true [
				putchar as-byte cp >> 12 or E0h
				putchar as-byte cp >> 6 and 3Fh or 80h
				putchar as-byte cp and 3Fh or 80h
			]
		]
		str: str + 2
	]
]

;-------------------------------------------
;-- Print a UCS-2 string with newline to console
;-------------------------------------------
print-line-UCS2: func [
	str 	[byte-ptr!]									;-- zero-terminated UCS-2 string
][
	assert str <> null
	print-UCS2 str
	putchar as-byte 10									;-- newline
]

;-------------------------------------------
;-- Print a Latin-1 string to console
;-------------------------------------------
print-Latin1: func [
	str 	[c-string!]									;-- zero-terminated Latin-1 string
][
	assert str <> null
	prin str
]

;-------------------------------------------
;-- Print a Latin-1 string with newline to console
;-------------------------------------------
print-line-Latin1: func [
	str [c-string!]										;-- zero-terminated Latin-1 string
][
	assert str <> null
	prin str
	putchar as-byte 10									;-- newline
]

;-------------------------------------------
;-- Red/System Unicode replacement printing functions
;-------------------------------------------

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]									;-- UTF-8 literal string
	i
]

prin-hex: func [i [integer!] return: [integer!]][
	printf ["%08X" i]									;-- UTF-8 literal string
	i
]

prin-float: func [f [float!] return: [float!]][
	printf ["%.14g" f]									;-- UTF-8 literal string
	f
]

prin-float32: func [f [float32!] return: [float32!]][
	printf ["%.7g" as-float f]							;-- UTF-8 literal string
	f
]

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

#define __LC_CTYPE 0
#define __LC_ALL   6

#import [
	LIBC-file cdecl [
		wprintf: "wprintf" [
			[variadic]
			return: 	[integer!]
		]
		setlocale: "setlocale" [
			category	[integer!]
			locale		[c-string!]
			return:		[c-string!]
		]
	]
]

;-------------------------------------------
;-- Print a UCS-4 string to console
;-------------------------------------------
print-UCS4: func [
	str 	[int-ptr!]									;-- zero-terminated UCS-4 string
	/local
		cp [integer!]
][
	assert str <> null

	while [cp: str/value not zero? cp][
		case [
			cp <= 7Fh [
				putchar as-byte cp
			]
			cp <= 07FFh [
				putchar as-byte cp >> 6 or C0h
				putchar as-byte cp and 3Fh or 80h
			]
			cp <= FFFFh [
				putchar as-byte cp >> 12 or E0h
				putchar as-byte cp >> 6 and 3Fh or 80h
				putchar as-byte cp and 3Fh or 80h
			]
			cp <= 001FFFFFh [
				putchar as-byte cp >> 18 or F0h
				putchar as-byte cp >> 12 and 3Fh or 80h
				putchar as-byte cp >>  6 and 3Fh or 80h
				putchar as-byte cp and 3Fh or 80h
			]
			true [
				print-line "Error in print-UCS4: codepoint > 1FFFFFh"
			]
		]
		str: str + 2
	]
]

;-------------------------------------------
;-- Print a UCS-4 string to console
;-------------------------------------------
print-line-UCS4: func [
	str    [int-ptr!]									;-- zero-terminated UCS-4 string
	/local
		cp [integer!]									;-- codepoint
][
	assert str <> null

	print-UCS4 str										;@@ throw an error on failure
	putchar as-byte 10									;-- newline
]

;-------------------------------------------
;-- Print a UCS-2 string to console
;-------------------------------------------
print-UCS2: func [
	str 	[byte-ptr!]									;-- zero-terminated UCS-2 string
	/local
		cp [integer!]
][
	assert str <> null

	while [
		cp: as-integer str/2
		cp: cp << 8 + str/1
		not zero? cp
	][
		case [
			cp <= 7Fh [
				putchar as-byte cp
			]
			cp <= 07FFh [
				putchar as-byte cp >> 6 or C0h
				putchar as-byte cp and 3Fh or 80h
			]
			true [
				putchar as-byte cp >> 12 or E0h
				putchar as-byte cp >> 6 and 3Fh or 80h
				putchar as-byte cp and 3Fh or 80h
			]
		]
		str: str + 2
	]
]

;-------------------------------------------
;-- Print a UCS-2 string with newline to console
;-------------------------------------------
print-line-UCS2: func [
	str 	[byte-ptr!]									;-- zero-terminated UCS-2 string
][
	assert str <> null
	print-UCS2 str
	putchar as-byte 10									;-- newline
]

;-------------------------------------------
;-- Print a Latin-1 string to console
;-------------------------------------------
print-Latin1: func [
	str 	[c-string!]									;-- zero-terminated Latin-1 string
][
	assert str <> null
	prin str
]

;-------------------------------------------
;-- Print a Latin-1 string with newline to console
;-------------------------------------------
print-line-Latin1: func [
	str [c-string!]										;-- zero-terminated Latin-1 string
][
	assert str <> null
	prin str
	putchar as-byte 10									;-- newline
]

;-------------------------------------------
;-- Red/System Unicode replacement printing functions
;-------------------------------------------

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!]][
	wprintf ["%i" i]									;-- UTF-8 literal string
	i
]

prin-hex: func [i [integer!] return: [integer!]][
	wprintf ["%08X" i]									;-- UTF-8 literal string
	i
]

prin-float: func [f [float!] return: [float!]][
	wprintf ["%.14g" f]									;-- UTF-8 literal string
	f
]

prin-float32: func [f [float32!] return: [float32!]][
	wprintf ["%.7g" as-float f]							;-- UTF-8 literal string
	f
]


r340: Fixing a link to the demo

r340: Fixing a link to the demo

h1. What is CruiseControl.rb?

CruiseControl.rb is a continuous integration tool. Its basic purpose in life is to alert members of a software project
when one of them checks something into source control that breaks the build.

CC.rb is easy to install, pleasant to use and simple to hack. It's written in "Ruby":http://www.ruby-lang.org/en/.

p(hint). Hint: "Martin Fowler":http://martinfowler.com/ explains the how and why of Continuous Integration in this
         "article":http://martinfowler.com/articles/continuousIntegration.html.

h1. Feature list

* Can be installed in 10 minutes.

* Works out of the box with a regular "Ruby":http://www.ruby-lang.org/en/ or "Ruby on Rails":http://rubyonrails.org
  project. No configuration necessary.

* Web-based dashboard, convenient, useful and pretty.

* When a build is broken or fixed, notifies users via email, instant messaging or
  "CCTray":http://ccnet.sourceforge.net/CCNET/CCTray.html.

* RSS feed to track the build status of your favourite projects.

* Jump to the code causing a build error in one click.

* Displays custom build artifacts. No configuration necessary.

* Can interoperate with any build tool that can be invoked through command line and returns a non-zero exit code if
  the build fails. Like:
** nant
** ant
** etc...

* Extendable through builder plugins, custom build schedulers and other configuration options.

* Infinitely hackable thanks to publicly available source code and Ruby open classes.

* Free as in "free beer".

h1. Demo site

"Here":http://cruisecontrolrb.thoughtworks.com/projects is a public CruiseControl.rb instance
building itself and some other open-source projects.

Next step: "download":download.html CruiseControl.rb

h1. What is CruiseControl.rb?

CruiseControl.rb is a continuous integration tool. Its basic purpose in life is to alert members of a software project
when one of them checks something into source control that breaks the build.

CC.rb is easy to install, pleasant to use and simple to hack. It's written in "Ruby":http://www.ruby-lang.org/en/.

p(hint). Hint: "Martin Fowler":http://martinfowler.com/ explains the how and why of Continuous Integration in this
         "article":http://martinfowler.com/articles/continuousIntegration.html.

h1. Feature list

* Can be installed in 10 minutes.

* Works out of the box with a regular "Ruby":http://www.ruby-lang.org/en/ or "Ruby on Rails":http://rubyonrails.org
  project. No configuration necessary.

* Web-based dashboard, convenient, useful and pretty.

* When a build is broken or fixed, notifies users via email, instant messaging or
  "CCTray":http://ccnet.sourceforge.net/CCNET/CCTray.html.

* RSS feed to track the build status of your favourite projects.

* Jump to the code causing a build error in one click.

* Displays custom build artifacts. No configuration necessary.

* Can interoperate with any build tool that can be invoked through command line and returns a non-zero exit code if
  the build fails. Like:
** nant
** ant
** etc...

* Extendable through builder plugins, custom build schedulers and other configuration options.

* Infinitely hackable thanks to publicly available source code and Ruby open classes.

* Free as in "free beer".

h1. Demo site

"Here":http://cruisecontrolrb.thoughtworks.com/ is a public CruiseControl.rb instance building itself
and some other open-source projects.

Next step: "download":download.html CruiseControl.rb


FIX: changed default word value in context from `none` to `unset`.

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!]
		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
		sym:	symbol/resolve sym

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

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

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

		sym: alloc-tail as series! ctx/symbols/value
		copy-cell as cell! word sym

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

		series: as series! ctx/values/value
		(as-integer series/tail - series/offset) >> 4 - 1
	]

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

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

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

		if word/index = -1 [
			word/index: find-word word/ctx word/symbol
		]
		values: as series! word/ctx/values/value
		copy-cell value values/offset + word/index
	]

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

		if any [										;-- ensure word is properly bound to a context
			null? word/ctx
			word/index = -1
		][
			sym: symbol/get word/symbol
			print-line [
				"*** Error: word '" sym/cache " has no value"
			]
			halt
		]
		values: as series! word/ctx/values/value
		values/offset + word/index
	]

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

		if zero? slots [slots: 1]
		cell: as red-context! ALLOC_TAIL(blk)
		cell/header: TYPE_CONTEXT						;-- implicit reset of all header flags
		cell/symbols: alloc-series slots 16 0			;-- force offset at head of buffer

		either stack? [
			cell/values: null							;TBD: complete this code branch
		][
			cell/values: alloc-cells slots
		]
		cell
	]

	make: func [
		spec	[red-block!]
		stack?	[logic!]
		return:	[red-context!]
		/local
			ctx	[red-context!]
			cell [red-value!]
			slot [red-value!]
			s	 [series!]
			type [integer!]
	][
		ctx: create root block/rs-length? spec stack?
		s: GET_BUFFER(spec)
		cell: s/offset

		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: alloc-tail as series! ctx/symbols/value
				copy-cell cell slot
				slot/header: TYPE_WORD
			]
			cell: cell + 1
		]
		ctx
	]

	;-- Actions --

	datatype/register [
		TYPE_CONTEXT
		TYPE_VALUE
		"context!"
		;-- General actions --
		null			;make
		null			;random
		null			;reflect
		null			;to
		null			;form
		null			;mold
		null			;get-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!]
		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
		sym:	symbol/resolve sym

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

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

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

		sym: alloc-tail as series! ctx/symbols/value
		copy-cell as cell! word sym

		value: alloc-tail as series! ctx/values/value
		value/header: TYPE_NONE

		series: as series! ctx/values/value
		(as-integer series/tail - series/offset) >> 4 - 1
	]

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

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

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

		if word/index = -1 [
			word/index: find-word word/ctx word/symbol
		]
		values: as series! word/ctx/values/value
		copy-cell value values/offset + word/index
	]

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

		if any [										;-- ensure word is properly bound to a context
			null? word/ctx
			word/index = -1
		][
			sym: symbol/get word/symbol
			print-line [
				"*** Error: word '" sym/cache " has no value"
			]
			halt
		]
		values: as series! word/ctx/values/value
		values/offset + word/index
	]

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

		if zero? slots [slots: 1]
		cell: as red-context! ALLOC_TAIL(blk)
		cell/header: TYPE_CONTEXT						;-- implicit reset of all header flags
		cell/symbols: alloc-series slots 16 0			;-- force offset at head of buffer

		either stack? [
			cell/values: null							;TBD: complete this code branch
		][
			cell/values: alloc-cells slots
		]
		cell
	]

	make: func [
		spec	[red-block!]
		stack?	[logic!]
		return:	[red-context!]
		/local
			ctx	[red-context!]
			cell [red-value!]
			slot [red-value!]
			s	 [series!]
			type [integer!]
	][
		ctx: create root block/rs-length? spec stack?
		s: GET_BUFFER(spec)
		cell: s/offset

		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: alloc-tail as series! ctx/symbols/value
				copy-cell cell slot
				slot/header: TYPE_WORD
			]
			cell: cell + 1
		]
		ctx
	]

	;-- Actions --

	datatype/register [
		TYPE_CONTEXT
		TYPE_VALUE
		"context!"
		;-- General actions --
		null			;make
		null			;random
		null			;reflect
		null			;to
		null			;form
		null			;mold
		null			;get-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
	]
]


TESTS: fixed invalid CASE tests.

TESTS: fixed invalid CASE tests.

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~~~

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] default [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!"

#define case-int-1 [case [ ci = 1 [cia: 1] ci = 2 [cia: 2] true [cia: 3]]]

	--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~~~