TESTS: correct mistakes in words-of test

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

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

~~~start-file~~~ "words-of"

===start-group=== "words-of-basic"

	--test-- "wob1"
		wob1-o: make object! [
		    b: [a b c d]
		    c: #"a"
		    f: 1.0
		    o: make object! [a: 1 b: 2 c: 3]
		    i: 1
		    n: none
		    s: "abcde"
		]
		--assert [b c f o i n s] = words-of wob1-o

===end-group===

===start-group=== "words-of-self"

	--test-- "wos1"
		wos1-o: make object! [
		    b: [a b c d]
		    c: #"a"
		    f: 1.0
		    o: make object! [a: 1 b: 2 c: 3]
		    i: 1
		    n: none
		    s: "abcde"
		    wos: words-of self
		]
		--assert [b c f o i n s wos] = wos1-o/wos

	--test-- "wos2"
		wos2-o: make object! [
		    b: [a b c d]
		    c: #"a"
		    f: 1.0
		    o: make object! [a: 1 b: 2 c: 3]
		    i: 1
		    n: none
		    s: "abcde"
		    do-wos: does [words-of self]
		]
		--assert [b c f o i n s do-wos] = wos2-o/do-wos

===end-group===

~~~end-file~~~

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

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

~~~start-file~~~ "words-of"

===start-group=== "words-of-basic"

	--test-- "wob1"
		wob1-o: make object! [
		    b: [a b c d]
		    c: #"a"
		    f: 1.0
		    o: make object! [a: 1 b: 2 c: 3]
		    i: 1
		    n: none
		    s: "abcde"
		]
		--assert [b c f o i n s] = words-of wob1-o

===end-group===

===start-group=== "words-of-self"

	--test-- "wos1"
		wos1-o: make object! [
		    b: [a b c d]
		    c: #"a"
		    f: 1.0
		    o: make object! [a: 1 b: 2 c: 3]
		    i: 1
		    n: none
		    s: "abcde"
		    wos: words-of self
		]
		--assert [b c f o i n s] = wos1-o/wos

	--test-- "wos2"
		wos2-o: make object! [
		    b: [a b c d]
		    c: #"a"
		    f: 1.0
		    o: make object! [a: 1 b: 2 c: 3]
		    i: 1
		    n: none
		    s: "abcde"
		    do-wos: does [words-of self]
		]
		--assert [b c f o i n s] = wos2-o/do-wos

===end-group===

~~~end-file~~~


FIX: issue #294 (system/alias and system/words not treated consistently)

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	 1		;-- 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!]
]

#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 (dummy type)
		]
	]
	ARM [
		__fpu-struct!: alias struct! [
			type		 [integer!]			;-- only type for now...
		]
	]
]

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!]				;-- reserved for later use
	fpu			[__fpu-struct!]				;-- FPU settings
	alias		[integer!]					;-- aliases ID virtual access
	words		[integer!]					;-- global context accessor (dummy type)
]

#if target = 'IA-32 [
	system/fpu/control-word: 0322h			;-- default control word: division by zero,
											;-- 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	 1		;-- 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!]
]

#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
		]
	]
	ARM [
		__fpu-struct!: alias struct! [
			type		 [integer!]			;-- only type for now...
		]
	]
]

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!]				;-- reserved for later use
	fpu			[__fpu-struct!]				;-- FPU settings
	alias		[integer!]					;-- aliases ID virtual access
]

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


TEST: update tests according to spec of append

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

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

~~~start-file~~~ "function"

