TESTS: adds some EXIT/RETURN regression tests.

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"

	--test-- "fun-ret-15"								;-- issue #1169
		f: does [parse "1" [(return 123)]]
		--assert f = 123

	--test-- "fun-ret-16"
		f: does [do [return 124]]
		--assert f = 124

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


FEAT: object's functions can now be called using path notation.

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

#define CHECK_INFIX [
	if all [
		next < end
		TYPE_OF(next) = TYPE_WORD
	][
		value: _context/get next
		if TYPE_OF(value) = TYPE_OP [
			either next = as red-word! pc [
				if verbose > 0 [log "infix detected!"]
				infix?: yes
			][
				if TYPE_OF(pc) = TYPE_WORD [
					left: _context/get as red-word! pc
				]
				unless all [
					TYPE_OF(pc) = TYPE_WORD
					any [
						TYPE_OF(left) = TYPE_ACTION
						TYPE_OF(left) = TYPE_NATIVE
						TYPE_OF(left) = TYPE_FUNCTION
					]
					literal-first-arg? as red-native! left	;-- a literal argument is expected
				][
					if verbose > 0 [log "infix detected!"]
					infix?: yes
				]
			]
		]
	]
]

#define FETCH_ARGUMENT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
	either TYPE_OF(value) = TYPE_WORD [
		if verbose > 0 [log "evaluating argument"]
		pc: eval-expression pc end no yes
	][
		if verbose > 0 [log "fetching argument"]
		either TYPE_OF(pc) = TYPE_GET_WORD [
			copy-cell _context/get as red-word! pc stack/push*
		][
			stack/push pc
		]
		pc: pc + 1
	]
]

