remove unused globals

remove unused globals

% Parser generator using LALR techniques as used by yacc etc

module lalr;

% Author: Arthur Norman

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

% $Id: lalr.red 3137 2015-06-15 09:45:01Z arthurcnorman $

% The module genparser contains code that can create LALR parsing
% tables, while yyparse has a hand-written lexer suitable for use with
% Rlisp syntax together with the skeleton of an LR parser which can use
% the tables that are generated by genparser.

create!-package('(lalr genparser genparserprint yylex yyparse), nil);

switch tracelex, lalr_verbose;

global '(lex_char yylval last64 last64p which_line if_depth);
global '(next_lex_code);
global '(dot_char rpar_char rsquare_char);

#if (memq 'psl lispsystem!*)

% CSL has special vectors that hold just 8-bit integers (it also has ones
% for 16-bit integers) and use of those will decrease the amount of
% memory consumed by the parser tables. However if PSL does not have these
% it does not matter much since I can just use ordinary Lisp vectors...
% I set initial contents as all 0 rather than all nil since these are
% supposed to contain (small) integer values.

symbolic procedure mkvect8 n;
  begin
    scalar r;
    r := mkvect n;
    for i := 0:n do putv(r, i, 0);
    return r
  end;

inline procedure putv8(v, n, x); putv(v, n, x);

inline procedure getv8(v, n); getv(v, n);

procedure mkvect16 n;
  begin
    scalar r;
    r := mkvect n;
    for i := 0:n do putv(r, i, 0);
    return r
  end;

inline procedure putv16(v, n, x); putv(v, n, x);

inline procedure getv16(v, n); getv(v, n);

% Other CSL-isms that need simulation in PSL.

% If PSL does not have built-in hash tables I will model the
% effect that they provide using association lists. To arrange that
% a "table" can be updated in place I will have a list of length 1
% whose sole element is the association list. This code just uses
% EQUAL tests for hash table membership.

symbolic procedure mkhash(size, equality_mode, expansion_factor);
   list nil;

symbolic procedure puthash(key, table, value);
  begin
    scalar w;
    w := assoc(key, car table);
    if w then rplacd(w, value)
    else rplaca(table, (key . value) . car table);
    return value
  end;

symbolic procedure gethash(key, table);
  begin
    scalar w;
    w := assoc(key, car table);
    if w then return cdr w
    else return nil
  end;

symbolic procedure hashcontents table;
  car table;

symbolic procedure ttab n;
  tab n;

load gsort; % Not loaded by default and not autoloaded on demand.

symbolic procedure sort(ll, ff);
  gsort(ll, ff);

#endif

endmodule;

end;

% Parser generator using LALR techniques as used by yacc etc

module lalr;

% Author: Arthur Norman

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

% $Id: lalr.red 3137 2015-06-15 09:45:01Z arthurcnorman $

% The module genparser contains code that can create LALR parsing
% tables, while yyparse has a hand-written lexer suitable for use with
% Rlisp syntax together with the skeleton of an LR parser which can use
% the tables that are generated by genparser.

create!-package('(lalr genparser genparserprint yylex yyparse), nil);

switch tracelex, lalr_verbose;

global '(lex_char yylval last64 last64p which_line if_depth);
global '(next_lex_code);
global '(dot_char rpar_char rsquare_char);

global '(goto_index goto_old_state goto_new_state);
global '(action_index, action_terminal action_result);
global '(action_first_error action_error_messages);
global '(action_fn action_a action_n);

global '(terminals non_terminals symbols goto_cache action_map);
fluid '(renamings);

#if (memq 'psl lispsystem!*)

% CSL has special vectors that hold just 8-bit integers (it also has ones
% for 16-bit integers) and use of those will decrease the amount of
% memory consumed by the parser tables. However if PSL does not have these
% it does not matter much since I can just use ordinary Lisp vectors...
% I set initial contents as all 0 rather than all nil since these are
% supposed to contain (small) integer values.

symbolic procedure mkvect8 n;
  begin
    scalar r;
    r := mkvect n;
    for i := 0:n do putv(r, i, 0);
    return r
  end;

inline procedure putv8(v, n, x); putv(v, n, x);

inline procedure getv8(v, n); getv(v, n);

procedure mkvect16 n;
  begin
    scalar r;
    r := mkvect n;
    for i := 0:n do putv(r, i, 0);
    return r
  end;

inline procedure putv16(v, n, x); putv(v, n, x);

inline procedure getv16(v, n); getv(v, n);

% Other CSL-isms that need simulation in PSL.

% If PSL does not have built-in hash tables I will model the
% effect that they provide using association lists. To arrange that
% a "table" can be updated in place I will have a list of length 1
% whose sole element is the association list. This code just uses
% EQUAL tests for hash table membership.

symbolic procedure mkhash(size, equality_mode, expansion_factor);
   list nil;

symbolic procedure puthash(key, table, value);
  begin
    scalar w;
    w := assoc(key, car table);
    if w then rplacd(w, value)
    else rplaca(table, (key . value) . car table);
    return value
  end;

symbolic procedure gethash(key, table);
  begin
    scalar w;
    w := assoc(key, car table);
    if w then return cdr w
    else return nil
  end;

symbolic procedure hashcontents table;
  car table;

symbolic procedure ttab n;
  tab n;

load gsort; % Not loaded by default and not autoloaded on demand.

symbolic procedure sort(ll, ff);
  gsort(ll, ff);

#endif

endmodule;

end;


FIX: possible memory corruptions occuring due to missed series expansion.

Red/System [
	Title:   "Common datatypes utility functions"
	Author:  "Nenad Rakocevic"
	File: 	 %common.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
	}
]

names!: alias struct! [
	buffer	[c-string!]								;-- datatype name string
	size	[integer!]								;-- buffer size - 1 (not counting terminal `!`)
	word	[red-word!]								;-- datatype name as word! value
]

name-table:   declare names! 						;-- datatype names table
action-table: declare int-ptr!						;-- actions jump table

set-type: func [										;@@ convert to macro?
	cell [cell!]
	type [integer!]
][
	cell/header: cell/header and type-mask or type
]

alloc-at-tail: func [
	blk		[red-block!]
	return: [cell!]
][
	alloc-tail as series! blk/node/value
]

alloc-tail: func [
	s		 [series!]
	return:  [cell!]
	/local
		cell [red-value!]
][
	if (as byte-ptr! s/tail + 1) >= ((as byte-ptr! s + 1) + s/size) [
		s: expand-series s 0
	]

	cell: s/tail
	;-- ensure that cell is within series upper boundary
	assert (as byte-ptr! cell) < ((as byte-ptr! s + 1) + s/size)

	s/tail: cell + 1									;-- move tail to next cell
	cell
]

alloc-tail-unit: func [
	s		 [series!]
	unit 	 [integer!]
	return:  [byte-ptr!]
	/local
		p	 [byte-ptr!]
][
	if ((as byte-ptr! s/tail) + unit) >= ((as byte-ptr! s + 1) + s/size) [
		s: expand-series s 0
	]

	p: as byte-ptr! s/tail
	;-- ensure that cell is within series upper boundary
	assert p < ((as byte-ptr! s + 1) + s/size)

	s/tail: as cell! p + unit							;-- move tail to next unit slot
	p
]

copy-cell: func [
	src		[cell!]
	dst		[cell!]
	return: [red-value!]
][
	copy-memory											;@@ optimize for 16 bytes copying
		as byte-ptr! dst
		as byte-ptr! src
		size? cell!
	dst
]

words: context [
	spec:			-1
	body:			-1
	words:			-1
	logic!:			-1
	integer!:		-1
	any-type!:		-1
	repeat:			-1
	foreach:		-1
	map-each:		-1
	remove-each:	-1
	exit*:			-1
	return*:		-1
	self:			-1
	values:			-1

	any*:			-1
	break*:			-1
	copy:			-1
	end:			-1
	fail:			-1
	into:			-1
	opt:			-1
	not*:			-1
	quote:			-1
	reject:			-1
	set:			-1
	skip:			-1
	some:			-1
	thru:			-1
	to:				-1
	none:			-1
	pipe:			-1
	dash:			-1
	then:			-1
	if*:			-1
	remove:			-1
	while*:			-1
	insert:			-1
	only:			-1
	collect:		-1
	keep:			-1
	ahead:			-1

	_body:			as red-word! 0
	_windows:		as red-word! 0
	_syllable:		as red-word! 0
	_macosx:		as red-word! 0
	_linux:			as red-word! 0

	_push:			as red-word! 0
	_pop:			as red-word! 0
	_fetch:			as red-word! 0
	_match:			as red-word! 0
	_iterate:		as red-word! 0
	_paren:			as red-word! 0
	_anon:			as red-word! 0
	_end:			as red-word! 0

	_on-parse-event: as red-word! 0

	build: does [
		spec:			symbol/make "spec"
		body:			symbol/make "body"
		words:			symbol/make "words"
		logic!:			symbol/make "logic!"
		integer!:		symbol/make "integer!"
		any-type!:		symbol/make "any-type!"
		exit*:			symbol/make "exit"
		return*:		symbol/make "return"

		windows:		symbol/make "Windows"
		syllable:		symbol/make "Syllable"
		macosx:			symbol/make "MacOSX"
		linux:			symbol/make "Linux"

		repeat:			symbol/make "repeat"
		foreach:		symbol/make "foreach"
		map-each:		symbol/make "map-each"
		remove-each:	symbol/make "remove-each"

		any*:			symbol/make "any"
		break*:			symbol/make "break"
		copy:			symbol/make "copy"
		end:			symbol/make "end"
		fail:			symbol/make "fail"
		into:			symbol/make "into"
		opt:			symbol/make "opt"
		not*:			symbol/make "not"
		quote:			symbol/make "quote"
		reject:			symbol/make "reject"
		set:			symbol/make "set"
		skip:			symbol/make "skip"
		some:			symbol/make "some"
		thru:			symbol/make "thru"
		to:				symbol/make "to"
		none:			symbol/make "none"
		pipe:			symbol/make "|"
		dash:			symbol/make "-"
		then:			symbol/make "then"
		if*:			symbol/make "if"
		remove:			symbol/make "remove"
		while*:			symbol/make "while"
		insert:			symbol/make "insert"
		only:			symbol/make "only"
		collect:		symbol/make "collect"
		keep:			symbol/make "keep"
		ahead:			symbol/make "ahead"

		self:			symbol/make "self"
		values:			symbol/make "values"

		_body:			_context/add-global body
		_windows:		_context/add-global windows
		_syllable:		_context/add-global syllable
		_macosx:		_context/add-global macosx
		_linux:			_context/add-global linux

		_push:			word/load "push"
		_pop:			word/load "pop"
		_fetch:			word/load "fetch"
		_match:			word/load "match"
		_iterate:		word/load "iterate"
		_paren:			word/load "paren"
		_anon:			word/load "<anon>"				;-- internal usage
		_end:			_context/add-global end

		_on-parse-event: word/load "on-parse-event"
	]
]

refinements: context [
	local: 		as red-refinement! 0
	extern: 	as red-refinement! 0

	build: does [
		local:	refinement/load "local"
		extern:	refinement/load "extern"
	]
]

Red/System [
	Title:   "Common datatypes utility functions"
	Author:  "Nenad Rakocevic"
	File: 	 %common.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
	}
]

