TESTS: Added a few copy and in tests to object-test.red

Red [
	Title:   "Red/System object! datatype test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %object-test.red
	Version: "0.1.0"
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2014 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~~~ "object"

===start-group=== "basic tests"

	--test-- "basic-1"
		obj1: context []
		--assert "make object! []" = mold obj1

	--test-- "basic-2"
		obj2: object []
		--assert "make object! []" = mold obj2

	--test-- "basic-3"
		obj3: make object! []
		--assert "make object! []" = mold obj3

	--test-- "basic-4"
		blk: []
		obj4: object blk
		--assert "make object! []" = mold obj4

	--test-- "basic-5"
		obj5: object [
			a: 123
			show: does [a + 1]
			reset: does [a: none]
			--assert show = 124
			--assert a = 123
		]
		--assert obj5/show = 124
		obj5/reset
		--assert none? obj5/a

	--test-- "basic-6"
		obj5/a: 456
		--assert obj5/a = 456

	--test-- "basic-7"
		--assert find obj5 'a
		--assert not find obj5 'z
		--assert 456 = select obj5 'a
		--assert none? select obj5 'z

	--test-- "basic-8"
		obj8: context [
			b: 123
			a: object [
				b: 456
				double: does [b * 2]
				set-b: does [b: 'hello]
			]
		]
		--assert obj8/b = 123
		--assert obj8/a/b = 456
		--assert obj8/a/double = 912
		obj8/a/set-b
		--assert obj8/a/b = 'hello

	--test-- "basic-9"
		obj8/a/b: 'red
		--assert obj8/a/b = 'red

	--test-- "basic-10"
		obj10: object [
			a: 1
			b: 2
			inc: func [i /with a][b: i + either with [a][b]]
			sub: context [
				a: 3
				b: 4
				inc: func [i /with a][b: i + either with [a][b]]
			]
		]
		--assert 12 = obj10/inc 10
		--assert obj10/b = 12

		--assert 14 = obj10/sub/inc 10
		--assert obj10/sub/b = 14

	--test-- "basic-11"
		--assert 30 = obj10/inc/with 10 20
		--assert obj10/b = 30

		--assert 50 = obj10/sub/inc/with 10 40
		--assert obj10/sub/b = 50

	--test-- "basic-12"
		blk: [a: 99]
		obj12: object blk
		--assert obj12/a = 99

===end-group===

===start-group=== "Comparison tests"

	--test-- "comp-1"  --assert 	(context [])	 = (context [])
	--test-- "comp-2"  --assert not (context [a: 1]) = (context [])
	--test-- "comp-3"  --assert 	(context [a: 1]) = (context [a: 1])
	--test-- "comp-4"  --assert not (context [a: 1]) = (context [a: 2])
	--test-- "comp-5"  --assert 	(context [a: 1]) < (context [a: 2])
	--test-- "comp-6"  --assert not (context [a: 1]) >= (context [a: 2])
	--test-- "comp-7"  --assert 	(context [a: 2]) < (context [a: 1 b: none])

	--test-- "comp-8"
		obj:  context [a: 123]
		obj2: context [a: 123]
		--assert obj = obj2
		--assert not same? obj obj2
		--assert same? obj obj

===end-group===

===start-group=== "SELF test"

	--test-- "self-1"
		obj: context [
			--assert "make object! []" = mold/flat self
		]

	--test-- "self-2"
		obj: context [
			a: 123
			--assert "make object! [a: 123 b: unset]" = mold/flat self
			b: 456
		]

	--test-- "self-3"
		result: {make object! [b: 123 c: "hello" show: func [][--assert object? self] foo: unset]}

		obj: object [
			b: 123
			c: "hello"
			show: does [--assert object? self]
			--assert result = mold/flat self
			foo: does [--assert object? self c: none]
			foo
		]
		obj/show
		--assert none? obj/c

	--test-- "self-4"
		p1: object [
		    a: 1
		    b: 2
		    e: does [self/b]
		    f: does [self/b: 789 self/e]
		    --assert self/e = 2
		]
		--assert p1/e = 2
		--assert p1/f = 789

===end-group===

===start-group=== "simple object tests"

	--test-- "simple object 1"
		so1-a: 0
		so1-o: make object! [so1-a: 1]
		--assert so1-a = 0
		--assert so1-o/so1-a = 1

	--test-- "simple object 2"
		so2-s: "0"
		so2-o: make object! [so2-s: "1"]
		--assert so2-s = "0"
		--assert so2-o/so2-s = "1"

	--test-- "simple object 3"
		so3-s: "0"
		so3-i: 0
		so3-l: true
		so3-c: #"a"
		so3-b: [a b c]
		so3-f: func [][0]
		so3-bs: charset #"^(00)"
		so3-o: make object! [
			so3-s: "1"
			so3-i: 1
			so3-l: false
			so3-c: #"b"
			so3-b: [a b d]
			so3-f: func [][1]
			so3-bs: charset #"^(01)"
		]
		--assert so3-s = "0"
		--assert so3-o/so3-s = "1"
		--assert so3-i = 0
		--assert so3-o/so3-i = 1
		--assert so3-l = true
		--assert so3-o/so3-l = false
		--assert so3-c = #"a"
		--assert so3-o/so3-c = #"b"
		--assert so3-b = [a b c]
		--assert so3-o/so3-b = [a b d]
		--assert so3-f = 0
		--assert so3-o/so3-f = 1
		--assert "make bitset! #{80}" = mold so3-bs
		--assert "make bitset! #{40}" = mold so3-o/so3-bs

===end-group===

===start-group=== "nested objects"

	--test-- "no1"
		no1-o: make object! [o: make object! [i: 1] ]
		--assert no1-o/o/i = 1

	--test-- "no2"
		no2-o1: make object! [
			o2: make object! [
				i: 1
			]
		]
		--assert no2-o1/o2/i = 1

	--test-- "no3"
		no3-o1: make object! [
			o2: make object! [
			o3: make object! [
			o4: make object! [
				i: 1
			]]]
		]
		--assert no3-o1/o2/o3/o4/i = 1

	--test-- "no4"
		no4-o1: make object! [
			o2: make object! [
			o3: make object! [
			o4: make object! [
			o5: make object! [
			o6: make object! [
			o7: make object! [
				i: 1
			]]]]]]
		]
		--assert no4-o1/o2/o3/o4/o5/o6/o7/i = 1

	--test-- "no5"
		no5-o1: make object! [
			o2: make object! [
			o3: make object! [
			o4: make object! [
			o5: make object! [
			o6: make object! [
			o7: make object! [
			o8: make object! [
			o9: make object! [
			o10: make object! [
			o11: make object! [
			o12: make object! [
			o13: make object! [
			o14: make object! [
			o15: make object! [
				i: 1
			]]]]]]]]]]]]]]
		]
		--assert no5-o1/o2/o3/o4/o5/o6/o7/o8/o9/o10/o11/o12/o13/o14/o15/i = 1

	--test-- "no6 issue #928"
		no6-o: make object! [
			a: 1
			o: make object! [
				b: 2
				f: does [a]
				]
			]
		--assert 1 = no6-o/o/f

===end-group===

===start-group=== "object prototype tests"

	--test-- "op1"
		op1-o1: make object! [i: 1]
		op1-o2: make op1-o1 []
		--assert op1-o2/i = 1

	--test-- "op2"
		op2-o1: make object! [i: 1]
		op2-o2: make op2-o1 [i: 2]
		--assert op2-o2/i = 2
		--assert op2-o1/i = 1

	--test-- "op3"
		op3-o1: make object! [i: 1]
		op3-o2: make op3-o1 [i: 2 j: 3]
		--assert op3-o2/i = 2
		--assert op3-o2/j = 3

===end-group===

===start-group=== "object initialisation processing"

	--test-- "oip1"
		oip1-i: 1
		oip1-o: make object! [
			i: oip1-i
		]
		--assert 1 = oip1-o/i

	--test-- "oip2"
		oip2-i: 1
		oip2-o: make object! [
			i: either oip2-i = 1 [2] [3]
		]
		--assert 2 = oip2-o/i

	--test-- "oip3"
		oip3-i: 1
		oip3-o: make object! [
			i: 0
			set 'oip3-i 2
		]
		--assert 2 = oip3-i

	--test-- "oip4"
		oip4-o: make object! [
			i: 0
			set 'oip4-i 3
		]
		--assert 3 = oip4-i

===end-group===

===start-group=== "inheritance"

	--test-- "inherit-1"
		proto: context [
			a: 123
			get-a: does [a]
		]
		new: make proto [a: 99]
		--assert new/a = 99
		--assert new/get-a = 99
		--assert proto/a = 123
		--assert proto/get-a = 123

	--test-- "inherit-2"
		new/a: 456
		--assert new/get-a = 456
		proto/a: 759
		--assert proto/a = 759
		--assert new/get-a = 456

	--test-- "inherit-3"
		newnew: make new [
			reset: does [a: none]
		]
		--assert newnew/a = 456
		newnew/reset
		--assert none? newnew/a
		--assert new/a = 456
		--assert proto/a = 759

	--test-- "inherit-4"
		base: context [
			v: 0
			foo: does [v]
		]

		i: 0
		list: []
		loop 2 [
			bb: make base [v: i]
			--assert bb/foo = i
			append list bb
			i: i + 1
		]
		--assert object? list/1
		--assert list/1/v = 0
		--assert list/2/v = 1

	--test-- "inherit-5"
		base5: context [
			b: 123
			get-b: does [b]
			a: object [
				b: 456
				double: does [b * 2]
				set-b: func [/with v] [b: either with [v]['hello]]
			]
		]
		proto5: context [
			b: 999
			value: 71
			foo: does [b + value]
		]
		new: make base5 proto5
		--assert object? new
		--assert new/b = 999
		--assert new/value = 71
		--assert new/a/b = 456
		--assert base5/b = 123

	--test-- "inherit-6"
		--assert new/get-b = 999
		--assert new/a/double = 912
		--assert new/a/set-b/with 10
		--assert new/a/b = 10
		--assert new/b = 999
		--assert base5/b = 123
		--assert new/a/double = 20
		--assert base5/a/double = 20

	--test-- "inherit-7"
		--assert same? new/a base5/a

	--test-- "inherit-8"
		--assert new/foo = 1070

	--test-- "inherit-9"
		base9: context [
			v: 123456
			show: does [v]
		]
		i: 100
		list: []
		loop 3 [
			new9: make base9 [v: i]
			--assert new9/v = i
			--assert new9/show = i
			append list new9
			i: i + 1
		]
		--assert base9/v = 123456
		--assert list/1/v = 100
		--assert list/2/v = 101
		--assert list/3/v = 102

	--test-- "inherit-10"
		base10: make object! [
			emb: make object! [
				a: 1
			]
		]
		new10: make base10 []
		base10/emb/a: 9
		--assert 9 = new10/emb/a

===end-group===

===start-group=== "external deep setting"

	--test-- "ext-1"
		p1: object [
		    a: 1
		    b: 2
		]

		p1/a: context [
			t: 99
			z: 128
			q: object [zz: 345 show: does [zz]]
		]
		--assert object? p1/a
		--assert p1/a/z = 128
		--assert p1/a/q/show = 345

	--test-- "ext-2"
		p1/a/t: does [123]
		--assert p1/a/t = 123

===end-group===

===start-group=== "dynamic invocation"

	--test-- "dyn-1"
		d: context [
			value: 998
		    f: does [value]
		]
		h: :d/f
		--assert h = 998
		d/value: 123
		--assert 123 = do [h]

	--test-- "dyn-2"
		f: func [/local z][
		    z: object [
		        a: 1
		        g: func [/with b /local c][c: 10 either with [a + b + 10][a * 2]]
		        j: func [i][i + 1]
		    ]
	    	z
		]
		o: make f [a: 3]
		--assert 46 = o/j 45
		--assert 101 = o/j 100

	--test-- "dyn-3"
		--assert 52 = o/j o/j 50

	--test-- "dyn-4"
		--assert 33 = o/g/with 20
		--assert 59 = o/g/with o/j 45

	--test-- "dyn-5"
		--assert 12 = o/j z: 5 + 6
		--assert  z = 11

	--test-- "dyn-6"
		--assert [17] = reduce [o/j o/j z: 5 + 10]
		--assert z = 15

	--test-- "dyn-7"
		repeat c 1 [
			if yes [
				--assert 52 = o/j o/j 50
				--assert 59 = o/g/with o/j 45
				--assert [22] = reduce [o/j o/j z: 5 + 15]
				--assert z = 20
			]
		]

	--test-- "dyn-8"
		o2: context [zz: none]				;-- test renaming a statically compiled object

		f: func [/alt][
			either alt [
				make object! [
					a: 10
					g: 123
				]
			][
				make object! [
					a: 1
					g: does [a]
				]
			]
		]
		o2: f
		--assert 1 = o2/g

	--test-- "dyn-9"
		o2: f/alt
		--assert 123 = o2/g

===end-group===

===start-group=== "copy"

	--test-- "copy-1"
		co1: make object! [a: 1]
		co2: copy co1
		co1/a: 2
		--assert 2 = co1/a
		--assert 1 = co2/a

	--test-- "copy-2"
		co1: make object! [
			a: 1
			f: func[][a]
		]
		co2: copy co1
		co1/a: 2
		--assert 2 = co1/f
		--assert 1 = co2/f

	--test-- "copy-3"
		co1: make object! [
			a: 1
			b: 2
			blk: [1 2 3 4]
		]
		co2: copy co1
		co1/blk/1: 5
		--assert 5 = co1/blk/1
		--assert 5 = co2/blk/1

	--test-- "copy-4"
		co1: make object! [
			a: 1
			b: 2
			blk: [1 2 3 4]
		]
		co2: copy/deep co1
		co1/blk/1: 5
		--assert 5 = co1/blk/1
		--assert 1 = co2/blk/1

	--test-- "copy-5"
		co1: make object! [
			a: 1
			s: "Silly old string"
			f: func [][
				[s a]
			]
		]
		co2: copy co1
		co1/a: 5
		co1/s/2: #"h"
		co1/s/3: #"i"
		co1/s/4: #"n"
		--assert "Shiny old string" = co1/s
		--assert "Shiny old string" = co2/s

	--test-- "copy-6"
		co1: make object! [
			a: 1
			s: "Silly old string"
		]
		co2: copy co1
		co1/a: 5
		co1/s/2: #"h"
		co1/s/3: #"i"
		co1/s/4: #"n"
		replace co1/s "old" "new"
		--assert "Shiny new string" = co1/s
		--assert "Shiny new string" = co2/s

	--test-- "copy-7"
		co5: make object! [
			a: 1
			s: ["Silly old string"]
		]
		co6: copy/deep co5
		co5/a: 5
		co5/s/2: #"h"
		co5/s/3: #"i"
		co5/s/4: #"n"
		replace co5/s "old" "new"
		--assert "Shiny new string" = co5/s
		--assert "Silly old string" = co6/s

	--test-- "copy-8"
		co1: make object! [
			s: "Silly old string"
			f: func[][s]
		]
		co2: copy co1
		co1/s/2: #"h"
		co1/s/3: #"i"
		co1/s/4: #"n"
		replace co1/s "old" "new"
		--assert "Shiny new string" = co1/f
		--assert "Shiny new string" = co2/f

	--test-- "copy-9"
		co1: make object! [
			s: "Silly old string"
			f: func[][s]
		]
		co2: copy/deep co1
		co1/s/2: #"h"
		co1/s/3: #"i"
		co1/s/4: #"n"
		replace co1/s "old" "new"
		--assert "Shiny new string" = co1/f
		--assert "Silly old string" = co2/f

===end-group===

===start-group=== "in"

	--test-- "in1"
		ino1: make object! [
			i: 1
			c: #"a"
			f: 1.0
			b: [1 2 3 4]
			s: "abcdef"
			o: make object! [
			]
		]
		--assert 'i = in ino1 'i
		--assert 'c = in ino1 'c
		--assert 'b = in ino1 'b
		--assert 'f = in ino1 'f
		--assert 's = in ino1 's
		--assert 'o = in ino1 'o

	--test-- "in2"
		ino1: make object! [
			i: 1
			c: #"a"
			f: 1.0
			b: [1 2 3 4]
			s: "abcdef"
			o: make object! [
				c: #"b"
				i: 2
				f: 2.0
				b: [5 6 7 8]
				s: "ghijkl"
				o: make object! [
				]
			]
		]
		--assert 'i = in ino1 'i
		--assert 'c = in ino1 'c
		--assert 'b = in ino1 'b
		--assert 'f = in ino1 'f
		--assert 's = in ino1 's
		--assert 'o = in ino1 'o
		--assert 'i = in ino1/o 'i
		--assert 'c = in ino1/o 'c
		--assert 'b = in ino1/o 'b
		--assert 'f = in ino1/o 'f
		--assert 's = in ino1/o 's
		--assert 'o = in ino1/o 'o

	--test-- "in3"
		ino1: make object! [
			i: 1
			c: #"a"
			f: 1.0
			b: [1 2 3 4]
			s: "abcdef"
			o: make object! [
				c: #"b"
				i: 2
				f: 2.0
				b: [5 6 7 8]
				s: "ghijkl"
				o: make object! [
					c: #"c"
					i: 3
					f: 3.0
					b: [9 10 11 12]
					s; "mnopqr"
					o: make object! [
					]
				]
			]
		]
		--assert 'i = in ino1 'i
		--assert 'c = in ino1 'c
		--assert 'b = in ino1 'b
		--assert 'f = in ino1 'f
		--assert 's = in ino1 's
		--assert 'o = in ino1 'o
		--assert 'i = in ino1/o 'i
		--assert 'c = in ino1/o 'c
		--assert 'b = in ino1/o 'b
		--assert 'f = in ino1/o 'f
		--assert 's = in ino1/o 's
		--assert 'o = in ino1/o 'o
		--assert 'i = in ino1/o/o 'i
		--assert 'c = in ino1/o/o 'c
		--assert 'b = in ino1/o/o 'b
		--assert 'f = in ino1/o/o 'f
		--assert 's = in ino1/o/o 's
		--assert 'o = in ino1/o/o 'o

		--test-- "in4"
		ino1: make object! [
			i: 1
			c: #"a"
			f: 1.0
			b: [1 2 3 4]
			s: "abcdef"
			o: make object! [
				c: #"b"
				i: 2
				f: 2.0
				b: [5 6 7 8]
				s: "ghijkl"
				o: make object! [
					c: #"c"
					i: 3
					f: 3.0
					b: [9 10 11 12]
					s; "mnopqr"
					o: make object! [
						c: #"d"
						f: 4.0
						i: 4
						b: [13 14 15 16]
						s: "stuvwx"
					]
				]
			]
		]
		--assert 'i = in ino1 'i
		--assert 'c = in ino1 'c
		--assert 'b = in ino1 'b
		--assert 'f = in ino1 'f
		--assert 's = in ino1 's
		--assert 'o = in ino1 'o
		--assert 'i = in ino1/o 'i
		--assert 'c = in ino1/o 'c
		--assert 'b = in ino1/o 'b
		--assert 'f = in ino1/o 'f
		--assert 's = in ino1/o 's
		--assert 'o = in ino1/o 'o
		--assert 'i = in ino1/o/o 'i
		--assert 'c = in ino1/o/o 'c
		--assert 'b = in ino1/o/o 'b
		--assert 'f = in ino1/o/o 'f
		--assert 's = in ino1/o/o 's
		--assert 'o = in ino1/o/o 'o
		--assert 'i = in ino1/o/o/o 'i
		--assert 'c = in ino1/o/o/o 'c
		--assert 'b = in ino1/o/o/o 'b
		--assert 'f = in ino1/o/o/o 'f
		--assert 's = in ino1/o/o/o 's

===end-group===

~~~end-file~~~

Red [
	Title:   "Red/System object! datatype test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %object-test.red
	Version: "0.1.0"
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2014 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~~~ "object"

===start-group=== "basic tests"

	--test-- "basic-1"
		obj1: context []
		--assert "make object! []" = mold obj1

	--test-- "basic-2"
		obj2: object []
		--assert "make object! []" = mold obj2

	--test-- "basic-3"
		obj3: make object! []
		--assert "make object! []" = mold obj3

	--test-- "basic-4"
		blk: []
		obj4: object blk
		--assert "make object! []" = mold obj4

	--test-- "basic-5"
		obj5: object [
			a: 123
			show: does [a + 1]
			reset: does [a: none]
			--assert show = 124
			--assert a = 123
		]
		--assert obj5/show = 124
		obj5/reset
		--assert none? obj5/a

	--test-- "basic-6"
		obj5/a: 456
		--assert obj5/a = 456

	--test-- "basic-7"
		--assert find obj5 'a
		--assert not find obj5 'z
		--assert 456 = select obj5 'a
		--assert none? select obj5 'z

	--test-- "basic-8"
		obj8: context [
			b: 123
			a: object [
				b: 456
				double: does [b * 2]
				set-b: does [b: 'hello]
			]
		]
		--assert obj8/b = 123
		--assert obj8/a/b = 456
		--assert obj8/a/double = 912
		obj8/a/set-b
		--assert obj8/a/b = 'hello

	--test-- "basic-9"
		obj8/a/b: 'red
		--assert obj8/a/b = 'red

	--test-- "basic-10"
		obj10: object [
			a: 1
			b: 2
			inc: func [i /with a][b: i + either with [a][b]]
			sub: context [
				a: 3
				b: 4
				inc: func [i /with a][b: i + either with [a][b]]
			]
		]
		--assert 12 = obj10/inc 10
		--assert obj10/b = 12

		--assert 14 = obj10/sub/inc 10
		--assert obj10/sub/b = 14

	--test-- "basic-11"
		--assert 30 = obj10/inc/with 10 20
		--assert obj10/b = 30

		--assert 50 = obj10/sub/inc/with 10 40
		--assert obj10/sub/b = 50

	--test-- "basic-12"
		blk: [a: 99]
		obj12: object blk
		--assert obj12/a = 99

===end-group===

===start-group=== "Comparison tests"

	--test-- "comp-1"  --assert 	(context [])	 = (context [])
	--test-- "comp-2"  --assert not (context [a: 1]) = (context [])
	--test-- "comp-3"  --assert 	(context [a: 1]) = (context [a: 1])
	--test-- "comp-4"  --assert not (context [a: 1]) = (context [a: 2])
	--test-- "comp-5"  --assert 	(context [a: 1]) < (context [a: 2])
	--test-- "comp-6"  --assert not (context [a: 1]) >= (context [a: 2])
	--test-- "comp-7"  --assert 	(context [a: 2]) < (context [a: 1 b: none])

	--test-- "comp-8"
		obj:  context [a: 123]
		obj2: context [a: 123]
		--assert obj = obj2
		--assert not same? obj obj2
		--assert same? obj obj

===end-group===

===start-group=== "SELF test"

	--test-- "self-1"
		obj: context [
			--assert "make object! []" = mold/flat self
		]

	--test-- "self-2"
		obj: context [
			a: 123
			--assert "make object! [a: 123 b: unset]" = mold/flat self
			b: 456
		]

	--test-- "self-3"
		result: {make object! [b: 123 c: "hello" show: func [][--assert object? self] foo: unset]}

		obj: object [
			b: 123
			c: "hello"
			show: does [--assert object? self]
			--assert result = mold/flat self
			foo: does [--assert object? self c: none]
			foo
		]
		obj/show
		--assert none? obj/c

	--test-- "self-4"
		p1: object [
		    a: 1
		    b: 2
		    e: does [self/b]
		    f: does [self/b: 789 self/e]
		    --assert self/e = 2
		]
		--assert p1/e = 2
		--assert p1/f = 789

===end-group===

===start-group=== "simple object tests"

	--test-- "simple object 1"
		so1-a: 0
		so1-o: make object! [so1-a: 1]
		--assert so1-a = 0
		--assert so1-o/so1-a = 1

	--test-- "simple object 2"
		so2-s: "0"
		so2-o: make object! [so2-s: "1"]
		--assert so2-s = "0"
		--assert so2-o/so2-s = "1"

	--test-- "simple object 3"
		so3-s: "0"
		so3-i: 0
		so3-l: true
		so3-c: #"a"
		so3-b: [a b c]
		so3-f: func [][0]
		so3-bs: charset #"^(00)"
		so3-o: make object! [
			so3-s: "1"
			so3-i: 1
			so3-l: false
			so3-c: #"b"
			so3-b: [a b d]
			so3-f: func [][1]
			so3-bs: charset #"^(01)"
		]
		--assert so3-s = "0"
		--assert so3-o/so3-s = "1"
		--assert so3-i = 0
		--assert so3-o/so3-i = 1
		--assert so3-l = true
		--assert so3-o/so3-l = false
		--assert so3-c = #"a"
		--assert so3-o/so3-c = #"b"
		--assert so3-b = [a b c]
		--assert so3-o/so3-b = [a b d]
		--assert so3-f = 0
		--assert so3-o/so3-f = 1
		--assert "make bitset! #{80}" = mold so3-bs
		--assert "make bitset! #{40}" = mold so3-o/so3-bs

===end-group===

===start-group=== "nested objects"

	--test-- "no1"
		no1-o: make object! [o: make object! [i: 1] ]
		--assert no1-o/o/i = 1

	--test-- "no2"
		no2-o1: make object! [
			o2: make object! [
				i: 1
			]
		]
		--assert no2-o1/o2/i = 1

	--test-- "no3"
		no3-o1: make object! [
			o2: make object! [
			o3: make object! [
			o4: make object! [
				i: 1
			]]]
		]
		--assert no3-o1/o2/o3/o4/i = 1

	--test-- "no4"
		no4-o1: make object! [
			o2: make object! [
			o3: make object! [
			o4: make object! [
			o5: make object! [
			o6: make object! [
			o7: make object! [
				i: 1
			]]]]]]
		]
		--assert no4-o1/o2/o3/o4/o5/o6/o7/i = 1

	--test-- "no5"
		no5-o1: make object! [
			o2: make object! [
			o3: make object! [
			o4: make object! [
			o5: make object! [
			o6: make object! [
			o7: make object! [
			o8: make object! [
			o9: make object! [
			o10: make object! [
			o11: make object! [
			o12: make object! [
			o13: make object! [
			o14: make object! [
			o15: make object! [
				i: 1
			]]]]]]]]]]]]]]
		]
		--assert no5-o1/o2/o3/o4/o5/o6/o7/o8/o9/o10/o11/o12/o13/o14/o15/i = 1

	--test-- "no6 issue #928"
		no6-o: make object! [
			a: 1
			o: make object! [
				b: 2
				f: does [a]
				]
			]
		--assert 1 = no6-o/o/f

===end-group===

===start-group=== "object prototype tests"

	--test-- "op1"
		op1-o1: make object! [i: 1]
		op1-o2: make op1-o1 []
		--assert op1-o2/i = 1

	--test-- "op2"
		op2-o1: make object! [i: 1]
		op2-o2: make op2-o1 [i: 2]
		--assert op2-o2/i = 2
		--assert op2-o1/i = 1

	--test-- "op3"
		op3-o1: make object! [i: 1]
		op3-o2: make op3-o1 [i: 2 j: 3]
		--assert op3-o2/i = 2
		--assert op3-o2/j = 3

===end-group===

===start-group=== "object initialisation processing"

	--test-- "oip1"
		oip1-i: 1
		oip1-o: make object! [
			i: oip1-i
		]
		--assert 1 = oip1-o/i

	--test-- "oip2"
		oip2-i: 1
		oip2-o: make object! [
			i: either oip2-i = 1 [2] [3]
		]
		--assert 2 = oip2-o/i

	--test-- "oip3"
		oip3-i: 1
		oip3-o: make object! [
			i: 0
			set 'oip3-i 2
		]
		--assert 2 = oip3-i

	--test-- "oip4"
		oip4-o: make object! [
			i: 0
			set 'oip4-i 3
		]
		--assert 3 = oip4-i

===end-group===

===start-group=== "inheritance"

	--test-- "inherit-1"
		proto: context [
			a: 123
			get-a: does [a]
		]
		new: make proto [a: 99]
		--assert new/a = 99
		--assert new/get-a = 99
		--assert proto/a = 123
		--assert proto/get-a = 123

	--test-- "inherit-2"
		new/a: 456
		--assert new/get-a = 456
		proto/a: 759
		--assert proto/a = 759
		--assert new/get-a = 456

	--test-- "inherit-3"
		newnew: make new [
			reset: does [a: none]
		]
		--assert newnew/a = 456
		newnew/reset
		--assert none? newnew/a
		--assert new/a = 456
		--assert proto/a = 759

	--test-- "inherit-4"
		base: context [
			v: 0
			foo: does [v]
		]

		i: 0
		list: []
		loop 2 [
			bb: make base [v: i]
			--assert bb/foo = i
			append list bb
			i: i + 1
		]
		--assert object? list/1
		--assert list/1/v = 0
		--assert list/2/v = 1

	--test-- "inherit-5"
		base5: context [
			b: 123
			get-b: does [b]
			a: object [
				b: 456
				double: does [b * 2]
				set-b: func [/with v] [b: either with [v]['hello]]
			]
		]
		proto5: context [
			b: 999
			value: 71
			foo: does [b + value]
		]
		new: make base5 proto5
		--assert object? new
		--assert new/b = 999
		--assert new/value = 71
		--assert new/a/b = 456
		--assert base5/b = 123

	--test-- "inherit-6"
		--assert new/get-b = 999
		--assert new/a/double = 912
		--assert new/a/set-b/with 10
		--assert new/a/b = 10
		--assert new/b = 999
		--assert base5/b = 123
		--assert new/a/double = 20
		--assert base5/a/double = 20

	--test-- "inherit-7"
		--assert same? new/a base5/a

	--test-- "inherit-8"
		--assert new/foo = 1070

	--test-- "inherit-9"
		base9: context [
			v: 123456
			show: does [v]
		]
		i: 100
		list: []
		loop 3 [
			new9: make base9 [v: i]
			--assert new9/v = i
			--assert new9/show = i
			append list new9
			i: i + 1
		]
		--assert base9/v = 123456
		--assert list/1/v = 100
		--assert list/2/v = 101
		--assert list/3/v = 102

===end-group===

===start-group=== "external deep setting"

	--test-- "ext-1"
		p1: object [
		    a: 1
		    b: 2
		]

		p1/a: context [
			t: 99
			z: 128
			q: object [zz: 345 show: does [zz]]
		]
		--assert object? p1/a
		--assert p1/a/z = 128
		--assert p1/a/q/show = 345

	--test-- "ext-2"
		p1/a/t: does [123]
		--assert p1/a/t = 123

===end-group===

===start-group=== "dynamic invocation"

	--test-- "dyn-1"
		d: context [
			value: 998
		    f: does [value]
		]
		h: :d/f
		--assert h = 998
		d/value: 123
		--assert 123 = do [h]

	--test-- "dyn-2"
		f: func [/local z][
		    z: object [
		        a: 1
		        g: func [/with b /local c][c: 10 either with [a + b + 10][a * 2]]
		        j: func [i][i + 1]
		    ]
	    	z
		]
		o: make f [a: 3]
		--assert 46 = o/j 45
		--assert 101 = o/j 100

	--test-- "dyn-3"
		--assert 52 = o/j o/j 50

	--test-- "dyn-4"
		--assert 33 = o/g/with 20
		--assert 59 = o/g/with o/j 45

	--test-- "dyn-5"
		--assert 12 = o/j z: 5 + 6
		--assert  z = 11

	--test-- "dyn-6"
		--assert [17] = reduce [o/j o/j z: 5 + 10]
		--assert z = 15

	--test-- "dyn-7"
		repeat c 1 [
			if yes [
				--assert 52 = o/j o/j 50
				--assert 59 = o/g/with o/j 45
				--assert [22] = reduce [o/j o/j z: 5 + 15]
				--assert z = 20
			]
		]

	--test-- "dyn-8"
		o2: context [zz: none]				;-- test renaming a statically compiled object

		f: func [/alt][
			either alt [
				make object! [
					a: 10
					g: 123
				]
			][
				make object! [
					a: 1
					g: does [a]
				]
			]
		]
		o2: f
		--assert 1 = o2/g

	--test-- "dyn-9"
		o2: f/alt
		--assert 123 = o2/g

===end-group===

~~~end-file~~~


TESTS: corrected object copy tests

TESTS: corrected object copy tests

Red [
	Title:   "Red/System object! datatype test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %object-test.red
	Version: "0.1.0"
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2014 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~~~ "object"

===start-group=== "basic tests"

	--test-- "basic-1"
		obj1: context []
		--assert "make object! []" = mold obj1

	--test-- "basic-2"
		obj2: object []
		--assert "make object! []" = mold obj2

	--test-- "basic-3"
		obj3: make object! []
		--assert "make object! []" = mold obj3

	--test-- "basic-4"
		blk: []
		obj4: object blk
		--assert "make object! []" = mold obj4

	--test-- "basic-5"
		obj5: object [
			a: 123
			show: does [a + 1]
			reset: does [a: none]
			--assert show = 124
			--assert a = 123
		]
		--assert obj5/show = 124
		obj5/reset
		--assert none? obj5/a

	--test-- "basic-6"
		obj5/a: 456
		--assert obj5/a = 456

	--test-- "basic-7"
		--assert find obj5 'a
		--assert not find obj5 'z
		--assert 456 = select obj5 'a
		--assert none? select obj5 'z

	--test-- "basic-8"
		obj8: context [
			b: 123
			a: object [
				b: 456
				double: does [b * 2]
				set-b: does [b: 'hello]
			]
		]
		--assert obj8/b = 123
		--assert obj8/a/b = 456
		--assert obj8/a/double = 912
		obj8/a/set-b
		--assert obj8/a/b = 'hello

	--test-- "basic-9"
		obj8/a/b: 'red
		--assert obj8/a/b = 'red

	--test-- "basic-10"
		obj10: object [
			a: 1
			b: 2
			inc: func [i /with a][b: i + either with [a][b]]
			sub: context [
				a: 3
				b: 4
				inc: func [i /with a][b: i + either with [a][b]]
			]
		]
		--assert 12 = obj10/inc 10
		--assert obj10/b = 12

		--assert 14 = obj10/sub/inc 10
		--assert obj10/sub/b = 14

	--test-- "basic-11"
		--assert 30 = obj10/inc/with 10 20
		--assert obj10/b = 30

		--assert 50 = obj10/sub/inc/with 10 40
		--assert obj10/sub/b = 50

	--test-- "basic-12"
		blk: [a: 99]
		obj12: object blk
		--assert obj12/a = 99

===end-group===

===start-group=== "Comparison tests"

	--test-- "comp-1"  --assert 	(context [])	 = (context [])
	--test-- "comp-2"  --assert not (context [a: 1]) = (context [])
	--test-- "comp-3"  --assert 	(context [a: 1]) = (context [a: 1])
	--test-- "comp-4"  --assert not (context [a: 1]) = (context [a: 2])
	--test-- "comp-5"  --assert 	(context [a: 1]) < (context [a: 2])
	--test-- "comp-6"  --assert not (context [a: 1]) >= (context [a: 2])
	--test-- "comp-7"  --assert 	(context [a: 2]) < (context [a: 1 b: none])

	--test-- "comp-8"
		obj:  context [a: 123]
		obj2: context [a: 123]
		--assert obj = obj2
		--assert not same? obj obj2
		--assert same? obj obj

===end-group===

===start-group=== "SELF test"

	--test-- "self-1"
		obj: context [
			--assert "make object! []" = mold/flat self
		]

	--test-- "self-2"
		obj: context [
			a: 123
			--assert "make object! [a: 123 b: unset]" = mold/flat self
			b: 456
		]

	--test-- "self-3"
		result: {make object! [b: 123 c: "hello" show: func [][--assert object? self] foo: unset]}

		obj: object [
			b: 123
			c: "hello"
			show: does [--assert object? self]
			--assert result = mold/flat self
			foo: does [--assert object? self c: none]
			foo
		]
		obj/show
		--assert none? obj/c

	--test-- "self-4"
		p1: object [
		    a: 1
		    b: 2
		    e: does [self/b]
		    f: does [self/b: 789 self/e]
		    --assert self/e = 2
		]
		--assert p1/e = 2
		--assert p1/f = 789

===end-group===

===start-group=== "simple object tests"

	--test-- "simple object 1"
		so1-a: 0
		so1-o: make object! [so1-a: 1]
		--assert so1-a = 0
		--assert so1-o/so1-a = 1

	--test-- "simple object 2"
		so2-s: "0"
		so2-o: make object! [so2-s: "1"]
		--assert so2-s = "0"
		--assert so2-o/so2-s = "1"

	--test-- "simple object 3"
		so3-s: "0"
		so3-i: 0
		so3-l: true
		so3-c: #"a"
		so3-b: [a b c]
		so3-f: func [][0]
		so3-bs: charset #"^(00)"
		so3-o: make object! [
			so3-s: "1"
			so3-i: 1
			so3-l: false
			so3-c: #"b"
			so3-b: [a b d]
			so3-f: func [][1]
			so3-bs: charset #"^(01)"
		]
		--assert so3-s = "0"
		--assert so3-o/so3-s = "1"
		--assert so3-i = 0
		--assert so3-o/so3-i = 1
		--assert so3-l = true
		--assert so3-o/so3-l = false
		--assert so3-c = #"a"
		--assert so3-o/so3-c = #"b"
		--assert so3-b = [a b c]
		--assert so3-o/so3-b = [a b d]
		--assert so3-f = 0
		--assert so3-o/so3-f = 1
		--assert "make bitset! #{80}" = mold so3-bs
		--assert "make bitset! #{40}" = mold so3-o/so3-bs

===end-group===

===start-group=== "nested objects"

	--test-- "no1"
		no1-o: make object! [o: make object! [i: 1] ]
		--assert no1-o/o/i = 1

	--test-- "no2"
		no2-o1: make object! [
			o2: make object! [
				i: 1
			]
		]
		--assert no2-o1/o2/i = 1

	--test-- "no3"
		no3-o1: make object! [
			o2: make object! [
			o3: make object! [
			o4: make object! [
				i: 1
			]]]
		]
		--assert no3-o1/o2/o3/o4/i = 1

	--test-- "no4"
		no4-o1: make object! [
			o2: make object! [
			o3: make object! [
			o4: make object! [
			o5: make object! [
			o6: make object! [
			o7: make object! [
				i: 1
			]]]]]]
		]
		--assert no4-o1/o2/o3/o4/o5/o6/o7/i = 1

	--test-- "no5"
		no5-o1: make object! [
			o2: make object! [
			o3: make object! [
			o4: make object! [
			o5: make object! [
			o6: make object! [
			o7: make object! [
			o8: make object! [
			o9: make object! [
			o10: make object! [
			o11: make object! [
			o12: make object! [
			o13: make object! [
			o14: make object! [
			o15: make object! [
				i: 1
			]]]]]]]]]]]]]]
		]
		--assert no5-o1/o2/o3/o4/o5/o6/o7/o8/o9/o10/o11/o12/o13/o14/o15/i = 1

	--test-- "no6 issue #928"
		no6-o: make object! [
			a: 1
			o: make object! [
				b: 2
				f: does [a]
				]
			]
		--assert 1 = no6-o/o/f

===end-group===

===start-group=== "object prototype tests"

	--test-- "op1"
		op1-o1: make object! [i: 1]
		op1-o2: make op1-o1 []
		--assert op1-o2/i = 1

	--test-- "op2"
		op2-o1: make object! [i: 1]
		op2-o2: make op2-o1 [i: 2]
		--assert op2-o2/i = 2
		--assert op2-o1/i = 1

	--test-- "op3"
		op3-o1: make object! [i: 1]
		op3-o2: make op3-o1 [i: 2 j: 3]
		--assert op3-o2/i = 2
		--assert op3-o2/j = 3

===end-group===

===start-group=== "object initialisation processing"

	--test-- "oip1"
		oip1-i: 1
		oip1-o: make object! [
			i: oip1-i
		]
		--assert 1 = oip1-o/i

	--test-- "oip2"
		oip2-i: 1
		oip2-o: make object! [
			i: either oip2-i = 1 [2] [3]
		]
		--assert 2 = oip2-o/i

	--test-- "oip3"
		oip3-i: 1
		oip3-o: make object! [
			i: 0
			set 'oip3-i 2
		]
		--assert 2 = oip3-i

	--test-- "oip4"
		oip4-o: make object! [
			i: 0
			set 'oip4-i 3
		]
		--assert 3 = oip4-i

===end-group===

===start-group=== "inheritance"

	--test-- "inherit-1"
		proto: context [
			a: 123
			get-a: does [a]
		]
		new: make proto [a: 99]
		--assert new/a = 99
		--assert new/get-a = 99
		--assert proto/a = 123
		--assert proto/get-a = 123

	--test-- "inherit-2"
		new/a: 456
		--assert new/get-a = 456
		proto/a: 759
		--assert proto/a = 759
		--assert new/get-a = 456

	--test-- "inherit-3"
		newnew: make new [
			reset: does [a: none]
		]
		--assert newnew/a = 456
		newnew/reset
		--assert none? newnew/a
		--assert new/a = 456
		--assert proto/a = 759

	--test-- "inherit-4"
		base: context [
			v: 0
			foo: does [v]
		]

		i: 0
		list: []
		loop 2 [
			bb: make base [v: i]
			--assert bb/foo = i
			append list bb
			i: i + 1
		]
		--assert object? list/1
		--assert list/1/v = 0
		--assert list/2/v = 1

	--test-- "inherit-5"
		base5: context [
			b: 123
			get-b: does [b]
			a: object [
				b: 456
				double: does [b * 2]
				set-b: func [/with v] [b: either with [v]['hello]]
			]
		]
		proto5: context [
			b: 999
			value: 71
			foo: does [b + value]
		]
		new: make base5 proto5
		--assert object? new
		--assert new/b = 999
		--assert new/value = 71
		--assert new/a/b = 456
		--assert base5/b = 123

	--test-- "inherit-6"
		--assert new/get-b = 999
		--assert new/a/double = 912
		--assert new/a/set-b/with 10
		--assert new/a/b = 10
		--assert new/b = 999
		--assert base5/b = 123
		--assert new/a/double = 20
		--assert base5/a/double = 20

	--test-- "inherit-7"
		--assert same? new/a base5/a

	--test-- "inherit-8"
		--assert new/foo = 1070

	--test-- "inherit-9"
		base9: context [
			v: 123456
			show: does [v]
		]
		i: 100
		list: []
		loop 3 [
			new9: make base9 [v: i]
			--assert new9/v = i
			--assert new9/show = i
			append list new9
			i: i + 1
		]
		--assert base9/v = 123456
		--assert list/1/v = 100
		--assert list/2/v = 101
		--assert list/3/v = 102

	--test-- "inherit-10"
		base10: make object! [
			oo: make object! [
				a: 1
			]
		]
		new10: make base10 []
		base10/oo/a: 9
		--assert 9 = new10/oo/a

	--test-- "inherit-11"
		base11: make object! [
			a: 1
			oo: make object! [
				f: func [][a]
			]
		]
		new11: make base11 [a: 2]
		--assert 1 = new11/oo/f

===end-group===

===start-group=== "external deep setting"

	--test-- "ext-1"
		p1: object [
		    a: 1
		    b: 2
		]

		p1/a: context [
			t: 99
			z: 128
			q: object [zz: 345 show: does [zz]]
		]
		--assert object? p1/a
		--assert p1/a/z = 128
		--assert p1/a/q/show = 345

	--test-- "ext-2"
		p1/a/t: does [123]
		--assert p1/a/t = 123

===end-group===

===start-group=== "dynamic invocation"

	--test-- "dyn-1"
		d: context [
			value: 998
		    f: does [value]
		]
		h: :d/f
		--assert h = 998
		d/value: 123
		--assert 123 = do [h]

	--test-- "dyn-2"
		f: func [/local z][
		    z: object [
		        a: 1
		        g: func [/with b /local c][c: 10 either with [a + b + 10][a * 2]]
		        j: func [i][i + 1]
		    ]
	    	z
		]
		o: make f [a: 3]
		--assert 46 = o/j 45
		--assert 101 = o/j 100

	--test-- "dyn-3"
		--assert 52 = o/j o/j 50

	--test-- "dyn-4"
		--assert 33 = o/g/with 20
		--assert 59 = o/g/with o/j 45

	--test-- "dyn-5"
		--assert 12 = o/j z: 5 + 6
		--assert  z = 11

	--test-- "dyn-6"
		--assert [17] = reduce [o/j o/j z: 5 + 10]
		--assert z = 15

	--test-- "dyn-7"
		repeat c 1 [
			if yes [
				--assert 52 = o/j o/j 50
				--assert 59 = o/g/with o/j 45
				--assert [22] = reduce [o/j o/j z: 5 + 15]
				--assert z = 20
			]
		]

	--test-- "dyn-8"
		o2: context [zz: none]				;-- test renaming a statically compiled object

		f: func [/alt][
			either alt [
				make object! [
					a: 10
					g: 123
				]
			][
				make object! [
					a: 1
					g: does [a]
				]
			]
		]
		o2: f
		--assert 1 = o2/g

	--test-- "dyn-9"
		o2: f/alt
		--assert 123 = o2/g

===end-group===

===start-group=== "copy"

	--test-- "copy-1"
		co1: make object! [a: 1]
		co2: copy co1
		co1/a: 2
		--assert 2 = co1/a
		--assert 1 = co2/a

	--test-- "copy-2"
		co1: make object! [
			a: 1
			f: func[][a]
		]
		co2: copy co1
		co1/a: 2
		--assert 2 = co1/f
		--assert 2 = co2/f

	--test-- "copy-3"
		co1: make object! [
			a: 1
			b: 2
			blk: [1 2 3 4]
		]
		co2: copy co1
		co1/blk/1: 5
		--assert 5 = co1/blk/1
		--assert 5 = co2/blk/1

	--test-- "copy-4"
		co1: make object! [
			a: 1
			b: 2
			blk: [1 2 3 4]
		]
		co2: copy/deep co1
		co1/blk/1: 5
		--assert 5 = co1/blk/1
		--assert 1 = co2/blk/1

	--test-- "copy-5"
		co1: make object! [
			a: 1
			s: "Silly old string"
			f: func [][
				[s a]
			]
		]
		co2: copy co1
		co1/a: 5
		co1/s/2: #"h"
		co1/s/3: #"i"
		co1/s/4: #"n"
		--assert "Shiny old string" = co1/s
		--assert "Shiny old string" = co2/s

	--test-- "copy-6"
		co1: make object! [
			a: 1
			s: "Silly old string"
		]
		co2: copy co1
		co1/a: 5
		co1/s/2: #"h"
		co1/s/3: #"i"
		co1/s/4: #"n"
		replace co1/s "old" "new"
		--assert "Shiny new string" = co1/s
		--assert "Shiny new string" = co2/s

	--test-- "copy-7"
		co5: make object! [
			a: 1
			s: ["Silly old string"]
		]
		co6: copy/deep co5
		co5/a: 5
		co5/s/2: #"h"
		co5/s/3: #"i"
		co5/s/4: #"n"
		replace co5/s "old" "new"
		--assert "Shiny new string" = co5/s
		--assert "Silly old string" = co6/s

	--test-- "copy-8"
		co1: make object! [
			s: "Silly old string"
			f: func[][s]
		]
		co2: copy co1
		co1/s/2: #"h"
		co1/s/3: #"i"
		co1/s/4: #"n"
		replace co1/s "old" "new"
		--assert "Shiny new string" = co1/f
		--assert "Shiny new string" = co2/f

	--test-- "copy-9"
		co1: make object! [
			s: "Silly old string"
			f: func[][s]
		]
		co2: copy/deep co1
		co1/s/2: #"h"
		co1/s/3: #"i"
		co1/s/4: #"n"
		replace co1/s "old" "new"
		--assert "Shiny new string" = co1/f
		--assert "Silly old string" = co2/f

	--test-- "copy-10"
		co1: make object! [
			a: 1
			f: func[][a]
		]
		co2: copy/deep co1
		co1/a: 2
		--assert 2 = co1/f
		--assert 1 = co2/f

	--test-- "copy-11"
		co1: make object! [
			a: 1
			oo: make object! [
				f: func[][a]
			]
		]
		co2: copy/deep co1
		co1/a: 2
		--assert 2 = co1/oo/f
		--assert 2 = co2/oo/f

	--test-- "copy-12"
		co1: make object! [
			a: 1
			oo: make object! [
				f: func[][a]
			]
		]
		co2: copy/deep co1
		co1/a: 2
		--assert 2 = co1/oo/f
		--assert 2 = co2/oo/f

===end-group===

===start-group=== "in"

	--test-- "in1"
		ino1: make object! [
			i: 1
			c: #"a"
			f: 1.0
			b: [1 2 3 4]
			s: "abcdef"
			o: make object! [
			]
		]
		--assert 'i = in ino1 'i
		--assert 'c = in ino1 'c
		--assert 'b = in ino1 'b
		--assert 'f = in ino1 'f
		--assert 's = in ino1 's
		--assert 'o = in ino1 'o

	--test-- "in2"
		ino1: make object! [
			i: 1
			c: #"a"
			f: 1.0
			b: [1 2 3 4]
			s: "abcdef"
			o: make object! [
				c: #"b"
				i: 2
				f: 2.0
				b: [5 6 7 8]
				s: "ghijkl"
				o: make object! [
				]
			]
		]
		--assert 'i = in ino1 'i
		--assert 'c = in ino1 'c
		--assert 'b = in ino1 'b
		--assert 'f = in ino1 'f
		--assert 's = in ino1 's
		--assert 'o = in ino1 'o
		--assert 'i = in ino1/o 'i
		--assert 'c = in ino1/o 'c
		--assert 'b = in ino1/o 'b
		--assert 'f = in ino1/o 'f
		--assert 's = in ino1/o 's
		--assert 'o = in ino1/o 'o

	--test-- "in3"
		ino1: make object! [
			i: 1
			c: #"a"
			f: 1.0
			b: [1 2 3 4]
			s: "abcdef"
			o: make object! [
				c: #"b"
				i: 2
				f: 2.0
				b: [5 6 7 8]
				s: "ghijkl"
				o: make object! [
					c: #"c"
					i: 3
					f: 3.0
					b: [9 10 11 12]
					s; "mnopqr"
					o: make object! [
					]
				]
			]
		]
		--assert 'i = in ino1 'i
		--assert 'c = in ino1 'c
		--assert 'b = in ino1 'b
		--assert 'f = in ino1 'f
		--assert 's = in ino1 's
		--assert 'o = in ino1 'o
		--assert 'i = in ino1/o 'i
		--assert 'c = in ino1/o 'c
		--assert 'b = in ino1/o 'b
		--assert 'f = in ino1/o 'f
		--assert 's = in ino1/o 's
		--assert 'o = in ino1/o 'o
		--assert 'i = in ino1/o/o 'i
		--assert 'c = in ino1/o/o 'c
		--assert 'b = in ino1/o/o 'b
		--assert 'f = in ino1/o/o 'f
		--assert 's = in ino1/o/o 's
		--assert 'o = in ino1/o/o 'o

		--test-- "in4"
		ino1: make object! [
			i: 1
			c: #"a"
			f: 1.0
			b: [1 2 3 4]
			s: "abcdef"
			o: make object! [
				c: #"b"
				i: 2
				f: 2.0
				b: [5 6 7 8]
				s: "ghijkl"
				o: make object! [
					c: #"c"
					i: 3
					f: 3.0
					b: [9 10 11 12]
					s; "mnopqr"
					o: make object! [
						c: #"d"
						f: 4.0
						i: 4
						b: [13 14 15 16]
						s: "stuvwx"
					]
				]
			]
		]
		--assert 'i = in ino1 'i
		--assert 'c = in ino1 'c
		--assert 'b = in ino1 'b
		--assert 'f = in ino1 'f
		--assert 's = in ino1 's
		--assert 'o = in ino1 'o
		--assert 'i = in ino1/o 'i
		--assert 'c = in ino1/o 'c
		--assert 'b = in ino1/o 'b
		--assert 'f = in ino1/o 'f
		--assert 's = in ino1/o 's
		--assert 'o = in ino1/o 'o
		--assert 'i = in ino1/o/o 'i
		--assert 'c = in ino1/o/o 'c
		--assert 'b = in ino1/o/o 'b
		--assert 'f = in ino1/o/o 'f
		--assert 's = in ino1/o/o 's
		--assert 'o = in ino1/o/o 'o
		--assert 'i = in ino1/o/o/o 'i
		--assert 'c = in ino1/o/o/o 'c
		--assert 'b = in ino1/o/o/o 'b
		--assert 'f = in ino1/o/o/o 'f
		--assert 's = in ino1/o/o/o 's

===end-group===

~~~end-file~~~

Red [
	Title:   "Red/System object! datatype test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %object-test.red
	Version: "0.1.0"
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2014 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~~~ "object"

===start-group=== "basic tests"

	--test-- "basic-1"
		obj1: context []
		--assert "make object! []" = mold obj1

	--test-- "basic-2"
		obj2: object []
		--assert "make object! []" = mold obj2

	--test-- "basic-3"
		obj3: make object! []
		--assert "make object! []" = mold obj3

	--test-- "basic-4"
		blk: []
		obj4: object blk
		--assert "make object! []" = mold obj4

	--test-- "basic-5"
		obj5: object [
			a: 123
			show: does [a + 1]
			reset: does [a: none]
			--assert show = 124
			--assert a = 123
		]
		--assert obj5/show = 124
		obj5/reset
		--assert none? obj5/a

	--test-- "basic-6"
		obj5/a: 456
		--assert obj5/a = 456

	--test-- "basic-7"
		--assert find obj5 'a
		--assert not find obj5 'z
		--assert 456 = select obj5 'a
		--assert none? select obj5 'z

	--test-- "basic-8"
		obj8: context [
			b: 123
			a: object [
				b: 456
				double: does [b * 2]
				set-b: does [b: 'hello]
			]
		]
		--assert obj8/b = 123
		--assert obj8/a/b = 456
		--assert obj8/a/double = 912
		obj8/a/set-b
		--assert obj8/a/b = 'hello

	--test-- "basic-9"
		obj8/a/b: 'red
		--assert obj8/a/b = 'red

	--test-- "basic-10"
		obj10: object [
			a: 1
			b: 2
			inc: func [i /with a][b: i + either with [a][b]]
			sub: context [
				a: 3
				b: 4
				inc: func [i /with a][b: i + either with [a][b]]
			]
		]
		--assert 12 = obj10/inc 10
		--assert obj10/b = 12

		--assert 14 = obj10/sub/inc 10
		--assert obj10/sub/b = 14

	--test-- "basic-11"
		--assert 30 = obj10/inc/with 10 20
		--assert obj10/b = 30

		--assert 50 = obj10/sub/inc/with 10 40
		--assert obj10/sub/b = 50

	--test-- "basic-12"
		blk: [a: 99]
		obj12: object blk
		--assert obj12/a = 99

===end-group===

===start-group=== "Comparison tests"

	--test-- "comp-1"  --assert 	(context [])	 = (context [])
	--test-- "comp-2"  --assert not (context [a: 1]) = (context [])
	--test-- "comp-3"  --assert 	(context [a: 1]) = (context [a: 1])
	--test-- "comp-4"  --assert not (context [a: 1]) = (context [a: 2])
	--test-- "comp-5"  --assert 	(context [a: 1]) < (context [a: 2])
	--test-- "comp-6"  --assert not (context [a: 1]) >= (context [a: 2])
	--test-- "comp-7"  --assert 	(context [a: 2]) < (context [a: 1 b: none])

	--test-- "comp-8"
		obj:  context [a: 123]
		obj2: context [a: 123]
		--assert obj = obj2
		--assert not same? obj obj2
		--assert same? obj obj

===end-group===

===start-group=== "SELF test"

	--test-- "self-1"
		obj: context [
			--assert "make object! []" = mold/flat self
		]

	--test-- "self-2"
		obj: context [
			a: 123
			--assert "make object! [a: 123 b: unset]" = mold/flat self
			b: 456
		]

	--test-- "self-3"
		result: {make object! [b: 123 c: "hello" show: func [][--assert object? self] foo: unset]}

		obj: object [
			b: 123
			c: "hello"
			show: does [--assert object? self]
			--assert result = mold/flat self
			foo: does [--assert object? self c: none]
			foo
		]
		obj/show
		--assert none? obj/c

	--test-- "self-4"
		p1: object [
		    a: 1
		    b: 2
		    e: does [self/b]
		    f: does [self/b: 789 self/e]
		    --assert self/e = 2
		]
		--assert p1/e = 2
		--assert p1/f = 789

===end-group===

===start-group=== "simple object tests"

	--test-- "simple object 1"
		so1-a: 0
		so1-o: make object! [so1-a: 1]
		--assert so1-a = 0
		--assert so1-o/so1-a = 1

	--test-- "simple object 2"
		so2-s: "0"
		so2-o: make object! [so2-s: "1"]
		--assert so2-s = "0"
		--assert so2-o/so2-s = "1"

	--test-- "simple object 3"
		so3-s: "0"
		so3-i: 0
		so3-l: true
		so3-c: #"a"
		so3-b: [a b c]
		so3-f: func [][0]
		so3-bs: charset #"^(00)"
		so3-o: make object! [
			so3-s: "1"
			so3-i: 1
			so3-l: false
			so3-c: #"b"
			so3-b: [a b d]
			so3-f: func [][1]
			so3-bs: charset #"^(01)"
		]
		--assert so3-s = "0"
		--assert so3-o/so3-s = "1"
		--assert so3-i = 0
		--assert so3-o/so3-i = 1
		--assert so3-l = true
		--assert so3-o/so3-l = false
		--assert so3-c = #"a"
		--assert so3-o/so3-c = #"b"
		--assert so3-b = [a b c]
		--assert so3-o/so3-b = [a b d]
		--assert so3-f = 0
		--assert so3-o/so3-f = 1
		--assert "make bitset! #{80}" = mold so3-bs
		--assert "make bitset! #{40}" = mold so3-o/so3-bs

===end-group===

===start-group=== "nested objects"

	--test-- "no1"
		no1-o: make object! [o: make object! [i: 1] ]
		--assert no1-o/o/i = 1

	--test-- "no2"
		no2-o1: make object! [
			o2: make object! [
				i: 1
			]
		]
		--assert no2-o1/o2/i = 1

	--test-- "no3"
		no3-o1: make object! [
			o2: make object! [
			o3: make object! [
			o4: make object! [
				i: 1
			]]]
		]
		--assert no3-o1/o2/o3/o4/i = 1

	--test-- "no4"
		no4-o1: make object! [
			o2: make object! [
			o3: make object! [
			o4: make object! [
			o5: make object! [
			o6: make object! [
			o7: make object! [
				i: 1
			]]]]]]
		]
		--assert no4-o1/o2/o3/o4/o5/o6/o7/i = 1

	--test-- "no5"
		no5-o1: make object! [
			o2: make object! [
			o3: make object! [
			o4: make object! [
			o5: make object! [
			o6: make object! [
			o7: make object! [
			o8: make object! [
			o9: make object! [
			o10: make object! [
			o11: make object! [
			o12: make object! [
			o13: make object! [
			o14: make object! [
			o15: make object! [
				i: 1
			]]]]]]]]]]]]]]
		]
		--assert no5-o1/o2/o3/o4/o5/o6/o7/o8/o9/o10/o11/o12/o13/o14/o15/i = 1

	--test-- "no6 issue #928"
		no6-o: make object! [
			a: 1
			o: make object! [
				b: 2
				f: does [a]
				]
			]
		--assert 1 = no6-o/o/f

===end-group===

===start-group=== "object prototype tests"

	--test-- "op1"
		op1-o1: make object! [i: 1]
		op1-o2: make op1-o1 []
		--assert op1-o2/i = 1

	--test-- "op2"
		op2-o1: make object! [i: 1]
		op2-o2: make op2-o1 [i: 2]
		--assert op2-o2/i = 2
		--assert op2-o1/i = 1

	--test-- "op3"
		op3-o1: make object! [i: 1]
		op3-o2: make op3-o1 [i: 2 j: 3]
		--assert op3-o2/i = 2
		--assert op3-o2/j = 3

===end-group===

===start-group=== "object initialisation processing"

	--test-- "oip1"
		oip1-i: 1
		oip1-o: make object! [
			i: oip1-i
		]
		--assert 1 = oip1-o/i

	--test-- "oip2"
		oip2-i: 1
		oip2-o: make object! [
			i: either oip2-i = 1 [2] [3]
		]
		--assert 2 = oip2-o/i

	--test-- "oip3"
		oip3-i: 1
		oip3-o: make object! [
			i: 0
			set 'oip3-i 2
		]
		--assert 2 = oip3-i

	--test-- "oip4"
		oip4-o: make object! [
			i: 0
			set 'oip4-i 3
		]
		--assert 3 = oip4-i

===end-group===

===start-group=== "inheritance"

	--test-- "inherit-1"
		proto: context [
			a: 123
			get-a: does [a]
		]
		new: make proto [a: 99]
		--assert new/a = 99
		--assert new/get-a = 99
		--assert proto/a = 123
		--assert proto/get-a = 123

	--test-- "inherit-2"
		new/a: 456
		--assert new/get-a = 456
		proto/a: 759
		--assert proto/a = 759
		--assert new/get-a = 456

	--test-- "inherit-3"
		newnew: make new [
			reset: does [a: none]
		]
		--assert newnew/a = 456
		newnew/reset
		--assert none? newnew/a
		--assert new/a = 456
		--assert proto/a = 759

	--test-- "inherit-4"
		base: context [
			v: 0
			foo: does [v]
		]

		i: 0
		list: []
		loop 2 [
			bb: make base [v: i]
			--assert bb/foo = i
			append list bb
			i: i + 1
		]
		--assert object? list/1
		--assert list/1/v = 0
		--assert list/2/v = 1

	--test-- "inherit-5"
		base5: context [
			b: 123
			get-b: does [b]
			a: object [
				b: 456
				double: does [b * 2]
				set-b: func [/with v] [b: either with [v]['hello]]
			]
		]
		proto5: context [
			b: 999
			value: 71
			foo: does [b + value]
		]
		new: make base5 proto5
		--assert object? new
		--assert new/b = 999
		--assert new/value = 71
		--assert new/a/b = 456
		--assert base5/b = 123

	--test-- "inherit-6"
		--assert new/get-b = 999
		--assert new/a/double = 912
		--assert new/a/set-b/with 10
		--assert new/a/b = 10
		--assert new/b = 999
		--assert base5/b = 123
		--assert new/a/double = 20
		--assert base5/a/double = 20

	--test-- "inherit-7"
		--assert same? new/a base5/a

	--test-- "inherit-8"
		--assert new/foo = 1070

	--test-- "inherit-9"
		base9: context [
			v: 123456
			show: does [v]
		]
		i: 100
		list: []
		loop 3 [
			new9: make base9 [v: i]
			--assert new9/v = i
			--assert new9/show = i
			append list new9
			i: i + 1
		]
		--assert base9/v = 123456
		--assert list/1/v = 100
		--assert list/2/v = 101
		--assert list/3/v = 102

	--test-- "inherit-10"
		base10: make object! [
			emb: make object! [
				a: 1
			]
		]
		new10: make base10 []
		base10/emb/a: 9
		--assert 9 = new10/emb/a

===end-group===

===start-group=== "external deep setting"

	--test-- "ext-1"
		p1: object [
		    a: 1
		    b: 2
		]

		p1/a: context [
			t: 99
			z: 128
			q: object [zz: 345 show: does [zz]]
		]
		--assert object? p1/a
		--assert p1/a/z = 128
		--assert p1/a/q/show = 345

	--test-- "ext-2"
		p1/a/t: does [123]
		--assert p1/a/t = 123

===end-group===

===start-group=== "dynamic invocation"

	--test-- "dyn-1"
		d: context [
			value: 998
		    f: does [value]
		]
		h: :d/f
		--assert h = 998
		d/value: 123
		--assert 123 = do [h]

	--test-- "dyn-2"
		f: func [/local z][
		    z: object [
		        a: 1
		        g: func [/with b /local c][c: 10 either with [a + b + 10][a * 2]]
		        j: func [i][i + 1]
		    ]
	    	z
		]
		o: make f [a: 3]
		--assert 46 = o/j 45
		--assert 101 = o/j 100

	--test-- "dyn-3"
		--assert 52 = o/j o/j 50

	--test-- "dyn-4"
		--assert 33 = o/g/with 20
		--assert 59 = o/g/with o/j 45

	--test-- "dyn-5"
		--assert 12 = o/j z: 5 + 6
		--assert  z = 11

	--test-- "dyn-6"
		--assert [17] = reduce [o/j o/j z: 5 + 10]
		--assert z = 15

	--test-- "dyn-7"
		repeat c 1 [
			if yes [
				--assert 52 = o/j o/j 50
				--assert 59 = o/g/with o/j 45
				--assert [22] = reduce [o/j o/j z: 5 + 15]
				--assert z = 20
			]
		]

	--test-- "dyn-8"
		o2: context [zz: none]				;-- test renaming a statically compiled object

		f: func [/alt][
			either alt [
				make object! [
					a: 10
					g: 123
				]
			][
				make object! [
					a: 1
					g: does [a]
				]
			]
		]
		o2: f
		--assert 1 = o2/g

	--test-- "dyn-9"
		o2: f/alt
		--assert 123 = o2/g

===end-group===

===start-group=== "copy"

	--test-- "copy-1"
		co1: make object! [a: 1]
		co2: copy co1
		co1/a: 2
		--assert 2 = co1/a
		--assert 1 = co2/a

	--test-- "copy-2"
		co1: make object! [
			a: 1
			f: func[][a]
		]
		co2: copy co1
		co1/a: 2
		--assert 2 = co1/f
		--assert 1 = co2/f

	--test-- "copy-3"
		co1: make object! [
			a: 1
			b: 2
			blk: [1 2 3 4]
		]
		co2: copy co1
		co1/blk/1: 5
		--assert 5 = co1/blk/1
		--assert 5 = co2/blk/1

	--test-- "copy-4"
		co1: make object! [
			a: 1
			b: 2
			blk: [1 2 3 4]
		]
		co2: copy/deep co1
		co1/blk/1: 5
		--assert 5 = co1/blk/1
		--assert 1 = co2/blk/1

	--test-- "copy-5"
		co1: make object! [
			a: 1
			s: "Silly old string"
			f: func [][
				[s a]
			]
		]
		co2: copy co1
		co1/a: 5
		co1/s/2: #"h"
		co1/s/3: #"i"
		co1/s/4: #"n"
		--assert "Shiny old string" = co1/s
		--assert "Shiny old string" = co2/s

	--test-- "copy-6"
		co1: make object! [
			a: 1
			s: "Silly old string"
		]
		co2: copy co1
		co1/a: 5
		co1/s/2: #"h"
		co1/s/3: #"i"
		co1/s/4: #"n"
		replace co1/s "old" "new"
		--assert "Shiny new string" = co1/s
		--assert "Shiny new string" = co2/s

	--test-- "copy-7"
		co5: make object! [
			a: 1
			s: ["Silly old string"]
		]
		co6: copy/deep co5
		co5/a: 5
		co5/s/2: #"h"
		co5/s/3: #"i"
		co5/s/4: #"n"
		replace co5/s "old" "new"
		--assert "Shiny new string" = co5/s
		--assert "Silly old string" = co6/s

	--test-- "copy-8"
		co1: make object! [
			s: "Silly old string"
			f: func[][s]
		]
		co2: copy co1
		co1/s/2: #"h"
		co1/s/3: #"i"
		co1/s/4: #"n"
		replace co1/s "old" "new"
		--assert "Shiny new string" = co1/f
		--assert "Shiny new string" = co2/f

	--test-- "copy-9"
		co1: make object! [
			s: "Silly old string"
			f: func[][s]
		]
		co2: copy/deep co1
		co1/s/2: #"h"
		co1/s/3: #"i"
		co1/s/4: #"n"
		replace co1/s "old" "new"
		--assert "Shiny new string" = co1/f
		--assert "Silly old string" = co2/f

===end-group===

===start-group=== "in"

	--test-- "in1"
		ino1: make object! [
			i: 1
			c: #"a"
			f: 1.0
			b: [1 2 3 4]
			s: "abcdef"
			o: make object! [
			]
		]
		--assert 'i = in ino1 'i
		--assert 'c = in ino1 'c
		--assert 'b = in ino1 'b
		--assert 'f = in ino1 'f
		--assert 's = in ino1 's
		--assert 'o = in ino1 'o

	--test-- "in2"
		ino1: make object! [
			i: 1
			c: #"a"
			f: 1.0
			b: [1 2 3 4]
			s: "abcdef"
			o: make object! [
				c: #"b"
				i: 2
				f: 2.0
				b: [5 6 7 8]
				s: "ghijkl"
				o: make object! [
				]
			]
		]
		--assert 'i = in ino1 'i
		--assert 'c = in ino1 'c
		--assert 'b = in ino1 'b
		--assert 'f = in ino1 'f
		--assert 's = in ino1 's
		--assert 'o = in ino1 'o
		--assert 'i = in ino1/o 'i
		--assert 'c = in ino1/o 'c
		--assert 'b = in ino1/o 'b
		--assert 'f = in ino1/o 'f
		--assert 's = in ino1/o 's
		--assert 'o = in ino1/o 'o

	--test-- "in3"
		ino1: make object! [
			i: 1
			c: #"a"
			f: 1.0
			b: [1 2 3 4]
			s: "abcdef"
			o: make object! [
				c: #"b"
				i: 2
				f: 2.0
				b: [5 6 7 8]
				s: "ghijkl"
				o: make object! [
					c: #"c"
					i: 3
					f: 3.0
					b: [9 10 11 12]
					s; "mnopqr"
					o: make object! [
					]
				]
			]
		]
		--assert 'i = in ino1 'i
		--assert 'c = in ino1 'c
		--assert 'b = in ino1 'b
		--assert 'f = in ino1 'f
		--assert 's = in ino1 's
		--assert 'o = in ino1 'o
		--assert 'i = in ino1/o 'i
		--assert 'c = in ino1/o 'c
		--assert 'b = in ino1/o 'b
		--assert 'f = in ino1/o 'f
		--assert 's = in ino1/o 's
		--assert 'o = in ino1/o 'o
		--assert 'i = in ino1/o/o 'i
		--assert 'c = in ino1/o/o 'c
		--assert 'b = in ino1/o/o 'b
		--assert 'f = in ino1/o/o 'f
		--assert 's = in ino1/o/o 's
		--assert 'o = in ino1/o/o 'o

		--test-- "in4"
		ino1: make object! [
			i: 1
			c: #"a"
			f: 1.0
			b: [1 2 3 4]
			s: "abcdef"
			o: make object! [
				c: #"b"
				i: 2
				f: 2.0
				b: [5 6 7 8]
				s: "ghijkl"
				o: make object! [
					c: #"c"
					i: 3
					f: 3.0
					b: [9 10 11 12]
					s; "mnopqr"
					o: make object! [
						c: #"d"
						f: 4.0
						i: 4
						b: [13 14 15 16]
						s: "stuvwx"
					]
				]
			]
		]
		--assert 'i = in ino1 'i
		--assert 'c = in ino1 'c
		--assert 'b = in ino1 'b
		--assert 'f = in ino1 'f
		--assert 's = in ino1 's
		--assert 'o = in ino1 'o
		--assert 'i = in ino1/o 'i
		--assert 'c = in ino1/o 'c
		--assert 'b = in ino1/o 'b
		--assert 'f = in ino1/o 'f
		--assert 's = in ino1/o 's
		--assert 'o = in ino1/o 'o
		--assert 'i = in ino1/o/o 'i
		--assert 'c = in ino1/o/o 'c
		--assert 'b = in ino1/o/o 'b
		--assert 'f = in ino1/o/o 'f
		--assert 's = in ino1/o/o 's
		--assert 'o = in ino1/o/o 'o
		--assert 'i = in ino1/o/o/o 'i
		--assert 'c = in ino1/o/o/o 'c
		--assert 'b = in ino1/o/o/o 'b
		--assert 'f = in ino1/o/o/o 'f
		--assert 's = in ino1/o/o/o 's

===end-group===

~~~end-file~~~


FEAT: forbid BREAK/CONTINUE to pass through function calls.

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 debug? = yes [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 debug? = yes [if verbose > 0 [log "infix detected!"]]
					infix?: yes
				]
			]
		]
	]
]

#define FETCH_ARGUMENT [
	if pc >= end [fire [TO_ERROR(script no-arg) fname value]]

	switch TYPE_OF(value) [
		TYPE_WORD [
			#if debug? = yes [if verbose > 0 [log "evaluating argument"]]
			pc: eval-expression pc end no yes
		]
		TYPE_GET_WORD [
			#if debug? = yes [if verbose > 0 [log "fetching argument as-is"]]
			stack/push pc
			pc: pc + 1
		]
		default [
			#if debug? = yes [if verbose > 0 [log "fetching argument"]]
			switch TYPE_OF(pc) [
				TYPE_GET_WORD [
					copy-cell _context/get as red-word! pc stack/push*
				]
				TYPE_PAREN [
					either TYPE_OF(value) = TYPE_LIT_WORD [
						stack/mark-native as red-word! pc	;@@ ~paren
						eval as red-block! pc yes
						stack/unwind
					][
						stack/push pc
					]
				]
				TYPE_GET_PATH [
					eval-path pc pc + 1 end no yes yes
				]
				default [
					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
	]

	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
	]

	set-locals: func [
		fun [red-function!]
		/local
			tail  [red-value!]
			value [red-value!]
			s	  [series!]
			set?  [logic!]
	][
		s: as series! fun/spec/value
		value: s/offset
		tail:  s/tail
		set?:  no

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					if set? [none/push]
				]
				TYPE_REFINEMENT [
					unless set? [set?: yes]
					logic/push false
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]
	]

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

		eval body yes

		ctx/values: saved
		in-func?: in-func? - 1
		switch system/thrown [
			RED_ERROR			   [throw RED_ERROR]			  ;-- let exception pass through
			RED_BREAK_EXCEPTION	   [fire [TO_ERROR(throw break)]]
			RED_CONTINUE_EXCEPTION [fire [TO_ERROR(throw continue)]]
			default [0]											  ;-- else, do nothing
		]
		system/thrown: 0
	]

	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!]
			fun	   [red-function!]
			infix? [logic!]
			op	   [red-op!]
			s	   [series!]
			node   [node!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value

		either op/header and body-flag <> 0 [
			node: as node! op/code
			s: as series! node/value
			fun: as red-function! s/offset + 3

			either TYPE_OF(fun) = TYPE_ROUTINE [
				exec-routine as red-routine! fun
			][
				set-locals fun
				eval-function fun as red-block! s/offset
			]
		][
			call-op: as function! [] op/code
			call-op
			0											;-- @@ to make compiler happy!
		]

		#if debug? = yes [
			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!]
		ref-pos [red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			expected  [red-value!]
			path-end  [red-value!]
			fname	  [red-word!]
			blk		  [red-block!]
			vec		  [red-vector!]
			bool	  [red-logic!]
			arg		  [red-value!]
			s		  [series!]
			required? [logic!]
			args	  [node!]
			p		  [int-ptr!]
			ref-array [int-ptr!]
			index	  [integer!]
			size	  [integer!]
			type	  [integer!]
			pos		  [byte-ptr!]
			bits 	  [byte-ptr!]
			set? 	  [logic!]
			ret-set?  [logic!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]
		fname:	   as red-word! pc - 1
		args:	   null

		either function? [
			fun: as red-function! native
			s: as series! fun/more/value
			blk: as red-block! s/offset + 1
			if TYPE_OF(blk) = TYPE_BLOCK [args: blk/node]
		][
			args: native/args
		]
		if null? args [
			args: _function/preprocess-spec native

			either function? [
				blk/header: TYPE_BLOCK
				blk/head:	0
				blk/node:	args
			][
				native/args: args
			]
		]

		unless null? path [
			path-end: block/rs-tail as red-block! path
			fname: as red-word! ref-pos

			if ref-pos + 1 < path-end [					;-- test if refinement are following the function
				either null? path/args [
					args: _function/preprocess-options native path ref-pos args fname function?
					path/args: args
				][
					args: path/args
				]
			]
		]

		s: as series! args/value
		value:	   s/offset
		tail:	   s/tail
		required?: yes
		index: 	   0

		while [value < tail][
			expected: value + 1

			if TYPE_OF(value) <> TYPE_SET_WORD [
				switch TYPE_OF(expected) [
					TYPE_TYPESET [
						either required? [
							bits: (as byte-ptr! expected) + 4
							BS_TEST_BIT(bits TYPE_UNSET set?)

							either all [set? pc >= end][ ;-- check for unset! spec
								unset/push
							][
								FETCH_ARGUMENT
								arg:  stack/top - 1
								type: TYPE_OF(arg)
								BS_TEST_BIT(bits type set?)
								unless set? [ERR_EXPECT_ARGUMENT(type index)]
								index: index + 1
							]
						][
							none/push
						]
					]
					TYPE_LOGIC [
						stack/push expected
						bool: as red-logic! expected
						required?: bool/value
					]
					TYPE_VECTOR [
						vec: as red-vector! expected
						s: GET_BUFFER(vec)
						p: as int-ptr! s/offset
						size: (as-integer (as int-ptr! s/tail) - p) / 4
						ref-array: system/stack/top - size
						system/stack/top: ref-array			;-- reserve space on native stack for refs array
						copy-memory as byte-ptr! ref-array as byte-ptr! p size * 4
					]
					default [assert false]				;-- trap it, if stack corrupted
				]
			]
			value: value + 2
		]

		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!]
		get?	[logic!]
		sub?	[logic!]
		return: [red-value!]
		/local
			path	[red-path!]
			head	[red-value!]
			tail	[red-value!]
			item	[red-value!]
			parent	[red-value!]
			gparent	[red-value!]
			saved	[red-value!]
			arg		[red-value!]
	][
		#if debug? = yes [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 [
				if set? [fire [TO_ERROR(script invalid-path-set) path]]
				if get? [fire [TO_ERROR(script invalid-path-get) path]]
				pc: eval-code parent pc end yes path item - 1 parent
				return pc
			]
			TYPE_UNSET [fire [TO_ERROR(script no-value)	head]]
			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 [fire [TO_ERROR(script no-value)	item]]
				TYPE_PAREN [
					stack/mark-native words/_body		;@@ ~paren
					eval as red-block! value yes		;-- eval paren content
					stack/unwind
					value: stack/top - 1
				]
				default [0]								;-- compilation pass-thru
			]
			#if debug? = yes [if verbose > 0 [print-line ["eval: path item: " TYPE_OF(value)]]]

			gparent: parent								;-- save grand-parent reference
			arg: either all [set? item + 1 = tail][stack/arguments][null]
			parent: actions/eval-path parent value arg

			unless get? [
				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 gparent
						return pc
					]
					default [0]
				]
			]
			item: item + 1
		]

		stack/top: saved
		either sub? [stack/push parent][stack/set-last parent]
		pc
	]

	eval-code: func [
		value	[red-value!]
		pc		[red-value!]
		end		[red-value!]
		sub?	[logic!]
		path	[red-path!]
		slot 	[red-value!]
		parent	[red-value!]
		return: [red-value!]
		/local
			name [red-word!]
			obj  [red-object!]
			fun	 [red-function!]
			int	 [red-integer!]
			s	 [series!]
			ctx	 [node!]
	][
		either null? slot [
			name: as red-word! pc - 1
			if TYPE_OF(name) <> TYPE_WORD [name: words/_anon]
		][
			name: as red-word! slot
		]
		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				#if debug? = yes [if verbose > 0 [log "pushing action/native frame"]]
				stack/mark-native name
				pc: eval-arguments as red-native! value pc end path slot 	;-- fetch args and exec
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					if verbose > 0 [
						value: stack/arguments
						print-line ["eval: action/native return type: " TYPE_OF(value)]
					]
				]
			]
			TYPE_ROUTINE [
				#if debug? = yes [if verbose > 0 [log "pushing routine frame"]]
				stack/mark-native name
				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 debug? = yes [
					if verbose > 0 [
						value: stack/arguments
						print-line ["eval: routine return type: " TYPE_OF(value)]
					]
				]
			]
			TYPE_FUNCTION [
				#if debug? = yes [if verbose > 0 [log "pushing function frame"]]
				obj: as red-object! parent
				ctx: either all [
					parent <> null
					TYPE_OF(parent) = TYPE_OBJECT
				][
					obj/ctx
				][
					fun: as red-function! value
					s: as series! fun/more/value
					int: as red-integer! s/offset + 4
					either TYPE_OF(int) = TYPE_INTEGER [
						ctx: as node! int/value
					][
						name/ctx						;-- get a context from calling name
					]
				]
				stack/mark-func name
				pc: eval-arguments as red-native! value pc end path slot
				_function/call as red-function! value ctx
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					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 debug? = yes [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 words/_body
				eval as red-block! pc yes
				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
				if pc >= end [fire [TO_ERROR(script need-value) pc - 1]]
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					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 no sub?
			]
			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 debug? = yes [
					if verbose > 0 [
						print "eval: '"
						print-symbol as red-word! pc
						print lf
					]
				]
				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 [
								unset/push-last
							][
								pc: eval-expression pc end no yes
								stack/set-last stack/top - 1
							]
							stack/unroll stack/FLAG_FUNCTION
							throw THROWN_RETURN
						]
						true [0]
					]
				]
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_UNSET [
						fire [
							TO_ERROR(script no-value)
							pc - 1
						]
					]
					TYPE_LIT_WORD [
						word/push as red-word! value	;-- push lit-word! on stack
					]
					TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null value
					]
					default [
						#if debug? = yes [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 debug? = yes [
							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 no sub?
			]
			TYPE_GET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no yes sub?
			]
			TYPE_LIT_PATH [
				value: stack/push pc
				value/header: TYPE_PATH
				pc: pc + 1
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
			TYPE_NATIVE
			TYPE_ROUTINE
			TYPE_FUNCTION [
				value: pc + 1
				if value >= end [value: end]
				pc: eval-code pc value end sub? null null null
			]
			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!]
		chain? [logic!]									;-- chain it with previous stack frame
		/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-eval words/_body					;-- outer stack frame

		while [value < tail][
			#if debug? = yes [if verbose > 0 [log "root loop..."]]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]
		either chain? [stack/unwind-last][stack/unwind]
	]

]

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 debug? = yes [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 debug? = yes [if verbose > 0 [log "infix detected!"]]
					infix?: yes
				]
			]
		]
	]
]