interpreter: context [
	verbose: 0

	return-type: -1										;-- return type for routine calls
	in-func?:	 0										;@@ make it thread-safe?

	log: func [msg [c-string!]][
		print "eval: "
		print-line msg
	]

	print-symbol: func [
		word [red-word!]
		/local
			sym [red-symbol!]
	][
		sym: symbol/get word/symbol
		print-line sym/cache
	]

	literal-first-arg?: func [
		native 	[red-native!]
		return: [logic!]
		/local
			fun	  	  [red-function!]
			value	  [red-value!]
			tail	  [red-value!]
			s		  [series!]
	][
		s: as series! either TYPE_OF(native) = TYPE_FUNCTION [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]
		value: s/offset
		tail:  s/tail

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD 		[return no]
				TYPE_LIT_WORD	[return yes]
				default 		[0]
			]
			value: value + 1
		]
		no
	]

	eval-option: func [
		pc		  [red-value!]
		end		  [red-value!]
		value	  [red-value!]
		tail	  [red-value!]
		word	  [red-word!]
		offset	  [int-ptr!]
		args	  [int-ptr!]
		function? [logic!]
		return:	  [red-value!]
		/local
			ref	  [red-refinement!]
			slot  [red-logic!]
			type  [integer!]
			pos	  [integer!]
			idx	  [integer!]
			pos2  [integer!]
	][
		pos:  0											;-- stack offset
		idx:  1											;-- native stack ref-array index
		args/value: 0

		while [value < tail][

			switch TYPE_OF(value) [
				TYPE_REFINEMENT [
					ref: as red-refinement! value
					either EQUAL_WORDS?(ref word) [
						slot: as red-logic! stack/arguments + pos
						slot/value: true

						value: value + 1
						pos2: pos + 1
						while [
							type: TYPE_OF(value)
							all [
								value < tail
								any [
									type = TYPE_WORD
									type = TYPE_GET_WORD
									type = TYPE_LIT_WORD
									type = TYPE_STRING
								]
							]
						][
							unless type = TYPE_STRING [
								FETCH_ARGUMENT
								if function? [
									copy-cell stack/top - 1 stack/arguments + pos2
									stack/pop 1
								]
								pos2: pos2 + 1
								args/value: args/value + 1
							]
							value: value + 1
						]
						unless function? [offset/value: idx]
						return pc
					][
						idx: idx + 1
					]
					pos: pos + 1
				]
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					pos: pos + 1
				]
				default [0]
			]

			value: value + 1
		]
		print "Error: refinement /"
		print-symbol word
		print-line " not found!"
		halt
		null
	]

	eval-function: func [
		[catch]
		fun  [red-function!]
		body [red-block!]
		/local
			saved
	][
		in-func?: in-func? + 1
		saved: fun/ctx/values
		fun/ctx/values: as node! stack/arguments
		eval body
		fun/ctx/values: saved
		in-func?: in-func? - 1
	]

	exec-routine: func [
		fun	 [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			count  [integer!]
			call
	][
		s: as series! fun/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: (routine/get-arity fun) - 1				;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert false]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			left   [red-value!]
			infix? [logic!]
			op	   [red-op!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op

		if verbose > 0 [
			value: stack/arguments
			print-line ["eval: op return type: " TYPE_OF(value)]
		]

		infix?: no
		next: as red-word! pc
		CHECK_INFIX
		if infix? [pc: eval-infix value pc end sub?]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		path	[red-path!]
		pos 	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			head	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			path-end  [red-value!]
			s		  [series!]
			required? [logic!]
			index	  [integer!]
			count	  [integer!]
			offset	  [integer!]
			args	  [integer!]
			size	  [integer!]
			ref-array [int-ptr!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]

		s: as series! either function? [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]

		head:  s/offset
		value: head
		tail:  s/tail

		unless null? path [
			path-end: block/rs-tail as red-block! path
			if pos + 1 = path-end [path: null]			;-- no refinement following the function
		]												;-- so, process it as a non-path call

		count:  	 0									;-- base arity (mandatory arguments only)
		index: 	 	 1
		args:		 -1
		offset:		 -1
		return-type: -1
		ref?:		 no
		required?:	 yes								;-- yes: processing mandatory args, no: optional args

		unless function? [
			size: as-integer tail - value				;@@ takes more space than really needed
			ref-array: system/stack/top - size
			system/stack/top: ref-array					;-- reserve space on native stack for refs array
		]

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					either required? [
						FETCH_ARGUMENT
						count: count + 1
					][
						if function? [none/push]
					]
				]
				TYPE_REFINEMENT [
					if required? [required?: no]		;-- no more mandatory arguments

					either function? [
						logic/push false
					][
						ref-array/index: -1
						index: index + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]

		unless routine? [
			if path <> null [
				pos: pos + 1

				while [pos < path-end][
					pc: eval-option pc end head tail as red-word! pos :offset :args function?

					unless function? [
						either args > 0 [
							ref-array/offset: count + args - 1
							count: count + args
						][
							ref-array/offset: 0
						]
					]
					pos: pos + 1
				]
			]
		]

		unless function? [
			system/stack/top: ref-array					;-- reset native stack to our custom arguments frame
			call: as function! [] native/code			;-- direct call for actions/natives
			call
		]
		pc
	]

	eval-path: func [
		value   [red-value!]
		pc		[red-value!]							;-- path to evaluate
		end		[red-value!]
		set?	[logic!]
		return: [red-value!]
		/local
			path   [red-path!]
			head   [red-value!]
			tail   [red-value!]
			item   [red-value!]
			parent [red-value!]
			saved  [red-value!]
	][
		if verbose > 0 [print-line "eval: path"]

		path:   as red-path! value
		head:   block/rs-head as red-block! path
		tail:   block/rs-tail as red-block! path
		item:   head + 1
		saved:  stack/top

		if TYPE_OF(head) <> TYPE_WORD [
			print-line "*** Error: path value must start with a word!"
			halt
		]

		parent: _context/get as red-word! head

		switch TYPE_OF(parent) [
			TYPE_ACTION								;@@ replace with TYPE_ANY_FUNCTION
			TYPE_NATIVE
			TYPE_ROUTINE
			TYPE_FUNCTION [
				pc: eval-code parent pc end yes path item - 1
				return pc
			]
			default [0]
		]

		while [item < tail][
			#if debug? = yes [if verbose > 0 [print-line ["eval: path parent: " TYPE_OF(parent)]]]

			value: either any [
				TYPE_OF(item) = TYPE_GET_WORD
				all [
					parent = head
					TYPE_OF(item) = TYPE_WORD
					TYPE_OF(parent) <> TYPE_OBJECT
				]
			][
				_context/get as red-word! item
			][
				item
			]
			switch TYPE_OF(value) [
				TYPE_UNSET [
					print-line "*** Error: word in path has no value!"
					stack/push parent
					return pc
				]
				TYPE_PAREN [
					stack/mark-native words/_body		;@@ ~paren
					eval as red-block! value			;-- eval paren content
					stack/unwind
					value: stack/top - 1
				]
				default [0]								;-- pass-thru
			]
			#if debug? = yes [if verbose > 0 [print-line ["eval: path item: " TYPE_OF(value)]]]

			parent: actions/eval-path parent value all [set? item + 1 = tail]

			switch TYPE_OF(parent) [
				TYPE_ACTION								;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code parent pc end yes path item
					return pc
				]
				default [0]
			]

			item: item + 1
		]

		stack/top: saved
		stack/push parent
		pc
	]

	eval-code: func [
		value	[red-value!]
		pc		[red-value!]
		end		[red-value!]
		sub?	[logic!]
		path	[red-path!]
		slot 	[red-value!]
		return: [red-value!]
		/local
			fun	   [red-function!]
			native [red-native!]
			s	   [series!]
			call
	][
		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				if verbose > 0 [log "pushing action/native frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot 	;-- fetch args and exec
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: action/native return type: " TYPE_OF(value)]
				]
			]
			TYPE_ROUTINE [
				if verbose > 0 [log "pushing routine frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot
				exec-routine as red-routine! value
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: routine return type: " TYPE_OF(value)]
				]
			]
			TYPE_FUNCTION [
				if verbose > 0 [log "pushing function frame"]
				stack/mark-func as red-word! pc	;@@
				pc: eval-arguments as red-native! value pc end path slot
				fun: as red-function! value
				s: as series! fun/more/value

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

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: function return type: " TYPE_OF(value)]
				]
			]
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		prefix?	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			value  [red-value!]
			left   [red-value!]
			w	   [red-word!]
			op	   [red-value!]
			sym	   [integer!]
			infix? [logic!]
	][
		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

		infix?: no
		unless prefix? [
			next: as red-word! pc + 1
			CHECK_INFIX
			if infix? [
				stack/mark-native as red-word! pc + 1
				sub?: yes								;-- force sub? for infix expressions
				op: value
			]
		]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no yes		;-- yes: push value on top of stack
				pc: eval-path value pc end yes
			]
			TYPE_GET_WORD [
				copy-cell _context/get as red-word! pc stack/push*
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				either sub? [
					w: word/push as red-word! pc		;-- nested expression: push value
				][
					w: as red-word! stack/set-last pc	;-- root expression: return value
				]
				w/header: TYPE_WORD						;-- coerce it to a word!
				pc: pc + 1
			]
			TYPE_WORD [
				if verbose > 0 [
					print "eval: '"
					print-symbol as red-word! pc
				]
				value: _context/get as red-word! pc

				if positive? in-func? [
					w: as red-word! pc
					sym: w/symbol
					case [
						sym = words/exit* [
							copy-cell unset-value stack/arguments
							stack/unroll stack/FLAG_FUNCTION
							throw THROWN_EXIT
						]
						sym = words/return* [
							pc: pc + 1
							either pc >= end [
								copy-cell unset-value stack/arguments
							][
								pc: eval-expression pc end no yes
							]
							stack/unroll stack/FLAG_FUNCTION
							throw THROWN_RETURN
						]
						true [0]
					]
				]
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_UNSET [
						print-line "*** Error: word has no value!"
						either sub? [stack/push unset-value][stack/set-last unset-value]
					]
					TYPE_LIT_WORD [
						w: word/push as red-word! value	;-- push lit-word! on stack
						w/header: TYPE_WORD				;-- coerce it to a word!
					]
					TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: word return type: " TYPE_OF(value)]
						]
					]
				]
			]
			TYPE_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no
			]
			TYPE_LIT_PATH [
				value: stack/push pc
				value/header: TYPE_PATH
				pc: pc + 1
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]

		if infix? [
			pc: eval-infix op pc end sub?
			unless prefix? [
				either sub? [stack/unwind][stack/unwind-last]
			]
		]
		pc
	]

	eval-next: func [
		value	[red-value!]
		tail	[red-value!]
		sub?	[logic!]
		return: [red-value!]							;-- return start of next expression
	][
		stack/mark-native words/_body					;-- outer stack frame
		value: eval-expression value tail no sub?
		either sub? [stack/unwind][stack/unwind-last]
		value
	]

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			arg	  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			arg: stack/arguments
			arg/header: TYPE_UNSET
			exit
		]

		stack/mark-native words/_body					;-- outer stack frame

		while [value < tail][
			if verbose > 0 [log "root loop..."]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]
		stack/unwind-last
	]

]

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