===start-group=== "Basic function tests"

	--test-- "fun-1"
		foo1: func [][1]
		--assert 1 = foo1

	--test-- "fun-2"
		foo2: func [a][a]
		--assert 5 = foo2 5
		--assert "a" = foo2 "a"
		--assert [123] = foo2 [123]

	--test-- "fun-3"
		foo3: func [a /local c][c: 1 a + c]
		--assert 3 = foo3 2

	--test-- "fun-4"
		foo4: func [a /ref][either ref [a][0]]
		--assert 0 = foo4 5
		--assert 5 = foo4/ref 5

	--test-- "fun-5"
		foo5: func [a /ref b][if ref [a: a + b] a * 2]
		--assert 10 = foo5 5
		--assert 16 = foo5/ref 5 3

	--test-- "fun-6"
		z: 10
		foo6: func [a [integer!] b [integer!] /ref d /local c][
			c: 2
			unless ref [d: 0]
			a + b * c + z + d
		]

		--assert 16 = foo6 1 2
		--assert 21 = foo6/ref 1 2 5

	--test-- "fun-7"
		bar:  func [] [foo7]
		foo7: func [] [42]
		--assert 42 = bar

	--test-- "fun-8"
		foo8: func ['a :b][
			--assert a = 'test
			--assert "(1 + 2)" = mold b
		]
		foo8 test (1 + 2)

	--test-- "fun-9"
		foo9: func [/local cnt][
			cnt: [0]
			cnt/1: cnt/1 + 1
		]
		--assert 1 = foo9
		--assert 2 = foo9
		--assert 3 = foo9

	--test-- "fun-10"
		foo10: func [a][a + 0]
		foo10: func [][1]
		--assert 1 = foo10 "dummy"						;-- make it crash if wrong function referenced

	--test-- "fun-11"
		non-evaluated: func ['param] [param]
		res: first [(1 + 2)]
		--assert res = quote (1 + 2)
		--assert res = non-evaluated (quote (1 + 2))
		--assert 'quote = non-evaluated quote (1 + 2)

===end-group===

===start-group=== "Alternate constructor tests"

	--test-- "fun-alt-1"
		z: 0
		alt1: function [a][
			z: 2
			a + z
		]
		--assert 10 = alt1 8
		--assert z = 0

	--test-- "fun-alt-2"
		alt2: does [123]
		--assert 123 = alt2

	--test-- "fun-alt-3"
		alt3: has [c][c: 1 c]
		--assert 1 = alt3

===end-group===

===start-group=== "Exit and Return tests"

	--test-- "fun-exit-1"
		ex1: does [123 exit 0]
		--assert unset! = type? ex1

	--test-- "fun-exit-2"
		ex2: does [if true [exit] 0]
		--assert unset! = type? ex2

	--test-- "fun-exit-3"
		ex3: does [until [if true [if true [exit]] true] 0]
		--assert unset! = type? ex3

	--test-- "fun-ret-1"
		ret1: does [return true]
		--assert ret1

	--test-- "fun-ret-2"
		ret2: does [return 123]
		--assert 123 = ret2

	--test-- "fun-ret-3"
		ret3: does [if true [return 3]]
		--assert 3 = ret3

	--test-- "fun-ret-4"
		ret4: does [return 1 + 1]
		--assert 2 = ret4

	--test-- "fun-ret-5"
		ret5: does [return either false [12][34]]
		--assert 34 = ret5

	--test-- "fun-ret-6"								;-- issue #770
		ret6: func [i [integer!]][
			until [
				if true [
					if i = 0 [
						if true [return 0]
						return 1
					]
					return 2
				]
				return 3
				true
			]
		]
		--assert 0 = ret6 0
		--assert 2 = ret6 1

	--test-- "fun-ret-7"
		f: function [][
			blk: [1 2 3 4 5]
			foreach i blk [
				case [
					i > 1 [return i]
				]
			]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-8"
		f: function [][
		    case [
		        2 > 1 [return true]
		    ]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-9"
		f: function [][if true [return true]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		g: function [][if true [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		f: function [][true]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-11"
		f: function [][if true [return true]]
		g: function [][if (f) [return 1]]
		--assert g = 1

	--test-- "fun-ret-12"
		f: function [][if true [return true] ]
		g: function [][if not not f [return 1]]
		--assert g = 1

	--test-- "fun-ret-13"
		f: function [][if true [return 'X]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-14"								;-- issue #778
	 	--assert 1 = do load "f: func [][return 1] t: f"

===end-group===

===start-group=== "Reflection"
	clean-strings: func [blk [block!]][
		blk: copy blk
		forall blk [if string? blk/1 [remove blk blk: back blk]]
		blk
	]

	--test-- "fun-ref-1"
		ref1: func [a b][a + b]
		--assert [a b] = spec-of :ref1
		body: body-of :ref1
		--assert any [
			[a + b] = body
			none? body									;-- if option store-bodies = no
		]

	--test-- "fun-ref-2"
		blk: clean-strings spec-of :append
		--assert blk = [
			series [series! bitset! map!] value [any-type!] /part length [number! series!]
			/only /dup count [number!] return: [series! bitset! map!]
		]

	--test-- "fun-ref-3"
		blk: clean-strings spec-of :set
		--assert blk = [word [any-word! block! object!] value [any-type!] /any return: [any-type!]]

	--test-- "fun-ref-4"
		blk: clean-strings spec-of :<
		--assert blk = [value1 [any-type!] value2 [any-type!]]

===end-group===

===start-group=== "Capturing of iterators counter word(s)"

	--test-- "fun-capt-1"
		f1: function [] [repeat ii 5 [ii]]
		--assert none <> find spec-of :f1 'ii
		f1
		--assert unset? get/any 'ii

	--test-- "fun-capt-2"
		f2: function [] [foreach ii [1 2 3] [ii]]
		--assert none <> find spec-of :f2 'ii
		f2
		--assert unset? get/any 'ii

	--test-- "fun-capt-3"
		f3: function [] [foreach [ii jj] [1 2 3 4] [ii jj]]
		--assert none <> find spec-of :f3 'ii
		--assert none <> find spec-of :f3 'jj
		f3
		--assert unset? get/any 'ii
		--assert unset? get/any 'jj

===end-group===

===start-group=== "Reported issues"
  	--test-- "ri1 issue #415"
    	i415-f: func [] [
    		g: func [] [1]
    		g
    	]
    --assert 1 = i415-f

  	--test-- "ri2 issue #461"
  		ri2-fn: func ['word] [:word]
  	--assert op? ri2-fn :+

  	--test-- "ri3 issue #461"
  		ri3-fn: func ['word] [mold :word]
  	--assert "'+" = ri3-fn '+

  	--test-- "ri4 issue #461"
  		ri4-fn: func ['word] [mold :word]
  	--assert "+" = ri4-fn +

  	;--test-- "ri5 issue #420"
  	;	ri5-fn: function [][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri5-fn

  	;--test-- "ri6 issue #420"
  	;	ri6-fn: func [
  	;		/local
  	;			g
  	;	][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri6-fn

  	;--test-- "ri7 issue #420"
  	;	ri7-g: func [][true]
  	;	ri7-f: func [][g]
  	;--assert ri7-f

  	--test-- "ri8 issue #443"
  		ri8-fn: func[
  			/local
  				ri8-b
  				ri8-i
  				ri8-j
  		][
  			ri8-b: copy []
  			foreach [ri8-i ri8-j] [1 2 3 4] [append ri8-b ri8-i * ri8-j]
  			ri8-b
  		]
  		ri8-i: 100
  		ri8-j: 200
  	--assert [2 12] = ri8-fn
  	--assert 100 = ri8-i
  	--assert 200 = ri8-j

  	--test-- "ri9 issue #443"
  		ri9-i: -1
  		ri9-j: -2
  		ri9-fn: function[][
  			ri9-b: copy []
  			foreach [ri9-i ri9-j] [1 2 3 4] [append ri9-b ri9-i * ri9-j]
  			ri9-b
  		]
  	--assert [2 12] = ri9-fn
  	--assert ri9-i = -1
  	--assert ri9-j = -2
  	;--assert unset! = type? get 'ri9-i		;-- temporary disabled to avoid the hardcoded error msg
  	;--assert unset! = type? get 'ri9-j

===end-group===

===start-group=== "Infix operators creation"
	--test-- "infix-1"
		infix: function [a b][a * 10 + b]
		***: make op! :infix
		--assert 7 *** 3 = 73

	unless system/state/interpreted? [			;-- routine creation not supported by interpreter
		infix2: routine [a [integer!] b [integer!]][integer/box a * 20 + b]

		--test-- "infix-2"
			*+*: make op! :infix2
			--assert 5 *+* 6 = 106

		--test-- "infix-3"
			--assert 5 *+* 6 *** 7 = 1067
	]

===end-group===

===start-group=== "Scope of Varibles"

	--test-- "scope1 issue #825"
		s1-text: "abcde"
		s1-f: function [/extern s1-text] [
			s1-text
		]
		--assert s1-f = "abcde"

	--test-- "scope2 issue #825"
		s2-f: function [/extern s2-text] [
			s2-text
		]
		s2-text: "abcde"
		--assert s2-f = "abcde"

	--test-- "scope3 issue #825"
		s3-text: "abcde"
		s3-f: func [/local s3-text] [
			s3-text: "12345"
		]

	--test-- "scope4 issue #825"
		s4-text: "abcde"
		s4-f: function [extern s4-text] [
			if extern [s4-text: "12345"]
			s4-text
		]
		--assert "12345" = s4-f true "00000"

	--test-- "scope5 issue #825"
		s5-text: "abcde"
		s5-f: func[/extern s5-text] [
			either extern [
				s5-text
			][
				"00000"
			]
		]
		--assert "12345" = s5-f/extern "12345"

	--test-- "scope6 issue #825"
		s6-text: "abcde"
		s6-f: func [local s6-text] [
			s6-text
		]
		--assert "12345" = s6-f "filler" "12345"

	--test-- "scope7 issue #825"
		s7-text: "abcde"
		s7-f: function [local s7-text] [
			s7-text
		]
		--assert "12345" = s7-f "filler" "12345"

===end-group===

===start-group=== "functionfunction"
comment {                                       ####################################
    --test-- "funfun1"
        ff1-i: 1
        ff1-f: function [][ff1-i: 2 f: func[][ff1-i] f]
        --assert 2 = ff1-f
                                                #################################### }

    --test-- "funfun2"
        ff2-i: 1
        ff2-f: function [][ff2-i: 2 ff2-i]
        ff2-r: ff2-f
        --assert 1 = ff2-i
        --assert 2 = ff2-r

    --test-- "funfun3"
        ff3-i: 1
        ff3-f: function [][
            ff3-i: 2
            o: make object! [
                ff3-i: 3
            ]
            o/ff3-i
        ]
        --assert 3 = ff3-f

    --test-- "funfun4"
        ff4-i: 1
        ff4-f: function [][
            ff4-i: 2
            o: make object! [
                ff4-i: 3
            ]
            ff4-i
        ]
        --assert 2 = ff4-f

    --test-- "funfun5 #964"
        ff5-f: function [] [
            either true [
                ff5-x
             ][
                ff5-x: 0
            ]
        ]
        --assert none = ff5-f

    --test-- "funfun6 #964"
        ff6-f: function [] [
            either false [
                ff6-x
             ][
                ff6-x: 0
            ]
        ]
        --assert 0 = ff6-f

    --test-- "funfun7"
        ff7-f: function [] [
            a: 1
            b: make object! [c: 2]
            c
        ]
        --assert none = ff7-f

     --test-- "funfun8"
        ff8-i: 1
        ff8-f: function [] [
            a: 1
            b: make object! [ff8-i: 2]
            ff8-i
        ]
        --assert none = ff8-f

if system/state/interpreted? [                          ;-- not yet supported by compiler
    --test-- "funfun9"
        ff9-f: function [] [
            a: 1
            b: function [] [c: 2]
            b
            c
        ]
        --assert none = ff9-f
]

if system/state/interpreted? [                          ;-- not yet supported by compiler
     --test-- "funfun10"
        ff10-i: 1
        ff10-f: function [] [
            a:
            b: function [] [ff10-i: 2]
            b
            ff10-i
        ]
        --assert none = ff10-f
]

if system/state/interpreted? [                          ;-- not yet supported by compiler
    --test-- "funfun11"
        ff11-i: 1
        ff11-f: function [] [
            ff: func [/local ff11-i][ff11-i: 2]
            ff11-i
        ]
        --assert none = ff11-f
        --assert 1 = ff11-i
]

    --test-- "funfun12"
        ff12-i: 1
        ff12-f: function [] [
            ff: make object! [ff12-i: 2]
            ff12-i
        ]
        --assert none = ff12-f
        --assert 1 = ff12-i
 comment {                                          ####################################
    --test-- "funfun13"
        ff13-i: 1
        ff13-f: function [/extern ff13-i] [
            ff: func [/local ff13-i][ff13-i: 2]
            ff13-i: 3
        ]
        --assert 3 = ff13-f
        --assert 3 = ff13-i
                                                    ####################################}
    --test-- "funfun14"
        ff14-i: 1
        ff14-f: function [/extern ff14-i] [
            ff: make object! [ff14-i: 2]
            ff14-i: 3
        ]
        --assert 3 = ff14-f
        --assert 3 = ff14-i
 comment {                                          ####################################
    --test-- "funfun15"
        ff15-i: 1
        ff15-f: func [
            /local ff15-i
        ][
            ff15-i: 2
            ff: function [
                /extern ff15-i
            ][
                ff15-i
            ]
            ff
        ]
        --assert 2 = ff15-f
        --assert 1 = ff15-i
                                                    ####################################}

if system/state/interpreted? [                      ;-- not yet supported by compiler
    --test-- "funfun16"
        ff16-f: function [] [
            f2: func [i] [i: 1]
            f2 i
            i
        ]
        --assert none = ff16-f
]

if system/state/interpreted? [                      ;-- not yet supported by compiler
    --test-- "funfun17"
        ff17-i: 10
        ff17-f: function [] [
            f2: func [ff17-i] [ff17-i: 1]
            f2 ff17-i
            ff17-i
        ]
        --assert none = ff17-f
]

===end-group===

===start-group=== "functions with objects"
comment {                                          ####################################
    --test-- "fwo1 - #965"
        fwo1-f: func [
            o object!
        ][
          append o/a o/b
        ]
        fwo1-o: make object! [
            a: "hello"
            b: " world"
        ]
        --assert "hello world" = fwo1-f
                                                    ####################################}
===end-group===

===start-group=== "function with lit-arg"
    fwla-f: func ['x][:x]

    --test-- "fwla1"
        --assert 10 = fwla-f 10

    --test-- "fwla2"
        --assert 50 = fwla-f (20 + 30)

    --test-- "fwla3"
        fwla3-i: 40
        --assert 40 = fwla-f :fwla3-i

    --test-- "fwla4"
        fwla4-o: make object! [i: 50]
        --assert 50 = fwla-f :fwla4-o/i

    --test-- "fwla5"
        --assert (first ['fwla4-o/i]) = fwla-f 'fwla4-o/i

    --test-- "fwla6"
        --assert (first [fwla4-o/i:]) = fwla-f fwla4-o/i:

    --test-- "fwla7"
        --assert (first [fwla4-o/i]) = fwla-f fwla4-o/i
===end-group===

===start-group=== "function with get-arg"
        fwga-f: func [:x][:x]

    --test-- "fwga1"
        --assert 10 = fwga-f 10

    --test-- "fwga2"
        --assert (first [(20 + 30)]) = fwga-f (20 + 30)

    --test-- "fwga3"
        fwga3-i: 40
        --assert (first [:fwga3-i]) = fwga-f :fwga3-i

    --test-- "fwga4"
        fwga4-o: make object! [i: 50]
        --assert (first [:fwga4-o/i]) = fwga-f :fwga4-o/i

    --test-- "fwga5"
        fwga5-i: 10
        fwga5-f: func[:x][set x 1 + get x]
        --assert 11 = fwga5-f fwga5-i
        --assert 11 = fwga5-i

    --test-- "fwga6"
        --assert (first [fwga4-o/i]) = fwga-f fwga4-o/i

    --test-- "fwga7"
        --assert (first ['fwga4-o/i]) = fwga-f 'fwga4-o/i

    --test-- "fwga8"
        --assert (first [fwga4-o/i:]) = fwga-f fwga4-o/i:
===end-group===

~~~end-file~~~

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

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

~~~start-file~~~ "function"

===start-group=== "Basic function tests"

	--test-- "fun-1"
		foo1: func [][1]
		--assert 1 = foo1

	--test-- "fun-2"
		foo2: func [a][a]
		--assert 5 = foo2 5
		--assert "a" = foo2 "a"
		--assert [123] = foo2 [123]

	--test-- "fun-3"
		foo3: func [a /local c][c: 1 a + c]
		--assert 3 = foo3 2

	--test-- "fun-4"
		foo4: func [a /ref][either ref [a][0]]
		--assert 0 = foo4 5
		--assert 5 = foo4/ref 5

	--test-- "fun-5"
		foo5: func [a /ref b][if ref [a: a + b] a * 2]
		--assert 10 = foo5 5
		--assert 16 = foo5/ref 5 3

	--test-- "fun-6"
		z: 10
		foo6: func [a [integer!] b [integer!] /ref d /local c][
			c: 2
			unless ref [d: 0]
			a + b * c + z + d
		]

		--assert 16 = foo6 1 2
		--assert 21 = foo6/ref 1 2 5

	--test-- "fun-7"
		bar:  func [] [foo7]
		foo7: func [] [42]
		--assert 42 = bar

	--test-- "fun-8"
		foo8: func ['a :b][
			--assert a = 'test
			--assert "(1 + 2)" = mold b
		]
		foo8 test (1 + 2)

	--test-- "fun-9"
		foo9: func [/local cnt][
			cnt: [0]
			cnt/1: cnt/1 + 1
		]
		--assert 1 = foo9
		--assert 2 = foo9
		--assert 3 = foo9

	--test-- "fun-10"
		foo10: func [a][a + 0]
		foo10: func [][1]
		--assert 1 = foo10 "dummy"						;-- make it crash if wrong function referenced

	--test-- "fun-11"
		non-evaluated: func ['param] [param]
		res: first [(1 + 2)]
		--assert res = quote (1 + 2)
		--assert res = non-evaluated (quote (1 + 2))
		--assert 'quote = non-evaluated quote (1 + 2)

===end-group===

===start-group=== "Alternate constructor tests"

	--test-- "fun-alt-1"
		z: 0
		alt1: function [a][
			z: 2
			a + z
		]
		--assert 10 = alt1 8
		--assert z = 0

	--test-- "fun-alt-2"
		alt2: does [123]
		--assert 123 = alt2

	--test-- "fun-alt-3"
		alt3: has [c][c: 1 c]
		--assert 1 = alt3

===end-group===

===start-group=== "Exit and Return tests"

	--test-- "fun-exit-1"
		ex1: does [123 exit 0]
		--assert unset! = type? ex1

	--test-- "fun-exit-2"
		ex2: does [if true [exit] 0]
		--assert unset! = type? ex2

	--test-- "fun-exit-3"
		ex3: does [until [if true [if true [exit]] true] 0]
		--assert unset! = type? ex3

	--test-- "fun-ret-1"
		ret1: does [return true]
		--assert ret1

	--test-- "fun-ret-2"
		ret2: does [return 123]
		--assert 123 = ret2

	--test-- "fun-ret-3"
		ret3: does [if true [return 3]]
		--assert 3 = ret3

	--test-- "fun-ret-4"
		ret4: does [return 1 + 1]
		--assert 2 = ret4

	--test-- "fun-ret-5"
		ret5: does [return either false [12][34]]
		--assert 34 = ret5

	--test-- "fun-ret-6"								;-- issue #770
		ret6: func [i [integer!]][
			until [
				if true [
					if i = 0 [
						if true [return 0]
						return 1
					]
					return 2
				]
				return 3
				true
			]
		]
		--assert 0 = ret6 0
		--assert 2 = ret6 1

	--test-- "fun-ret-7"
		f: function [][
			blk: [1 2 3 4 5]
			foreach i blk [
				case [
					i > 1 [return i]
				]
			]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-8"
		f: function [][
		    case [
		        2 > 1 [return true]
		    ]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-9"
		f: function [][if true [return true]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		g: function [][if true [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		f: function [][true]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-11"
		f: function [][if true [return true]]
		g: function [][if (f) [return 1]]
		--assert g = 1

	--test-- "fun-ret-12"
		f: function [][if true [return true] ]
		g: function [][if not not f [return 1]]
		--assert g = 1

	--test-- "fun-ret-13"
		f: function [][if true [return 'X]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-14"								;-- issue #778
	 	--assert 1 = do load "f: func [][return 1] t: f"

===end-group===

===start-group=== "Reflection"
	clean-strings: func [blk [block!]][
		blk: copy blk
		forall blk [if string? blk/1 [remove blk blk: back blk]]
		blk
	]

	--test-- "fun-ref-1"
		ref1: func [a b][a + b]
		--assert [a b] = spec-of :ref1
		body: body-of :ref1
		--assert any [
			[a + b] = body
			none? body									;-- if option store-bodies = no
		]

	--test-- "fun-ref-2"
		blk: clean-strings spec-of :append
		--assert blk = [
			series [series! bitset!] value [any-type!] /part length [number! series!]
			/only /dup count [number!] return: [series! bitset!]
		]

	--test-- "fun-ref-3"
		blk: clean-strings spec-of :set
		--assert blk = [word [any-word! block! object!] value [any-type!] /any return: [any-type!]]

	--test-- "fun-ref-4"
		blk: clean-strings spec-of :<
		--assert blk = [value1 [any-type!] value2 [any-type!]]

===end-group===

===start-group=== "Capturing of iterators counter word(s)"

	--test-- "fun-capt-1"
		f1: function [] [repeat ii 5 [ii]]
		--assert none <> find spec-of :f1 'ii
		f1
		--assert unset? get/any 'ii

	--test-- "fun-capt-2"
		f2: function [] [foreach ii [1 2 3] [ii]]
		--assert none <> find spec-of :f2 'ii
		f2
		--assert unset? get/any 'ii

	--test-- "fun-capt-3"
		f3: function [] [foreach [ii jj] [1 2 3 4] [ii jj]]
		--assert none <> find spec-of :f3 'ii
		--assert none <> find spec-of :f3 'jj
		f3
		--assert unset? get/any 'ii
		--assert unset? get/any 'jj

===end-group===

===start-group=== "Reported issues"
  	--test-- "ri1 issue #415"
    	i415-f: func [] [
    		g: func [] [1]
    		g
    	]
    --assert 1 = i415-f

  	--test-- "ri2 issue #461"
  		ri2-fn: func ['word] [:word]
  	--assert op? ri2-fn :+

  	--test-- "ri3 issue #461"
  		ri3-fn: func ['word] [mold :word]
  	--assert "'+" = ri3-fn '+

  	--test-- "ri4 issue #461"
  		ri4-fn: func ['word] [mold :word]
  	--assert "+" = ri4-fn +

  	;--test-- "ri5 issue #420"
  	;	ri5-fn: function [][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri5-fn

  	;--test-- "ri6 issue #420"
  	;	ri6-fn: func [
  	;		/local
  	;			g
  	;	][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri6-fn

  	;--test-- "ri7 issue #420"
  	;	ri7-g: func [][true]
  	;	ri7-f: func [][g]
  	;--assert ri7-f

  	--test-- "ri8 issue #443"
  		ri8-fn: func[
  			/local
  				ri8-b
  				ri8-i
  				ri8-j
  		][
  			ri8-b: copy []
  			foreach [ri8-i ri8-j] [1 2 3 4] [append ri8-b ri8-i * ri8-j]
  			ri8-b
  		]
  		ri8-i: 100
  		ri8-j: 200
  	--assert [2 12] = ri8-fn
  	--assert 100 = ri8-i
  	--assert 200 = ri8-j

  	--test-- "ri9 issue #443"
  		ri9-i: -1
  		ri9-j: -2
  		ri9-fn: function[][
  			ri9-b: copy []
  			foreach [ri9-i ri9-j] [1 2 3 4] [append ri9-b ri9-i * ri9-j]
  			ri9-b
  		]
  	--assert [2 12] = ri9-fn
  	--assert ri9-i = -1
  	--assert ri9-j = -2
  	;--assert unset! = type? get 'ri9-i		;-- temporary disabled to avoid the hardcoded error msg
  	;--assert unset! = type? get 'ri9-j

===end-group===

===start-group=== "Infix operators creation"
	--test-- "infix-1"
		infix: function [a b][a * 10 + b]
		***: make op! :infix
		--assert 7 *** 3 = 73

	unless system/state/interpreted? [			;-- routine creation not supported by interpreter
		infix2: routine [a [integer!] b [integer!]][integer/box a * 20 + b]

		--test-- "infix-2"
			*+*: make op! :infix2
			--assert 5 *+* 6 = 106

		--test-- "infix-3"
			--assert 5 *+* 6 *** 7 = 1067
	]

===end-group===

===start-group=== "Scope of Varibles"

	--test-- "scope1 issue #825"
		s1-text: "abcde"
		s1-f: function [/extern s1-text] [
			s1-text
		]
		--assert s1-f = "abcde"

	--test-- "scope2 issue #825"
		s2-f: function [/extern s2-text] [
			s2-text
		]
		s2-text: "abcde"
		--assert s2-f = "abcde"

	--test-- "scope3 issue #825"
		s3-text: "abcde"
		s3-f: func [/local s3-text] [
			s3-text: "12345"
		]

	--test-- "scope4 issue #825"
		s4-text: "abcde"
		s4-f: function [extern s4-text] [
			if extern [s4-text: "12345"]
			s4-text
		]
		--assert "12345" = s4-f true "00000"

	--test-- "scope5 issue #825"
		s5-text: "abcde"
		s5-f: func[/extern s5-text] [
			either extern [
				s5-text
			][
				"00000"
			]
		]
		--assert "12345" = s5-f/extern "12345"

	--test-- "scope6 issue #825"
		s6-text: "abcde"
		s6-f: func [local s6-text] [
			s6-text
		]
		--assert "12345" = s6-f "filler" "12345"

	--test-- "scope7 issue #825"
		s7-text: "abcde"
		s7-f: function [local s7-text] [
			s7-text
		]
		--assert "12345" = s7-f "filler" "12345"

===end-group===

===start-group=== "functionfunction"
comment {                                       ####################################
    --test-- "funfun1"
        ff1-i: 1
        ff1-f: function [][ff1-i: 2 f: func[][ff1-i] f]
        --assert 2 = ff1-f
                                                #################################### }

    --test-- "funfun2"
        ff2-i: 1
        ff2-f: function [][ff2-i: 2 ff2-i]
        ff2-r: ff2-f
        --assert 1 = ff2-i
        --assert 2 = ff2-r

    --test-- "funfun3"
        ff3-i: 1
        ff3-f: function [][
            ff3-i: 2
            o: make object! [
                ff3-i: 3
            ]
            o/ff3-i
        ]
        --assert 3 = ff3-f

    --test-- "funfun4"
        ff4-i: 1
        ff4-f: function [][
            ff4-i: 2
            o: make object! [
                ff4-i: 3
            ]
            ff4-i
        ]
        --assert 2 = ff4-f

    --test-- "funfun5 #964"
        ff5-f: function [] [
            either true [
                ff5-x
             ][
                ff5-x: 0
            ]
        ]
        --assert none = ff5-f

    --test-- "funfun6 #964"
        ff6-f: function [] [
            either false [
                ff6-x
             ][
                ff6-x: 0
            ]
        ]
        --assert 0 = ff6-f

    --test-- "funfun7"
        ff7-f: function [] [
            a: 1
            b: make object! [c: 2]
            c
        ]
        --assert none = ff7-f

     --test-- "funfun8"
        ff8-i: 1
        ff8-f: function [] [
            a: 1
            b: make object! [ff8-i: 2]
            ff8-i
        ]
        --assert none = ff8-f

if system/state/interpreted? [                          ;-- not yet supported by compiler
    --test-- "funfun9"
        ff9-f: function [] [
            a: 1
            b: function [] [c: 2]
            b
            c
        ]
        --assert none = ff9-f
]

if system/state/interpreted? [                          ;-- not yet supported by compiler
     --test-- "funfun10"
        ff10-i: 1
        ff10-f: function [] [
            a:
            b: function [] [ff10-i: 2]
            b
            ff10-i
        ]
        --assert none = ff10-f
]

if system/state/interpreted? [                          ;-- not yet supported by compiler
    --test-- "funfun11"
        ff11-i: 1
        ff11-f: function [] [
            ff: func [/local ff11-i][ff11-i: 2]
            ff11-i
        ]
        --assert none = ff11-f
        --assert 1 = ff11-i
]

    --test-- "funfun12"
        ff12-i: 1
        ff12-f: function [] [
            ff: make object! [ff12-i: 2]
            ff12-i
        ]
        --assert none = ff12-f
        --assert 1 = ff12-i
 comment {                                          ####################################
    --test-- "funfun13"
        ff13-i: 1
        ff13-f: function [/extern ff13-i] [
            ff: func [/local ff13-i][ff13-i: 2]
            ff13-i: 3
        ]
        --assert 3 = ff13-f
        --assert 3 = ff13-i
                                                    ####################################}
    --test-- "funfun14"
        ff14-i: 1
        ff14-f: function [/extern ff14-i] [
            ff: make object! [ff14-i: 2]
            ff14-i: 3
        ]
        --assert 3 = ff14-f
        --assert 3 = ff14-i
 comment {                                          ####################################
    --test-- "funfun15"
        ff15-i: 1
        ff15-f: func [
            /local ff15-i
        ][
            ff15-i: 2
            ff: function [
                /extern ff15-i
            ][
                ff15-i
            ]
            ff
        ]
        --assert 2 = ff15-f
        --assert 1 = ff15-i
                                                    ####################################}

if system/state/interpreted? [                      ;-- not yet supported by compiler
    --test-- "funfun16"
        ff16-f: function [] [
            f2: func [i] [i: 1]
            f2 i
            i
        ]
        --assert none = ff16-f
]

if system/state/interpreted? [                      ;-- not yet supported by compiler
    --test-- "funfun17"
        ff17-i: 10
        ff17-f: function [] [
            f2: func [ff17-i] [ff17-i: 1]
            f2 ff17-i
            ff17-i
        ]
        --assert none = ff17-f
]

===end-group===

===start-group=== "functions with objects"
comment {                                          ####################################
    --test-- "fwo1 - #965"
        fwo1-f: func [
            o object!
        ][
          append o/a o/b
        ]
        fwo1-o: make object! [
            a: "hello"
            b: " world"
        ]
        --assert "hello world" = fwo1-f
                                                    ####################################}
===end-group===

===start-group=== "function with lit-arg"
    fwla-f: func ['x][:x]

    --test-- "fwla1"
        --assert 10 = fwla-f 10

    --test-- "fwla2"
        --assert 50 = fwla-f (20 + 30)

    --test-- "fwla3"
        fwla3-i: 40
        --assert 40 = fwla-f :fwla3-i

    --test-- "fwla4"
        fwla4-o: make object! [i: 50]
        --assert 50 = fwla-f :fwla4-o/i

    --test-- "fwla5"
        --assert (first ['fwla4-o/i]) = fwla-f 'fwla4-o/i

    --test-- "fwla6"
        --assert (first [fwla4-o/i:]) = fwla-f fwla4-o/i:

    --test-- "fwla7"
        --assert (first [fwla4-o/i]) = fwla-f fwla4-o/i
===end-group===

===start-group=== "function with get-arg"
        fwga-f: func [:x][:x]

    --test-- "fwga1"
        --assert 10 = fwga-f 10

    --test-- "fwga2"
        --assert (first [(20 + 30)]) = fwga-f (20 + 30)

    --test-- "fwga3"
        fwga3-i: 40
        --assert (first [:fwga3-i]) = fwga-f :fwga3-i

    --test-- "fwga4"
        fwga4-o: make object! [i: 50]
        --assert (first [:fwga4-o/i]) = fwga-f :fwga4-o/i

    --test-- "fwga5"
        fwga5-i: 10
        fwga5-f: func[:x][set x 1 + get x]
        --assert 11 = fwga5-f fwga5-i
        --assert 11 = fwga5-i

    --test-- "fwga6"
        --assert (first [fwga4-o/i]) = fwga-f fwga4-o/i

    --test-- "fwga7"
        --assert (first ['fwga4-o/i]) = fwga-f 'fwga4-o/i

    --test-- "fwga8"
        --assert (first [fwga4-o/i:]) = fwga-f fwga4-o/i:
===end-group===

~~~end-file~~~


FEAT: moved the platform detection code at Red level now (using system/platform).

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 [
	#if OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: 	 "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
			]
		]
	]
]

#include %input.red
#include %help.red

read-argument: routine [
	/local
		args [str-array!]
		str	 [red-string!]
][
	if system/args-count <> 2 [
		SET_RETURN(none-value)
		exit
	]
	args: system/args-list + 1							;-- skip binary filename
	str: simple-io/read-txt args/item
	SET_RETURN(str)
]

init-console: routine [
	str [string!]
	/local
		ret
][
	;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]
]

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

	foreach c buffer [
		case [
			escaped?	[escaped?: no]
			in-comment? [if c = #"^/" [in-comment?: no]]
			'else [
				switch c [
					#"^^" [escaped?: yes]
					#";"  [if all [zero? list/2 not in-string?][in-comment?: yes]]
					#"["  [unless in-string? [list/1: list/1 + 1]]
					#"]"  [unless in-string? [list/1: list/1 - 1]]
					#"^"" [if zero? list/2 [in-string?: not in-string?]]
					#"{"  [if zero? list/2 [in-string?: yes] list/2: list/2 + 1]
					#"}"  [if 1 = list/2   [in-string?: no]  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: ask prompt [
			append buffer line
			cnt: count-delimiters buffer
			append buffer lf							;-- needed for multiline modes

			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

if script: read-argument [
	script: load script
	either any [
		not script/1 == 'Red
		not block? script/2
	][
		print "*** Error: not a Red program!"
	][
		do skip script 2
	]
	quit
]

if system/platform = 'windows [init-console "Red Console"]

print {
-=== Red Console alpha version ===-
Type HELP for starting information.
}

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 [
	#if OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: 	 "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
			]
		]
	]
]

#include %input.red
#include %help.red

read-argument: routine [
	/local
		args [str-array!]
		str	 [red-string!]
][
	if system/args-count <> 2 [
		SET_RETURN(none-value)
		exit
	]
	args: system/args-list + 1							;-- skip binary filename
	str: simple-io/read-txt args/item
	SET_RETURN(str)
]

init-console: routine [
	str [string!]
	/local
		ret
][
	#if 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]
	]
]

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

	foreach c buffer [
		case [
			escaped?	[escaped?: no]
			in-comment? [if c = #"^/" [in-comment?: no]]
			'else [
				switch c [
					#"^^" [escaped?: yes]
					#";"  [if all [zero? list/2 not in-string?][in-comment?: yes]]
					#"["  [unless in-string? [list/1: list/1 + 1]]
					#"]"  [unless in-string? [list/1: list/1 - 1]]
					#"^"" [if zero? list/2 [in-string?: not in-string?]]
					#"{"  [if zero? list/2 [in-string?: yes] list/2: list/2 + 1]
					#"}"  [if 1 = list/2   [in-string?: no]  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: ask prompt [
			append buffer line
			cnt: count-delimiters buffer
			append buffer lf							;-- needed for multiline modes

			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

if script: read-argument [
	script: load script
	either any [
		not script/1 == 'Red
		not block? script/2
	][
		print "*** Error: not a Red program!"
	][
		do skip script 2
	]
	quit
]
init-console "Red Console"

print {
-=== Red Console alpha version ===-
Type HELP for starting information.
}

do-console


TESTS: fixes in float32 tests to avoid collision with predefined `pi` value.

Red/System [
	Title:   "Red/System integer! datatype tests"
	Author:  "Peter W A Wood"
	File: 	 %float32-test.reds
	Version: 0.1.0
	Rights:  "Copyright (C) 2012 Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "float32"

===start-group=== "float32 assignment"
  --test-- "float32-1"
    f: as float32! 100.0
  --assert f = as float32! 100.0
  --test-- "float32-2"
    f: as float32! 1.222090944E+33
  --assert f = as float32! 1.222090944E+33
  --test-- "float32-3"
    f: as float32! 9.99999E-25
  --assert f = as float32! 9.99999E-25
  --test-- "float32-4"
    f: as float32! 1.0
    f1: f
  --assert f1 = as float32! 1.0
===end-group===

===start-group=== "float argument to external function"

	pi64: 3.1415927

	--test-- "float32-ext-1"
	--assert (as float32! -1.0) = as-float32 cos pi64

	;--test-- "float32-ext-2"
	;--assert  (as float32! 0.0) = (as float32! sin pi32)		; not working, because of rounding error.

	--test-- "float32-ext-3"
	--assert (as float32! -1.0) = as-float32 cos 3.1415927

===end-group===

===start-group=== "float32 function arguments"
    ff: func [
      fff     [float32!]
      ffg     [float32!]
      return: [integer!]
      /local
      ffl [float32!]
    ][
       ffl: fff
       if ffl <> fff [return 1]
       ffl: ffg
       if ffl <> ffg [return 2]
       1
    ]

  --test-- "float32-func-args-1"
  --assert 1 = ff as float32! 1.0 as float32! 2.0

  --test-- "float32-func-args-2"
  --assert 1 = ff as float32! 1.222090944E+33 as float32! 9.99999E-25

===end-group===

===start-group=== "float32 locals"

	local-float: func [n [float32!] return: [float32!] /local p][p: n p]

	--test-- "float32-loc-1"
	pi64: 3.14159265358979
	pi32: local-float as float32! 3.1415927
	--assert pi32 =  as float32! 3.1415927
	--assert (as float32! -1.0) = as-float32 cos pi64
	--assert (as float32! -1.0) = local-float as-float32 cos pi64

	--test-- "float32-loc-2"
	f: local-float pi32
	--assert pi32 = local-float f

	--test-- "float32-loc-3"
	local-float2: func [n [float32!] return: [float32!] /local p][p: n local-float p]

	pi32: local-float2 as float32! 3.1415927
	--assert (as float32! 3.1415927) = local-float2 pi32
	--assert (as float32! -1.0) = local-float2 as-float32 cos pi64
	f: local-float2 pi32
	--assert pi32 = local-float2 f

	--test-- "float32-loc-4"
	local-float3: func [n [float32!] return: [float32!] /local p [float32!]][p: n local-float p]

	pi32: local-float3 as float32! 3.1415927
	--assert (as float32! 3.1415927) = local-float3 pi32
	--assert (as float32! -1.0) = local-float3 as-float32 cos pi64
	f: local-float3 pi32
	--assert pi32 = local-float3 f

	--test-- "float32-loc-5"
	local-float4: func [n [float32!] return: [float32!] /local r p][p: n p]
	--assert (as float32! 3.1415927) = local-float4 pi32
	--assert (as float32! -1.0) = local-float4 as-float32 cos pi64
	f: local-float4 pi32
	--assert pi32 = local-float4 f

	--test-- "float32-loc-6"
	local-float5: func [n [float32!] return: [float32!] /local r p][p: n local-float p]
	--assert (as float32! 3.1415927) = local-float5 pi32
	--assert (as float32! -1.0) = local-float5 as-float32 cos pi64
	f: local-float5 pi32
	--assert pi32 = local-float5 f

===end-group===

===start-group=== "float32 function return"

    ff1: func [
      ff1i      [integer!]
      return:   [float32!]
    ][
      as float32! switch ff1i [
        1 [1.0]
        2 [1.222090944E+33]
        3 [9.99999E-30]
      ]
    ]
  --test-- "float32 return 1"
  --assert (as float32! 1.0) = ff1 1
  --test-- "float32 return 2"
  --assert (as float32! 1.222090944E+33) = ff1 2
  --test-- "float32 return 3"
  --assert (as float32! 9.99999E-30) = ff1 3

===end-group===

===start-group=== "float32 struct!"

  --test-- "float32-struct-1"
    sf1: declare struct! [
      a   [float32!]
    ]
  --assert (as float32! 0.0) = sf1/a

  --test-- "float32-struct-2"
    sf2: declare struct! [
      a   [float32!]
    ]
    sf2/a: as float32! 1.222090944E+33
  --assert (as float32! 1.222090944E+33) = sf2/a

    sf3: declare struct! [
      a   [float32!]
      b   [float32!]
    ]

  --test-- "float32-struct-3"
    sf3/a: as float32! 1.222090944E+33
    sf3/b: as float32! 9.99999E-25

  --assert (as float32! 1.222090944E+33) = sf3/a
  --assert (as float32! 9.99999E-25) = sf3/b

  --test-- "float32-struct-4"
    sf4: declare struct! [
      c   [byte!]
      a   [float32!]
      l   [logic!]
      b   [float32!]
    ]
    sf4/a: as float32! 1.222090944E+33
    sf4/b: as float32! 9.99999E-25
  --assert (as float32! 1.222090944E+33) = sf4/a
  --assert (as float32! 9.99999E-25) = sf4/b

===end-group===

===start-group=== "float32 pointers"

  --test-- "float32-point-1"
  pi32: as float32! 3.1415927
  p: declare pointer! [float32!]
  p/value: as float32! 3.1415927
  --assert pi32 = p/value

 ;TBD: add more float pointer tests in %pointer-test.reds.

===end-group===

===start-group=== "expressions with returned float values"

    fe1: function [
      return: [float32!]
    ][
      as float32! 1.0
    ]
    fe2: function [
      return: [float32!]
    ][
      as float32! 2.0
    ]

  --test-- "ewrfv0"
  --assertf32~= as float32! 1.0 (fe1 * as float32! 1.0) as float32! 0.1E-3

  --test-- "ewrfv1"
  --assertf32~= as float32! 1.0 (as float32! 1.0) * fe1 as float32! 0.1E-3

  --test-- "ewrfv2"
  --assertf32~= as float32! 0.5 (fe1 / fe2) as float32! 0.1E-3

===end-group===

===start-group=== "float32 arguments to typed functions"
    fatf1: function [
      [typed]
      count [integer!]
      list [typed-value!]
      return: [float32!]
      /local
        a [float32!]
    ][
      a: as float32! list/value
      a
    ]

    fatf2: function [
      [typed]
      count [integer!]
      list [typed-value!]
      return: [float32!]
      /local
        a [float32!]
        b [float32!]
    ][
      a: as float32! list/value
      list: list + 1
      b: as float32! list/value
      a + b
    ]

  --test-- "fatf-1"
  --assert (as float32! 2.0) = (fatf1 as float32! 2.0)

  --test-- "fatf-2"
  --assert (as float32! 2.0) = ((fatf1 as float32! 1.0) + (fatf1 as float32! 1.0))

  --test-- "fatf-3"
  --assert (as float32! 3.0) = fatf2 [as float32! 1.0 as float32! 2.0]

===end-group===

===start-group=== "Casting float! arguments to float32!"

    cfaf1: function [
        a   [float!]
        return: [float32!]
    ][
      as float32! a
    ]
    cfaf2: function [
        a   [float!]
        b   [float!]
        return: [float32!]
    ][
      (as float32! a) + (as float32! b)
    ]

  --test-- "cfaf1"
  --assert (as float32! 1.0) = cfaf1 1.0

  --test-- "cfaf2"
  --assertf32~= (as float32! 3.0) (cfaf2 1.0 2.0) (as float32! 0.1e-7)

===end-group===

===start-group=== "calculations"

	fcfoo: func [a [float32!] return: [float32!]][a]

	fcptr: declare struct! [a [float32!]]
	fcptr/a: as float32! 3.0

	fc2: as float32! 3.0

	--test-- "fc-1"
		fc1: as float32! 2.0
		fc1: fc1 / (fc1 - as float32! 1.0)
	--assertf32~= as float32! 2.0 fc1 as float32! 0.1E-7

	--test-- "fc-2"
	--assert (as float32! 5.0) - (as float32! 3.0) = as float32! 2.0			;-- imm/imm

	--test-- "fc-3"
	--assert (as float32! 5.0) - fc2 = as float32! 2.0							;-- imm/ref

	--test-- "fc-4"
	--assert (as float32! 5.0) - (fcfoo as float32! 3.0) = as float32! 2.0		;-- imm/reg(block!)

	--test-- "fc-5"
	--assertf32~= (as float32! 5.0) - fcptr/a as float32! 2.0 as float32! 1E-10		;-- imm/reg(path!)

	--test-- "fc-6"
	--assert fc2 - (as float32! 5.0) = as float32! -2.0							;-- ref/imm

	--test-- "fc-7"
	--assert fc2 - (fcfoo as float32! 5.0) = as float32! -2.0					;-- ref/reg(block!)

	--test-- "fc-8"
	--assert fc2 - fcptr/a = as float32! 0.0									;-- ref/reg(path!)

	--test-- "fc-9"
	--assertf32~= (fcfoo as float32! 5.0) - as float32! 3.0 as float32! 2.0 as float32! 1E-10	;-- reg(block!)/imm

	--test-- "fc-10"
	--assert (fcfoo as float32! 5.0) - (fcfoo as float32! 3.0) = as float32! 2.0	;-- reg(block!)/reg(block!)

	--test-- "fc-11"
	--assert (fcfoo as float32! 5.0) - fcptr/a = as float32! 2.0				;-- reg(block!)/reg(path!)

	--test-- "fc-12"
	--assert fcptr/a - (fcfoo as float32! 5.0) = as float32! 2.0				;-- reg(path!)/reg(block!)

===end-group===

===start-group=== "implicit literal type casting of function arguments"
  --test-- "fiitc1"
    flitc1-f: function [
      x       [float32!]
      y       [float!]
      z       [float32!]
      return: [float32!]
    ][
      x + z
    ]
  --assert (as float32! 4.00) = flitc1-f 1.00 2.00 3.00
===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System integer! datatype tests"
	Author:  "Peter W A Wood"
	File: 	 %float32-test.reds
	Version: 0.1.0
	Rights:  "Copyright (C) 2012 Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "float32"

===start-group=== "float32 assignment"
  --test-- "float32-1"
    f: as float32! 100.0
  --assert f = as float32! 100.0
  --test-- "float32-2"
    f: as float32! 1.222090944E+33
  --assert f = as float32! 1.222090944E+33
  --test-- "float32-3"
    f: as float32! 9.99999E-25
  --assert f = as float32! 9.99999E-25
  --test-- "float32-4"
    f: as float32! 1.0
    f1: f
  --assert f1 = as float32! 1.0
===end-group===

===start-group=== "float argument to external function"

	pi32: 3.1415927

	--test-- "float32-ext-1"
	--assert (as float32! -1.0) = as-float32 cos pi32

	;--test-- "float32-ext-2"
	;--assert  (as float32! 0.0) = (as float32! sin pi32)		; not working, because of rounding error.

	--test-- "float32-ext-3"
	--assert (as float32! -1.0) = as-float32 cos 3.1415927

===end-group===

===start-group=== "float32 function arguments"
    ff: func [
      fff     [float32!]
      ffg     [float32!]
      return: [integer!]
      /local
      ffl [float32!]
    ][
       ffl: fff
       if ffl <> fff [return 1]
       ffl: ffg
       if ffl <> ffg [return 2]
       1
    ]

  --test-- "float32-func-args-1"
  --assert 1 = ff as float32! 1.0 as float32! 2.0

  --test-- "float32-func-args-2"
  --assert 1 = ff as float32! 1.222090944E+33 as float32! 9.99999E-25

===end-group===

===start-group=== "float32 locals"

	local-float: func [n [float32!] return: [float32!] /local p][p: n p]

	--test-- "float32-loc-1"
	pi64: 3.14159265358979
	pi: local-float as float32! 3.1415927
	--assert pi =  as float32! 3.1415927
	--assert (as float32! -1.0) = as-float32 cos pi64
	--assert (as float32! -1.0) = local-float as-float32 cos pi64

	--test-- "float32-loc-2"
	f: local-float pi
	--assert pi = local-float f

	--test-- "float32-loc-3"
	local-float2: func [n [float32!] return: [float32!] /local p][p: n local-float p]

	pi: local-float2 as float32! 3.1415927
	--assert (as float32! 3.1415927) = local-float2 pi
	--assert (as float32! -1.0) = local-float2 as-float32 cos pi64
	f: local-float2 pi
	--assert pi = local-float2 f

	--test-- "float32-loc-4"
	local-float3: func [n [float32!] return: [float32!] /local p [float32!]][p: n local-float p]

	pi: local-float3 as float32! 3.1415927
	--assert (as float32! 3.1415927) = local-float3 pi
	--assert (as float32! -1.0) = local-float3 as-float32 cos pi64
	f: local-float3 pi
	--assert pi = local-float3 f

	--test-- "float32-loc-5"
	local-float4: func [n [float32!] return: [float32!] /local r p][p: n p]
	--assert (as float32! 3.1415927) = local-float4 pi
	--assert (as float32! -1.0) = local-float4 as-float32 cos pi64
	f: local-float4 pi
	--assert pi = local-float4 f

	--test-- "float32-loc-6"
	local-float5: func [n [float32!] return: [float32!] /local r p][p: n local-float p]
	--assert (as float32! 3.1415927) = local-float5 pi
	--assert (as float32! -1.0) = local-float5 as-float32 cos pi64
	f: local-float5 pi
	--assert pi = local-float5 f

===end-group===

===start-group=== "float32 function return"

    ff1: func [
      ff1i      [integer!]
      return:   [float32!]
    ][
      as float32! switch ff1i [
        1 [1.0]
        2 [1.222090944E+33]
        3 [9.99999E-30]
      ]
    ]
  --test-- "float32 return 1"
  --assert (as float32! 1.0) = ff1 1
  --test-- "float32 return 2"
  --assert (as float32! 1.222090944E+33) = ff1 2
  --test-- "float32 return 3"
  --assert (as float32! 9.99999E-30) = ff1 3

===end-group===

===start-group=== "float32 struct!"

  --test-- "float32-struct-1"
    sf1: declare struct! [
      a   [float32!]
    ]
  --assert (as float32! 0.0) = sf1/a

  --test-- "float32-struct-2"
    sf2: declare struct! [
      a   [float32!]
    ]
    sf2/a: as float32! 1.222090944E+33
  --assert (as float32! 1.222090944E+33) = sf2/a

    sf3: declare struct! [
      a   [float32!]
      b   [float32!]
    ]

  --test-- "float32-struct-3"
    sf3/a: as float32! 1.222090944E+33
    sf3/b: as float32! 9.99999E-25

  --assert (as float32! 1.222090944E+33) = sf3/a
  --assert (as float32! 9.99999E-25) = sf3/b

  --test-- "float32-struct-4"
    sf4: declare struct! [
      c   [byte!]
      a   [float32!]
      l   [logic!]
      b   [float32!]
    ]
    sf4/a: as float32! 1.222090944E+33
    sf4/b: as float32! 9.99999E-25
  --assert (as float32! 1.222090944E+33) = sf4/a
  --assert (as float32! 9.99999E-25) = sf4/b

===end-group===

===start-group=== "float32 pointers"

  --test-- "float32-point-1"
  pi: as float32! 3.1415927
  p: declare pointer! [float32!]
  p/value: as float32! 3.1415927
  --assert pi = p/value

 ;TBD: add more float pointer tests in %pointer-test.reds.

===end-group===

===start-group=== "expressions with returned float values"

    fe1: function [
      return: [float32!]
    ][
      as float32! 1.0
    ]
    fe2: function [
      return: [float32!]
    ][
      as float32! 2.0
    ]

  --test-- "ewrfv0"
  --assertf32~= as float32! 1.0 (fe1 * as float32! 1.0) as float32! 0.1E-3

  --test-- "ewrfv1"
  --assertf32~= as float32! 1.0 (as float32! 1.0) * fe1 as float32! 0.1E-3

  --test-- "ewrfv2"
  --assertf32~= as float32! 0.5 (fe1 / fe2) as float32! 0.1E-3

===end-group===

===start-group=== "float32 arguments to typed functions"
    fatf1: function [
      [typed]
      count [integer!]
      list [typed-value!]
      return: [float32!]
      /local
        a [float32!]
    ][
      a: as float32! list/value
      a
    ]

    fatf2: function [
      [typed]
      count [integer!]
      list [typed-value!]
      return: [float32!]
      /local
        a [float32!]
        b [float32!]
    ][
      a: as float32! list/value
      list: list + 1
      b: as float32! list/value
      a + b
    ]

  --test-- "fatf-1"
  --assert (as float32! 2.0) = (fatf1 as float32! 2.0)

  --test-- "fatf-2"
  --assert (as float32! 2.0) = ((fatf1 as float32! 1.0) + (fatf1 as float32! 1.0))

  --test-- "fatf-3"
  --assert (as float32! 3.0) = fatf2 [as float32! 1.0 as float32! 2.0]

===end-group===

===start-group=== "Casting float! arguments to float32!"

    cfaf1: function [
        a   [float!]
        return: [float32!]
    ][
      as float32! a
    ]
    cfaf2: function [
        a   [float!]
        b   [float!]
        return: [float32!]
    ][
      (as float32! a) + (as float32! b)
    ]

  --test-- "cfaf1"
  --assert (as float32! 1.0) = cfaf1 1.0

  --test-- "cfaf2"
  --assertf32~= (as float32! 3.0) (cfaf2 1.0 2.0) (as float32! 0.1e-7)

===end-group===

===start-group=== "calculations"

	fcfoo: func [a [float32!] return: [float32!]][a]

	fcptr: declare struct! [a [float32!]]
	fcptr/a: as float32! 3.0

	fc2: as float32! 3.0

	--test-- "fc-1"
		fc1: as float32! 2.0
		fc1: fc1 / (fc1 - as float32! 1.0)
	--assertf32~= as float32! 2.0 fc1 as float32! 0.1E-7

	--test-- "fc-2"
	--assert (as float32! 5.0) - (as float32! 3.0) = as float32! 2.0			;-- imm/imm

	--test-- "fc-3"
	--assert (as float32! 5.0) - fc2 = as float32! 2.0							;-- imm/ref

	--test-- "fc-4"
	--assert (as float32! 5.0) - (fcfoo as float32! 3.0) = as float32! 2.0		;-- imm/reg(block!)

	--test-- "fc-5"
	--assertf32~= (as float32! 5.0) - fcptr/a as float32! 2.0 as float32! 1E-10		;-- imm/reg(path!)

	--test-- "fc-6"
	--assert fc2 - (as float32! 5.0) = as float32! -2.0							;-- ref/imm

	--test-- "fc-7"
	--assert fc2 - (fcfoo as float32! 5.0) = as float32! -2.0					;-- ref/reg(block!)

	--test-- "fc-8"
	--assert fc2 - fcptr/a = as float32! 0.0									;-- ref/reg(path!)

	--test-- "fc-9"
	--assertf32~= (fcfoo as float32! 5.0) - as float32! 3.0 as float32! 2.0 as float32! 1E-10	;-- reg(block!)/imm

	--test-- "fc-10"
	--assert (fcfoo as float32! 5.0) - (fcfoo as float32! 3.0) = as float32! 2.0	;-- reg(block!)/reg(block!)

	--test-- "fc-11"
	--assert (fcfoo as float32! 5.0) - fcptr/a = as float32! 2.0				;-- reg(block!)/reg(path!)

	--test-- "fc-12"
	--assert fcptr/a - (fcfoo as float32! 5.0) = as float32! 2.0				;-- reg(path!)/reg(block!)

===end-group===

===start-group=== "implicit literal type casting of function arguments"
  --test-- "fiitc1"
    flitc1-f: function [
      x       [float32!]
      y       [float!]
      z       [float32!]
      return: [float32!]
    ][
      x + z
    ]
  --assert (as float32! 4.00) = flitc1-f 1.00 2.00 3.00
===end-group===

~~~end-file~~~


FIX: added missing latin1-to-UCS4 function (just the prototype for now, implementation is pending).

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

#enum encoding! [
	Latin1: 1
	UCS-2:  2
	UCS-4:  4
]

unicode: context [
	verbose: 0

	#define U_REPLACEMENT 	FFFDh
	;	choose one of the following options
	;	FFFDh			; U+FFFD = replacement character
	;	1Ah				; U+001A = control SUB (substitute)
	;	241Ah			; U+241A = symbol for substitute
	;	2426h			; U+2426 = symbol for substitute form two
	;	3Fh				; U+003F = question mark
	;	BFh				; U+00BF = inverted question mark
	;	DC00h + b1		; U+DCxx where xx = b1 (never a Unicode codepoint)

	latin1-to-UCS2: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/latin1-to-UCS2"]]

		used: as-integer s/tail - s/offset
		if used * 2 >= s/size [							;-- ensure we have enough space
			s: expand-series s used * 2 + 1
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  (as byte-ptr! s/offset) + (used * 2)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 1
			dst: dst - 2
			dst/1: src/1
			dst/2: null-byte
		]
		s/flags: s/flags and flag-unit-mask or UCS-2	;-- s/unit: UCS-2
		s
	]

	latin1-to-UCS4: func [

	][
		;TBD
	]

	UCS2-to-UCS4: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/UCS2-to-UCS4"]]

		used: as-integer s/tail - s/offset
		if used * 2 >= s/size [							;-- ensure we have enough space
			s: expand-series s used * 2 + 1
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  as int-ptr! (as byte-ptr! s/offset) + (used * 2)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 2
			dst: dst - 1
			dst/value: (as-integer src/2) << 8 + src/1
		]
		s/flags: s/flags and flag-unit-mask or UCS-4	;-- s/unit: UCS-4
		s
	]

	load-utf8: func [
		src		   [c-string!]							;-- UTF-8 input buffer (zero-terminated)
		size	   [integer!]							;-- size of src in bytes (including terminal NUL)
		return:	   [node!]
		/local
			node   [node!]
			s 	   [series!]
			buf1   [byte-ptr!]
			buf4   [int-ptr!]
			end    [byte-ptr!]
			unit   [integer!]
			b1 	   [integer!]							;-- up to four bytes in a UTF-8 sequence
			b2	   [integer!]							;-- for computing purposes they are of integer! type
			b3     [integer!]
			b4     [integer!]
			cp	   [integer!]							; computed codepoint
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/load-utf8"]]

		assert positive? size
		node: alloc-series size 1 0

		s:    as series! node/value
		buf1: as byte-ptr! s/offset
		end:  buf1 + s/size
		unit: Latin1									;-- start with 1 byte/codepoint

		assert not zero? as-integer src/1				;@@ ensure input string not empty

		;-- the first part of loop is Rudolf's code with very minor modifications
		;-- (res/value replaced by cp, 'u renamed to 'src)
		;-- original source code: https://gist.github.com/1325840

		until [
			b1: as-integer src/1

			; cycling through res is done at the end; likewise for src
			; to account for this, as soon as a multiple byte sequence is consumed
			; the pointer in src is moved one less than the number of bytes consumed

			either b1 < 80h	[							; single byte (ASCII)
				cp: b1									; and we are done
			][
				cp: U_REPLACEMENT
				; assume error by default - this simplifies code greatly
				; cp is now only set if a correct sequence has been decoded

				unless b1 < C0h [						; 80h - BFh may not start a sequence
					case  [
						b1 < E0h [						; start of two-byte sequence
							b2: as-integer src/2
							if all [
								b2 >= 80h b2 < C0h
							][
								cp:	(b1 - C0h << 6) or
									(b2 - 80h)
	;							if any [
	;								cp > 7Fh			; optional test for overlong
	;								cp = 0				; even so, must allow U+0000
	;							][
									src: src + 1
	;							]
							]
						]
						b1 < F0h [						; start of three-byte sequence
							b2: as-integer src/2
							b3: as-integer src/3
							if all [
								b2 >= 80h b2 < C0h
								b3 >= 80h b3 < C0h
							][
								cp:	(b1 - E0h << 12) or
									(b2 - 80h <<  6) or
									(b3 - 80h)
								if all [
									any [cp < DC00h cp > DCFFh]
	;								cp > 7FFh			; optional test for overlong
								][
									src: src + 2
								]
							]
						]
						b1 < F8h [						; start of four-byte sequence
							b2: as-integer src/2
							b3: as-integer src/3
							b4: as-integer src/4
							if all [
								b2 >= 80h b2 < C0h
								b3 >= 80h b3 < C0h
								b4 >= 80h b4 < C0h
							][
								cp:	(b1 - F0h << 18) or
									(b2 - 80h << 12) or
									(b3 - 80h <<  6) or
									(b4 - 80h)
								if all [
									cp <= 0010FFFFh
	;								cp > FFFFh			; optional test for overlong
								][
									src: src + 3
								]
							]
						]
	;					true [
	;						error case					;@@ throw an error! value
	;					]
					]
				]
			]

			switch unit [
				Latin1 [
					either cp > 255 [					;@@ missing Latin1 => UCS-4 case!!
						s/tail: as cell! buf1
						unit: UCS-2
						s:    latin1-to-UCS2 s			;-- upgrade to UCS-2
						buf1: as byte-ptr! s/tail
						end:  (as byte-ptr! s/offset) + s/size

						buf1/1: as-byte cp and FFh
						buf1/2: as-byte cp >> 8
						buf1: buf1 + 2
					][
						buf1/value: as-byte cp
						buf1: buf1 + 1
						assert buf1 <= end				;@@ should not happen if we're good
					]
				]
				UCS-2 [
					either cp > 65535 [
						s/tail: as cell! buf1
						unit: UCS-4
						s:    UCS2-to-UCS4 s			;-- upgrade to UCS-4
						buf4: as int-ptr! s/tail
						end:  (as byte-ptr! s/offset) + s/size

						buf4/value: cp
						buf4: buf4 + 1
					][
						if buf1 >= end [
							s/tail: as cell! buf1
							s: expand-series s s/size + (size >> 2)	;-- increase size by 50%
							buf1: as byte-ptr! s/tail
							end: (as byte-ptr! s/offset) + s/size
						]
						buf1/1: as-byte cp and FFh
						buf1/2: as-byte cp >> 8
						buf1: buf1 + 2
					]
				]
				UCS-4 [
					if buf4 >= (as int-ptr! end) [
						s: expand-series s s/size + size ;-- increase size by 100%
						buf4: as int-ptr! s/tail
						end: (as byte-ptr! s/offset) + s/size
					]
					buf4/value: cp
					buf4: buf4 + 1
				]
			]
			src: src + 1
			zero? b1
		] 												;-- end until

		s/tail: as cell! switch unit [					;-- position s/tail just before the NUL character
			Latin1 [buf1 - 1]
			UCS-2  [buf1 - 2]
			UCS-4  [buf4 - 1]
		]
		assert s/size + GET_UNIT(s) >= as-integer (s/tail - s/offset)

		node
	]

]

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

#enum encoding! [
	Latin1: 1
	UCS-2:  2
	UCS-4:  4
]

unicode: context [
	verbose: 0

	#define U_REPLACEMENT 	FFFDh
	;	choose one of the following options
	;	FFFDh			; U+FFFD = replacement character
	;	1Ah				; U+001A = control SUB (substitute)
	;	241Ah			; U+241A = symbol for substitute
	;	2426h			; U+2426 = symbol for substitute form two
	;	3Fh				; U+003F = question mark
	;	BFh				; U+00BF = inverted question mark
	;	DC00h + b1		; U+DCxx where xx = b1 (never a Unicode codepoint)

	latin1-to-UCS2: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/latin1-to-UCS2"]]

		used: as-integer s/tail - s/offset
		if used * 2 >= s/size [							;-- ensure we have enough space
			s: expand-series s used * 2 + 1
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  (as byte-ptr! s/offset) + (used * 2)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 1
			dst: dst - 2
			dst/1: src/1
			dst/2: null-byte
		]
		s/flags: s/flags and flag-unit-mask or UCS-2	;-- s/unit: UCS-2
		s
	]

	UCS2-to-UCS4: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/UCS2-to-UCS4"]]

		used: as-integer s/tail - s/offset
		if used * 2 >= s/size [							;-- ensure we have enough space
			s: expand-series s used * 2 + 1
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  as int-ptr! (as byte-ptr! s/offset) + (used * 2)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 2
			dst: dst - 1
			dst/value: (as-integer src/2) << 8 + src/1
		]
		s/flags: s/flags and flag-unit-mask or UCS-4	;-- s/unit: UCS-4
		s
	]

	load-utf8: func [
		src		   [c-string!]							;-- UTF-8 input buffer (zero-terminated)
		size	   [integer!]							;-- size of src in bytes (including terminal NUL)
		return:	   [node!]
		/local
			node   [node!]
			s 	   [series!]
			buf1   [byte-ptr!]
			buf4   [int-ptr!]
			end    [byte-ptr!]
			unit   [integer!]
			b1 	   [integer!]							;-- up to four bytes in a UTF-8 sequence
			b2	   [integer!]							;-- for computing purposes they are of integer! type
			b3     [integer!]
			b4     [integer!]
			cp	   [integer!]							; computed codepoint
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/load-utf8"]]

		assert positive? size
		node: alloc-series size 1 0

		s:    as series! node/value
		buf1: as byte-ptr! s/offset
		end:  buf1 + s/size
		unit: Latin1									;-- start with 1 byte/codepoint

		assert not zero? as-integer src/1				;@@ ensure input string not empty

		;-- the first part of loop is Rudolf's code with very minor modifications
		;-- (res/value replaced by cp, 'u renamed to 'src)
		;-- original source code: https://gist.github.com/1325840

		until [
			b1: as-integer src/1

			; cycling through res is done at the end; likewise for src
			; to account for this, as soon as a multiple byte sequence is consumed
			; the pointer in src is moved one less than the number of bytes consumed

			either b1 < 80h	[							; single byte (ASCII)
				cp: b1									; and we are done
			][
				cp: U_REPLACEMENT
				; assume error by default - this simplifies code greatly
				; cp is now only set if a correct sequence has been decoded

				unless b1 < C0h [						; 80h - BFh may not start a sequence
					case  [
						b1 < E0h [						; start of two-byte sequence
							b2: as-integer src/2
							if all [
								b2 >= 80h b2 < C0h
							][
								cp:	(b1 - C0h << 6) or
									(b2 - 80h)
	;							if any [
	;								cp > 7Fh			; optional test for overlong
	;								cp = 0				; even so, must allow U+0000
	;							][
									src: src + 1
	;							]
							]
						]
						b1 < F0h [						; start of three-byte sequence
							b2: as-integer src/2
							b3: as-integer src/3
							if all [
								b2 >= 80h b2 < C0h
								b3 >= 80h b3 < C0h
							][
								cp:	(b1 - E0h << 12) or
									(b2 - 80h <<  6) or
									(b3 - 80h)
								if all [
									any [cp < DC00h cp > DCFFh]
	;								cp > 7FFh			; optional test for overlong
								][
									src: src + 2
								]
							]
						]
						b1 < F8h [						; start of four-byte sequence
							b2: as-integer src/2
							b3: as-integer src/3
							b4: as-integer src/4
							if all [
								b2 >= 80h b2 < C0h
								b3 >= 80h b3 < C0h
								b4 >= 80h b4 < C0h
							][
								cp:	(b1 - F0h << 18) or
									(b2 - 80h << 12) or
									(b3 - 80h <<  6) or
									(b4 - 80h)
								if all [
									cp <= 0010FFFFh
	;								cp > FFFFh			; optional test for overlong
								][
									src: src + 3
								]
							]
						]
	;					true [
	;						error case					;@@ throw an error! value
	;					]
					]
				]
			]

			switch unit [
				Latin1 [
					either cp > 255 [
						s/tail: as cell! buf1
						unit: UCS-2
						s:    latin1-to-UCS2 s			;-- upgrade to UCS-2
						buf1: as byte-ptr! s/tail
						end:  (as byte-ptr! s/offset) + s/size

						buf1/1: as-byte cp and FFh
						buf1/2: as-byte cp >> 8
						buf1: buf1 + 2
					][
						buf1/value: as-byte cp
						buf1: buf1 + 1
						assert buf1 <= end				;@@ should not happen if we're good
					]
				]
				UCS-2 [
					either cp > 65535 [
						s/tail: as cell! buf1
						unit: UCS-4
						s:    UCS2-to-UCS4 s			;-- upgrade to UCS-4
						buf4: as int-ptr! s/tail
						end:  (as byte-ptr! s/offset) + s/size

						buf4/value: cp
						buf4: buf4 + 1
					][
						if buf1 >= end [
							s/tail: as cell! buf1
							s: expand-series s s/size + (size >> 2)	;-- increase size by 50%
							buf1: as byte-ptr! s/tail
							end: (as byte-ptr! s/offset) + s/size
						]
						buf1/1: as-byte cp and FFh
						buf1/2: as-byte cp >> 8
						buf1: buf1 + 2
					]
				]
				UCS-4 [
					if buf4 >= (as int-ptr! end) [
						s: expand-series s s/size + size ;-- increase size by 100%
						buf4: as int-ptr! s/tail
						end: (as byte-ptr! s/offset) + s/size
					]
					buf4/value: cp
					buf4: buf4 + 1
				]
			]
			src: src + 1
			zero? b1
		] 												;-- end until

		s/tail: as cell! switch unit [					;-- position s/tail just before the NUL character
			Latin1 [buf1 - 1]
			UCS-2  [buf1 - 2]
			UCS-4  [buf4 - 1]
		]
		assert s/size + GET_UNIT(s) >= as-integer (s/tail - s/offset)

		node
	]

]


TESTS: Add RANDOM tests for INTEGER!

TESTS: Add RANDOM tests for INTEGER!

Red [
	Title:   "Red/System integer! datatype tests"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %integer-test.red
	Version: "0.1.0"
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

;; These supplement the bulk of the integer tests which are automatically
;; generated.

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

~~~start-file~~~ "integer"

===start-group=== "absolute"
	--test-- "abs1" --assert 0 = absolute 0
	--test-- "abs2" --assert 1 = absolute 1
	--test-- "abs3" --assert 1 = absolute -1
	--test-- "abs4" --assert 2147483647 = absolute -2147483647
	--test-- "abs5" --assert 2147483647 = absolute 2147483647
===end-group===

===start-group=== "power"
	--test-- "pow1" --assert 3 	 = power  3 1
	--test-- "pow2" --assert 9 	 = power -3 2
	--test-- "pow3" --assert -27 = power -3 3
	--test-- "pow4" --assertf~= -0.3333333333333333 (power -3 -1) 1E-13
	--test-- "pow5" --assert -1  = power -1 3
	--test-- "pow6" --assert 1	 = power -1 -4
	;--test-- "pow7" --assert 0.0 = power 0 -1		;@@ return INF or 0.0
===end-group===

===start-group=== "max/min"
	--test-- "max1" --assert 3 	 = max  3 1
	--test-- "min1" --assert -3  = min -3 2
===end-group===

===start-group=== "negative?/positive?"
	--test-- "neg1" --assert true  = negative? -1
	--test-- "neg2" --assert false = negative? 0
	--test-- "neg3" --assert false = negative? 1
	--test-- "pos1" --assert true  = positive? 1
	--test-- "pos2" --assert false = positive? 0
	--test-- "pos3" --assert false = positive? -1
===end-group===

===start-group=== "complemented"
	--test-- "comp-1" --assert -2 = complement 1
	--test-- "comp-2" --assert -1 = complement 0
	--test-- "comp-3" --assert 0  = complement FFFFFFFFh
===end-group===

===start-group=== "shift"
	--test-- "shift-1" --assert 1  = shift 2 1
	--test-- "shift-2" --assert 16 = shift/left 2 3
	--test-- "shift-3" --assert FFFFFFFEh = shift FFFFFFFCh 1
	--test-- "shift-4" --assert 7FFFFFFEh = shift/logical FFFFFFFCh 1
===end-group===

===start-group=== "shift op!"
	--test-- "shift-op-1" --assert 2 >> 1 = 1
	--test-- "shift-op-2" --assert 2 << 3 = 16
	--test-- "shift-op-3" --assert FFFFFFFCh >> 1 = FFFFFFFEh
	--test-- "shift-op-4" --assert FFFFFFFCh >>> 1 = 7FFFFFFEh
===end-group===

===start-group=== "and"
	--test-- "and1" --assert 01h and 10h = 00h
	--test-- "and2" --assert 11h and 10h = 10h
	--test-- "and3" --assert 01h and 1Fh = 01h
===end-group===

===start-group=== "or"
	--test-- "or1" --assert  01h or 10h  = 11h
	--test-- "or2" --assert  11h or 10h  = 11h
	--test-- "or3" --assert  01h or 1Fh  = 1Fh
===end-group===

===start-group=== "xor"
	--test-- "xor1" --assert 01h xor 10h = 11h
	--test-- "xor2" --assert 11h xor 10h = 01h
	--test-- "xor3" --assert 01h xor 1Fh = 1Eh
===end-group===

===start-group=== "random"
	--test-- "random1" --assert 1 = random 1
	--test-- "random2" --assert 2 = random/only next [1 2]
	--test-- "random3" --assert not negative? random 1
===end-group===

===start-group=== "round"
	--test-- "round1" --assert  123904 = round/to  123'456 1024
	--test-- "round2" --assert -123904 = round/to -123'456 1024

	--test-- "round3" --assert  21 = round/down/to  23 3
	--test-- "round4" --assert -21 = round/down/to -23 3

	--test-- "round5" --assert  24 = round/even/to  23 3
	--test-- "round6" --assert -24 = round/even/to -23 3

	--test-- "round7" --assert  24 = round/half-down/to  23 3
	--test-- "round8" --assert -24 = round/half-down/to -23 3

	--test-- "round9" --assert  21 = round/floor/to  23 3
	--test-- "round10" --assert -24 = round/floor/to -23 3

	--test-- "round11" --assert  24 = round/ceiling/to  23 3
	--test-- "round12" --assert -21 = round/ceiling/to -23 3

	--test-- "round13" --assert  24 = round/half-ceiling/to  23 3
	--test-- "round14" --assert -24 = round/half-ceiling/to -23 3
===end-group===

~~~end-file~~~

Red [
	Title:   "Red/System integer! datatype tests"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %integer-test.red
	Version: "0.1.0"
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

;; These supplement the bulk of the integer tests which are automatically
;; generated.

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

~~~start-file~~~ "integer"

===start-group=== "absolute"
	--test-- "abs1" --assert 0 = absolute 0
	--test-- "abs2" --assert 1 = absolute 1
	--test-- "abs3" --assert 1 = absolute -1
	--test-- "abs4" --assert 2147483647 = absolute -2147483647
	--test-- "abs5" --assert 2147483647 = absolute 2147483647
===end-group===

===start-group=== "power"
	--test-- "pow1" --assert 3 	 = power  3 1
	--test-- "pow2" --assert 9 	 = power -3 2
	--test-- "pow3" --assert -27 = power -3 3
	--test-- "pow4" --assertf~= -0.3333333333333333 (power -3 -1) 1E-13
	--test-- "pow5" --assert -1  = power -1 3
	--test-- "pow6" --assert 1	 = power -1 -4
	;--test-- "pow7" --assert 0.0 = power 0 -1		;@@ return INF or 0.0
===end-group===

===start-group=== "max/min"
	--test-- "max1" --assert 3 	 = max  3 1
	--test-- "min1" --assert -3  = min -3 2
===end-group===

===start-group=== "negative?/positive?"
	--test-- "neg1" --assert true  = negative? -1
	--test-- "neg2" --assert false = negative? 0
	--test-- "neg3" --assert false = negative? 1
	--test-- "pos1" --assert true  = positive? 1
	--test-- "pos2" --assert false = positive? 0
	--test-- "pos3" --assert false = positive? -1
===end-group===

===start-group=== "complemented"
	--test-- "comp-1" --assert -2 = complement 1
	--test-- "comp-2" --assert -1 = complement 0
	--test-- "comp-3" --assert 0  = complement FFFFFFFFh
===end-group===

===start-group=== "shift"
	--test-- "shift-1" --assert 1  = shift 2 1
	--test-- "shift-2" --assert 16 = shift/left 2 3
	--test-- "shift-3" --assert FFFFFFFEh = shift FFFFFFFCh 1
	--test-- "shift-4" --assert 7FFFFFFEh = shift/logical FFFFFFFCh 1
===end-group===

===start-group=== "shift op!"
	--test-- "shift-op-1" --assert 2 >> 1 = 1
	--test-- "shift-op-2" --assert 2 << 3 = 16
	--test-- "shift-op-3" --assert FFFFFFFCh >> 1 = FFFFFFFEh
	--test-- "shift-op-4" --assert FFFFFFFCh >>> 1 = 7FFFFFFEh
===end-group===

===start-group=== "and"
	--test-- "and1" --assert 01h and 10h = 00h
	--test-- "and2" --assert 11h and 10h = 10h
	--test-- "and3" --assert 01h and 1Fh = 01h
===end-group===

===start-group=== "or"
	--test-- "or1" --assert  01h or 10h  = 11h
	--test-- "or2" --assert  11h or 10h  = 11h
	--test-- "or3" --assert  01h or 1Fh  = 1Fh
===end-group===

===start-group=== "xor"
	--test-- "xor1" --assert 01h xor 10h = 11h
	--test-- "xor2" --assert 11h xor 10h = 01h
	--test-- "xor3" --assert 01h xor 1Fh = 1Eh
===end-group===

===start-group=== "round"
	--test-- "round1" --assert  123904 = round/to  123'456 1024
	--test-- "round2" --assert -123904 = round/to -123'456 1024

	--test-- "round3" --assert  21 = round/down/to  23 3
	--test-- "round4" --assert -21 = round/down/to -23 3

	--test-- "round5" --assert  24 = round/even/to  23 3
	--test-- "round6" --assert -24 = round/even/to -23 3

	--test-- "round7" --assert  24 = round/half-down/to  23 3
	--test-- "round8" --assert -24 = round/half-down/to -23 3

	--test-- "round9" --assert  21 = round/floor/to  23 3
	--test-- "round10" --assert -24 = round/floor/to -23 3

	--test-- "round11" --assert  24 = round/ceiling/to  23 3
	--test-- "round12" --assert -21 = round/ceiling/to -23 3

	--test-- "round13" --assert  24 = round/half-ceiling/to  23 3
	--test-- "round14" --assert -24 = round/half-ceiling/to -23 3
===end-group===

~~~end-file~~~