names!: alias struct! [
	buffer	[c-string!]								;-- datatype name string
	size	[integer!]								;-- buffer size - 1 (not counting terminal `!`)
	word	[red-word!]								;-- datatype name as word! value
]

name-table:   declare names! 						;-- datatype names table
action-table: declare int-ptr!						;-- actions jump table

set-type: func [										;@@ convert to macro?
	cell [cell!]
	type [integer!]
][
	cell/header: cell/header and type-mask or type
]

alloc-at-tail: func [
	blk		[red-block!]
	return: [cell!]
][
	alloc-tail as series! blk/node/value
]

alloc-tail: func [
	s		 [series!]
	return:  [cell!]
	/local
		cell [red-value!]
][
	if (as byte-ptr! s/tail + 1) > ((as byte-ptr! s + 1) + s/size) [
		s: expand-series s 0
	]

	cell: s/tail
	;-- ensure that cell is within series upper boundary
	assert (as byte-ptr! cell) < ((as byte-ptr! s + 1) + s/size)

	s/tail: cell + 1									;-- move tail to next cell
	cell
]

alloc-tail-unit: func [
	s		 [series!]
	unit 	 [integer!]
	return:  [byte-ptr!]
	/local
		p	 [byte-ptr!]
][
	if ((as byte-ptr! s/tail) + unit) > ((as byte-ptr! s + 1) + s/size) [
		s: expand-series s 0
	]

	p: as byte-ptr! s/tail
	;-- ensure that cell is within series upper boundary
	assert p < ((as byte-ptr! s + 1) + s/size)

	s/tail: as cell! p + unit							;-- move tail to next unit slot
	p
]

copy-cell: func [
	src		[cell!]
	dst		[cell!]
	return: [red-value!]
][
	copy-memory											;@@ optimize for 16 bytes copying
		as byte-ptr! dst
		as byte-ptr! src
		size? cell!
	dst
]

words: context [
	spec:			-1
	body:			-1
	words:			-1
	logic!:			-1
	integer!:		-1
	any-type!:		-1
	repeat:			-1
	foreach:		-1
	map-each:		-1
	remove-each:	-1
	exit*:			-1
	return*:		-1
	self:			-1
	values:			-1

	any*:			-1
	break*:			-1
	copy:			-1
	end:			-1
	fail:			-1
	into:			-1
	opt:			-1
	not*:			-1
	quote:			-1
	reject:			-1
	set:			-1
	skip:			-1
	some:			-1
	thru:			-1
	to:				-1
	none:			-1
	pipe:			-1
	dash:			-1
	then:			-1
	if*:			-1
	remove:			-1
	while*:			-1
	insert:			-1
	only:			-1
	collect:		-1
	keep:			-1
	ahead:			-1

	_body:			as red-word! 0
	_windows:		as red-word! 0
	_syllable:		as red-word! 0
	_macosx:		as red-word! 0
	_linux:			as red-word! 0

	_push:			as red-word! 0
	_pop:			as red-word! 0
	_fetch:			as red-word! 0
	_match:			as red-word! 0
	_iterate:		as red-word! 0
	_paren:			as red-word! 0
	_anon:			as red-word! 0
	_end:			as red-word! 0

	_on-parse-event: as red-word! 0

	build: does [
		spec:			symbol/make "spec"
		body:			symbol/make "body"
		words:			symbol/make "words"
		logic!:			symbol/make "logic!"
		integer!:		symbol/make "integer!"
		any-type!:		symbol/make "any-type!"
		exit*:			symbol/make "exit"
		return*:		symbol/make "return"

		windows:		symbol/make "Windows"
		syllable:		symbol/make "Syllable"
		macosx:			symbol/make "MacOSX"
		linux:			symbol/make "Linux"

		repeat:			symbol/make "repeat"
		foreach:		symbol/make "foreach"
		map-each:		symbol/make "map-each"
		remove-each:	symbol/make "remove-each"

		any*:			symbol/make "any"
		break*:			symbol/make "break"
		copy:			symbol/make "copy"
		end:			symbol/make "end"
		fail:			symbol/make "fail"
		into:			symbol/make "into"
		opt:			symbol/make "opt"
		not*:			symbol/make "not"
		quote:			symbol/make "quote"
		reject:			symbol/make "reject"
		set:			symbol/make "set"
		skip:			symbol/make "skip"
		some:			symbol/make "some"
		thru:			symbol/make "thru"
		to:				symbol/make "to"
		none:			symbol/make "none"
		pipe:			symbol/make "|"
		dash:			symbol/make "-"
		then:			symbol/make "then"
		if*:			symbol/make "if"
		remove:			symbol/make "remove"
		while*:			symbol/make "while"
		insert:			symbol/make "insert"
		only:			symbol/make "only"
		collect:		symbol/make "collect"
		keep:			symbol/make "keep"
		ahead:			symbol/make "ahead"

		self:			symbol/make "self"
		values:			symbol/make "values"

		_body:			_context/add-global body
		_windows:		_context/add-global windows
		_syllable:		_context/add-global syllable
		_macosx:		_context/add-global macosx
		_linux:			_context/add-global linux

		_push:			word/load "push"
		_pop:			word/load "pop"
		_fetch:			word/load "fetch"
		_match:			word/load "match"
		_iterate:		word/load "iterate"
		_paren:			word/load "paren"
		_anon:			word/load "<anon>"				;-- internal usage
		_end:			_context/add-global end

		_on-parse-event: word/load "on-parse-event"
	]
]

refinements: context [
	local: 		as red-refinement! 0
	extern: 	as red-refinement! 0

	build: does [
		local:	refinement/load "local"
		extern:	refinement/load "extern"
	]
]