#define CHECK_INFIX [
	if all [
		next < end
		TYPE_OF(next) = TYPE_WORD
	][
		value: _context/get next
		if TYPE_OF(value) = TYPE_OP [
			either next = as red-word! pc [
				if verbose > 0 [log "infix detected!"]
				infix?: yes
			][
				if TYPE_OF(pc) = TYPE_WORD [
					left: _context/get as red-word! pc
				]
				unless all [
					TYPE_OF(pc) = TYPE_WORD
					any [
						TYPE_OF(left) = TYPE_ACTION
						TYPE_OF(left) = TYPE_NATIVE
						TYPE_OF(left) = TYPE_FUNCTION
					]
					literal-first-arg? as red-native! left	;-- a literal argument is expected
				][
					if verbose > 0 [log "infix detected!"]
					infix?: yes
				]
			]
		]
	]
]

#define FETCH_ARGUMENT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
	either TYPE_OF(value) = TYPE_WORD [
		if verbose > 0 [log "evaluating argument"]
		pc: eval-expression pc end no yes
	][
		if verbose > 0 [log "fetching argument"]
		either TYPE_OF(pc) = TYPE_GET_WORD [
			copy-cell _context/get as red-word! pc stack/push*
		][
			stack/push pc
		]
		pc: pc + 1
	]
]