#define FETCH_ARGUMENT [
	if pc >= end [fire [TO_ERROR(script no-arg) fname value]]

	switch TYPE_OF(value) [
		TYPE_WORD [
			#if debug? = yes [if verbose > 0 [log "evaluating argument"]]
			pc: eval-expression pc end no yes
		]
		TYPE_GET_WORD [
			#if debug? = yes [if verbose > 0 [log "fetching argument as-is"]]
			stack/push pc
			pc: pc + 1
		]
		default [
			#if debug? = yes [if verbose > 0 [log "fetching argument"]]
			switch TYPE_OF(pc) [
				TYPE_GET_WORD [
					copy-cell _context/get as red-word! pc stack/push*
				]
				TYPE_PAREN [
					either TYPE_OF(value) = TYPE_LIT_WORD [
						stack/mark-native as red-word! pc	;@@ ~paren
						eval as red-block! pc yes
						stack/unwind
					][
						stack/push pc
					]
				]
				TYPE_GET_PATH [
					eval-path pc pc + 1 end no yes yes
				]
				default [
					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
	]

	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
	]

	set-locals: func [
		fun [red-function!]
		/local
			tail  [red-value!]
			value [red-value!]
			s	  [series!]
			set?  [logic!]
	][
		s: as series! fun/spec/value
		value: s/offset
		tail:  s/tail
		set?:  no

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					if set? [none/push]
				]
				TYPE_REFINEMENT [
					unless set? [set?: yes]
					logic/push false
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]
	]

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

		eval body yes

		ctx/values: saved
		in-func?: in-func? - 1
		switch system/thrown [
			RED_ERROR			   [throw RED_ERROR]			  ;-- let exception pass through
			RED_BREAK_EXCEPTION	   [throw RED_BREAK_EXCEPTION]	  ;-- let exception pass through
			RED_CONTINUE_EXCEPTION [throw RED_CONTINUE_EXCEPTION] ;-- let exception pass through
			default [0]											  ;-- do nothing else
		]
		system/thrown: 0
	]

	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!]
			fun	   [red-function!]
			infix? [logic!]
			op	   [red-op!]
			s	   [series!]
			node   [node!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value

		either op/header and body-flag <> 0 [
			node: as node! op/code
			s: as series! node/value
			fun: as red-function! s/offset + 3

			either TYPE_OF(fun) = TYPE_ROUTINE [
				exec-routine as red-routine! fun
			][
				set-locals fun
				eval-function fun as red-block! s/offset
			]
		][
			call-op: as function! [] op/code
			call-op
			0											;-- @@ to make compiler happy!
		]

		#if debug? = yes [
			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!]
		ref-pos [red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			expected  [red-value!]
			path-end  [red-value!]
			fname	  [red-word!]
			blk		  [red-block!]
			vec		  [red-vector!]
			bool	  [red-logic!]
			arg		  [red-value!]
			s		  [series!]
			required? [logic!]
			args	  [node!]
			p		  [int-ptr!]
			ref-array [int-ptr!]
			index	  [integer!]
			size	  [integer!]
			type	  [integer!]
			pos		  [byte-ptr!]
			bits 	  [byte-ptr!]
			set? 	  [logic!]
			ret-set?  [logic!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]
		fname:	   as red-word! pc - 1
		args:	   null

		either function? [
			fun: as red-function! native
			s: as series! fun/more/value
			blk: as red-block! s/offset + 1
			if TYPE_OF(blk) = TYPE_BLOCK [args: blk/node]
		][
			args: native/args
		]
		if null? args [
			args: _function/preprocess-spec native

			either function? [
				blk/header: TYPE_BLOCK
				blk/head:	0
				blk/node:	args
			][
				native/args: args
			]
		]

		unless null? path [
			path-end: block/rs-tail as red-block! path
			fname: as red-word! ref-pos

			if ref-pos + 1 < path-end [					;-- test if refinement are following the function
				either null? path/args [
					args: _function/preprocess-options native path ref-pos args fname function?
					path/args: args
				][
					args: path/args
				]
			]
		]

		s: as series! args/value
		value:	   s/offset
		tail:	   s/tail
		required?: yes
		index: 	   0

		while [value < tail][
			expected: value + 1

			if TYPE_OF(value) <> TYPE_SET_WORD [
				switch TYPE_OF(expected) [
					TYPE_TYPESET [
						either required? [
							bits: (as byte-ptr! expected) + 4
							BS_TEST_BIT(bits TYPE_UNSET set?)

							either all [set? pc >= end][ ;-- check for unset! spec
								unset/push
							][
								FETCH_ARGUMENT
								arg:  stack/top - 1
								type: TYPE_OF(arg)
								BS_TEST_BIT(bits type set?)
								unless set? [ERR_EXPECT_ARGUMENT(type index)]
								index: index + 1
							]
						][
							none/push
						]
					]
					TYPE_LOGIC [
						stack/push expected
						bool: as red-logic! expected
						required?: bool/value
					]
					TYPE_VECTOR [
						vec: as red-vector! expected
						s: GET_BUFFER(vec)
						p: as int-ptr! s/offset
						size: (as-integer (as int-ptr! s/tail) - p) / 4
						ref-array: system/stack/top - size
						system/stack/top: ref-array			;-- reserve space on native stack for refs array
						copy-memory as byte-ptr! ref-array as byte-ptr! p size * 4
					]
					default [assert false]				;-- trap it, if stack corrupted
				]
			]
			value: value + 2
		]

		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!]
		get?	[logic!]
		sub?	[logic!]
		return: [red-value!]
		/local
			path	[red-path!]
			head	[red-value!]
			tail	[red-value!]
			item	[red-value!]
			parent	[red-value!]
			gparent	[red-value!]
			saved	[red-value!]
			arg		[red-value!]
	][
		#if debug? = yes [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 [
				if set? [fire [TO_ERROR(script invalid-path-set) path]]
				if get? [fire [TO_ERROR(script invalid-path-get) path]]
				pc: eval-code parent pc end yes path item - 1 parent
				return pc
			]
			TYPE_UNSET [fire [TO_ERROR(script no-value)	head]]
			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 [fire [TO_ERROR(script no-value)	item]]
				TYPE_PAREN [
					stack/mark-native words/_body		;@@ ~paren
					eval as red-block! value yes		;-- eval paren content
					stack/unwind
					value: stack/top - 1
				]
				default [0]								;-- compilation pass-thru
			]
			#if debug? = yes [if verbose > 0 [print-line ["eval: path item: " TYPE_OF(value)]]]

			gparent: parent								;-- save grand-parent reference
			arg: either all [set? item + 1 = tail][stack/arguments][null]
			parent: actions/eval-path parent value arg

			unless get? [
				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 gparent
						return pc
					]
					default [0]
				]
			]
			item: item + 1
		]

		stack/top: saved
		either sub? [stack/push parent][stack/set-last parent]
		pc
	]

	eval-code: func [
		value	[red-value!]
		pc		[red-value!]
		end		[red-value!]
		sub?	[logic!]
		path	[red-path!]
		slot 	[red-value!]
		parent	[red-value!]
		return: [red-value!]
		/local
			name [red-word!]
			obj  [red-object!]
			fun	 [red-function!]
			int	 [red-integer!]
			s	 [series!]
			ctx	 [node!]
	][
		either null? slot [
			name: as red-word! pc - 1
			if TYPE_OF(name) <> TYPE_WORD [name: words/_anon]
		][
			name: as red-word! slot
		]
		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				#if debug? = yes [if verbose > 0 [log "pushing action/native frame"]]
				stack/mark-native name
				pc: eval-arguments as red-native! value pc end path slot 	;-- fetch args and exec
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					if verbose > 0 [
						value: stack/arguments
						print-line ["eval: action/native return type: " TYPE_OF(value)]
					]
				]
			]
			TYPE_ROUTINE [
				#if debug? = yes [if verbose > 0 [log "pushing routine frame"]]
				stack/mark-native name
				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 debug? = yes [
					if verbose > 0 [
						value: stack/arguments
						print-line ["eval: routine return type: " TYPE_OF(value)]
					]
				]
			]
			TYPE_FUNCTION [
				#if debug? = yes [if verbose > 0 [log "pushing function frame"]]
				obj: as red-object! parent
				ctx: either all [
					parent <> null
					TYPE_OF(parent) = TYPE_OBJECT
				][
					obj/ctx
				][
					fun: as red-function! value
					s: as series! fun/more/value
					int: as red-integer! s/offset + 4
					either TYPE_OF(int) = TYPE_INTEGER [
						ctx: as node! int/value
					][
						name/ctx						;-- get a context from calling name
					]
				]
				stack/mark-func name
				pc: eval-arguments as red-native! value pc end path slot
				_function/call as red-function! value ctx
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					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 debug? = yes [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 words/_body
				eval as red-block! pc yes
				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
				if pc >= end [fire [TO_ERROR(script need-value) pc - 1]]
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					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 no sub?
			]
			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 debug? = yes [
					if verbose > 0 [
						print "eval: '"
						print-symbol as red-word! pc
						print lf
					]
				]
				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 [
								unset/push-last
							][
								pc: eval-expression pc end no yes
								stack/set-last stack/top - 1
							]
							stack/unroll stack/FLAG_FUNCTION
							throw THROWN_RETURN
						]
						true [0]
					]
				]
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_UNSET [
						fire [
							TO_ERROR(script no-value)
							pc - 1
						]
					]
					TYPE_LIT_WORD [
						word/push as red-word! value	;-- push lit-word! on stack
					]
					TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null value
					]
					default [
						#if debug? = yes [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 debug? = yes [
							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 no sub?
			]
			TYPE_GET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no yes sub?
			]
			TYPE_LIT_PATH [
				value: stack/push pc
				value/header: TYPE_PATH
				pc: pc + 1
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
			TYPE_NATIVE
			TYPE_ROUTINE
			TYPE_FUNCTION [
				value: pc + 1
				if value >= end [value: end]
				pc: eval-code pc value end sub? null null null
			]
			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!]
		chain? [logic!]									;-- chain it with previous stack frame
		/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-eval words/_body					;-- outer stack frame

		while [value < tail][
			#if debug? = yes [if verbose > 0 [log "root loop..."]]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]
		either chain? [stack/unwind-last][stack/unwind]
	]

]


