FEAT: added QUOTE mezzanine function.

FEAT: added QUOTE mezzanine function.

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

;-- datatype! is not defined here for obvious circular reference issue

unset!:			make datatype! #get-definition TYPE_UNSET
none!:			make datatype! #get-definition TYPE_NONE
logic!:			make datatype! #get-definition TYPE_LOGIC
block!:			make datatype! #get-definition TYPE_BLOCK
string!:		make datatype! #get-definition TYPE_STRING
integer!:		make datatype! #get-definition TYPE_INTEGER
;symbol!:		make datatype! #get-definition TYPE_SYMBOL
;context!:		make datatype! #get-definition TYPE_CONTEXT
word!:			make datatype! #get-definition TYPE_WORD
error!:			make datatype! #get-definition TYPE_ERROR
typeset!:		make datatype! #get-definition TYPE_TYPESET
file!:			make datatype! #get-definition TYPE_FILE

set-word!:		make datatype! #get-definition TYPE_SET_WORD
get-word!:		make datatype! #get-definition TYPE_GET_WORD
lit-word!:		make datatype! #get-definition TYPE_LIT_WORD
refinement!:	make datatype! #get-definition TYPE_REFINEMENT
binary!:		make datatype! #get-definition TYPE_BINARY
paren!:			make datatype! #get-definition TYPE_PAREN
char!:			make datatype! #get-definition TYPE_CHAR
issue!:			make datatype! #get-definition TYPE_ISSUE
path!:			make datatype! #get-definition TYPE_PATH
set-path!:		make datatype! #get-definition TYPE_SET_PATH
get-path!:		make datatype! #get-definition TYPE_GET_PATH
lit-path!:		make datatype! #get-definition TYPE_LIT_PATH
native!:		make datatype! #get-definition TYPE_NATIVE
action!:		make datatype! #get-definition TYPE_ACTION
op!:			make datatype! #get-definition TYPE_OP
function!:		make datatype! #get-definition TYPE_FUNCTION
closure!:		make datatype! #get-definition TYPE_CLOSURE
routine!:		make datatype! #get-definition TYPE_ROUTINE
object!:		make datatype! #get-definition TYPE_OBJECT
port!:			make datatype! #get-definition TYPE_PORT
bitset!:		make datatype! #get-definition TYPE_BITSET
float!:			make datatype! #get-definition TYPE_FLOAT

none:  			make none! 0
true:  			make logic! 1
false: 			make logic! 0

;------------------------------------------
;-				Actions					  -
;------------------------------------------

make: make action! [[									;--	this one works!	;-)
		"Returns a new value made from a spec for that value's type."
		type	 [any-type!] "The datatype or a prototype value."
		spec	 [any-type!] "The specification	of the new value."
		return:  [any-type!] "Returns the specified datatype."
	]
	#get-definition ACT_MAKE
]

;random

reflect: make action! [[
		"Returns internal details about a value via reflection."
		value	[any-type!]
		field 	[word!] "spec, body, words, etc. Each datatype defines its own reflectors"
	]
	#get-definition ACT_REFLECT
]

;to

form: make action! [[
		"Returns a user-friendly string representation of a value."
		value	  [any-type!]
		/part "Limit the length of the result"
			limit [integer!]
		return:	  [string!]
	]
	#get-definition ACT_FORM
]

mold: make action! [[
		"Returns a source format string representation of a value."
		value	  [any-type!]
		/only "Exclude outer brackets if value is a block"
		/all  "TBD: Return value in loadable format"
		/flat "TBD: Exclude all indentation"
		/part "Limit the length of the result"
			limit [integer!]
		return:	  [string!]
	]
	#get-definition ACT_MOLD
]

;-- Scalar actions --

absolute: make action! [[
		"Returns the non-negative value."
		value	 [number!]
		return:  [number!]
	]
	#get-definition ACT_ABSOLUTE
]

add: make action! [[
		"Returns the sum of the two values."
		value1	 [number!]
		value2	 [number!]
		return:  [number!]
	]
	#get-definition ACT_ADD
]

divide: make action! [[
		"Returns the quotient of two values."
		value1	 [number!] "The dividend (numerator)."
		value2	 [number!] "The divisor (denominator)."
		return:  [number!]
	]
	#get-definition ACT_DIVIDE
]

multiply: make action! [[
		"Returns the product of two values."
		value1	 [number!]
		value2	 [number!]
		return:  [number!]
	]
	#get-definition ACT_MULTIPLY
]

negate: make action! [[
		"Returns the opposite (additive inverse) value."
		number 	 [number!]
		return:  [number!]
	]
	#get-definition ACT_NEGATE
]

power: make action! [[
		"Returns a number raised to a given power (exponent)."
		number	 [number!] "Base value."
		exponent [number!] "The power (index) to raise the base value by."
		return:	 [number!]
	]
	#get-definition ACT_POWER
]

remainder: make action! [[
		"Returns what is left over when one value is divided by another."
		value1 	 [number!]
		value2 	 [number!]
		return:  [number!]
	]
	#get-definition ACT_REMAINDER
]

round: make action! [[
		"TBD: Returns the nearest integer. Halves round up (away from zero) by default."
		n		[number!]
		/to		"Return the nearest multiple of the scale parameter"
		scale	[number!] "Must be a non-zero value"
		/even		"Halves round toward even results"
		/down		"Round toward zero, ignoring discarded digits. (truncate)"
		/half-down	"Halves round toward zero"
		/floor		"Round in negative direction"
		/ceiling	"Round in positive direction"
		/half-ceiling "Halves round in positive direction"
	]
	#get-definition ACT_ROUND
]

subtract: make action! [[
		"Returns the difference between two values."
		value1	 [number!]
		value2	 [number!]
		return:  [number!]
	]
	#get-definition ACT_SUBTRACT
]

even?: make action! [[
		"Returns true if the number is evenly divisible by 2."
		number 	 [number!]
		return:  [number!]
	]
	#get-definition ACT_EVEN?
]

odd?: make action! [[
		"Returns true if the number has a remainder of 1 when divided by 2."
		number 	 [number!]
		return:  [number!]
	]
	#get-definition ACT_ODD?
]

;-- Bitwise actions --

;and~
;complement
;or~
;xor~

;-- Series actions --

append: make action! [[
		"Inserts value(s) at series tail; returns series head."
		series	   [series!]
		value	   [any-type!]
		/part "Limit the number of values inserted"
			length [number! series!]
		/only "Insert block types as single values (overrides /part)"
		/dup  "Duplicate the inserted values"
			count  [number!]
		return:    [series!]
	]
	#get-definition ACT_APPEND
]

at: make action! [[
		"Returns a series at a given index."
		series	 [series!]
		index 	 [integer!]
		return:  [series!]
	]
	#get-definition ACT_AT
]