interpreter: context [
	verbose: 0

	return-type: -1										;-- return type for routine calls
	in-func?:	 0										;@@ make it thread-safe?

	log: func [msg [c-string!]][
		print "eval: "
		print-line msg
	]

	print-symbol: func [
		word [red-word!]
		/local
			sym [red-symbol!]
	][
		sym: symbol/get word/symbol
		print-line sym/cache
	]

	literal-first-arg?: func [
		native 	[red-native!]
		return: [logic!]
		/local
			fun	  	  [red-function!]
			value	  [red-value!]
			tail	  [red-value!]
			s		  [series!]
	][
		s: as series! either TYPE_OF(native) = TYPE_FUNCTION [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]
		value: s/offset
		tail:  s/tail

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD 		[return no]
				TYPE_LIT_WORD	[return yes]
				default 		[0]
			]
			value: value + 1
		]
		no
	]

	eval-option: func [
		pc		  [red-value!]
		end		  [red-value!]
		value	  [red-value!]
		tail	  [red-value!]
		word	  [red-word!]
		offset	  [int-ptr!]
		args	  [int-ptr!]
		function? [logic!]
		return:	  [red-value!]
		/local
			ref	  [red-refinement!]
			slot  [red-logic!]
			type  [integer!]
			pos	  [integer!]
			idx	  [integer!]
			pos2  [integer!]
	][
		pos:  0											;-- stack offset
		idx:  1											;-- native stack ref-array index
		args/value: 0

		while [value < tail][

			switch TYPE_OF(value) [
				TYPE_REFINEMENT [
					ref: as red-refinement! value
					either EQUAL_WORDS?(ref word) [
						slot: as red-logic! stack/arguments + pos
						slot/value: true

						value: value + 1
						pos2: pos + 1
						while [
							type: TYPE_OF(value)
							all [
								value < tail
								any [
									type = TYPE_WORD
									type = TYPE_GET_WORD
									type = TYPE_LIT_WORD
									type = TYPE_STRING
								]
							]
						][
							unless type = TYPE_STRING [
								FETCH_ARGUMENT
								if function? [
									copy-cell stack/top - 1 stack/arguments + pos2
									stack/pop 1
								]
								pos2: pos2 + 1
								args/value: args/value + 1
							]
							value: value + 1
						]
						unless function? [offset/value: idx]
						return pc
					][
						idx: idx + 1
					]
					pos: pos + 1
				]
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					pos: pos + 1
				]
				default [0]
			]

			value: value + 1
		]
		print "Error: refinement /"
		print-symbol word
		print-line " not found!"
		halt
		null
	]

	eval-function: func [
		[catch]
		fun  [red-function!]
		body [red-block!]
		/local
			saved
	][
		in-func?: in-func? + 1
		saved: fun/ctx/values
		fun/ctx/values: as node! stack/arguments
		eval body
		fun/ctx/values: saved
		in-func?: in-func? - 1
	]

	exec-routine: func [
		fun	 [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			count  [integer!]
			call
	][
		s: as series! fun/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: (routine/get-arity fun) - 1				;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert false]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			left   [red-value!]
			infix? [logic!]
			op	   [red-op!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op

		if verbose > 0 [
			value: stack/arguments
			print-line ["eval: op return type: " TYPE_OF(value)]
		]

		infix?: no
		next: as red-word! pc
		CHECK_INFIX
		if infix? [pc: eval-infix value pc end sub?]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		path	[red-path!]
		pos 	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			head	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			path-end  [red-value!]
			s		  [series!]
			required? [logic!]
			index	  [integer!]
			count	  [integer!]
			offset	  [integer!]
			args	  [integer!]
			size	  [integer!]
			ref-array [int-ptr!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]

		s: as series! either function? [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]

		head:  s/offset
		value: head
		tail:  s/tail

		unless null? path [
			path-end: block/rs-tail as red-block! path
			if pos + 1 = path-end [path: null]			;-- no refinement following the function
		]												;-- so, process it as a non-path call

		count:  	 0									;-- base arity (mandatory arguments only)
		index: 	 	 1
		args:		 -1
		offset:		 -1
		return-type: -1
		ref?:		 no
		required?:	 yes								;-- yes: processing mandatory args, no: optional args

		unless function? [
			size: as-integer tail - value				;@@ takes more space than really needed
			ref-array: system/stack/top - size
			system/stack/top: ref-array					;-- reserve space on native stack for refs array
		]

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					either required? [
						FETCH_ARGUMENT
						count: count + 1
					][
						if function? [none/push]
					]
				]
				TYPE_REFINEMENT [
					if required? [required?: no]		;-- no more mandatory arguments

					either function? [
						logic/push false
					][
						ref-array/index: -1
						index: index + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]

		unless routine? [
			if path <> null [
				pos: pos + 1

				while [pos < path-end][
					pc: eval-option pc end head tail as red-word! pos :offset :args function?

					unless function? [
						either args > 0 [
							ref-array/offset: count + args - 1
							count: count + args
						][
							ref-array/offset: 0
						]
					]
					pos: pos + 1
				]
			]
		]

		unless function? [
			system/stack/top: ref-array					;-- reset native stack to our custom arguments frame
			call: as function! [] native/code			;-- direct call for actions/natives
			call
		]
		pc
	]

	eval-path: func [
		value   [red-value!]
		pc		[red-value!]							;-- path to evaluate
		end		[red-value!]
		set?	[logic!]
		return: [red-value!]
		/local
			path   [red-path!]
			head   [red-value!]
			tail   [red-value!]
			item   [red-value!]
			parent [red-value!]
			saved  [red-value!]
	][
		if verbose > 0 [print-line "eval: path"]

		path:   as red-path! value
		head:   block/rs-head as red-block! path
		tail:   block/rs-tail as red-block! path
		item:   head + 1
		saved:  stack/top

		if TYPE_OF(head) <> TYPE_WORD [
			print-line "*** Error: path value must start with a word!"
			halt
		]

		parent: _context/get as red-word! head

		while [item < tail][
			#if debug? = yes [if verbose > 0 [print-line ["eval: path parent: " TYPE_OF(parent)]]]

			switch TYPE_OF(parent) [
				TYPE_ACTION								;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code parent pc end yes path item - 1
					return pc
				]
				default [0]
			]

			value: either any [
				TYPE_OF(item) = TYPE_GET_WORD
				all [
					parent = head
					TYPE_OF(item) = TYPE_WORD
					TYPE_OF(parent) <> TYPE_OBJECT
				]
			][
				_context/get as red-word! item
			][
				item
			]
			switch TYPE_OF(value) [
				TYPE_UNSET [
					print-line "*** Error: word in path has no value!"
					stack/push parent
					return pc
				]
				TYPE_PAREN [
					stack/mark-native words/_body		;@@ ~paren
					eval as red-block! value			;-- eval paren content
					stack/unwind
					value: stack/top - 1
				]
				default [0]								;-- pass-thru
			]
			#if debug? = yes [if verbose > 0 [print-line ["eval: path item: " TYPE_OF(value)]]]

			parent: actions/eval-path parent value all [set? item + 1 = tail]
			item: item + 1
		]

		stack/top: saved
		stack/push parent
		pc
	]

	eval-code: func [
		value	[red-value!]
		pc		[red-value!]
		end		[red-value!]
		sub?	[logic!]
		path	[red-path!]
		slot 	[red-value!]
		return: [red-value!]
		/local
			fun	   [red-function!]
			native [red-native!]
			s	   [series!]
			call
	][
		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				if verbose > 0 [log "pushing action/native frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot 	;-- fetch args and exec
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: action/native return type: " TYPE_OF(value)]
				]
			]
			TYPE_ROUTINE [
				if verbose > 0 [log "pushing routine frame"]
				stack/mark-native as red-word! pc
				pc: eval-arguments as red-native! value pc end path slot
				exec-routine as red-routine! value
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: routine return type: " TYPE_OF(value)]
				]
			]
			TYPE_FUNCTION [
				if verbose > 0 [log "pushing function frame"]
				stack/mark-func as red-word! pc	;@@
				pc: eval-arguments as red-native! value pc end path slot
				fun: as red-function! value
				s: as series! fun/more/value

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

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: function return type: " TYPE_OF(value)]
				]
			]
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		prefix?	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			value  [red-value!]
			left   [red-value!]
			w	   [red-word!]
			op	   [red-value!]
			sym	   [integer!]
			infix? [logic!]
	][
		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

		infix?: no
		unless prefix? [
			next: as red-word! pc + 1
			CHECK_INFIX
			if infix? [
				stack/mark-native as red-word! pc + 1
				sub?: yes								;-- force sub? for infix expressions
				op: value
			]
		]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no yes		;-- yes: push value on top of stack
				pc: eval-path value pc end yes
			]
			TYPE_GET_WORD [
				copy-cell _context/get as red-word! pc stack/push*
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				either sub? [
					w: word/push as red-word! pc		;-- nested expression: push value
				][
					w: as red-word! stack/set-last pc	;-- root expression: return value
				]
				w/header: TYPE_WORD						;-- coerce it to a word!
				pc: pc + 1
			]
			TYPE_WORD [
				if verbose > 0 [
					print "eval: '"
					print-symbol as red-word! pc
				]
				value: _context/get as red-word! pc

				if positive? in-func? [
					w: as red-word! pc
					sym: w/symbol
					case [
						sym = words/exit* [
							copy-cell unset-value stack/arguments
							stack/unroll stack/FLAG_FUNCTION
							throw THROWN_EXIT
						]
						sym = words/return* [
							pc: pc + 1
							either pc >= end [
								copy-cell unset-value stack/arguments
							][
								pc: eval-expression pc end no yes
							]
							stack/unroll stack/FLAG_FUNCTION
							throw THROWN_RETURN
						]
						true [0]
					]
				]
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_UNSET [
						print-line "*** Error: word has no value!"
						either sub? [stack/push unset-value][stack/set-last unset-value]
					]
					TYPE_LIT_WORD [
						w: word/push as red-word! value	;-- push lit-word! on stack
						w/header: TYPE_WORD				;-- coerce it to a word!
					]
					TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: word return type: " TYPE_OF(value)]
						]
					]
				]
			]
			TYPE_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no
			]
			TYPE_LIT_PATH [
				value: stack/push pc
				value/header: TYPE_PATH
				pc: pc + 1
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]

		if infix? [
			pc: eval-infix op pc end sub?
			unless prefix? [
				either sub? [stack/unwind][stack/unwind-last]
			]
		]
		pc
	]

	eval-next: func [
		value	[red-value!]
		tail	[red-value!]
		sub?	[logic!]
		return: [red-value!]							;-- return start of next expression
	][
		stack/mark-native words/_body					;-- outer stack frame
		value: eval-expression value tail no sub?
		either sub? [stack/unwind][stack/unwind-last]
		value
	]

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
			arg	  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			arg: stack/arguments
			arg/header: TYPE_UNSET
			exit
		]

		stack/mark-native words/_body					;-- outer stack frame

		while [value < tail][
			if verbose > 0 [log "root loop..."]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]
		stack/unwind-last
	]

]