TESTS: changed the bitset indexes to be 0-based and simplified the bitset words naming.

Red [
	Title:   "Red local contexts binding test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %bitset-test.red
	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"
]

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

~~~start-file~~~ "bitset"

===start-group=== "basic tests"

	--test-- "basic-bitset-1"
		bs: make bitset! [0 1 2 3]
		--assert true = pick bs 0
		--assert true = pick bs 1
		--assert true = pick bs 2
		--assert true = pick bs 3
		--assert false = pick bs 4
		--assert false = pick bs 256
		--assert false = pick bs 257
		--assert false = pick bs 2147483647
		--assert false = pick bs -2147483648

===end-group===

===start-group=== "poke"

	--test-- "poke-1"
		bs: make bitset! [0 1 2 3]
		poke bs 4 true
		--assert true = pick bs 0
		--assert true = pick bs 1
		--assert true = pick bs 2
		--assert true = pick bs 3
		--assert true = pick bs 4
		--assert false = pick bs 5

===end-group===

~~~end-file~~~

Red [
	Title:   "Red local contexts binding test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %bitset-test.red
	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"
]

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

~~~start-file~~~ "bitset"

===start-group=== "basic tests"

	--test-- "basic-bitset-1"
		bb-1-bs: make bitset! [0 1 2 3]
		--assert true = pick bb-1-bs 1
		--assert true = pick bb-1-bs 2
		--assert true = pick bb-1-bs 3
		--assert true = pick bb-1-bs 4
		--assert false = pick bb-1-bs 5
		--assert false = pick bb-1-bs 256
		--assert false = pick bb-1-bs 257
		--assert false = pick bb-1-bs 2147483647
		--assert false = pick bb-1-bs -2147483648

===end-group===

===start-group=== "poke"

	--test "poke-1"
		p-1-bs: make bitset! [0 1 2 3]
		poke p-1-bs 5 true
		--assert true = pick p-1-bs 1
		--assert true = pick p-1-bs 2
		--assert true = pick p-1-bs 3
		--assert true = pick p-1-bs 4
		--assert true = pick p-1-bs 5
		--assert false = pick p-1-bs 6

===end-group===

~~~end-file~~~