back: make action! [[
		"Returns a series at the previous index."
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_BACK
]

;change

clear: make action! [[
		"Removes series values from current index to tail; returns new tail."
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_CLEAR
]

copy: make action! [[
		"Returns a copy of a non-scalar value."
		value	 [series!]
		/part	 "Limit the length of the result"
			length [number! series!]
		/deep	 "Copy nested values"
		/types	 "Copy only specific types of non-scalar values"
			kind [datatype!]
		return:  [series!]
	]
	#get-definition ACT_COPY
]

find: make action! [[
		"Returns the series where a value is found, or NONE."
		series	 [series! none!]
		value 	 [any-type!]
		/part "Limit the length of the search"
			length [number! series!]
		/only "Treat a series search value as a single value"
		/case "Perform a case-sensitive search"
		/any  "TBD: Use * and ? wildcards in string searches"
		/with "TBD: Use custom wildcards in place of * and ?"
			wild [string!]
		/skip "Treat the series as fixed size records"
			size [integer!]
		/last "Find the last occurrence of value, from the tail"
		/reverse "Find the last occurrence of value, from the current index"
		/tail "Return the tail of the match found, rather than the head"
		/match "Match at current index only and return tail of match"
	]
	#get-definition ACT_FIND
]

head: make action! [[
		"Returns a series at its first index."
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_HEAD
]

head?: make action! [[
		"Returns true if a series is at its first index."
		series	 [series!]
		return:  [logic!]
	]
	#get-definition ACT_HEAD?
]

index?: make action! [[
		"Returns the current series index, relative to the head."
		series	 [series!]
		return:  [integer!]
	]
	#get-definition ACT_INDEX?
]

insert: make action! [[
		"Inserts value(s) at series index; returns series head."
		series	   [series!]
		value	   [any-type!]
		/part "Limit the number of values inserted"
			length [number! series!]
		/only "Insert block types as single values (overrides /part)"
		/dup  "Duplicate the inserted values"
			count  [number!]
		return:    [series!]
	]
	#get-definition ACT_INSERT
]

length?: make action! [[
		"Returns the number of values in the series, from the current index to the tail."
		series	 [series!]
		return:  [integer!]
	]
	#get-definition ACT_LENGTH?
]

next: make action! [[
		"Returns a series at the next index."
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_NEXT
]

pick: make action! [[
		"Returns the series value at a given index."
		series	 [series!]
		index 	 [integer! logic!]
		return:  [any-type!]
	]
	#get-definition ACT_PICK
]

poke: make action! [[
		"Replaces the series value at a given index, and returns the new value."
		series	 [series!]
		index 	 [integer! logic!]
		value 	 [any-type!]
		return:  [series!]
	]
	#get-definition ACT_POKE
]

remove: make action! [[
		"Returns the series at the same index after removing a value."
		series	 [series! none!]
		/part "Removes a number of values, or values up to the given series index"
			length [number! series!]
		return:  [series! none!]
	]
	#get-definition ACT_REMOVE
]

;reverse

select: make action! [[
		"Find a value in a series and return the next value, or NONE."
		series	 [series! none!]
		value 	 [any-type!]
		/part "Limit the length of the search"
			length [number! series!]
		/only "Treat a series search value as a single value"
		/case "Perform a case-sensitive search"
		/any  "TBD: Use * and ? wildcards in string searches"
		/with "TBD: Use custom wildcards in place of * and ?"
			wild [string!]
		/skip "Treat the series as fixed size records"
			size [integer!]
		/last "Find the last occurrence of value, from the tail"
		/reverse "Find the last occurrence of value, from the current index"
		return:  [any-type!]
	]
	#get-definition ACT_SELECT
]

;sort

skip: make action! [[
		"Returns the series relative to the current index."
		series	 [series!]
		offset 	 [integer!]
		return:  [series!]
	]
	#get-definition ACT_SKIP
]

;swap

tail: make action! [[
		"Returns a series at the index after its last value."
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_TAIL
]

tail?: make action! [[
		"Returns true if a series is past its last value."
		series	 [series!]
		return:  [logic!]
	]
	#get-definition ACT_TAIL?
]

;take
;trim

;-- I/O actions --

;create
;close
;delete
;modify
;open
;open?
;query
;read
;rename
;update
;write

;------------------------------------------
;-				Natives					  -
;------------------------------------------

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

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

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

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

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

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

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

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

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

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

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

;break: make native! [
;	[]													;@@ add /return option
;	none
;]

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

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

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

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

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

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

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

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

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

get: make native! [[
		"Returns the value a word refers to."
		word	[word!]
		/any "If word has no value, return UNSET rather than causing an error"
		return: [any-type!]
	]
	#get-definition NAT_GET
]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

load: make native! [[
		"Returns a value or block of values by reading and evaluating a source."
		source [file! url! string! binary! block!]
		/header "TBD: Include Red header as a loaded value"
		/all    "TBD: Don't evaluate Red header"
		/type	"TBD:"
		/into "Put results in out block, instead of creating a new block"
			out [block!] "Target block for results, when /into is used"
	]
	#get-definition NAT_LOAD
]

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

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

;------------------------------------------
;-			   Operators				  -
;------------------------------------------

;-- #load temporary directive is used to workaround REBOL LOAD limitations on some words

#load set-word! "+"  make op! :add
#load set-word! "-"  make op! :subtract
#load set-word! "*"  make op! :multiply
#load set-word! "/"  make op! :divide
#load set-word! "="  make op! :equal?
#load set-word! "<>" make op! :not-equal?
#load set-word! "==" make op! :strict-equal?
#load set-word! "=?" make op! :same?
#load set-word! "<"  make op! :lesser?
#load set-word! ">"  make op! :greater?
#load set-word! "<=" make op! :lesser-or-equal?
#load set-word! ">=" make op! :greater-or-equal?

;------------------------------------------
;-				Scalars					  -
;------------------------------------------
Red: true												;-- ultimate Truth ;-) (pre-defines Red word)

yes: on: true
no: off: false
;empty?: :tail?

tab:		 #"^-"
cr: 		 #"^M"
newline: lf: #"^/"
escape:      #"^["
slash: 		 #"/"
sp: space: 	 #" "
null: 		 #"^@"
crlf:		 "^M^/"
dot:		 #"."

;------------------------------------------
;-			   Mezzanines				  -
;------------------------------------------

quit-return: routine [
	"Stops evaluation and exits the program with a given status."
	status			[integer!] "Process termination value to return"
][
	quit status
]
quit: func [
	"Stops evaluation and exits the program."
	/return status	[integer!] "Return an exit status"
][
	quit-return any [status 0]
]

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

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

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

quote: func [
	:value
][
	:value
]

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

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

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

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

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

system: function [
	"Returns information about the interpreter."
	/version	"Return the system version"
	/words		"Return a block of global words available"
	/platform	"Return a word identifying the operating system"
][
	case [
		version [#version]
		words	[#system [_context/get-words]]
		platform [
			#system [
				#switch OS [
					Windows  [SET_RETURN(words/_windows)]
					Syllable [SET_RETURN(words/_syllable)]
					MacOSX	 [SET_RETURN(words/_macosx)]
					#default [SET_RETURN(words/_linux)]
				]
			]
		]
		'else [
			print "Please specify a system refinement value (/version, /words, or /platform)."
		]
	]
]

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

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

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

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

;-- datatype! is not defined here for obvious circular reference issue

unset!:			make datatype! #get-definition TYPE_UNSET
none!:			make datatype! #get-definition TYPE_NONE
logic!:			make datatype! #get-definition TYPE_LOGIC
block!:			make datatype! #get-definition TYPE_BLOCK
string!:		make datatype! #get-definition TYPE_STRING
integer!:		make datatype! #get-definition TYPE_INTEGER
;symbol!:		make datatype! #get-definition TYPE_SYMBOL
;context!:		make datatype! #get-definition TYPE_CONTEXT
word!:			make datatype! #get-definition TYPE_WORD
error!:			make datatype! #get-definition TYPE_ERROR
typeset!:		make datatype! #get-definition TYPE_TYPESET
file!:			make datatype! #get-definition TYPE_FILE

set-word!:		make datatype! #get-definition TYPE_SET_WORD
get-word!:		make datatype! #get-definition TYPE_GET_WORD
lit-word!:		make datatype! #get-definition TYPE_LIT_WORD
refinement!:	make datatype! #get-definition TYPE_REFINEMENT
binary!:		make datatype! #get-definition TYPE_BINARY
paren!:			make datatype! #get-definition TYPE_PAREN
char!:			make datatype! #get-definition TYPE_CHAR
issue!:			make datatype! #get-definition TYPE_ISSUE
path!:			make datatype! #get-definition TYPE_PATH
set-path!:		make datatype! #get-definition TYPE_SET_PATH
get-path!:		make datatype! #get-definition TYPE_GET_PATH
lit-path!:		make datatype! #get-definition TYPE_LIT_PATH
native!:		make datatype! #get-definition TYPE_NATIVE
action!:		make datatype! #get-definition TYPE_ACTION
op!:			make datatype! #get-definition TYPE_OP
function!:		make datatype! #get-definition TYPE_FUNCTION
closure!:		make datatype! #get-definition TYPE_CLOSURE
routine!:		make datatype! #get-definition TYPE_ROUTINE
object!:		make datatype! #get-definition TYPE_OBJECT
port!:			make datatype! #get-definition TYPE_PORT
bitset!:		make datatype! #get-definition TYPE_BITSET
float!:			make datatype! #get-definition TYPE_FLOAT

none:  			make none! 0
true:  			make logic! 1
false: 			make logic! 0

;------------------------------------------
;-				Actions					  -
;------------------------------------------

make: make action! [[									;--	this one works!	;-)
		"Returns a new value made from a spec for that value's type."
		type	 [any-type!] "The datatype or a prototype value."
		spec	 [any-type!] "The specification	of the new value."
		return:  [any-type!] "Returns the specified datatype."
	]
	#get-definition ACT_MAKE
]

;random

reflect: make action! [[
		"Returns internal details about a value via reflection."
		value	[any-type!]
		field 	[word!] "spec, body, words, etc. Each datatype defines its own reflectors"
	]
	#get-definition ACT_REFLECT
]

;to

form: make action! [[
		"Returns a user-friendly string representation of a value."
		value	  [any-type!]
		/part "Limit the length of the result"
			limit [integer!]
		return:	  [string!]
	]
	#get-definition ACT_FORM
]

mold: make action! [[
		"Returns a source format string representation of a value."
		value	  [any-type!]
		/only "Exclude outer brackets if value is a block"
		/all  "TBD: Return value in loadable format"
		/flat "TBD: Exclude all indentation"
		/part "Limit the length of the result"
			limit [integer!]
		return:	  [string!]
	]
	#get-definition ACT_MOLD
]

;-- Scalar actions --

absolute: make action! [[
		"Returns the non-negative value."
		value	 [number!]
		return:  [number!]
	]
	#get-definition ACT_ABSOLUTE
]

add: make action! [[
		"Returns the sum of the two values."
		value1	 [number!]
		value2	 [number!]
		return:  [number!]
	]
	#get-definition ACT_ADD
]

divide: make action! [[
		"Returns the quotient of two values."
		value1	 [number!] "The dividend (numerator)."
		value2	 [number!] "The divisor (denominator)."
		return:  [number!]
	]
	#get-definition ACT_DIVIDE
]

multiply: make action! [[
		"Returns the product of two values."
		value1	 [number!]
		value2	 [number!]
		return:  [number!]
	]
	#get-definition ACT_MULTIPLY
]

negate: make action! [[
		"Returns the opposite (additive inverse) value."
		number 	 [number!]
		return:  [number!]
	]
	#get-definition ACT_NEGATE
]

power: make action! [[
		"Returns a number raised to a given power (exponent)."
		number	 [number!] "Base value."
		exponent [number!] "The power (index) to raise the base value by."
		return:	 [number!]
	]
	#get-definition ACT_POWER
]

remainder: make action! [[
		"Returns what is left over when one value is divided by another."
		value1 	 [number!]
		value2 	 [number!]
		return:  [number!]
	]
	#get-definition ACT_REMAINDER
]

round: make action! [[
		"TBD: Returns the nearest integer. Halves round up (away from zero) by default."
		n		[number!]
		/to		"Return the nearest multiple of the scale parameter"
		scale	[number!] "Must be a non-zero value"
		/even		"Halves round toward even results"
		/down		"Round toward zero, ignoring discarded digits. (truncate)"
		/half-down	"Halves round toward zero"
		/floor		"Round in negative direction"
		/ceiling	"Round in positive direction"
		/half-ceiling "Halves round in positive direction"
	]
	#get-definition ACT_ROUND
]

subtract: make action! [[
		"Returns the difference between two values."
		value1	 [number!]
		value2	 [number!]
		return:  [number!]
	]
	#get-definition ACT_SUBTRACT
]

even?: make action! [[
		"Returns true if the number is evenly divisible by 2."
		number 	 [number!]
		return:  [number!]
	]
	#get-definition ACT_EVEN?
]

odd?: make action! [[
		"Returns true if the number has a remainder of 1 when divided by 2."
		number 	 [number!]
		return:  [number!]
	]
	#get-definition ACT_ODD?
]

;-- Bitwise actions --

;and~
;complement
;or~
;xor~

;-- Series actions --

append: make action! [[
		"Inserts value(s) at series tail; returns series head."
		series	   [series!]
		value	   [any-type!]
		/part "Limit the number of values inserted"
			length [number! series!]
		/only "Insert block types as single values (overrides /part)"
		/dup  "Duplicate the inserted values"
			count  [number!]
		return:    [series!]
	]
	#get-definition ACT_APPEND
]

at: make action! [[
		"Returns a series at a given index."
		series	 [series!]
		index 	 [integer!]
		return:  [series!]
	]
	#get-definition ACT_AT
]

back: make action! [[
		"Returns a series at the previous index."
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_BACK
]

;change

clear: make action! [[
		"Removes series values from current index to tail; returns new tail."
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_CLEAR
]

copy: make action! [[
		"Returns a copy of a non-scalar value."
		value	 [series!]
		/part	 "Limit the length of the result"
			length [number! series!]
		/deep	 "Copy nested values"
		/types	 "Copy only specific types of non-scalar values"
			kind [datatype!]
		return:  [series!]
	]
	#get-definition ACT_COPY
]

find: make action! [[
		"Returns the series where a value is found, or NONE."
		series	 [series! none!]
		value 	 [any-type!]
		/part "Limit the length of the search"
			length [number! series!]
		/only "Treat a series search value as a single value"
		/case "Perform a case-sensitive search"
		/any  "TBD: Use * and ? wildcards in string searches"
		/with "TBD: Use custom wildcards in place of * and ?"
			wild [string!]
		/skip "Treat the series as fixed size records"
			size [integer!]
		/last "Find the last occurrence of value, from the tail"
		/reverse "Find the last occurrence of value, from the current index"
		/tail "Return the tail of the match found, rather than the head"
		/match "Match at current index only and return tail of match"
	]
	#get-definition ACT_FIND
]

head: make action! [[
		"Returns a series at its first index."
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_HEAD
]

head?: make action! [[
		"Returns true if a series is at its first index."
		series	 [series!]
		return:  [logic!]
	]
	#get-definition ACT_HEAD?
]

index?: make action! [[
		"Returns the current series index, relative to the head."
		series	 [series!]
		return:  [integer!]
	]
	#get-definition ACT_INDEX?
]

insert: make action! [[
		"Inserts value(s) at series index; returns series head."
		series	   [series!]
		value	   [any-type!]
		/part "Limit the number of values inserted"
			length [number! series!]
		/only "Insert block types as single values (overrides /part)"
		/dup  "Duplicate the inserted values"
			count  [number!]
		return:    [series!]
	]
	#get-definition ACT_INSERT
]

length?: make action! [[
		"Returns the number of values in the series, from the current index to the tail."
		series	 [series!]
		return:  [integer!]
	]
	#get-definition ACT_LENGTH?
]

next: make action! [[
		"Returns a series at the next index."
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_NEXT
]

pick: make action! [[
		"Returns the series value at a given index."
		series	 [series!]
		index 	 [integer! logic!]
		return:  [any-type!]
	]
	#get-definition ACT_PICK
]

poke: make action! [[
		"Replaces the series value at a given index, and returns the new value."
		series	 [series!]
		index 	 [integer! logic!]
		value 	 [any-type!]
		return:  [series!]
	]
	#get-definition ACT_POKE
]

remove: make action! [[
		"Returns the series at the same index after removing a value."
		series	 [series! none!]
		/part "Removes a number of values, or values up to the given series index"
			length [number! series!]
		return:  [series! none!]
	]
	#get-definition ACT_REMOVE
]

;reverse

select: make action! [[
		"Find a value in a series and return the next value, or NONE."
		series	 [series! none!]
		value 	 [any-type!]
		/part "Limit the length of the search"
			length [number! series!]
		/only "Treat a series search value as a single value"
		/case "Perform a case-sensitive search"
		/any  "TBD: Use * and ? wildcards in string searches"
		/with "TBD: Use custom wildcards in place of * and ?"
			wild [string!]
		/skip "Treat the series as fixed size records"
			size [integer!]
		/last "Find the last occurrence of value, from the tail"
		/reverse "Find the last occurrence of value, from the current index"
		return:  [any-type!]
	]
	#get-definition ACT_SELECT
]

;sort

skip: make action! [[
		"Returns the series relative to the current index."
		series	 [series!]
		offset 	 [integer!]
		return:  [series!]
	]
	#get-definition ACT_SKIP
]

;swap

tail: make action! [[
		"Returns a series at the index after its last value."
		series	 [series!]
		return:  [series!]
	]
	#get-definition ACT_TAIL
]

tail?: make action! [[
		"Returns true if a series is past its last value."
		series	 [series!]
		return:  [logic!]
	]
	#get-definition ACT_TAIL?
]

;take
;trim

;-- I/O actions --

;create
;close
;delete
;modify
;open
;open?
;query
;read
;rename
;update
;write

;------------------------------------------
;-				Natives					  -
;------------------------------------------

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

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

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

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

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

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

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

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

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

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

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

;break: make native! [
;	[]													;@@ add /return option
;	none
;]

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

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

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

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

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

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

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

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

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

get: make native! [[
		"Returns the value a word refers to."
		word	[word!]
		/any "If word has no value, return UNSET rather than causing an error"
		return: [any-type!]
	]
	#get-definition NAT_GET
]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

load: make native! [[
		"Returns a value or block of values by reading and evaluating a source."
		source [file! url! string! binary! block!]
		/header "TBD: Include Red header as a loaded value"
		/all    "TBD: Don't evaluate Red header"
		/type	"TBD:"
		/into "Put results in out block, instead of creating a new block"
			out [block!] "Target block for results, when /into is used"
	]
	#get-definition NAT_LOAD
]

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

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

;------------------------------------------
;-			   Operators				  -
;------------------------------------------

;-- #load temporary directive is used to workaround REBOL LOAD limitations on some words

#load set-word! "+"  make op! :add
#load set-word! "-"  make op! :subtract
#load set-word! "*"  make op! :multiply
#load set-word! "/"  make op! :divide
#load set-word! "="  make op! :equal?
#load set-word! "<>" make op! :not-equal?
#load set-word! "==" make op! :strict-equal?
#load set-word! "=?" make op! :same?
#load set-word! "<"  make op! :lesser?
#load set-word! ">"  make op! :greater?
#load set-word! "<=" make op! :lesser-or-equal?
#load set-word! ">=" make op! :greater-or-equal?

;------------------------------------------
;-				Scalars					  -
;------------------------------------------
Red: true												;-- ultimate Truth ;-) (pre-defines Red word)

yes: on: true
no: off: false
;empty?: :tail?

tab:		 #"^-"
cr: 		 #"^M"
newline: lf: #"^/"
escape:      #"^["
slash: 		 #"/"
sp: space: 	 #" "
null: 		 #"^@"
crlf:		 "^M^/"
dot:		 #"."

;------------------------------------------
;-			   Mezzanines				  -
;------------------------------------------

quit-return: routine [
	"Stops evaluation and exits the program with a given status."
	status			[integer!] "Process termination value to return"
][
	quit status
]
quit: func [
	"Stops evaluation and exits the program."
	/return status	[integer!] "Return an exit status"
][
	quit-return any [status 0]
]

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

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

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

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

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

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

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

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

system: function [
	"Returns information about the interpreter."
	/version	"Return the system version"
	/words		"Return a block of global words available"
	/platform	"Return a word identifying the operating system"
][
	case [
		version [#version]
		words	[#system [_context/get-words]]
		platform [
			#system [
				#switch OS [
					Windows  [SET_RETURN(words/_windows)]
					Syllable [SET_RETURN(words/_syllable)]
					MacOSX	 [SET_RETURN(words/_macosx)]
					#default [SET_RETURN(words/_linux)]
				]
			]
		]
		'else [
			print "Please specify a system refinement value (/version, /words, or /platform)."
		]
	]
]

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

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

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


I can now start to parse fragments of SML!

on echo;
load_package lalr;

lisp;

enable!-errorset(3,3);

prec := nil;

% The grammar used here is derived from one found at
%    https://www.mpi-sws.org/~rossberg/sml.html

grammar := '(

 (toplevel ((prog ";" "eof") (progn (terpri) (print !$1))))

% Constants for SML should be
%     int      [~]<digits>
%              [~]0x<hexdigits>
%     float    [~]<digits>.<digits>[e[~]<digits>]
%     word     0w<digits>
%              0wx<hexdigits>
%     string   "<chars>"        may use "\" based escape sequence
%     char     #"<1-char>"

 (con    ((!:number))      % Needs int vs. float, also hex input
         (("~" !:number))
         (("#" !:string))
         ((!:string)))

 (id     ((!:symbol)))

 (var    (("'" !:symbol))
         (("''" !:symbol)))

 (longid ((id) (progn (princ "Id found ") (print !$1) !$1))
         ((longid "." id)))

 (lab    ((id))
         ((!:number)))

 (tupletail
         ((")"))
         (("," exp tupletail)))

 (listail
         (("]"))
         (("," exp listail)))

 (seqtail
         ((")"))
         ((";" exp seqtail)))

 (seqexps
         (())
         ((";" exp seqexps)))

 (exp    ((con)    (progn (princ "Parsed constant") (print !$1)))
         ((longid))
         (("op" longid))
         ((exp exp))
         (("!" exp) (list 'pling !$2))
         (("+" exp) !$2)
         (("~" exp) (list 'minus !$2))
         ((exp id exp) (list !$2 !$1 !$3))
         ((exp "+" exp) (progn (printc "sum spotted") (list 'plus !$1 !$3)))
         ((exp "-" exp) (progn (printc "difference spotted") (list 'difference !$1 !$3)))
         ((exp "*" exp) (progn (printc "product spotted") (list 'times !$1 !$3)))
         ((exp "/" exp) (progn (printc "quotient spotted") (list 'quotient !$1 !$3)))
         ((exp "%" exp) (progn (printc "remainder spotted") (list 'remainder !$1 !$3)))
         ((exp "^" exp) (list 'stringconcat !$1 !$3))
         ((exp "div" exp) (progn (printc "quotient spotted") (list 'quotient !$1 !$3)))
         ((exp "mod" exp) (progn (printc "remainder spotted") (list 'remainder !$1 !$3)))
         ((exp ">" exp) (list 'greaterp !$1 !$3))
         ((exp ">=" exp) (list 'geq !$1 !$3))
         ((exp "<" exp) (list 'lessp !$1 !$3))
         ((exp "<=" exp) (list 'leq !$1 !$3))
         ((exp "=" exp) (list 'equal !$1 !$3))
         ((exp "<>" exp) (list 'neq !$1 !$3))
         ((exp ":=" exp) (list 'setq !$1 !$3))
         (("(" exp tupletail))
         (("{" "}"))
         (("{" exprow "}"))
         (("#" lab))
         (("[" "]"))
         (("[" exp listail))
         (("(" exp ";" exp seqtail))
         (("let" dec "in" exp seqexps "end"))
         ((exp ":" type))
         (("raise" exp))
         ((exp "handle" match))
         ((exp "andalso" exp))
         ((exp "orelse" exp))
         (("if" exp "then" exp "else" exp))
         (("while" exp "do" exp))
         (("case" exp "of" match))
         (("fn" match)))

 (exprow ((lab "=" exp))
         ((lab "=" exp "," exprow)))

 (match  ((pat "=>" exp))
         ((pat "=>" exp "|" match)))

 (pat    ((con))
         (("_"))
         ((id))
         (("op" id))
         ((longid))
         (("op" longid))
         ((longid pat))
         (("op" longid pat))
         ((pat id pat))
         (("(" patseq ")"))
         (("(" ")"))
         (("{" patrow "}"))
         (("[" patseq "]"))
         (("[" "]"))
         ((pat ":" typ))
         ((!:symbol "as" pat))
         (("op" !:symbol "as" pat))
         ((!:symbol ":" typ "as" pat))
         (("op" !:symbol ":" typ "as" pat)))

 (patseq ((pat))
         ((patseq "," pat)))

 (patrow (("..."))
         ((lab "=" pat))
         ((lab "=" pat "," patrow))
         ((id))
         ((id ":" typ))
         ((id "as" pat))
         ((id ":" typ "as" pat))
         ((id "," patrow))
         ((id ":" typ "," patrow))
         ((id "as" pat "," patrow))
         ((id ":" typ "as" pat "," patrow)))

 (typ    ((var))
         ((longid))
         ((typ longid))
         (("(" typ "," ttail ")" longid))
         (("(" typ ")"))
         ((typ "->" typ))
         ((typ starstuff))
         (("{" typrow "}")))

 (ttail  ((typ))
         ((typ "," ttail)))

 (starstuff (())
            (("*" typ starstuff)))

 (typrow ((lab ":" typ))
         ((lab ":" typ "," typrow)))

 (varcomma (())
         ((var))
         (("(" var varcommatail ")")))

 (varcommatail (("," var))
         (("," var varcommatail)))

 (dec    (("val" varcomma valbind))
         (("fun" varcomma funbind))
         (("type" typbind))
         (("datatype" datbind))
         (("datatype" datbind "withtype" typbind))
         (("datatype" id "=" "datatype" longid))
         (("abstype" datbind "with" dec "end"))
         (("abstype" datbind "withtype" typbind "with" dec "end"))
         (("exception" exnbind))
%        (("structure" strbind))
%@@      ((dec ";" dec))
         (("local" dec "in" dec "end"))
%        (("open" longid))   % Could have multiple longids here
%        (("nonfix" id))     % multiple ids
%        (("infix" id))
%        (("infix" digit id))
%        (("infixr" id))
%        (("infixr" digit id))
         )

 (valbind ((pat "=" exp))
          ((pat "=" exp "and" valbind))
          (("rec" valbind)))

 (funbind ((funmatch))
          ((funmatch "and" funbind)))

 (funmatch ((id patterns "=" exp) (progn (print !$1) (print !$2) (print !$4)
             (list 'de !$1 !$2 !$4)))
           (("op" id patterns "=" exp))
           ((id patterns ":" typ "=" exp))
           (("op" id patterns ":" typ "=" exp))
           ((id patterns "=" exp "|" funmatch))
           (("op" id patterns "=" exp "|" funmatch))
           ((id patterns ":" typ "=" exp "|" funmatch))
           (("op" id patterns ":" typ "=" exp "|" funmatch)))

 (patterns ((pat))
           ((patterns pat)))

 (typbind  ((varcomma id "=" typ))
           ((varcomma id "=" typ "and" typbind)))

 (datbind  ((varcomma id "=" conbind))
           ((varcomma id "=" conbind "and" datbind)))

 (conbind  ((id))
           ((id "of" typ))
           ((id "|" conbind))
           ((id "of" typ "|" conbind)))

 (exnbind  ((id))
           ((id "of" typ))
           ((id "|" exnbind))
           ((id "of" typ "|" exnbind))
           ((id "=" longid))
           ((id "=" longid "|" exnbind)))

% (str)
% (strbind)
% (sig)
% (typrefin)
% (spec)
% (valdesc)
% (typdesc)
% (detdesc)
% (condest)
% (exndesc)
% (strdesc)

(prog     ((dec))
          ((exp))
%         (("functor" fctbind))
%         (("signature" sigbind))
%         ((prog ";" prog))       % For now I will only allow one clause
          )

% (fctbind)
% (sigbind)
%
  )$

<< terpri(); prettyprint grammar; nil >>;

pp := lalr_create_parser(prec, grammar)$

tr yylex;

<< lex_init(); yyparse pp >>;

1+2;
eof

;;;;;

<< lex_init(); yyparse pp >>;

fun fact n =
  if n = 1 then 1
  else n * fact (n-1);

eof

;

end;

on echo;
load_package lalr;

lisp;

prec := nil;

% The grammar used here is derived from one found at
%    https://www.mpi-sws.org/~rossberg/sml.html

grammar := '(

 (toplevel ((prog)))

% Constants for SML should be
%     int      [~]<digits>
%              [~]0x<hexdigits>
%     float    [~]<digits>.<digits>[e[~]<digits>]
%     word     0w<digits>
%              0wx<hexdigits>
%     string   "<chars>"        may use "\" based escape sequence
%     char     #"<1-char>"

 (con    ((!:number))      % Needs int vs. float, also hex input
         (("~" !:number))
         (("#" !:string))
         ((!:string)))

 (id     ((!:symbol)))

 (var    (("'" !:symbol))
         (("''" !:symbol)))

 (longid ((id))
         ((longid "." id)))

 (lab    ((id))
         ((!:number)))

 (tupletail
         ((")"))
         (("," exp tupletail)))

 (listail
         (("]"))
         (("," exp listail)))

 (seqtail
         ((")"))
         ((";" exp seqtail)))

 (seqexps
         (())
         ((";" exp seqexps)))

 (exp    ((con))
         ((longid))
         (("op" longid))
         ((exp exp))
         ((exp id exp))
         (("(" exp tupletail))
         (("{" "}"))
         (("{" exprow "}"))
         (("#" lab))
         (("[" "]"))
         (("[" exp listail))
         (("(" exp ";" exp seqtail))
         (("let" dec "in" exp seqexps "end"))
         ((exp ":" type))
         (("raise" exp))
         ((exp "handle" match))
         ((exp "andalso" exp))
         ((exp "orelse" exp))
         (("if" exp "then" exp "else" exp))
         (("while" exp "do" exp))
         (("case" exp "of" match))
         (("fn" match)))

 (exprow ((lab "=" exp))
         ((lab "=" exp "," exprow)))

 (match  ((pat "=>" exp))
         ((pat "=>" exp "|" match)))

 (pat    ((con))
         (("_"))
         ((id))
         (("op" id))
         ((longid))
         (("op" longid))
         ((longid pat))
         (("op" longid pat))
         ((pat id pat))
         (("(" patseq ")"))
         (("(" ")"))
         (("{" patrow "}"))
         (("[" patseq "]"))
         (("[" "]"))
         ((pat ":" typ))
         ((!:symbol "as" pat))
         (("op" !:symbol "as" pat))
         ((!:symbol ":" typ "as" pat))
         (("op" !:symbol ":" typ "as" pat)))

 (patseq ((pat))
         ((patseq "," pat)))

 (patrow (("..."))
         ((lab "=" pat))
         ((lab "=" pat "," patrow))
         ((id))
         ((id ":" typ))
         ((id "as" pat))
         ((id ":" typ "as" pat))
         ((id "," patrow))
         ((id ":" typ "," patrow))
         ((id "as" pat "," patrow))
         ((id ":" typ "as" pat "," patrow)))

 (typ    ((var))
         ((longid))
         ((typ longid))
         (("(" typ "," ttail ")" longid))
         (("(" typ ")"))
         ((typ "->" typ))
         ((typ starstuff))
         (("{" typrow "}")))

 (ttail  ((typ))
         ((typ "," ttail)))

 (starstuff (())
            (("*" typ starstuff)))

 (typrow ((lab ":" typ))
         ((lab ":" typ "," typrow)))

 (varcomma (())
         ((var))
         (("(" var varcommatail ")")))

 (varcommatail (("," var))
         (("," var varcommatail)))

 (dec    (("val" varcomma valbind))
         (("fun" varcomma funbind))
         (("type" typbind))
         (("datatype" datbind))
         (("datatype" datbind "withtype" typbind))
         (("datatype" id "=" "datatype" longid))
         (("abstype" datbind "with" dec "end"))
         (("abstype" datbind "withtype" typbind "with" dec "end"))
         (("exception" exnbind))
%        (("structure" strbind))
         ((dec ";" dec))
         (("local" dec "in" dec "end"))
%        (("open" longid))   % Could have multiple longids here
%        (("nonfix" id))     % multiple ids
%        (("infix" id))
%        (("infix" digit id))
%        (("infixr" id))
%        (("infixr" digit id))
         )

 (valbind ((pat "=" exp))
          ((pat "=" exp "and" valbind))
          (("rec" valbind)))

 (funbind ((funmatch))
          ((funmatch "and" funbind)))

 (funmatch ((id patterns "=" exp))
           (("op" id patterns "=" exp))
           ((id patterns ":" typ "=" exp))
           (("op" id patterns ":" typ "=" exp))
           ((id patterns "=" exp "|" funmatch))
           (("op" id patterns "=" exp "|" funmatch))
           ((id patterns ":" typ "=" exp "|" funmatch))
           (("op" id patterns ":" typ "=" exp "|" funmatch)))

 (patterns ((pat))
           ((patterns pat)))

 (typbind  ((varcomma id "=" typ))
           ((varcomma id "=" typ "and" typbind)))

 (datbind  ((varcomma id "=" conbind))
           ((varcomma id "=" conbind "and" datbind)))

 (conbind  ((id))
           ((id "of" typ))
           ((id "|" conbind))
           ((id "of" typ "|" conbind)))

 (exnbind  ((id))
           ((id "of" typ))
           ((id "|" exnbind))
           ((id "of" typ "|" exnbind))
           ((id "=" longid))
           ((id "=" longid "|" exnbind)))

% (str)
% (strbind)
% (sig)
% (typrefin)
% (spec)
% (valdesc)
% (typdesc)
% (detdesc)
% (condest)
% (exndesc)
% (strdesc)

(prog     ((dec))
%         (("functor" fctbind))
%         (("signature" sigbind))
          ((prog ";" prog)))

% (fctbind)
% (sigbind)
%
  )$

<< terpri(); prettyprint grammar; nil >>;

pp := lalr_create_parser(prec, grammar);

end;


Entabbed file.

Entabbed file.

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

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: 	 "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
				ReadConsole: 	 "ReadConsoleA" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
	][
		#switch OS [
			MacOSX [
				#define ReadLine-library "libreadline.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
				rl-bind-key: "rl_bind_key" [
					key				[integer!]
					command			[integer!]
					return:			[integer!]
				]
				rl-insert:	 "rl_insert" [
					count			[integer!]
					key				[integer!]
					return:			[integer!]
				]
			]
			#if OS <> 'MacOSX [
				History-library cdecl [
					add-history: "add_history" [  ; Add line to the history.
						line		[c-string!]
					]
				]
			]
		]

		rl-insert-wrapper: func [
			[cdecl]
			count   [integer!]
			key	    [integer!]
			return: [integer!]
		][
			rl-insert count key
		]

	]
]

Windows?: system/platform = 'Windows

init-console: routine [
	str [string!]
	/local
		ret
][
	#either OS = 'Windows [
		;ret: AttachConsole -1
		;if zero? ret [print-line "ReadConsole failed!" halt]

		ret: SetConsoleTitle as c-string! string/rs-head str
		if zero? ret [print-line "SetConsoleTitle failed!" halt]
	][
		rl-bind-key as-integer tab as-integer :rl-insert-wrapper
	]
]

input: routine [
	prompt [string!]
	/local
		len ret str buffer line
][
	#either OS = 'Windows [
		len: 0
		buffer: allocate 128
		print as c-string! string/rs-head prompt
		ret: ReadConsole stdin buffer 127 :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		len: len + 1
		buffer/len: null-byte
		str: string/load as c-string! buffer len
;		free buffer
	][
		line: read-line as c-string! string/rs-head prompt
		if line = null [halt]  ; EOF

		 #if OS <> 'MacOSX [add-history line]

		str: string/load line  1 + length? line
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

count-delimiters: function [
	buffer	[string!]
	return: [block!]
][
	list: copy [0 0]
	c: none

	foreach c buffer [
		either in-comment? [
			switch c [
				#"^/" [in-comment?: false]
			]
		][
			switch c [
				#";" [in-comment?: true]
				#"[" [list/1: list/1 + 1]
				#"]" [list/1: list/1 - 1]
				#"{" [list/2: list/2 + 1]
				#"}" [list/2: list/2 - 1]
			]
		]
	]
	list
]

do-console: function [][
	buffer: make string! 10000
	prompt: red-prompt: "red>> "
	mode:  'mono

	switch-mode: [
		mode: case [
			cnt/1 > 0 ['block]
			cnt/2 > 0 ['string]
			'else 	  [
				prompt: red-prompt
				do eval
				'mono
			]
		]
		prompt: switch mode [
			block  ["[^-"]
			string ["{^-"]
			mono   [red-prompt]
		]
	]

	eval: [
		code: load/all buffer

		unless tail? code [
			set/any 'result do code

			unless unset? :result [
				if 67 = length? result: mold/part :result 67 [	;-- optimized for width = 72
					clear back tail result
					append result "..."
				]
				print ["==" result]
			]
		]
		clear buffer
	]

	while [true][
		unless tail? line: input prompt [
			append buffer line
			cnt: count-delimiters buffer

			either Windows? [
				remove skip tail buffer -2			;-- clear extra CR (Windows)
			][
				append buffer lf					;-- Unix
			]

			switch mode [
				block  [if cnt/1 <= 0 [do switch-mode]]
				string [if cnt/2 <= 0 [do switch-mode]]
				mono   [do either any [cnt/1 > 0 cnt/2 > 0][switch-mode][eval]]
			]
		]
	]
]

q: :quit

init-console "Red Console"

print {
-=== Red Console alpha version ===-
(only Latin-1 input supported)
}

do-console


FIX: improved console line endings support for non-Windows platforms. FIX: Q short-cut put back (when in console only). FIX: minor console code cleanups.

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

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: 	 "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
				ReadConsole: 	 "ReadConsoleA" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
	][
		#switch OS [
			MacOSX [  ; TODO: check this
				#define ReadLine-library "libreadline.dylib"
				#define History-library  "libhistory.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
			]
			History-library cdecl [
				add-history: "add_history" [  ; Add line to the history.
					line			[c-string!]
				]
			]
		]
	]
]

init-console: routine [
	str [string!]
	/local
		ret
][
	#either OS = 'Windows [
		;ret: AttachConsole -1
		;if zero? ret [print-line "ReadConsole failed!" halt]

		ret: SetConsoleTitle as c-string! string/rs-head str
		if zero? ret [print-line "ReadConsole failed!" halt]
	][
		print-line as-c-string string/rs-head str
	]
]

input: routine [
	/local
		len ret str buffer line
][
	#either OS = 'Windows [
		len: 0
		buffer: allocate 128
		ret: ReadConsole stdin buffer 127 :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		len: len + 1
		buffer/len: null-byte
		str: string/load as c-string! buffer len
;		free buffer
	][
		line: read-line ""
		if line = null [halt]  ; EOF

		add-history line

		str: string/load line  1 + length? line
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

count-delimiters: function [
	buffer	[string!]
	return: [block!]
][
	list: copy [0 0]
	c: none

	foreach c buffer [
		switch c [
			#"[" [list/1: list/1 + 1]
			#"]" [list/1: list/1 - 1]
			#"{" [list/2: list/2 + 1]
			#"}" [list/2: list/2 - 1]
		]
	]
	list
]

do-console: function [][
	buffer: make string! 10000
	prompt: red-prompt: "red>> "
	mode:  'mono

	switch-mode: [
		mode: case [
			cnt/1 > 0 ['block]
			cnt/2 > 0 ['string]
			'else 	  [
				prompt: red-prompt
				do eval
				'mono
			]
		]
		prompt: switch mode [
			block  ["[^-"]
			string ["{^-"]
			mono   [red-prompt]
		]
	]

	eval: [
		code: load/all buffer
		unless tail? code [
			set/any 'result do code
			unless unset? :result [
				print ["==" mold :result]				;@@ use mold/part
			]
		]
		clear buffer
	]

	while [true][
		prin prompt

		unless tail? line: input [
			append buffer line
			cnt: count-delimiters buffer

			if crlf = pos: skip tail buffer -2 [remove pos]	;-- clear extra CR (Windows)
			if lf <> last buffer [append buffer lf]			;-- Unix

			switch mode [
				block  [if cnt/1 <= 0 [do switch-mode]]
				string [if cnt/2 <= 0 [do switch-mode]]
				mono   [do either any [cnt/1 > 0 cnt/2 > 0][switch-mode][eval]]
			]
		]
	]
]

q: :quit

init-console "Red Console"

print {
-=== Red Console alpha version ===-
(only Latin-1 input supported)
}

do-console

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

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: 	 "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
				ReadConsole: 	 "ReadConsoleA" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
	][
		#switch OS [
			MacOSX [  ; TODO: check this
				#define ReadLine-library "libreadline.dylib"
				#define History-library  "libhistory.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
			]
			History-library cdecl [
				add-history: "add_history" [  ; Add line to the history.
					line			[c-string!]
				]
			]
		]
	]
]

init-console: routine [
	str [string!]
	/local
		ret
][
	#either OS = 'Windows [
		;ret: AttachConsole -1
		;if zero? ret [print-line "ReadConsole failed!" halt]

		ret: SetConsoleTitle as c-string! string/rs-head str
		if zero? ret [print-line "ReadConsole failed!" halt]
	][
		print-line as-c-string string/rs-head str
	]
]

input: routine [
	/local
		len ret str buffer line
][
	#either OS = 'Windows [
		len: 0
		buffer: allocate 128
		ret: ReadConsole stdin buffer 127 :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		len: len + 1
		buffer/len: null-byte
		str: string/load as c-string! buffer len
;		free buffer
	][
		line: read-line ""
		if line = null [halt]  ; EOF

		add-history line

		str: string/load line  1 + length? line
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

count-delimiters: function [
	buffer	[string!]
	return: [block!]
][
	list: copy [0 0]
	c: none

	foreach c buffer [
		switch c [
			#"[" [list/1: list/1 + 1]
			#"]" [list/1: list/1 - 1]
			#"{" [list/2: list/2 + 1]
			#"}" [list/2: list/2 - 1]
		]
	]
	list
]

clear-CR: function [str [string!]][
	if crlf = pos: skip tail str -2 [remove pos]
]

do-console: function [][
	buffer: make string! 10000
	prompt: red-prompt: "red>> "
	mode:  'mono

	switch-mode: [
		mode: case [
			cnt/1 > 0 ['block]
			cnt/2 > 0 ['string]
			'else 	  [
				prompt: red-prompt
				do eval
				'mono
			]
		]
		prompt: switch mode [
			block  ["[^-"]
			string ["{^-"]
			mono   [red-prompt]
		]
	]

	eval: [
		code: load/all buffer
		unless tail? code [
			set/any 'result do code
			unless unset? :result [
				print ["==" mold :result]				;@@ use mold/part
			]
		]
		clear buffer
	]

	while [true][
		prin prompt

		unless tail? line: input [
			if crlf = pos: skip tail line -2 [remove pos]	;-- clear extra CR (Windows)

			append buffer line
			cnt: count-delimiters buffer

			switch mode [
				block  [if cnt/1 <= 0 [do switch-mode]]
				string [if cnt/2 <= 0 [do switch-mode]]
				mono   [do either any [cnt/1 > 0 cnt/2 > 0][switch-mode][eval]]
			]
		]
	]
]

init-console "Red Console (Xmas demo edition!)"

print {
-=== Red Console alpha version ===-
(only Latin-1 input supported)
}

do-console


FIX: issue #1130 (Crash when getting HELP on numeric literal)

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, 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
	}
]

help: func [
	"Display helping information about words and other values"
	'word [any-type!] "Word you are looking for"
	/local func-name desc spec tab tab4 tab8 type start attributes info fun w ref block w1 w2 value
][
	tab: tab4: "    "
	tab8: "        "

	case [
		unset? :word [									;-- HELP with no arguments
			print {Use HELP or ? to see built-in info:

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other useful functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
    about - display version number and build date
    q or quit - leave the Red console
}
			exit
		]
		all [word? :word datatype? get :word] [			;-- HELP <datatype!>
			type: get :word
			foreach w system/words [
				if type = type? get w [
					case [
						any [function? get w native? get w action? get w op? get w routine? get w][
							prin [tab w]
							spec: spec-of get w

							either any [
								string? desc: spec/1
								string? desc: spec/2	;-- attributes block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
			exit
		]
		string? :word [
			foreach w system/words [
				if any [function? get w native? get w action? get w op? get w routine? get w][
					spec: spec-of get w
					if any [find form w word find form spec word] [
						prin [tab w]

						either any [
							string? desc: spec/1
							string? desc: spec/2		;-- attributes block case
						][
							print ["^-=> " desc]
						][
							prin lf
						]
					]
				]
			]
			exit
		]
		'else [
			type: type? :word
			print [mold :word "is" a-an form type type]
			exit
		]
	]

	func-name: :word

	argument-rule: [
		set word [word! | lit-word! | get-word!]
		(prin [tab mold :word])
		opt [set type block!  (prin [#" " mold type])]
		opt [set info string! (prin [" =>" append form info dot])]
		(prin lf)
	]

	case [
		unset? get/any :word [
			print ["Word" :word "is not defined"]
		]
		all [
			any [word? func-name path? func-name]
			fun: get func-name
			any [action? :fun function? :fun native? :fun op? :fun routine? :fun]
		][
			prin ["^/USAGE:^/" tab ]

			parse spec-of :fun [
				start: [									;-- 1st pass
					any [block! | string! ]
					opt [set w [word! | lit-word! | get-word!] (either op? :fun [prin [mold w func-name]][prin [func-name mold w]])]
					any [
						/local to end
						| set w [word! | lit-word! | get-word!] (prin [" " w])
						| set w refinement! (prin [" " mold w])
						| skip
					]
				]

				:start										;-- 2nd pass
				opt [set attributes block! (prin ["^/^/ATTRIBUTES:^/" tab mold attributes])]
				opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot lf tab func-name "is of type:" mold type? :fun])]

				(print "^/ARGUMENTS:")
				any [argument-rule]; (prin lf)]

				(print "^/REFINEMENTS:")
				any [
					/local [
						to ahead set-word! 'return set block block!
						(print ["^/RETURN:^/" mold block])
						| to end
					]
					| [
						set ref refinement! (prin [tab mold ref])
						opt [set info string! (prin [" =>" append form info dot])]
						(tab: tab8 prin lf)
						any [argument-rule]
						(tab: tab4)
					]
				]
			]
		]
		all [any [word? word path? word] object? get word][
			prin #"`"
			prin form word
			print "` is an object! of value:"

			foreach w words-of get word [
				value: get/any in get word w

				desc: case [
					object? :value  [words-of value]
					find [op! action! native! function! routine!] type?/word :value [
						spec: spec-of :value
						if string? spec/1 [spec: spec/1]
						spec
					]
					'else [:value]
				]

				desc: either string? desc [copy/part desc 47][mold/part/flat desc 47]

				if 47 = length? desc [					;-- optimized for width = 78
					clear skip tail desc -3
					append desc "..."
				]
				print [
					tab
					pad form/part w 16 16
					pad mold type? get/any w 9
					desc
				]
			]
		]
		'else [
			value: get :word
			print [
				word "is a"
				mold type? :value
				"of value:"
				mold either path? :value [get :value][:value]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

a-an: function [s [string!]][
	pick ["an" "a"] make logic! find "aeiou" s/1
]

what: function [
	"Lists all functions, or words of a given type"
][
	foreach w system/words [
		if any [function? get w native? get w action? get w op? get w routine? get w][
			prin pad form w 15
			spec: spec-of get w

			either any [
				string? desc: spec/1
				string? desc: spec/2					;-- attributes block case
			][
				print [#":" desc]
			][
				prin lf
			]
		]
	]
	exit												;-- return unset value
]

source: function [
	"Print the source of a function"
	'func-name [any-word!] "The name of the function"
][
	print either function? get func-name [
		[append mold func-name #":" mold get func-name]
	][
		type: mold type? get func-name
		["Sorry," func-name "is" a-an type "so no source is available"]
	]
]

about: function [
	"Print Red version information"
][
	print ["Red" system/version #"-" system/build]
]

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, 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
	}
]

help: func [
	"Display helping information about words and other values"
	'word [any-type!] "Word you are looking for"
	/local func-name desc spec tab tab4 tab8 type start attributes info fun w ref block w1 w2 value
][
	tab: tab4: "    "
	tab8: "        "

	case [
		unset? :word [									;-- HELP with no arguments
			print {Use HELP or ? to see built-in info:

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other useful functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
    about - display version number and build date
    q or quit - leave the Red console
}
			exit
		]
		all [word? word datatype? get :word] [			;-- HELP <datatype!>
			type: get :word
			foreach w system/words [
				if type = type? get w [
					case [
						any [function? get w native? get w action? get w op? get w routine? get w][
							prin [tab w]
							spec: spec-of get w

							either any [
								string? desc: spec/1
								string? desc: spec/2	;-- attributes block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
			exit
		]
		string? word [
			foreach w system/words [
				if any [function? get w native? get w action? get w op? get w routine? get w][
					spec: spec-of get w
					if any [find form w word find form spec word] [
						prin [tab w]

						either any [
							string? desc: spec/1
							string? desc: spec/2		;-- attributes block case
						][
							print ["^-=> " desc]
						][
							prin lf
						]
					]
				]
			]
			exit
		]
	]

	func-name: :word

	argument-rule: [
		set word [word! | lit-word! | get-word!]
		(prin [tab mold :word])
		opt [set type block!  (prin [#" " mold type])]
		opt [set info string! (prin [" =>" append form info dot])]
		(prin lf)
	]

	case [
		unset? get/any :word [
			print ["Word" :word "is not defined"]
		]
		all [
			any [word? func-name path? func-name]
			fun: get func-name
			any [action? :fun function? :fun native? :fun op? :fun routine? :fun]
		][
			prin ["^/USAGE:^/" tab ]

			parse spec-of :fun [
				start: [									;-- 1st pass
					any [block! | string! ]
					opt [set w [word! | lit-word! | get-word!] (either op? :fun [prin [mold w func-name]][prin [func-name mold w]])]
					any [
						/local to end
						| set w [word! | lit-word! | get-word!] (prin [" " w])
						| set w refinement! (prin [" " mold w])
						| skip
					]
				]

				:start										;-- 2nd pass
				opt [set attributes block! (prin ["^/^/ATTRIBUTES:^/" tab mold attributes])]
				opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot lf tab func-name "is of type:" mold type? :fun])]

				(print "^/ARGUMENTS:")
				any [argument-rule]; (prin lf)]

				(print "^/REFINEMENTS:")
				any [
					/local [
						to ahead set-word! 'return set block block!
						(print ["^/RETURN:^/" mold block])
						| to end
					]
					| [
						set ref refinement! (prin [tab mold ref])
						opt [set info string! (prin [" =>" append form info dot])]
						(tab: tab8 prin lf)
						any [argument-rule]
						(tab: tab4)
					]
				]
			]
		]
		all [any [word? word path? word] object? get word][
			prin #"`"
			prin form word
			print "` is an object! of value:"

			foreach w words-of get word [
				value: get/any in get word w

				desc: case [
					object? :value  [words-of value]
					find [op! action! native! function! routine!] type?/word :value [
						spec: spec-of :value
						if string? spec/1 [spec: spec/1]
						spec
					]
					'else [:value]
				]

				desc: either string? desc [copy/part desc 47][mold/part/flat desc 47]

				if 47 = length? desc [					;-- optimized for width = 78
					clear skip tail desc -3
					append desc "..."
				]
				print [
					tab
					pad form/part w 16 16
					pad mold type? get/any w 9
					desc
				]
			]
		]
		'else [
			value: get :word
			print [
				word "is a"
				mold type? :value
				"of value:"
				mold either path? :value [get :value][:value]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

what: function [
	"Lists all functions, or words of a given type"
][
	foreach w system/words [
		if any [function? get w native? get w action? get w op? get w routine? get w][
			prin pad form w 15
			spec: spec-of get w

			either any [
				string? desc: spec/1
				string? desc: spec/2					;-- attributes block case
			][
				print [#":" desc]
			][
				prin lf
			]
		]
	]
	exit												;-- return unset value
]

source: function [
	"Print the source of a function"
	'func-name [any-word!] "The name of the function"
][
	print either function? get func-name [
		[append mold func-name #":" mold get func-name]
	][
		type: mold type? get func-name
		a: pick ["an" "a"] make logic! find "aeiou" type/1
		["Sorry," func-name "is" a type "so no source is available"]
	]
]

about: function [
	"Print Red version information"
][
	print ["Red" system/version #"-" system/build]
]


FIX: minor comment updated about x87 exceptions default mask.

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

;-- FPU types returned by system/fpu/type
#define FPU_TYPE_X87	1					;-- Intel x87 unit
#define FPU_TYPE_SSE	2					;-- Intel SSE floating point unit
#define FPU_TYPE_VFP	3					;-- ARM Vector Floating Point unit

;-- FPU values for system/fpu/option/rounding
#define FPU_X87_ROUNDING_NEAREST	 0		;-- (even) rounded result is the closest to the infinitely precise result
#define FPU_X87_ROUNDING_DOWN		 1		;-- (toward -INF) rounded result is the closest to but no greater than the infinitely precise result
#define FPU_X87_ROUNDING_UP			 2		;-- (toward +INF) rounded result is the closest to but no less than the infinitely precise result
#define FPU_X87_ROUNDING_ZERO		 3		;-- (truncate) rounded result is the closest to but no greater in absolute value than the infinitely precise result

;-- FPU values for system/fpu/option/precision
#define FPU_X87_PRECISION_SINGLE	 0		;-- 32-bit float, 24-bit mantissa
#define FPU_X87_PRECISION_DOUBLE	 2		;-- 64-bit float, 53-bit mantissa
#define FPU_X87_PRECISION_DOUBLE_EXT 3		;-- 80-bit float, 64-bit mantissa

__stack!: alias struct! [
	top		[int-ptr!]
	frame	[int-ptr!]
	align	[int-ptr!]
]

#switch target [
	IA-32 [
		x87-mask!: alias struct! [			;-- x87 exception mask (true => disable exception)
			precision	[logic!]
			underflow	[logic!]
			overflow	[logic!]
			zero-divide [logic!]
			denormal	[logic!]
			invalid-op  [logic!]
		]

		x87-option!: alias struct! [
			rounding	[integer!]
			precision	[integer!]
		]

		__fpu-struct!: alias struct! [
			type		 [integer!]
			option		 [x87-option!]
			mask		 [x87-mask!]
			control-word [integer!]			;-- direct access to whole control word
			epsilon		 [integer!]			;-- Ulp threshold for almost-equal op (not used yet)
			update		 [integer!]			;-- action simulated using a read-only member
			init		 [integer!]			;-- action simulated using a read-only member
		]

		__cpu-struct!: alias struct! [
			eax			[integer!]
			ebx			[integer!]
			ecx			[integer!]
			edx			[integer!]
			esp			[integer!]
			ebp			[integer!]
			esi			[integer!]
			edi			[integer!]
		]
	]
	ARM [
		__fpu-struct!: alias struct! [
			type		 [integer!]			;-- only type for now...
		]

		__cpu-struct!: alias struct! [
			r0			[integer!]
			r1			[integer!]
			r2			[integer!]
			r3			[integer!]
			r4			[integer!]
			r5			[integer!]
			r6			[integer!]
			r7			[integer!]
			r8			[integer!]
			r9			[integer!]
			r10			[integer!]
			r11			[integer!]
			r12			[integer!]
			r13			[integer!]
			r14			[integer!]
			r15			[integer!]
		]

	]
]

system: declare struct! [					;-- store runtime accessible system values
	args-count	[integer!]					;-- command-line arguments count (do not move member)
	args-list	[str-array!]				;-- command-line arguments array pointer (do not move member)
	env-vars 	[str-array!]				;-- environment variables array pointer (always null for Windows)
	stack		[__stack!]					;-- stack virtual access
	pc			[byte-ptr!]					;-- CPU program counter value
	cpu			[__cpu-struct!]				;-- CPU registers
	fpu			[__fpu-struct!]				;-- FPU settings
	alias		[integer!]					;-- aliases ID virtual access
	words		[integer!]					;-- global context accessor (dummy type)
	thrown		[integer!]					;-- last THROWn value
]

#if type = 'exe [
	#if target = 'IA-32 [
		system/fpu/control-word: 0222h		;-- default control word: division by zero, invalid op,
											;-- underflow and overflow raise exceptions.
		system/fpu/update
	]
]

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

;-- FPU types returned by system/fpu/type
#define FPU_TYPE_X87	1					;-- Intel x87 unit
#define FPU_TYPE_SSE	2					;-- Intel SSE floating point unit
#define FPU_TYPE_VFP	3					;-- ARM Vector Floating Point unit

;-- FPU values for system/fpu/option/rounding
#define FPU_X87_ROUNDING_NEAREST	 0		;-- (even) rounded result is the closest to the infinitely precise result
#define FPU_X87_ROUNDING_DOWN		 1		;-- (toward -INF) rounded result is the closest to but no greater than the infinitely precise result
#define FPU_X87_ROUNDING_UP			 2		;-- (toward +INF) rounded result is the closest to but no less than the infinitely precise result
#define FPU_X87_ROUNDING_ZERO		 3		;-- (truncate) rounded result is the closest to but no greater in absolute value than the infinitely precise result

;-- FPU values for system/fpu/option/precision
#define FPU_X87_PRECISION_SINGLE	 0		;-- 32-bit float, 24-bit mantissa
#define FPU_X87_PRECISION_DOUBLE	 2		;-- 64-bit float, 53-bit mantissa
#define FPU_X87_PRECISION_DOUBLE_EXT 3		;-- 80-bit float, 64-bit mantissa

__stack!: alias struct! [
	top		[int-ptr!]
	frame	[int-ptr!]
	align	[int-ptr!]
]

#switch target [
	IA-32 [
		x87-mask!: alias struct! [			;-- x87 exception mask (true => disable exception)
			precision	[logic!]
			underflow	[logic!]
			overflow	[logic!]
			zero-divide [logic!]
			denormal	[logic!]
			invalid-op  [logic!]
		]

		x87-option!: alias struct! [
			rounding	[integer!]
			precision	[integer!]
		]

		__fpu-struct!: alias struct! [
			type		 [integer!]
			option		 [x87-option!]
			mask		 [x87-mask!]
			control-word [integer!]			;-- direct access to whole control word
			epsilon		 [integer!]			;-- Ulp threshold for almost-equal op (not used yet)
			update		 [integer!]			;-- action simulated using a read-only member
			init		 [integer!]			;-- action simulated using a read-only member
		]

		__cpu-struct!: alias struct! [
			eax			[integer!]
			ebx			[integer!]
			ecx			[integer!]
			edx			[integer!]
			esp			[integer!]
			ebp			[integer!]
			esi			[integer!]
			edi			[integer!]
		]
	]
	ARM [
		__fpu-struct!: alias struct! [
			type		 [integer!]			;-- only type for now...
		]

		__cpu-struct!: alias struct! [
			r0			[integer!]
			r1			[integer!]
			r2			[integer!]
			r3			[integer!]
			r4			[integer!]
			r5			[integer!]
			r6			[integer!]
			r7			[integer!]
			r8			[integer!]
			r9			[integer!]
			r10			[integer!]
			r11			[integer!]
			r12			[integer!]
			r13			[integer!]
			r14			[integer!]
			r15			[integer!]
		]

	]
]

system: declare struct! [					;-- store runtime accessible system values
	args-count	[integer!]					;-- command-line arguments count (do not move member)
	args-list	[str-array!]				;-- command-line arguments array pointer (do not move member)
	env-vars 	[str-array!]				;-- environment variables array pointer (always null for Windows)
	stack		[__stack!]					;-- stack virtual access
	pc			[byte-ptr!]					;-- CPU program counter value
	cpu			[__cpu-struct!]				;-- CPU registers
	fpu			[__fpu-struct!]				;-- FPU settings
	alias		[integer!]					;-- aliases ID virtual access
	words		[integer!]					;-- global context accessor (dummy type)
	thrown		[integer!]					;-- last THROWn value
]

#if type = 'exe [
	#if target = 'IA-32 [
		system/fpu/control-word: 0222h		;-- default control word: division by zero,
											;-- underflow and overflow raise exceptions.
		system/fpu/update
	]
]


FEAT: updated hello.reds script to use new PRINT function.

Red/System [
	Title:   "Red/System small demo app"
	Author:  "Nenad Rakocevic"
	File: 	 %hello.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt"
]

#either OS = 'Windows [
	#import [
		"kernel32.dll" stdcall [
			SetConsoleTextAttribute: "SetConsoleTextAttribute" [
				handle 		[integer!]
				attributes  [integer!]
				return:		[integer!]
			]
		]
	]

	set-pen-color: func [color [integer!]][
		SetConsoleTextAttribute stdout color
	]

	black:   0
	blue: 	 1
	green:	 2
	red:	 4
][
	set-pen-color: func [color [integer!]][
		either color = white [
			print "^[[0m"
		][
			print [
				"^[[" either color >= 7 [1][0] ";3"
				color and 7	"m"					;-- mask only right 3 bits for color
			]
		]
	]

	black:   0
	red: 	 1
	green:	 2
	blue:	 4
]

cyan:  	 blue or green
magenta: blue or red
yellow:  green or red
white:   blue or green or red

light-blue:  blue  or 8
light-green: green or 8
light-red: 	 red   or 8

print-logo: does [
	set-pen-color light-red
	print "R"
	set-pen-color white
	print "ed"
]

draw-hline: func [size [integer!] alt [integer!] /local c [integer!]][
	c: size							;-- local variable is not necessary, just for the demo
	until [
		either positive? alt [		;-- print * and - alternatively
			alt: either alt = 1 [
				print "*"
				2
			][
				print "-"
				1
			]
		][
			print "-"				;-- print - only
		]
		c: c - 1
		zero? c
	]
	print newline
]

draw-vline: does [print "|"]

pad: func [n [integer!]][
	while [n > 0][print space n: n - 1] ;-- could have used UNTIL, just for the demo
]

banner: func [width [integer!]][
	draw-hline width 1
	draw-vline
	pad (width - 16) / 2 - 1
	print "Hello "
	print-logo
	print " World!"
	pad ((width - 16) / 2) - 1		;-- just showing nested parenthesis support
	draw-vline
	print newline
	draw-hline width 0
]

print-logo
print ["/System v0.2.0 beta" lf lf]

size: 20
until [
	banner size
	size: size + 2
	size = 40
]

Red/System [
	Title:   "Red/System small demo app"
	Author:  "Nenad Rakocevic"
	File: 	 %hello.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt"
]

#either OS = 'Windows [
	#import [
		"kernel32.dll" stdcall [
			SetConsoleTextAttribute: "SetConsoleTextAttribute" [
				handle 		[integer!]
				attributes  [integer!]
				return:		[integer!]
			]
		]
	]

	set-pen-color: func [color [integer!]][
		SetConsoleTextAttribute stdout color
	]

	black:   0
	blue: 	 1
	green:	 2
	red:	 4
][
	set-pen-color: func [color [integer!]][
		either color = white [
			prin "^[[0m"
		][
			prin "^[["
			prin-int either color >= 7 [1][0]
			prin ";3"
			prin-int color and 7	;-- mask only right 3 bits for color
			prin "m"
		]
	]

	black:   0
	red: 	 1
	green:	 2
	blue:	 4
]

cyan:  	 blue or green
magenta: blue or red
yellow:  green or red
white:   blue or green or red

light-blue:  blue  or 8
light-green: green or 8
light-red: 	 red   or 8

prin-logo: does [
	set-pen-color light-red
	prin "R"
	set-pen-color white
	prin "ed"
]

draw-hline: func [size [integer!] alt [integer!] /local c [integer!]][
	c: size							;-- local variable is not necessary, just for the demo
	until [
		either positive? alt [		;-- print * and - alternatively
			alt: either alt = 1 [
				prin "*"
				2
			][
				prin "-"
				1
			]
		][
			prin "-"				;-- print - only
		]
		c: c - 1
		zero? c
	]
	prin "^/"
]

draw-vline: does [prin "|"]

pad: func [n [integer!]][
	while [n > 0][prin " " n: n - 1] ;-- could have used UNTIL, just for the demo
]

banner: func [width [integer!]][
	draw-hline width 1
	draw-vline
	pad (width - 16) / 2 - 1
	prin "Hello "
	prin-logo
	prin " World!"
	pad ((width - 16) / 2) - 1		;-- just showing nested parenthesis support
	draw-vline
	prin newline
	draw-hline width 0
]

prin-logo
print "/System v0.2.0 beta^/"

size: 20
until [
	banner size
	size: size + 2
	size = 40
]