TESTS: added Either tests to conditional-test.reds

Red/System [
	Title:   "Red/System conditonal test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %conditional-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.reds

~~~start-file~~~ "conditional"

  --test-- "nested ifs inside a function with many return points"
    ;; a bug was fixed that caused this code to raise a segmentation error
    ;; the test waa passing until the lines marked ;###### were added
    scan-utf-8: func [
      str [c-string!]
      return: [integer!]
      /local
        i [integer!]
    ][
      i: 1
      until [
        if str/1 > #"^(7F)" [
          if #"^(C0)" = str/1 [return i]
          if #"^(C1)" = str/1 [return i]
          if #"^(F4)" < str/1 [return i]
          if str/1 < #"^(E0)" [
             if str/2 < #"^(80)" [return i]
             if str/2 > #"^(BF)" [return i]
             if str/3 <> null-byte [
               i: i + 1
               str: str + 1
             ]
          ]
        ]
        i: i + 1
        str: str + 1
        str/1 = null-byte
      ]
      0
    ]
  --assert 0 = scan-utf-8 "a"
  --assert 0 = scan-utf-8 "a very straightforward string"

  --test-- "simple if"
    i: 0
    if true [i: 1]
  --assert i = 1

  --test-- "nested if"
    i: 0
    if true [
      if true [
        i: 1
      ]
    ]
  --assert i = 1

  --test-- "double nested if"
    i: 0
    if true [
      if true [
        if true [
          i: 1
        ]
      ]
    ]
  --assert i = 1

  --test-- "triple nested if"
    i: 0
    if true [
      if true [
        if true [
          if true [
            i: 1
          ]
        ]
      ]
    ]
  --assert i = 1

  --test-- "byte nested if"
    ct-byte: #"^(C0)"
    i: 0
    if #"^(7F)" < ct-byte [
      if ct-byte < #"^(FE)" [
        if #"^(A5)" < ct-byte [
          if ct-byte = #"^(C0)" [
            i: 1
          ]
        ]
      ]
    ]
  --assert i = 1

  --test-- "byte nested if inside function"
    ct-byte-nested: func [
      b [byte!]
      return: [integer!]
    ][
      if b > #"^(7F)" [
        if #"^(C0)" = b [return 1]
        if #"^(C1)" = b [return 2]
        if #"^(F4)" < b [return 3]
        if b < #"^(E0)" [
          if b < #"^(D0)" [return 4]
          if b > #"^(CF)" [return 5]
        ]
      ]
      0
    ]
  --assert 0 = ct-byte-nested #"^(00)"
  --assert 1 = ct-byte-nested #"^(C0)"
  --assert 2 = ct-byte-nested #"^(C1)"
  --assert 3 = ct-byte-nested #"^(F9)"
  --assert 4 = ct-byte-nested #"^(C5)"
  --assert 5 = ct-byte-nested #"^(D1)"

  --test-- "either-true"
  --assert 1 = either true [1] [0]

  --test-- "either-false"
  --assert 1 = either false [0] [1]