FIX: removed dead code caused by system/words changed datatype.

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
	]

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

		ctx: TO_CTX(global-ctx)
		values: as series! ctx/values/value
		index: find-word ctx symbol yes
		assert index <> -1
		values/offset + index
	]

	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)
	]

	clone: func [
		node	[node!]
		return:	[node!]
		/local
			sym		[red-word!]
			ctx		[red-context!]
			new		[node!]
			src		[series!]
			dst		[series!]
			slots	[integer!]
	][
		ctx: TO_CTX(node)
		src: as series! ctx/symbols/value
		slots: (as-integer (src/tail - src/offset)) >> 4

		new: create
			slots
			ctx/header and flag-series-stk <> 0
			ctx/header and set-self-mask   <> 0

		ctx: TO_CTX(new)
		dst: as series! ctx/symbols/value
		dst/tail: dst/offset + slots
		sym: as red-word! dst/offset

		copy-memory
			as byte-ptr! sym
			as byte-ptr! src/offset
			slots << 4

		while [slots > 0][
			sym/ctx: new
			sym: sym + 1
			slots: slots - 1
		]
		new
	]

	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
	]

	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
	]

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

		ctx: TO_CTX(global-ctx)
		values: as series! ctx/values/value
		index: find-word ctx symbol yes
		assert index <> -1
		values/offset + index
	]

	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)
	]

	clone: func [
		node	[node!]
		return:	[node!]
		/local
			sym		[red-word!]
			ctx		[red-context!]
			new		[node!]
			src		[series!]
			dst		[series!]
			slots	[integer!]
	][
		ctx: TO_CTX(node)
		src: as series! ctx/symbols/value
		slots: (as-integer (src/tail - src/offset)) >> 4

		new: create
			slots
			ctx/header and flag-series-stk <> 0
			ctx/header and set-self-mask   <> 0

		ctx: TO_CTX(new)
		dst: as series! ctx/symbols/value
		dst/tail: dst/offset + slots
		sym: as red-word! dst/offset

		copy-memory
			as byte-ptr! sym
			as byte-ptr! src/offset
			slots << 4

		while [slots > 0][
			sym/ctx: new
			sym: sym + 1
			slots: slots - 1
		]
		new
	]

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


FIX: additional fix for issue #1019.

FIX: additional fix for issue #1019.

Red/System [
	Title:   "Curses example: display Red and curses information"
	Author:  "Bruno Anselme"
	EMail:   "be.red@free.fr"
	File:    %curses-example.reds
	Rights:  "Copyright (c) 2013 Bruno Anselme"
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
	Needs: {
		Red/System >= 0.3.1
		%curses.reds
	}
	Purpose: {
		Display Red and curses information.
		Test some terminal features.
	}
]

#include %../curses.reds

#switch OS [
	Windows   [ op-sys: "Windows" op-num: 1 ]
	MacOSX    [ op-sys: "MacOSX"  op-num: 2 ]
	#default  [ op-sys: "Linux"   op-num: 0 ]
]