~~~end-file~~~

Red/System [
	Title:   "Red/System conditonal test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %conditional-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.reds

~~~start-file~~~ "conditional"

  --test-- "nested ifs inside a function with many return points"
    ;; a bug was fixed that caused this code to raise a segmentation error
    ;; the test waa passing until the lines marked ;###### were added
    scan-utf-8: func [
      str [c-string!]
      return: [integer!]
      /local
        i [integer!]
    ][
      i: 1
      until [
        if str/1 > #"^(7F)" [
          if #"^(C0)" = str/1 [return i]
          if #"^(C1)" = str/1 [return i]
          if #"^(F4)" < str/1 [return i]
          if str/1 < #"^(E0)" [
             if str/2 < #"^(80)" [return i]
             if str/2 > #"^(BF)" [return i]
             if str/3 <> null-byte [
               i: i + 1
               str: str + 1
             ]
          ]
        ]
        i: i + 1
        str: str + 1
        str/1 = null-byte
      ]
      0
    ]
  --assert 0 = scan-utf-8 "a"
  --assert 0 = scan-utf-8 "a very straightforward string"

  --test-- "simple if"
    i: 0
    if true [i: 1]
  --assert i = 1

  --test-- "nested if"
    i: 0
    if true [
      if true [
        i: 1
      ]
    ]
  --assert i = 1

  --test-- "double nested if"
    i: 0
    if true [
      if true [
        if true [
          i: 1
        ]
      ]
    ]
  --assert i = 1

  --test-- "triple nested if"
    i: 0
    if true [
      if true [
        if true [
          if true [
            i: 1
          ]
        ]
      ]
    ]
  --assert i = 1

  --test-- "byte nested if"
    ct-byte: #"^(C0)"
    i: 0
    if #"^(7F)" < ct-byte [
      if ct-byte < #"^(FE)" [
        if #"^(A5)" < ct-byte [
          if ct-byte = #"^(C0)" [
            i: 1
          ]
        ]
      ]
    ]
  --assert i = 1

  --test-- "byte nested if inside function"
    ct-byte-nested: func [
      b [byte!]
      return: [integer!]
    ][
      if b > #"^(7F)" [
        if #"^(C0)" = b [return 1]
        if #"^(C1)" = b [return 2]
        if #"^(F4)" < b [return 3]
        if b < #"^(E0)" [
          if b < #"^(D0)" [return 4]
          if b > #"^(CF)" [return 5]
        ]
      ]
      0
    ]
  --assert 0 = ct-byte-nested #"^(00)"
  --assert 1 = ct-byte-nested #"^(C0)"
  --assert 2 = ct-byte-nested #"^(C1)"
  --assert 3 = ct-byte-nested #"^(F9)"
  --assert 4 = ct-byte-nested #"^(C5)"
  --assert 5 = ct-byte-nested #"^(D1)"

~~~end-file~~~


Partial fixes for call

Partial fixes for call

Red [
	Title:  "Red call binding"
	Author: "Bruno Anselme"
	EMail:  "be.red@free.fr"
	File:   %call.red
	Rights: "Copyright (c) 2014-2015 Bruno Anselme"
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
	Needs: {
		Red/System >= 0.4.1
		%call.reds
	}
]

#system-global [ #include %call.reds ]

; Routines definitions
redsys-call: routine [ "Set IO buffers if needed, execute call"
	cmd        [string!]  "Command"
	waitend    [logic!]   "Wait for end of child process"
	console    [logic!]   "Runs command with I/O redirected to console"
	shell      [logic!]   "Forces command to be run from shell"
	redirin    [logic!]   "Input redirection"
	in-str     [string!]  "Input data"
	redirout   [logic!]   "Output redirection"
	redirerr   [logic!]   "Error redirection"
	return:    [integer!]
	/local
	inp out err s
][
	either redirin [
		inp: declare p-buffer!
		inp/buffer: string/rs-head in-str
		s: GET_BUFFER(in-str)
		inp/count:  GET_UNIT(s) * string/rs-length? in-str
		#if OS = 'Windows [ system-call/to-ascii inp ]
	][
		inp: null
	]
	either redirout [
		out:  declare p-buffer!
		out/buffer: null
		out/count:  0
	][
		out: null
	]
	either redirerr [
		err:  declare p-buffer!
		err/buffer: null
		err/count:  0
	][
		err: null
	]
	system-call/call (as-c-string string/rs-head cmd) waitend console shell inp out err
]

get-out: routine [ "Returns redirected stdout"
	/local
		sout   [red-string!]
		str    [c-string!]
		result [integer!]
][
	with system-call [
		#either OS = 'Windows [
			result: IS_TEXT_UNICODE_UNICODE_MASK
			is-text-unicode outputs/out/buffer outputs/out/count :result
			either result = 0 [
				to-ascii outputs/out
				sout: string/load as-c-string outputs/out/buffer (outputs/out/count) UTF-8
			][
				sout: string/load as-c-string outputs/out/buffer ((outputs/out/count / 2)) UTF-16LE
			]
		][
			sout: string/load as-c-string outputs/out/buffer (outputs/out/count) UTF-8
		]
		free outputs/out/buffer
		SET_RETURN(sout)
	]
]

get-err: routine [ "Returns redirected stderr"
	/local
		serr	[red-string!]
		result	[integer!]
][
	with system-call [
		#either OS = 'Windows [
			result: IS_TEXT_UNICODE_UNICODE_MASK
			is-text-unicode outputs/err/buffer outputs/err/count :result
			either result = 0 [
				to-ascii outputs/err
				serr: string/load as-c-string outputs/err/buffer (outputs/err/count) UTF-8
			][
				serr: string/load as-c-string outputs/err/buffer ((outputs/err/count / 2)) UTF-16LE
			]
		][
			serr: string/load as-c-string outputs/err/buffer (outputs/err/count) UTF-8
		]
		free outputs/err/buffer
		SET_RETURN(serr)
	]
]

print-to-stderr: routine [ "Call to low level print to stderr"
	mesg	[string!]
][
	system-call/print-error [ as-c-string string/rs-head mesg ]
]

print-error: func [
	mesg			[string! block!]	"A shell command, an executable file or a block"
][
	if block? mesg [ mesg: form mesg ]
	print-to-stderr mesg
]