with curses [
	;-------------------------------------
	show-attr: func [   								;-- Print one attribute line, returns next line number
		wid     [window!]
		line    [integer!]
		attr    [integer!]
		mesg    [c-string!]
		return: [integer!]
	][
		mvwprintw [ wid line 2 mesg ]
		wmove wid line 25
		wprintw-attr wid attr "This is a Red's world"
		line + 1
	]
	;-------------------------------------
	show-all-attr: func [								;-- Create the attributes window
		return:  [window!]
		/local   win line
	][
		win: newwin 10 50 4 15
		box win 0 0
		line: 0
		mvwprintw [ win line 3 " Characters attibutes " ]
		line: line + 1
		line: show-attr win line A_BOLD "Bright or bold"
		line: show-attr win line A_REVERSE "Reverse"
		line: show-attr win line A_BLINK "Blink"
		line: show-attr win line A_UNDERLINE "Underline"
		line: show-attr win line A_INVIS "Invisible"
		line: show-attr win line A_DIM "Half bright"
		line: show-attr win line (A_BOLD or A_REVERSE or A_BLINK) "Bold+reverse+blink"
		line: show-attr win line (A_BOLD or A_UNDERLINE) "Bold+underline"
		win
	]
	;-------------------------------------
	init-color-pairs: func [							;--  Initialise 64 color-pairs with 8 basic colors
		/local id
	][
		colb: COLOR_BLACK
		colf: COLOR_BLACK
		until [
			colf: COLOR_BLACK
			until [
				id: (8 * colb) + colf + 1
				init-pair id colf colb
				colf: colf + 1
				colf > COLOR_WHITE
			]
			colb: colb + 1
			colb > COLOR_WHITE
		]
	]
	;-------------------------------------
	show-color: func [   								;-- Print the mesg with a calculated color pair value
		wid     [window!]
		line    [integer!]
		col     [integer!]
		mesg    [c-string!]
		return: [integer!]
		/local id
	][
		id: (8 * col) + line
		wattron wid color-pair id
		mvwprintw [ wid line (6 * col + 1) mesg ]
		wattroff wid color-pair id
		line + 1
	]
	;-------------------------------------
	show-all-colors: func [								;-- Create the colors window
		return:  [window!]
		/local win line column colb colf
	][
		win: newwin 10 50 4 15
		wcolor-set win 5
		box win 0 0
		line: 0
		mvwprintw [ win line 3 " Colors " ]
		colb: COLOR_BLACK
		colf: COLOR_BLACK
		column: 0
		until [
			line: 1
			colf: COLOR_BLACK
			until [
				line: show-color win line column " Red "
				colf: colf + 1
				colf > COLOR_WHITE
			]
			column: column + 1
			colb: colb + 1
			colb > COLOR_WHITE
		]
		win
	]
	;-------------------------------------
	show-term-inf: func [								;-- Create the terminal information window
		return:  [window!]
		/local win r g b col
	][
		win: newwin 13 ((getmaxx screen) - 10) 2 6
		r: 0 g: 0 b: 0
		col: COLOR_YELLOW
		box win 0 0
		mvwprintw [ win 0 3 " Terminal informations " ]
		mvwprintw [ win 1  2 "Terminal name    : %s" longname ]
		mvwprintw [ win 2  2 "Curses version   : %s" version ]
		mvwprintw [ win 3  2 "Application      : %s" system/args-list/item ]
		mvwprintw [ win 4  2 "OS               : %s" op-sys ]
		mvwprintw [ win 5  2 "Screen size      : %dx%d" getmaxx screen getmaxy screen ]
		mvwprintw [ win 6  2 "UTF-8            : %s" either UTF-8 [ "true" ][ "false" ]]
		win
	]
	;-------------------------------------
	show-features: func [								;-- Create the terminal information window
		return:  [window!]
		/local car key
	][
		win-demo: newwin 13 ((getmaxx screen) - 10) 2 6
		box win-demo 0 0
		mvwprintw [ win-demo 0 3 " Terminal features  (Esc to quit)" ]
		mvwprintw [ win-demo 1  2 "Has colors        : %s" either has-colors [ "true" ][ "false" ]]
		mvwprintw [ win-demo 2  2 "Can change color  : %s" either can-change-color [ "true" ][ "false" ]]
		mvwprintw [ win-demo 3  2 "Has Ins-Del char  : %s" either has-ic [ "true" ][ "false" ]]
		mvwprintw [ win-demo 4  2 "Has Ins-Del line  : %s" either has-il [ "true" ][ "false" ]]

		mvwprintw [ win-demo 6  2 "B to ring bell    : (if avaliable)" ]
		mvwprintw [ win-demo 7  2 "F to flash screen : (if avaliable)" ]
		mvwprintw [ win-demo 9  2 "Esc to quit" ]
		wrefresh win-demo
		until [
			key: getch
			car: trace-key key
			car: car and #"^(DF)"						;-- uppercase
			if key <> FFFFFFFFh [
				switch car [
				#"B"    [ beep  refresh ]
				#"F"    [ flash refresh ]
				default [ ]
				]
			]
			all [ ((key and A_ATTRIBUTES) = 0) (car = #"^(1B)") ]
		]
		del-win-demo
		touchwin win-menu
		return 0
	]
	;-------------------------------------
	show-input: func [									;-- Create the test input window
		return:  [window!]
		/local win str
	][
		win: newwin 10 50 4 15
		wcolor-set win 6
		box win 0 0
		mvwprintw [ win 0 3 " Test string input " ]
		mvwprintw [ win 2  2 "Write here : " ]
		str: make-c-string 1001
		wmove win 2 15
		wrefresh win
		curs-set 1
		echo-on
		nocbreak
		wgetstr win str
		echo-off
		raw
		mvwprintw [ win 5  2 "You wrote  : %s " str ]
		curs-set 0
		win
	]
	;-------------------------------------
	show-boxes: func [									;-- Create the boxes window
		return:  [window!]
		/local win
	][
		win: newwin 10 50 4 15
		wborder win #"|" #"+" #"-" #"=" #"/" #"\" #"\" #"/"
		mvwprintw [ win 0 3  " Border characters " ]
		mvwprintw [ win 2  4 "Border drawn with user defined characters" ]
		mvwhline win 3 4 (as integer! #"~") 41
		win
	]
	;-------------------------------------
	trace-key: func [
		key      [integer!]
		return:  [byte!]
		/local car nb-rows memcur
	][
		nb-rows: getmaxy screen
		memcur: curs-set 0
		car: 0
		either (key and FFFFFF00h) = 0 [
		car: key and 000000FFh
		mvprintw [ (nb-rows - 2)  3
					"Character pressed (int-hex-char) : %4d -   %02Xh -            "
					car
					car
				]
		mvaddch (nb-rows - 2)  53 car
		][
		if key <> FFFFFFFFh [
			mvprintw [ (nb-rows - 2)  3
					"Key pressed       (int-hex-name) : %4d - %04Xh - %s        "
					key
					key
					keyname key
					]
		]
		]
		refresh
		wrefresh win-demo
		curs-set memcur
		return as byte! car
	]
	;-------------------------------------
	show-edit: func [									;-- Create the test input window
		return:  [window!]
		/local  key car wx wy
	][
		wy: 3
		wx: 8
		win-demo: newwin 15 50 wy wx
		key: 0
		wbkgdset win-demo A_REVERSE
		werase win-demo
		mvwprintw [ win-demo 0 3 " Mini screen editor (Esc to quit)" ]
		mvwprintw [ win-demo 2  2 "Move the cursor with the arrow keys" ]
		mvwprintw [ win-demo 3  2 "Try Delete and Insert key" ]
		mvwprintw [ win-demo 4  2 "Insert/delete lines with Page Up/Down" ]
		mvwprintw [ win-demo 5  2 "Input text anywhere" ]
		mvwprintw [ win-demo 7  2 "Esc to quit Screen Editor" ]
		wmove win-demo 1 2
		if op-num = 1 [ move wy (wx + 2) ]				;-- Bugged Windows cursor management
		curs-set 1
		wrefresh win-demo
		until [
		key: getch
		car: trace-key key
		if key <> FFFFFFFFh [
			switch key [
			0000007Fh   [ wmove win-demo getcury win-demo ((getcurx win-demo) - 1) wdelch win-demo ]
			KEY_DC      [ wdelch win-demo ]
			KEY_IC      [ winsch win-demo 32 ]
			KEY_NPAGE   [ wdeleteln win-demo ]
			KEY_PPAGE   [ winsertln win-demo ]
			KEY_DOWN    [ wmove win-demo ((getcury win-demo) + 1) getcurx win-demo ]
			KEY_UP      [ wmove win-demo ((getcury win-demo) - 1) getcurx win-demo ]
			KEY_LEFT    [ wmove win-demo getcury win-demo ((getcurx win-demo) - 1) ]
			KEY_RIGHT   [ wmove win-demo getcury win-demo ((getcurx win-demo) + 1) ]
			default     [
				if ((key and A_ATTRIBUTES) = 0) [
				waddch win-demo as integer! car
				]
			]
			]
			if op-num = 1 [ move (wy - 1 + getcury win-demo) (wx + getcurx win-demo) ]	;-- Bugged Windows cursor management
			wrefresh win-demo
		]
		all [ ((key and A_ATTRIBUTES) = 0) (car = #"^(1B)") ]
		]
		curs-set 0
		wbkgdset win-demo A_NORMAL
		del-win-demo
		return 0
	]
	;-------------------------------------
	draw-charset: func [
		win      [window!]
		mask     [integer!]
		col      [integer!]
		/local car [integer!] row limit
	][
		row: 3
		wmove win row col
		car: 32
		either UTF-8 [ limit: 127 ][ limit: 255 ]
		until [
		waddch win (mask or car)
		car: car + 1
		if (car % 32) = 0 [
			row: row + 1
			wmove win row col
		]
		car = limit
		]
	]
	;-------------------------------------
	show-charset: func [								;-- Create the characters window
		return:  [window!]
		/local win
	][
		win: newwin 18 67 1 1
		wcolor-set win 6
		box win 0 0
		mvwprintw [ win 0 3 " Characters set " ]
		mvwprintw [ win 1 10 "Normal charset" ]
		draw-charset win A_NORMAL      1
		mvwprintw [ win 1 44 "Alt charset" ]
		draw-charset win A_ALTCHARSET  34
		if UTF-8 [
		mvwprintw-attr win 12 5 (A_REVERSE or A_BLINK) " Warning "
		wprintw [ win " : UTF-8 charset" ]
		mvwprintw [ win 13 17 "Only 7 bits chars are displayed" ]
		]
		return win
	]
	;-------------------------------------
	show-menu: func [									;-- Create the menu window
		return:  [window!]
		/local win
	][
		win: newwin 12 35 1 1
		wcolor-set win 7
		box win 0 0
		mvwprintw [ win  0 3 " Menu " ]
		mvwprintw [ win  1 2 "1 Terminal infos" ]
		mvwprintw [ win  2 2 "2 Check characters attributes" ]
		mvwprintw [ win  3 2 "3 Check colors" ]
		mvwprintw [ win  4 2 "4 Border characters" ]
		mvwprintw [ win  5 2 "5 Check terminal features" ]
		mvwprintw [ win  6 2 "6 Mini screen editor" ]
		mvwprintw [ win  7 2 "7 Test string input" ]
		mvwprintw [ win  8 2 "8 Display charset" ]
	;    mvwprintw [ win  9 2 "Accents éèàùüâô" ]
		mvwprintw [ win 10 2 "Ctrl+Q to exit" ]
		return win
	]
	;-------------------------------------
	del-win-demo: func [								;-- delete information window
	][
		if win-demo <> 0 [
		werase win-demo
		wrefresh win-demo
		delwin win-demo
		win-demo: 0
		touchwin win-menu
		]
	]
	;-------------------------------------
	main-loop: func [
		/local row col key car cc
	][
		key: 0
		car: #"^(00)"
		refresh
		wrefresh win-menu
		until [
			key: getch
			car: trace-key key
			if car <> #"^(00)" [
				del-win-demo
				refresh
				switch car [
					#"1"      [ win-demo: show-term-inf ]
					#"2"      [ win-demo: show-all-attr ]
					#"3"      [ win-demo: show-all-colors ]
					#"4"      [ win-demo: show-boxes ]
					#"5"      [ win-demo: show-features ]
					#"6"      [ win-demo: show-edit ]
					#"7"      [ win-demo: show-input ]
					#"8"      [ win-demo: show-charset ]
					default [  ]
				]
				wrefresh win-menu
				wrefresh win-demo
			]
			all [ ((key and A_ATTRIBUTES) = 0) (car = #"^Q") ]
		]
	]
	;-------------------------------------
	init-menu-bar: func [  								;-- callback function for ripoffline
		[cdecl]
		wid      [integer!]
		cols     [integer!]
	;    return:  [integer!]
	][
		menu-bar: wid
	;    return 0
	]
	;-------------------------------------
	init-status-bar: func [  							;-- callback function for ripoffline
		[cdecl]
		wid      [integer!]
		cols     [integer!]
	;    return:  [integer!]
	][
		status-bar: wid
	;    return 0
	]
	;-------------------------------------
	menu-bar: 0
	status-bar: 0
	ripoffline  1 as integer! :init-menu-bar
	ripoffline -1 as integer! :init-status-bar
	screen: init-screen
	init-color-pairs
	color-set 3

	wcolor-set menu-bar 49
	werase menu-bar
	wcolor-set status-bar 25
	werase status-bar
	wprintw  [ menu-bar "Line reserved for Menu bar" ]
	wnoutrefresh menu-bar
	either op-num = 1 [
		wprintw  [ status-bar "Line reserved for Status bar" ]
	][
		wprintw  [ status-bar curses/locale ]
	]
	wnoutrefresh status-bar

	box screen 0 0
	mvprintw [ 0 2 " The Red/System Curses Show " ]
	win-demo: 0
	win-menu: show-menu
	main-loop
	endwin
	if op-num = 1 [ print [ lf lf ] ]  					;-- Windows console needs to scroll
	print [ "That's all folks..." lf ]
]

Red/System [
	Title:   "Curses example: display Red and curses information"
	Author:  "Bruno Anselme"
	EMail:   "be.red@free.fr"
	File:    %curses-example.reds
	Rights:  "Copyright (c) 2013 Bruno Anselme"
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
	Needs: {
		Red/System >= 0.3.1
		%curses.reds
	}
	Purpose: {
		Display Red and curses information.
		Test some terminal features.
	}
]

#include %../curses.reds

#switch OS [
	Windows   [ op-sys: "Windows" op-num: 1 ]
	MacOSX    [ op-sys: "MacOSX"  op-num: 2 ]
	#default  [ op-sys: "Linux"   op-num: 0 ]
]

with curses [
	;-------------------------------------
	show-attr: func [   								;-- Print one attribute line, returns next line number
		wid     [window!]
		line    [integer!]
		attr    [integer!]
		mesg    [c-string!]
		return: [integer!]
	][
		mvwprintw [ wid line 2 mesg ]
		wmove wid line 25
		wprintw-attr wid attr "This is a Red's world"
		line + 1
	]
	;-------------------------------------
	show-all-attr: func [								;-- Create the attributes window
		return:  [window!]
		/local   win line
	][
		win: newwin 10 50 4 15
		box win 0 0
		line: 0
		mvwprintw [ win line 3 " Characters attibutes " ]
		line: line + 1
		line: show-attr win line A_BOLD "Bright or bold"
		line: show-attr win line A_REVERSE "Reverse"
		line: show-attr win line A_BLINK "Blink"
		line: show-attr win line A_UNDERLINE "Underline"
		line: show-attr win line A_INVIS "Invisible"
		line: show-attr win line A_DIM "Half bright"
		line: show-attr win line (A_BOLD or A_REVERSE or A_BLINK) "Bold+reverse+blink"
		line: show-attr win line (A_BOLD or A_UNDERLINE) "Bold+underline"
		win
	]
	;-------------------------------------
	init-color-pairs: func [							;--  Initialise 64 color-pairs with 8 basic colors
		/local id
	][
		colb: COLOR_BLACK
		colf: COLOR_BLACK
		until [
			colf: COLOR_BLACK
			until [
				id: (8 * colb) + colf + 1
				init-pair id colf colb
				colf: colf + 1
				colf > COLOR_WHITE
			]
			colb: colb + 1
			colb > COLOR_WHITE
		]
	]
	;-------------------------------------
	show-color: func [   								;-- Print the mesg with a calculated color pair value
		wid     [window!]
		line    [integer!]
		col     [integer!]
		mesg    [c-string!]
		return: [integer!]
		/local id
	][
		id: (8 * col) + line
		wattron wid color-pair id
		mvwprintw [ wid line (6 * col + 1) mesg ]
		wattroff wid color-pair id
		line + 1
	]
	;-------------------------------------
	show-all-colors: func [								;-- Create the colors window
		return:  [window!]
		/local win line column colb colf
	][
		win: newwin 10 50 4 15
		wcolor-set win 5
		box win 0 0
		line: 0
		mvwprintw [ win line 3 " Colors " ]
		colb: COLOR_BLACK
		colf: COLOR_BLACK
		column: 0
		until [
			line: 1
			colf: COLOR_BLACK
			until [
				line: show-color win line column " Red "
				colf: colf + 1
				colf > COLOR_WHITE
			]
			column: column + 1
			colb: colb + 1
			colb > COLOR_WHITE
		]
		win
	]
	;-------------------------------------
	show-term-inf: func [								;-- Create the terminal information window
		return:  [window!]
		/local win r g b col
	][
		win: newwin 13 ((getmaxx screen) - 10) 2 6
		r: 0 g: 0 b: 0
		col: COLOR_YELLOW
		box win 0 0
		mvwprintw [ win 0 3 " Terminal informations " ]
		mvwprintw [ win 1  2 "Terminal name    : %s" longname ]
		mvwprintw [ win 2  2 "Curses version   : %s" version ]
		mvwprintw [ win 3  2 "Application      : %s" system/args-list/item ]
		mvwprintw [ win 4  2 "OS               : %s" op-sys ]
		mvwprintw [ win 5  2 "Screen size      : %dx%d" getmaxx screen getmaxy screen ]
		mvwprintw [ win 6  2 "UTF-8            : %s" either UTF-8 [ "true" ][ "false" ]]
		win
	]
	;-------------------------------------
	show-features: func [								;-- Create the terminal information window
		return:  [window!]
		/local car key
	][
		win-demo: newwin 13 ((getmaxx screen) - 10) 2 6
		box win-demo 0 0
		mvwprintw [ win-demo 0 3 " Terminal features  (Esc to quit)" ]
		mvwprintw [ win-demo 1  2 "Has colors        : %s" either has-colors [ "true" ][ "false" ]]
		mvwprintw [ win-demo 2  2 "Can change color  : %s" either can-change-color [ "true" ][ "false" ]]
		mvwprintw [ win-demo 3  2 "Has Ins-Del char  : %s" either has-ic [ "true" ][ "false" ]]
		mvwprintw [ win-demo 4  2 "Has Ins-Del line  : %s" either has-il [ "true" ][ "false" ]]

		mvwprintw [ win-demo 6  2 "B to ring bell    : (if avaliable)" ]
		mvwprintw [ win-demo 7  2 "F to flash screen : (if avaliable)" ]
		mvwprintw [ win-demo 9  2 "Esc to quit" ]
		wrefresh win-demo
		until [
			key: getch
			car: trace-key key
			car: car and #"^(DF)"						;-- uppercase
			if key <> FFFFFFFFh [
				switch car [
				#"B"    [ beep  refresh ]
				#"F"    [ flash refresh ]
				default [ ]
				]
			]
			all [ ((key and A_ATTRIBUTES) = 0) (car = #"^(1B)") ]
		]
		del-win-demo
		touchwin win-menu
		return 0
	]
	;-------------------------------------
	show-input: func [									;-- Create the test input window
		return:  [window!]
		/local win str
	][
		win: newwin 10 50 4 15
		wcolor-set win 6
		box win 0 0
		mvwprintw [ win 0 3 " Test string input " ]
		mvwprintw [ win 2  2 "Write here : " ]
		str: make-c-string 1001
		wmove win 2 15
		wrefresh win
		curs-set 1
		echo-on
		nocbreak
		wgetstr win str
		echo-off
		raw
		mvwprintw [ win 5  2 "You wrote  : %s " str ]
		curs-set 0
		win
	]
	;-------------------------------------
	show-boxes: func [									;-- Create the boxes window
		return:  [window!]
		/local win
	][
		win: newwin 10 50 4 15
		wborder win #"|" #"+" #"-" #"=" #"/" #"\" #"\" #"/"
		mvwprintw [ win 0 3  " Border characters " ]
		mvwprintw [ win 2  4 "Border drawn with user defined characters" ]
		mvwhline win 3 4 (as integer! #"~") 41
		win
	]
	;-------------------------------------
	trace-key: func [
		key      [integer!]
		return:  [byte!]
		/local car nb-rows memcur
	][
		nb-rows: getmaxy screen
		memcur: curs-set 0
		car: 0
		either (key and FFFFFF00h) = 0 [
		car: key and 000000FFh
		mvprintw [ (nb-rows - 2)  3
					"Character pressed (int-hex-char) : %4d -   %02Xh -            "
					car
					car
				]
		mvaddch (nb-rows - 2)  53 car
		][
		if key <> FFFFFFFFh [
			mvprintw [ (nb-rows - 2)  3
					"Key pressed       (int-hex-name) : %4d - %04Xh - %s        "
					key
					key
					keyname key
					]
		]
		]
		refresh
		wrefresh win-demo
		curs-set memcur
		return as byte! car
	]
	;-------------------------------------
	show-edit: func [									;-- Create the test input window
		return:  [window!]
		/local  key car wx wy
	][
		wy: 3
		wx: 8
		win-demo: newwin 15 50 wy wx
		key: 0
		wbkgdset win-demo A_REVERSE
		werase win-demo
		mvwprintw [ win-demo 0 3 " Mini screen editor (Esc to quit)" ]
		mvwprintw [ win-demo 2  2 "Move the cursor with the arrow keys" ]
		mvwprintw [ win-demo 3  2 "Try Delete and Insert key" ]
		mvwprintw [ win-demo 4  2 "Insert/delete lines with Page Up/Down" ]
		mvwprintw [ win-demo 5  2 "Input text anywhere" ]
		mvwprintw [ win-demo 7  2 "Esc to quit Screen Editor" ]
		wmove win-demo 1 2
		if op-num = 1 [ move wy (wx + 2) ]				;-- Bugged Windows cursor management
		curs-set 1
		wrefresh win-demo
		until [
		key: getch
		car: trace-key key
		if key <> FFFFFFFFh [
			switch key [
			0000007Fh   [ wmove win-demo getcury win-demo ((getcurx win-demo) - 1) wdelch win-demo ]
			KEY_DC      [ wdelch win-demo ]
			KEY_IC      [ winsch win-demo 32 ]
			KEY_NPAGE   [ wdeleteln win-demo ]
			KEY_PPAGE   [ winsertln win-demo ]
			KEY_DOWN    [ wmove win-demo ((getcury win-demo) + 1) getcurx win-demo ]
			KEY_UP      [ wmove win-demo ((getcury win-demo) - 1) getcurx win-demo ]
			KEY_LEFT    [ wmove win-demo getcury win-demo ((getcurx win-demo) - 1) ]
			KEY_RIGHT   [ wmove win-demo getcury win-demo ((getcurx win-demo) + 1) ]
			default     [
				if ((key and A_ATTRIBUTES) = 0) [
				waddch win-demo as integer! car
				]
			]
			]
			if op-num = 1 [ move (wy - 1 + getcury win-demo) (wx + getcurx win-demo) ]	;-- Bugged Windows cursor management
			wrefresh win-demo
		]
		all [ ((key and A_ATTRIBUTES) = 0) (car = #"^(1B)") ]
		]
		curs-set 0
		wbkgdset win-demo A_NORMAL
		del-win-demo
		return 0
	]
	;-------------------------------------
	draw-charset: func [
		win      [window!]
		mask     [integer!]
		col      [integer!]
		/local car [integer!] row limit
	][
		row: 3
		wmove win row col
		car: 32
		either UTF-8 [ limit: 127 ][ limit: 255 ]
		until [
		waddch win (mask or car)
		car: car + 1
		if (car % 32) = 0 [
			row: row + 1
			wmove win row col
		]
		car = limit
		]
	]
	;-------------------------------------
	show-charset: func [								;-- Create the characters window
		return:  [window!]
		/local win
	][
		win: newwin 18 67 1 1
		wcolor-set win 6
		box win 0 0
		mvwprintw [ win 0 3 " Characters set " ]
		mvwprintw [ win 1 10 "Normal charset" ]
		draw-charset win A_NORMAL      1
		mvwprintw [ win 1 44 "Alt charset" ]
		draw-charset win A_ALTCHARSET  34
		if UTF-8 [
		mvwprintw-attr win 12 5 (A_REVERSE or A_BLINK) " Warning "
		wprintw [ win " : UTF-8 charset" ]
		mvwprintw [ win 13 17 "Only 7 bits chars are displayed" ]
		]
		return win
	]
	;-------------------------------------
	show-menu: func [									;-- Create the menu window
		return:  [window!]
		/local win
	][
		win: newwin 12 35 1 1
		wcolor-set win 7
		box win 0 0
		mvwprintw [ win  0 3 " Menu " ]
		mvwprintw [ win  1 2 "1 Terminal infos" ]
		mvwprintw [ win  2 2 "2 Check characters attributes" ]
		mvwprintw [ win  3 2 "3 Check colors" ]
		mvwprintw [ win  4 2 "4 Border characters" ]
		mvwprintw [ win  5 2 "5 Check terminal features" ]
		mvwprintw [ win  6 2 "6 Mini screen editor" ]
		mvwprintw [ win  7 2 "7 Test string input" ]
		mvwprintw [ win  8 2 "8 Display charset" ]
	;    mvwprintw [ win  9 2 "Accents éèàùüâô" ]
		mvwprintw [ win 10 2 "Ctrl+Q to exit" ]
		return win
	]
	;-------------------------------------
	del-win-demo: func [								;-- delete information window
	][
		if win-demo <> 0 [
		werase win-demo
		wrefresh win-demo
		delwin win-demo
		win-demo: 0
		touchwin win-menu
		]
	]
	;-------------------------------------
	main-loop: func [
		/local row col key car cc
	][
		key: 0
		car: #"^(0)"
		refresh
		wrefresh win-menu
		until [
			key: getch
			car: trace-key key
			if car <> #"^(0)" [
				del-win-demo
				refresh
				switch car [
					#"1"      [ win-demo: show-term-inf ]
					#"2"      [ win-demo: show-all-attr ]
					#"3"      [ win-demo: show-all-colors ]
					#"4"      [ win-demo: show-boxes ]
					#"5"      [ win-demo: show-features ]
					#"6"      [ win-demo: show-edit ]
					#"7"      [ win-demo: show-input ]
					#"8"      [ win-demo: show-charset ]
					default [  ]
				]
				wrefresh win-menu
				wrefresh win-demo
			]
			all [ ((key and A_ATTRIBUTES) = 0) (car = #"^Q") ]
		]
	]
	;-------------------------------------
	init-menu-bar: func [  								;-- callback function for ripoffline
		[cdecl]
		wid      [integer!]
		cols     [integer!]
	;    return:  [integer!]
	][
		menu-bar: wid
	;    return 0
	]
	;-------------------------------------
	init-status-bar: func [  							;-- callback function for ripoffline
		[cdecl]
		wid      [integer!]
		cols     [integer!]
	;    return:  [integer!]
	][
		status-bar: wid
	;    return 0
	]
	;-------------------------------------
	menu-bar: 0
	status-bar: 0
	ripoffline  1 as integer! :init-menu-bar
	ripoffline -1 as integer! :init-status-bar
	screen: init-screen
	init-color-pairs
	color-set 3

	wcolor-set menu-bar 49
	werase menu-bar
	wcolor-set status-bar 25
	werase status-bar
	wprintw  [ menu-bar "Line reserved for Menu bar" ]
	wnoutrefresh menu-bar
	either op-num = 1 [
		wprintw  [ status-bar "Line reserved for Status bar" ]
	][
		wprintw  [ status-bar curses/locale ]
	]
	wnoutrefresh status-bar

	box screen 0 0
	mvprintw [ 0 2 " The Red/System Curses Show " ]
	win-demo: 0
	win-menu: show-menu
	main-loop
	endwin
	if op-num = 1 [ print [ lf lf ] ]  					;-- Windows console needs to scroll
	print [ "That's all folks..." lf ]
]


FIX: issue #587 (Fetching function spec crashes when not available)

Red/System [
	Title:   "Function! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %function.reds
	Tabs:	 4
	Rights:  "Copyright (C) 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
	}
]

_function: context [
	verbose: 0

	call: func [
		fun	[red-function!]
		/local
			s	   [series!]
			native [red-native!]
			call
	][
		s: as series! fun/more/value

		native: as red-native! s/offset + 2
		either zero? native/code [
			interpreter/eval-function fun as red-block! s/offset
		][
			call: as function! [] native/code
			call
			0
		]
	]

	collect-word: func [
		value  [red-value!]
		list   [red-block!]
		ignore [red-block!]
		/local
			result [red-value!]
			word   [red-value!]
	][
		word: stack/push value
		word/header: TYPE_WORD							;-- convert the set-word! into a word!

		result: block/find ignore word null no no no null null no no no no

		if TYPE_OF(result) = TYPE_NONE [
			block/rs-append list word
			block/rs-append ignore word
		]
		stack/pop 2										;-- remove word and FIND result from stack
	]

	collect-many-words: func [
		blk	   [red-block!]
		list   [red-block!]
		ignore [red-block!]
		/local
			slot  [red-value!]
			tail  [red-value!]
	][
		slot: block/rs-head blk
		tail: block/rs-tail blk

		while [slot < tail][
			assert any [								;-- replace with ANY_WORD?
				TYPE_OF(slot) = TYPE_WORD
				TYPE_OF(slot) = TYPE_GET_WORD
				TYPE_OF(slot) = TYPE_LIT_WORD
			]
			collect-word slot list ignore
			slot: slot + 1
		]
	]

	collect-deep: func [
		list   [red-block!]
		ignore [red-block!]
		blk    [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			w	  [red-word!]
			many? [logic!]
			slot  [red-value!]
	][
		value: block/rs-head blk
		tail:  block/rs-tail blk

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_SET_WORD [
					collect-word value list ignore
				]
				TYPE_WORD [
					w: as red-word! value
					many?: any [
						EQUAL_SYMBOLS?(w/symbol words/foreach)
						;EQUAL_SYMBOLS?(w/symbol words/remove-each)
						;EQUAL_SYMBOLS?(w/symbol words/map-each)
					]
					if any [
						many?
						EQUAL_SYMBOLS?(w/symbol words/repeat)
					][
						if value + 1 < tail [
							slot: value + 1
							either all [many? TYPE_OF(slot) = TYPE_BLOCK][
								collect-many-words as red-block! slot list ignore
							][
								collect-word slot list ignore
							]
						]
					]
				]
				TYPE_BLOCK
				TYPE_PAREN [
					collect-deep list ignore as red-block! value
				]
				default [0]
			]
			value: value + 1
		]
	]

	collect-words: func [
		spec	[red-block!]
		body	[red-block!]
		return: [red-block!]
		/local
			list	[red-block!]
			ignore	[red-block!]
			extern	[red-block!]
			value	[red-value!]
			tail	[red-value!]
			s		[series!]
			extern? [logic!]
	][
		list: block/push* 8
		block/rs-append list as red-value! refinements/local

		ignore: block/clone spec no
		block/rs-append ignore as red-value! refinements/local

		value:  as red-value! refinements/extern		;-- process optional /extern
		extern: as red-block! block/find spec value null no no no null null no no no no
		extern?: TYPE_OF(extern) <> TYPE_NONE

		if extern? [
			s: GET_BUFFER(spec)
			s/tail: s/offset + extern/head				;-- cut /extern and extern words out
		]
		stack/pop 1										;-- remove FIND result from stack

		value:  block/rs-head ignore
		tail:	block/rs-tail ignore

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD 	  [0]						;-- do nothing
				TYPE_REFINEMENT
				TYPE_GET_WORD
				TYPE_SET_WORD [
					value/header: TYPE_WORD				;-- convert it to a word!
				]
				default [
					if extern? [
						print-line ["*** Error: invalid /extern values"]
						halt
					]
				]
			]
			value: value + 1
		]

		collect-deep list ignore body

		if 1 < block/rs-length? list [
			block/rs-append-block spec list
		]
		list
	]

	validate: func [									;-- temporary mimalist spec checking
		spec [red-block!]
		/local
			value  [red-value!]
			end	   [red-value!]
			next   [red-value!]
			block? [logic!]
	][
		value: block/rs-head spec
		end:   block/rs-tail spec

		while [value < end][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD [
					next: value + 1
					block?: all [
						next < end
						TYPE_OF(next) = TYPE_BLOCK
					]
					value: value + either block? [2][1]
				]
				TYPE_SET_WORD [
					next: value + 1
					unless all [
						next < end
						TYPE_OF(next) = TYPE_BLOCK
					][
						print-line "*** Error: return: not followed by type in function spec"
						halt
					]
					value: next
				]
				TYPE_LIT_WORD
				TYPE_REFINEMENT
				TYPE_BLOCK
				TYPE_STRING [
					value: value + 1
				]
				default [
					print-line "*** Error: invalid value in function spec"
					halt
				]
			]
		]
	]

	init-locals: func [
		nb 	   [integer!]
		/local
			p  [red-value!]
	][
		until [
			p: stack/push*
			p/header: TYPE_NONE
			nb: nb - 1
			zero? nb
		]
	]

	push: func [
		spec	 [red-block!]
		body	 [red-block!]
		ctx		 [node!]								;-- if not null, context is predefined by compiler
		code	 [integer!]
		return:	 [node!]								;-- return function's local context reference
		/local
			fun    [red-function!]
			native [red-native!]
			value  [red-value!]
			more   [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_function/push"]]

		fun: as red-function! stack/push*
		fun/header:  TYPE_FUNCTION						;-- implicit reset of all header flags
		fun/spec:	 spec/node
		fun/ctx:	 either null? ctx [_context/make spec yes no][ctx]
		fun/more:	 alloc-cells 3

		more: as series! fun/more/value
		value: either null? body [none-value][as red-value! body]
		copy-cell value alloc-tail more					;-- store body block or none
		alloc-tail more									;-- reserved place for "symbols"

		native: as red-native! alloc-tail more
		native/header: TYPE_NATIVE
		native/code: code

		if all [null? ctx not null? body][
			_context/bind body GET_CTX(fun) no			;-- do not bind if predefined context (already done)
		]
		fun/ctx
	]

	;-- Actions --

	reflect: func [
		fun		[red-function!]
		field	[integer!]
		return:	[red-block!]
		/local
			blk [red-block!]
			s	[series!]
	][
		case [
			field = words/spec [
				blk: as red-block! stack/arguments		;-- overwrite the function slot on stack
				blk/header: TYPE_BLOCK
				blk/node: fun/spec						;-- order of assignments matters
				blk/head: 0
			]
			field = words/body [
				s: as series! fun/more/value
				blk: as red-block! s/offset
				stack/set-last as red-value! blk
			]
			field = words/words [
				--NOT_IMPLEMENTED--						;@@ build the words block from spec
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		blk												;@@ TBD: remove it when all cases implemented
	]

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

		string/concatenate-literal buffer "?function?"
		part - 10
	]

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

		string/concatenate-literal buffer "func "

		blk: as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 0
		blk/node: fun/spec
		part: block/mold blk buffer only? all? flat? arg part - 5 indent	;-- spec

		s: as series! fun/more/value
		value: s/offset
		either TYPE_OF(value) = TYPE_NONE [
			string/concatenate-literal buffer " none"
			part - 5
		][
			block/mold as red-block! s/offset buffer only? all? flat? arg part indent	;-- body
		]
	]

	init: does [
		datatype/register [
			TYPE_FUNCTION
			TYPE_CONTEXT
			"function!"
			;-- General actions --
			null			;make
			null			;random
			:reflect
			null			;to
			:form
			: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:   "Function! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %function.reds
	Tabs:	 4
	Rights:  "Copyright (C) 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
	}
]

_function: context [
	verbose: 0

	call: func [
		fun	[red-function!]
		/local
			s	   [series!]
			native [red-native!]
			call
	][
		s: as series! fun/more/value

		native: as red-native! s/offset + 2
		either zero? native/code [
			interpreter/eval-function fun as red-block! s/offset
		][
			call: as function! [] native/code
			call
			0
		]
	]

	collect-word: func [
		value  [red-value!]
		list   [red-block!]
		ignore [red-block!]
		/local
			result [red-value!]
			word   [red-value!]
	][
		word: stack/push value
		word/header: TYPE_WORD							;-- convert the set-word! into a word!

		result: block/find ignore word null no no no null null no no no no

		if TYPE_OF(result) = TYPE_NONE [
			block/rs-append list word
			block/rs-append ignore word
		]
		stack/pop 2										;-- remove word and FIND result from stack
	]

	collect-many-words: func [
		blk	   [red-block!]
		list   [red-block!]
		ignore [red-block!]
		/local
			slot  [red-value!]
			tail  [red-value!]
	][
		slot: block/rs-head blk
		tail: block/rs-tail blk

		while [slot < tail][
			assert any [								;-- replace with ANY_WORD?
				TYPE_OF(slot) = TYPE_WORD
				TYPE_OF(slot) = TYPE_GET_WORD
				TYPE_OF(slot) = TYPE_LIT_WORD
			]
			collect-word slot list ignore
			slot: slot + 1
		]
	]

	collect-deep: func [
		list   [red-block!]
		ignore [red-block!]
		blk    [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			w	  [red-word!]
			many? [logic!]
			slot  [red-value!]
	][
		value: block/rs-head blk
		tail:  block/rs-tail blk

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_SET_WORD [
					collect-word value list ignore
				]
				TYPE_WORD [
					w: as red-word! value
					many?: any [
						EQUAL_SYMBOLS?(w/symbol words/foreach)
						;EQUAL_SYMBOLS?(w/symbol words/remove-each)
						;EQUAL_SYMBOLS?(w/symbol words/map-each)
					]
					if any [
						many?
						EQUAL_SYMBOLS?(w/symbol words/repeat)
					][
						if value + 1 < tail [
							slot: value + 1
							either all [many? TYPE_OF(slot) = TYPE_BLOCK][
								collect-many-words as red-block! slot list ignore
							][
								collect-word slot list ignore
							]
						]
					]
				]
				TYPE_BLOCK
				TYPE_PAREN [
					collect-deep list ignore as red-block! value
				]
				default [0]
			]
			value: value + 1
		]
	]

	collect-words: func [
		spec	[red-block!]
		body	[red-block!]
		return: [red-block!]
		/local
			list	[red-block!]
			ignore	[red-block!]
			extern	[red-block!]
			value	[red-value!]
			tail	[red-value!]
			s		[series!]
			extern? [logic!]
	][
		list: block/push* 8
		block/rs-append list as red-value! refinements/local

		ignore: block/clone spec no
		block/rs-append ignore as red-value! refinements/local

		value:  as red-value! refinements/extern		;-- process optional /extern
		extern: as red-block! block/find spec value null no no no null null no no no no
		extern?: TYPE_OF(extern) <> TYPE_NONE

		if extern? [
			s: GET_BUFFER(spec)
			s/tail: s/offset + extern/head				;-- cut /extern and extern words out
		]
		stack/pop 1										;-- remove FIND result from stack

		value:  block/rs-head ignore
		tail:	block/rs-tail ignore

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD 	  [0]						;-- do nothing
				TYPE_REFINEMENT
				TYPE_GET_WORD
				TYPE_SET_WORD [
					value/header: TYPE_WORD				;-- convert it to a word!
				]
				default [
					if extern? [
						print-line ["*** Error: invalid /extern values"]
						halt
					]
				]
			]
			value: value + 1
		]

		collect-deep list ignore body

		if 1 < block/rs-length? list [
			block/rs-append-block spec list
		]
		list
	]

	validate: func [									;-- temporary mimalist spec checking
		spec [red-block!]
		/local
			value  [red-value!]
			end	   [red-value!]
			next   [red-value!]
			block? [logic!]
	][
		value: block/rs-head spec
		end:   block/rs-tail spec

		while [value < end][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD [
					next: value + 1
					block?: all [
						next < end
						TYPE_OF(next) = TYPE_BLOCK
					]
					value: value + either block? [2][1]
				]
				TYPE_SET_WORD [
					next: value + 1
					unless all [
						next < end
						TYPE_OF(next) = TYPE_BLOCK
					][
						print-line "*** Error: return: not followed by type in function spec"
						halt
					]
					value: next
				]
				TYPE_LIT_WORD
				TYPE_REFINEMENT
				TYPE_BLOCK
				TYPE_STRING [
					value: value + 1
				]
				default [
					print-line "*** Error: invalid value in function spec"
					halt
				]
			]
		]
	]

	init-locals: func [
		nb 	   [integer!]
		/local
			p  [red-value!]
	][
		until [
			p: stack/push*
			p/header: TYPE_NONE
			nb: nb - 1
			zero? nb
		]
	]

	push: func [
		spec	 [red-block!]
		body	 [red-block!]
		ctx		 [node!]								;-- if not null, context is predefined by compiler
		code	 [integer!]
		return:	 [node!]								;-- return function's local context reference
		/local
			fun    [red-function!]
			native [red-native!]
			value  [red-value!]
			more   [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_function/push"]]

		fun: as red-function! stack/push*
		fun/header:  TYPE_FUNCTION						;-- implicit reset of all header flags
		fun/spec:	 spec/node
		fun/ctx:	 either null? ctx [_context/make spec yes no][ctx]
		fun/more:	 alloc-cells 3

		more: as series! fun/more/value
		value: either null? body [none-value][as red-value! body]
		copy-cell value alloc-tail more					;-- store body block or none
		alloc-tail more									;-- reserved place for "symbols"

		native: as red-native! alloc-tail more
		native/header: TYPE_NATIVE
		native/code: code

		if all [null? ctx not null? body][
			_context/bind body GET_CTX(fun) no			;-- do not bind if predefined context (already done)
		]
		fun/ctx
	]

	;-- Actions --

	reflect: func [
		fun		[red-function!]
		field	[integer!]
		return:	[red-block!]
		/local
			blk [red-block!]
			s	[series!]
	][
		case [
			field = words/spec [
				blk: as red-block! stack/arguments		;-- overwrite the function slot on stack
				blk/header: TYPE_BLOCK
				blk/node: fun/spec						;-- order of assignments matters
				blk/head: 0
			]
			field = words/body [
				s: as series! fun/more/value
				blk: as red-block! s/offset
				stack/set-last as red-value! blk
			]
			field = words/words [
				--NOT_IMPLEMENTED--						;@@ build the words block from spec
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		blk												;@@ TBD: remove it when all cases implemented
	]

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

		string/concatenate-literal buffer "?function?"
		part - 10
	]

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

		string/concatenate-literal buffer "func "

		blk: as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 0
		blk/node: fun/spec
		part: block/mold blk buffer only? all? flat? arg part - 5 indent	;-- spec

		s: as series! fun/more/value
		block/mold as red-block! s/offset buffer only? all? flat? arg part indent	;-- body
	]

	init: does [
		datatype/register [
			TYPE_FUNCTION
			TYPE_CONTEXT
			"function!"
			;-- General actions --
			null			;make
			null			;random
			:reflect
			null			;to
			:form
			: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
		]
	]
]


FEAT: implemented FORM support for error!, MAKE extended to accept a block as specification.

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

error: context [
	verbose: 0

	#enum field! [
		field-code
		field-type
		field-id
		field-arg1
		field-arg2
		field-arg3
		field-near
		field-where
	]

	create: func [
		cat		[red-word!]
		id		[red-word!]
		arg1 	[red-value!]
		arg2 	[red-value!]
		arg3 	[red-value!]
		return: [red-object!]
		/local
			err  [red-object!]
			base [red-value!]
			blk	 [red-block!]
	][
		blk: block/push* 2
		block/rs-append blk as red-value! cat
		block/rs-append blk as red-value! id

		err:  make null as red-value! blk
		base: object/get-values err

		unless null? arg1 [copy-cell arg1 base + field-arg1]
		unless null? arg2 [copy-cell arg2 base + field-arg2]
		unless null? arg3 [copy-cell arg3 base + field-arg3]
		err
	]

	reduce: func [
		blk		[red-block!]
		obj		[red-object!]
		return: [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			type  [integer!]
	][
		value: block/rs-head blk
		tail:  block/rs-tail blk

		while [value < tail][
			type: TYPE_OF(value)
			if any [
				type = TYPE_WORD
				type = TYPE_GET_WORD
			][
				copy-cell
					object/rs-select obj value
					value
			]
			value: value + 1
		]
		blk
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-object!]
		/local
			new		[red-object!]
			obj		[red-object!]
			series	[red-series!]
			errors	[red-object!]
			base	[red-value!]
			value	[red-value!]
			blk		[red-block!]
			int		[red-integer!]
			sym		[red-word!]
			w		[red-word!]
			cat		[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "error/make"]]

		new: as red-object! stack/push*

		object/copy
			as red-object! #get system/standard/error
			as red-object! new
			null
			no
			null

		series: as red-series! spec
		new/header: TYPE_ERROR							;-- implicit reset of all header flags
		new/class:  0
		new/on-set: null

		base:	object/get-values new
		errors: as red-object! #get system/catalog/errors
		sym:	as red-word! object/get-words errors

		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				copy-cell spec base						;-- set 'code field
				int: as red-integer! spec

				cat: int/value / 100
				w: sym + cat

				if (sym + object/get-size errors) <= as red-value! w [
					print-line "*** Error: invalid spec value for MAKE"
					return new
				]
				word/make-at w/symbol base + field-type	;-- set 'type field

				errors: (as red-object! object/get-values errors) + cat
				sym: as red-word! object/get-words errors

				w: sym + (int/value // 100)
				if (sym + object/get-size errors) <= as red-value! w [
					print-line "*** Error: invalid spec value for MAKE"
					return new
				]
				word/make-at w/symbol base + field-id	;-- set 'id field
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				value: block/rs-head blk

				switch TYPE_OF(value) [
					TYPE_WORD [
						cat: object/rs-find errors value

						if cat = -1 [
							print-line "*** Error: invalid 'type field in spec block for MAKE"
							return new
						]
						copy-cell value base + field-type

						errors: (as red-object! object/get-values errors) + cat
						value: value + 1
						if value < block/rs-tail blk [
							cat: object/rs-find errors value
							if cat = -1 [
								print-line "*** Error: invalid 'id field in spec block for MAKE"
								return new
							]
							copy-cell value base + field-id
						]
					]
					TYPE_SET_WORD [
						value: block/select-word blk words/_type
						if TYPE_OF(value) = TYPE_NONE [
							print-line "*** Error: 'type not found in spec block for MAKE"
							return new
						]
						copy-cell value base + field-type

						value: block/select-word blk words/_id
						if TYPE_OF(value) = TYPE_NONE [
							print-line "*** Error: 'id not found in spec block for MAKE"
							return new
						]
						copy-cell value base + field-id
					]
					default [
						print-line "*** Error: unsupported spec block for MAKE"
						return new
					]
				]
			]
			default [
				--NOT_IMPLEMENTED--
			]
		]
		new
	]

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

		base: object/get-values obj
		string/concatenate-literal buffer "*** "
		part: part - 4

		errors: as red-object! #get system/catalog/errors
		errors: as red-object! object/rs-select errors base + field-type

		str: as red-string! object/rs-select errors as red-value! words/_type
		assert TYPE_OF(str) = TYPE_STRING
		string/concatenate buffer str -1 0 yes no
		part: part - string/rs-length? str
		string/concatenate-literal buffer ": "
		part: part - 2

		value: object/rs-select errors base + field-id

		either TYPE_OF(value) = TYPE_STRING [
			str: as red-string! value
			string/concatenate buffer str -1 0 yes no
			part: part - string/rs-length? str
		][
			blk: block/clone as red-block! value no
			blk: reduce blk obj
			part: block/form blk buffer arg part
		]
		part
	]

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

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

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

error: context [
	verbose: 0

	#enum field! [
		field-code
		field-type
		field-id
		field-arg1
		field-arg2
		field-arg3
		field-near
		field-where
	]

	create: func [
		code 	[integer!]
		arg1 	[red-value!]
		arg2 	[red-value!]
		arg3 	[red-value!]
		return: [red-object!]
		/local
			err  [red-object!]
			base [red-value!]
	][
		err:  make null as red-value! integer/push code
		base: object/get-values err

		unless null? arg1 [copy-cell arg1 base + field-arg1]
		unless null? arg2 [copy-cell arg2 base + field-arg2]
		unless null? arg3 [copy-cell arg3 base + field-arg3]
		err
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-object!]
		/local
			new		[red-object!]
			obj		[red-object!]
			series	[red-series!]
			errors	[red-object!]
			base	[red-value!]
			int		[red-integer!]
			sym		[red-word!]
			w		[red-word!]
			cat		[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "error/make"]]

		new: as red-object! stack/push*

		object/copy
			as red-object! #get system/standard/error
			as red-object! new
			null
			no
			null

		series: as red-series! spec
		new/header: TYPE_ERROR							;-- implicit reset of all header flags
		new/class:  0
		new/on-set: null

		base:	object/get-values new
		errors: as red-object! #get system/catalog/errors
		sym:	as red-word! object/get-words errors

		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				copy-cell spec base						;-- set 'code field
				int: as red-integer! spec

				cat: int/value / 100
				w: sym + cat

				if (sym + object/get-size errors) <= as red-value! w [
					print-line "*** Error: invalid spec value for MAKE"
					return new
				]
				word/make-at w/symbol base + field-type	;-- set 'type field

				errors: (as red-object! object/get-values errors) + cat
				sym: as red-word! object/get-words errors

				w: sym + (int/value // 100)
				if (sym + object/get-size errors) <= as red-value! w [
					print-line "*** Error: invalid spec value for MAKE"
					return new
				]
				word/make-at w/symbol base + field-id	;-- set 'id field
			]
			default [
				--NOT_IMPLEMENTED--
			]
		]
		new
	]

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

		;TBD
		part
	]

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

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

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