call: func [ "Executes a shell command to run another process."
	cmd			[string! block!]	"A shell command, an executable file or a block"
	/wait							"Runs command and waits for exit"
	/console						"Runs command with I/O redirected to console"
	/shell							"Forces command to be run from shell"
	/input	in*	[string! block!]	"Redirects in to stdin"
	/output	out	[string! block!]	"Redirects stdout to out"
	/error	err	[string! block!]	"Redirects stderr to err"
	return:		[integer!]			"0 if success, -1 if error, or a process ID"
	/local
		pid		[integer!]
		str		[string!]
		do-in do-out do-err
][
	pid: 0
	if block? cmd [ cmd: form cmd ]
	either input  [
		if block? in* [ in*: form in* ]
		str: in*
	][
		str: ""
	]
	pid: redsys-call cmd wait console shell input str output error
	if output [
		str: get-out
		parse str [ while [ ahead crlf remove cr | skip ] ]
		out: head insert out str
	]
	if error [
		str: get-err
		parse str [ while [ ahead crlf remove cr | skip ] ]
		err: head insert err str
	]
	pid
]

Red [
	Title:  "Red call binding"
	Author: "Bruno Anselme"
	EMail:  "be.red@free.fr"
	File:   %call.red
	Rights: "Copyright (c) 2014-2015 Bruno Anselme"
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
	Needs: {
		Red/System >= 0.4.1
		%call.reds
	}
]

#system-global [ #include %call.reds ]

; Routines definitions
redsys-call: routine [ "Set IO buffers if needed, execute call"
	cmd        [string!]  "Command"
	waitend    [logic!]   "Wait for end of child process"
	console    [logic!]   "Runs command with I/O redirected to console"
	shell      [logic!]   "Forces command to be run from shell"
	redirin    [logic!]   "Input redirection"
	in-str     [string!]  "Input data"
	redirout   [logic!]   "Output redirection"
	redirerr   [logic!]   "Error redirection"
	return:    [integer!]
	/local
	inp out err s
][
	either redirin [
		inp: declare p-buffer!
		inp/buffer: string/rs-head in-str
		s: GET_BUFFER(in-str)
		inp/count:  GET_UNIT(s) * string/rs-length? in-str
		#if OS = 'Windows [ system-call/to-ascii inp ]
	][
		inp: null
	]
	either redirout [
		out:  declare p-buffer!
		out/buffer: null
		out/count:  0
	][
		out: null
	]
	either redirerr [
		err:  declare p-buffer!
		err/buffer: null
		err/count:  0
	][
		err: null
	]
	system-call/call (as-c-string string/rs-head cmd) waitend console shell inp out err
]

get-out: routine [ "Returns redirected stdout"
	/local
		sout   [red-string!]
		str    [c-string!]
		result [integer!]
][
	with system-call [
		#either OS = 'Windows [
			result: IS_TEXT_UNICODE_UNICODE_MASK
			is-text-unicode outputs/out/buffer outputs/out/count :result
			either result = 0 [
				to-ascii outputs/out
				sout: string/load as-c-string outputs/out/buffer (1 + outputs/out/count) UTF-8
			][
				sout: string/load as-c-string outputs/out/buffer (1 + (outputs/out/count / 2)) UTF-16LE
			]
		][
			sout: string/load as-c-string outputs/out/buffer (1 + outputs/out/count) UTF-8
		]
		free outputs/out/buffer
		SET_RETURN(sout)
	]
]

get-err: routine [ "Returns redirected stderr"
	/local
		serr	[red-string!]
		result	[integer!]
][
	with system-call [
		#either OS = 'Windows [
			result: IS_TEXT_UNICODE_UNICODE_MASK
			is-text-unicode outputs/err/buffer outputs/err/count :result
			either result = 0 [
				to-ascii outputs/err
				serr: string/load as-c-string outputs/err/buffer (1 + outputs/err/count) UTF-8
			][
				serr: string/load as-c-string outputs/err/buffer (1 + (outputs/err/count / 2)) UTF-16LE
			]
		][
			serr: string/load as-c-string outputs/err/buffer (1 + outputs/err/count) UTF-8
		]
		free outputs/err/buffer
		SET_RETURN(serr)
	]
]

print-to-stderr: routine [ "Call to low level print to stderr"
	mesg	[string!]
][
	system-call/print-error [ as-c-string string/rs-head mesg ]
]

print-error: func [
	mesg			[string! block!]	"A shell command, an executable file or a block"
][
	if block? mesg [ mesg: form mesg ]
	print-to-stderr mesg
]

call: func [ "Executes a shell command to run another process."
	cmd			[string! block!]	"A shell command, an executable file or a block"
	/wait							"Runs command and waits for exit"
	/console						"Runs command with I/O redirected to console"
	/shell							"Forces command to be run from shell"
	/input	in	[string! block!]	"Redirects in to stdin"
	/output	out	[string! block!]	"Redirects stdout to out"
	/error	err	[string! block!]	"Redirects stderr to err"
	return:		[integer!]			"0 if success, -1 if error, or a process ID"
	/local
		pid		[integer!]
		str		[string!]
		do-in do-out do-err
][
	pid: 0
	if block? cmd [ cmd: form cmd ]
	either input  [
		if block? in [ in: form in ]
		str: in
	][
		str: ""
	]
	pid: redsys-call cmd wait console shell input str output error
	if output [
		str: get-out
		parse str [ while [ ahead crlf remove cr | skip ] ]
		out: head insert out str
	]
	if error [
		str: get-err
		parse str [ while [ ahead crlf remove cr | skip ] ]
		err: head insert err str
	]
	pid
]