TESTS: fix error in bitset-test.reds

TESTS: fix error in bitset-test.reds

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

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


FIX: refactor form-type in common.reds

FIX: refactor form-type in common.reds

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

#define zero? 		  [0 =]
#define positive?	  [0 < ]				;-- space required after the lesser-than symbol
#define negative?	  [0 > ]
#define negate		  [0 -]
#define null?		  [null =]

#define forever		  [while [true]]
#define does		  [func []]
#define unless		  [if not]
#define	raise-error	  ***-on-quit

#define as-byte		  [as byte!]
#define as-logic	  [as logic!]
#define as-integer	  [as integer!]
#define as-c-string	  [as c-string!]

#define null-byte	  #"^(00)"
#define yes			  true
#define no			  false
#define on			  true
#define off			  false

#define byte-ptr!	  [pointer! [byte!]]
#define int-ptr!	  [pointer! [integer!]]
#define make-c-string [as c-string! allocate]

#define type-logic!		1					;-- type ID list for 'typeinfo attribut
#define type-integer!	2
#define type-byte!	    3
#define type-c-string!  4
#define type-byte-ptr!  5
#define type-int-ptr!	6
#define type-function!	7
#define type-struct!	1000
#define type-alias!?  [999 <=]
#define any-struct?		[1000 <=]

;-- Global variables definition --
stdout:		-1								;-- uninitialized default value
stdin:		-1								;-- uninitialized default value
stderr:		-1								;-- uninitialized default value

str-array!: alias struct! [
	item [c-string!]
]

typed-value!: alias struct! [
	value	[integer!]
	type	[integer!]
]

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

system: declare struct! [					;-- store runtime accessible system values
	args-count	[integer!]					;-- command-line arguments count (do not move member)
	args-list	[str-array!]				;-- command-line arguments array pointer (do not move member)
	env-vars 	[str-array!]				;-- environment variables array pointer (always null for Windows)
	stack		[__stack!]					;-- stack virtual access
	pc			[byte-ptr!]					;-- CPU program counter value
	alias		[integer!]					;-- aliases ID virtual access
]

;-------------------------------------------
;-- Convert a type ID to a c-string!
;-------------------------------------------
form-type: func [
	type 	[integer!]				  		;-- type ID
	return: [c-string!]						;-- type representation as c-string
][
	if type = type-integer!    [return "integer!"]
	if type = type-c-string!   [return "c-string!"]
	if type = type-logic! 	   [return "logic!"]
	if type = type-byte! 	     [return "byte!"]
	if type = type-byte-ptr!   [return "pointer! [byte!]"]
	if type = type-int-ptr!    [return "pointer! [integer!]"]
	if type = type-struct!     [return "struct!"]
	if type = type-function!   [return "function!"]
	if type-alias!? type       [return "alias"]
	"not valid type"
]

#switch OS [
	Windows  [#define LIBC-file	"msvcrt.dll"]
	Syllable [#define LIBC-file	"libc.so.2"]
	MacOSX	 [#define LIBC-file	"libc.dylib"]
	#default [
		#either config-name = 'Android [	;-- @@ see if declaring it as an OS wouldn't be too costly
			#define LIBC-file	"libc.so"
		][
			#define LIBC-file	"libc.so.6"	;-- Linux
		]
	]
]

#either use-natives? = no [					;-- C bindings or native counterparts
	#include %lib-C.reds
][
	#include %lib-natives.reds
]

#switch OS [								;-- loading OS-specific bindings
	Windows  [#include %win32.reds]
	Syllable [#include %syllable.reds]
	MacOSX	 [#include %darwin.reds]
	#default [#include %linux.reds]
]

#include %utils.reds						;-- load additional utility functions

#if debug? = yes [#include %debug.reds]		;-- loads optionally debug functions

;-- Run-time error handling --

#define RED_ERR_VMEM_RELEASE_FAILED		96
#define RED_ERR_VMEM_OUT_OF_MEMORY		97

***-on-quit: func [							;-- global exit handler
	status [integer!]
	address [integer!]
	/local msg
][
	unless zero? status [
		print [lf "*** Runtime Error " status ": "]

		if status =  1 [msg: "access violation"]
		if status =  2 [msg: "invalid alignment"]
		if status =  3 [msg: "breakpoint"]
		if status =  4 [msg: "single step"]
		if status =  5 [msg: "bounds exceeded"]
		if status =  6 [msg: "float denormal operan"]
		if status =  7 [msg: "float divide by zero"]
		if status =  8 [msg: "float inexact result"]
		if status =  9 [msg: "float invalid operation"]
		if status = 10 [msg: "float overflow"]
		if status = 11 [msg: "float stack check"]
		if status = 12 [msg: "float underflow"]
		if status = 13 [msg: "integer divide by zero"]
		if status = 14 [msg: "integer overflow"]
		if status = 15 [msg: "privileged instruction"]
		if status = 16 [msg: "invalid virtual address"]
		if status = 17 [msg: "illegal instruction"]
		if status = 18 [msg: "non-continuable exception"]
		if status = 19 [msg: "stack error or overflow"]
		if status = 20 [msg: "invalid disposition"]
		if status = 21 [msg: "guard page"]
		if status = 22 [msg: "invalid handle"]
		if status = 23 [msg: "illegal operand"]
		if status = 24 [msg: "illegal addressing mode"]
		if status = 25 [msg: "illegal trap"]
		if status = 26 [msg: "coprocessor error"]
		if status = 27 [msg: "non-existant physical address"]
		if status = 28 [msg: "object specific hardware error"]
		if status = 29 [msg: "hardware memory error consumed AR"]
		if status = 30 [msg: "hardware memory error consumed AO"]
		if status = 31 [msg: "privileged register"]

		if status = 96 [msg: "virtual memory release failed"]
		if status = 97 [msg: "out of memory"]
		if status = 98 [msg: "assertion failed"]
		if status = 99 [msg: "unknown error"]

		print msg

		#either debug? = yes [
			__print-debug-line as byte-ptr! address
		][
			print [lf "*** at: " as byte-ptr! address "h" lf]
		]
	]

	#if OS = 'Windows [						;-- special exit handler for Windows
		***-on-win32-quit
	]
	quit status
]

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

#define zero? 		  [0 =]
#define positive?	  [0 < ]				;-- space required after the lesser-than symbol
#define negative?	  [0 > ]
#define negate		  [0 -]
#define null?		  [null =]

#define forever		  [while [true]]
#define does		  [func []]
#define unless		  [if not]
#define	raise-error	  ***-on-quit

#define as-byte		  [as byte!]
#define as-logic	  [as logic!]
#define as-integer	  [as integer!]
#define as-c-string	  [as c-string!]

#define null-byte	  #"^(00)"
#define yes			  true
#define no			  false
#define on			  true
#define off			  false

#define byte-ptr!	  [pointer! [byte!]]
#define int-ptr!	  [pointer! [integer!]]
#define make-c-string [as c-string! allocate]

#define type-logic!		1					;-- type ID list for 'typeinfo attribut
#define type-integer!	2
#define type-byte!	    3
#define type-c-string!  4
#define type-byte-ptr!  5
#define type-int-ptr!	6
#define type-function!	7
#define type-struct!	1000
#define any-struct?		[1000 <=]

;-- Global variables definition --
stdout:		-1								;-- uninitialized default value
stdin:		-1								;-- uninitialized default value
stderr:		-1								;-- uninitialized default value

str-array!: alias struct! [
	item [c-string!]
]

typed-value!: alias struct! [
	value	[integer!]
	type	[integer!]
]

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

system: declare struct! [					;-- store runtime accessible system values
	args-count	[integer!]					;-- command-line arguments count (do not move member)
	args-list	[str-array!]				;-- command-line arguments array pointer (do not move member)
	env-vars 	[str-array!]				;-- environment variables array pointer (always null for Windows)
	stack		[__stack!]					;-- stack virtual access
	pc			[byte-ptr!]					;-- CPU program counter value
	alias		[integer!]					;-- aliases ID virtual access
]

;-------------------------------------------
;-- Convert a type ID to a c-string!
;-------------------------------------------
form-type: func [
	type 	[integer!]						;-- type ID
	return: [c-string!]						;-- type representation as c-string
	/local msg
][
	if type = type-logic! 	 [msg: "logic!"]
	if type = type-integer!  [msg: "integer!"]
	if type = type-byte! 	 [msg: "byte!"]
	if type = type-c-string! [msg: "c-string!"]
	if type = type-byte-ptr! [msg: "pointer! [byte!]"]
	if type = type-int-ptr!  [msg: "pointer! [integer!]"]
	if type = type-struct!   [msg: "struct!"]
	if type = type-function! [msg: "function!"]
	if type > 1000 [msg: "alias"]
	msg
]

#switch OS [
	Windows  [#define LIBC-file	"msvcrt.dll"]
	Syllable [#define LIBC-file	"libc.so.2"]
	MacOSX	 [#define LIBC-file	"libc.dylib"]
	#default [
		#either config-name = 'Android [	;-- @@ see if declaring it as an OS wouldn't be too costly
			#define LIBC-file	"libc.so"
		][
			#define LIBC-file	"libc.so.6"	;-- Linux
		]
	]
]

#either use-natives? = no [					;-- C bindings or native counterparts
	#include %lib-C.reds
][
	#include %lib-natives.reds
]

#switch OS [								;-- loading OS-specific bindings
	Windows  [#include %win32.reds]
	Syllable [#include %syllable.reds]
	MacOSX	 [#include %darwin.reds]
	#default [#include %linux.reds]
]

#include %utils.reds						;-- load additional utility functions

#if debug? = yes [#include %debug.reds]		;-- loads optionally debug functions

;-- Run-time error handling --

#define RED_ERR_VMEM_RELEASE_FAILED		96
#define RED_ERR_VMEM_OUT_OF_MEMORY		97

***-on-quit: func [							;-- global exit handler
	status [integer!]
	address [integer!]
	/local msg
][
	unless zero? status [
		print [lf "*** Runtime Error " status ": "]

		if status =  1 [msg: "access violation"]
		if status =  2 [msg: "invalid alignment"]
		if status =  3 [msg: "breakpoint"]
		if status =  4 [msg: "single step"]
		if status =  5 [msg: "bounds exceeded"]
		if status =  6 [msg: "float denormal operan"]
		if status =  7 [msg: "float divide by zero"]
		if status =  8 [msg: "float inexact result"]
		if status =  9 [msg: "float invalid operation"]
		if status = 10 [msg: "float overflow"]
		if status = 11 [msg: "float stack check"]
		if status = 12 [msg: "float underflow"]
		if status = 13 [msg: "integer divide by zero"]
		if status = 14 [msg: "integer overflow"]
		if status = 15 [msg: "privileged instruction"]
		if status = 16 [msg: "invalid virtual address"]
		if status = 17 [msg: "illegal instruction"]
		if status = 18 [msg: "non-continuable exception"]
		if status = 19 [msg: "stack error or overflow"]
		if status = 20 [msg: "invalid disposition"]
		if status = 21 [msg: "guard page"]
		if status = 22 [msg: "invalid handle"]
		if status = 23 [msg: "illegal operand"]
		if status = 24 [msg: "illegal addressing mode"]
		if status = 25 [msg: "illegal trap"]
		if status = 26 [msg: "coprocessor error"]
		if status = 27 [msg: "non-existant physical address"]
		if status = 28 [msg: "object specific hardware error"]
		if status = 29 [msg: "hardware memory error consumed AR"]
		if status = 30 [msg: "hardware memory error consumed AO"]
		if status = 31 [msg: "privileged register"]

		if status = 96 [msg: "virtual memory release failed"]
		if status = 97 [msg: "out of memory"]
		if status = 98 [msg: "assertion failed"]
		if status = 99 [msg: "unknown error"]

		print msg

		#either debug? = yes [
			__print-debug-line as byte-ptr! address
		][
			print [lf "*** at: " as byte-ptr! address "h" lf]
		]
	]

	#if OS = 'Windows [						;-- special exit handler for Windows
		***-on-win32-quit
	]
	quit status
]


TESTS: missing end of group marker.

TESTS: missing end of group marker.

Red/System [
	Title:   "Red/System pointer! datatype test script"
	Author:  "Nenad Rakocevic"
	File: 	 %pointer-test.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "pointer!"

===start-group=== "Pointers simple read/write tests"

	--test-- "pointer-rw-1"
	p-struct: declare struct! [n [integer!] m [integer!]]
	pA: declare pointer! [integer!]
	pB: declare pointer! [integer!]

	p-struct/n: 123
	--assert p-struct/n = 123

	--test-- "pointer-rw-2"
	pA: as [pointer! [integer!]] p-struct
	pA/value: 987
	--assert p-struct/n = 987
	pA/1: 987
	--assert p-struct/n = 987

	--test-- "pointer-rw-3"
	p-struct/n: 12345
	--assert pA/value = 12345
	--assert pA/1 = 12345

	--test-- "pointer-rw-4"
	p-int: 456789
	pA/2: p-int
	--assert p-struct/m = p-int
	--assert p-struct/n = 12345			;-- look for memory corruption

	--test-- "pointer-rw-5"
	p-idx: 1
	pA/p-idx: 1234567890
	--assert p-struct/n = 1234567890

	--test-- "pointer-rw-6"
	p-idx: 2
	pA/p-idx: 963
	--assert p-struct/n = 1234567890
	--assert p-struct/m = 963

	--test-- "pointer-rw-7"
	p-struct/n: 12345
	p-int: 147258
	p-struct/m: p-int
	--assert pA/2 = p-int
	--assert p-struct/n = 12345			;-- look for memory corruption

	--test-- "pointer-rw-8"
	pB: pA
	--assert pB/value = 12345

	--test-- "pointer-rw-9"
	foo-pointer: func [
		a [pointer! [integer!]]
		return: [pointer! [integer!]]
	][
		a
	]

	pB: foo-pointer pA
	--assert pB/value = 12345

	pointer-str: declare struct! [
		A [pointer! [integer!]]
		B [pointer! [integer!]]
		sub [
			struct! [
				C [pointer! [integer!]]
			]
		]
	]
	pointer-str/sub: declare struct! [C [pointer! [integer!]]]

	--test-- "pointer-rw-10"
	pointer-str/A: pA
	--assert pointer-str/A/value = 12345

	--test-- "pointer-rw-11"
	pointer-str/A/value: 258369147
	--assert p-struct/n = 258369147
	--assert p-struct/m = p-int				;-- look for memory corruption

	--test-- "pointer-rw-12"
	pointer-str/sub/C: pA
	--assert pointer-str/sub/C/value = 258369147

	--test-- "pointer-rw-13"
	pointer-str/sub/C/2: 987654321
	--assert p-struct/m = 987654321

	--test-- "pointer-rw-14"
	b-pointer: declare pointer! [byte!]
	b-str: "hello"
	b-pointer: as [pointer! [byte!]] b-str
	--assert b-pointer/value = #"h"

	--test-- "pointer-rw-15"
	foo-b-pointer: func [
		a [pointer! [byte!]]
		return: [pointer! [byte!]]
	][
		a
	]
	b-pointer2: declare pointer! [byte!]

	b-pointer2: foo-b-pointer b-pointer
	--assert b-pointer2/value = #"h"

===end-group===

===start-group=== "Pointers arithmetic"

	--test-- "pointer-calc-1"
	pa-struct: declare struct! [n [integer!] m [integer!] p [integer!] o [integer!]]
	pA: declare pointer! [integer!]
	pB: declare pointer! [integer!]

	pA: as [pointer! [integer!]] pa-struct
	pa-struct/n: 123456789
	pa-struct/m: 987654321
	--assert pA/value = 123456789

	--test-- "pointer-calc-2"
	pA: pA + 1
	--assert pA/value = 987654321

	--test-- "pointer-calc-3"
	pa-struct/o: 123
	pA: pA + 2
	--assert pA/value = 123

	--test-- "pointer-calc-4"
	pA: pA - 3
	--assert pA/value = 123456789

	--test-- "pointer-calc-5"
	pointer-idx: 3
	pA: pA + pointer-idx
	--assert pA/value = 123

	--test-- "pointer-calc-6"
	pointer-idx: -3
	pA: pA + pointer-idx
	--assert pA/value = 123456789

	--test-- "pointer-calc-7"
	pA: pA - pointer-idx
	--assert pA/value = 123

	--test-- "pointer-calc-8"
	b-pointer: b-pointer + 1
	--assert b-pointer/value = #"e"
	pointer-idx: 2
	b-pointer: b-pointer + pointer-idx
	--assert b-pointer/value = #"l"

	--test-- "pointer-calc-9"
	pA: as [pointer! [integer!]] pa-struct
	--assert pA/1 = 123456789
	--assert pA/2 = 987654321

	--test-- "pointer-calc-10"
	pointer-idx: 1
	--assert pA/pointer-idx = 123456789

	--test-- "pointer-calc-11"
	pointer-idx: 2
	--assert pA/pointer-idx = 987654321

	--test-- "pointer-calc-12"
	pointer-idx: 4
	--assert pA/pointer-idx = 123

===end-group===

===start-group=== "Local pointers simple read/write tests"

pointer-local-foo: func [
	/local
		p-struct [struct! [n [integer!] m [integer!]]]
		pA 		 [pointer! [integer!]]
		pB 		 [pointer! [integer!]]
		p-int    [integer!]
		p-idx    [integer!]
		pointer-str [struct! [
			A [pointer! [integer!]]
			B [pointer! [integer!]]
			sub [struct! [C [pointer! [integer!]]]]
		]]
		pa-struct [struct! [n [integer!] m [integer!] p [integer!] o [integer!]]]
		b-pointer [pointer! [byte!]]
		b-str	[c-string!]
		pointer-idx [integer!]
][

	--test-- "loc-point-rw-1"
	p-struct: declare struct! [n [integer!] m [integer!]]
	pA: declare pointer! [integer!]
	pB: declare pointer! [integer!]

	p-struct/n: 123
	--assert p-struct/n = 123

	--test-- "loc-point-rw-2"
	pA: as [pointer! [integer!]] p-struct
	pA/value: 987
	--assert p-struct/n = 987
	pA/1: 987
	--assert p-struct/n = 987

	--test-- "loc-point-rw-3"
	p-struct/n: 12345
	--assert pA/value = 12345
	--assert pA/1 = 12345

	--test-- "loc-point-rw-4"
	p-int: 456789
	pA/2: p-int
	--assert p-struct/m = p-int
	--assert p-struct/n = 12345			;-- look for memory corruption

	--test-- "loc-point-rw-5"
	p-idx: 1
	pA/p-idx: 369
	--assert p-struct/n = 369

	--test-- "loc-point-rw-6"
	p-idx: 2
	pA/p-idx: 963
	--assert p-struct/m = 963

	--test-- "loc-point-rw-7"
	p-struct/n: 12345
	p-int: 147258
	p-struct/m: p-int
	--assert pA/2 = p-int
	--assert p-struct/n = 12345			;-- look for memory corruption

	--test-- "loc-point-rw-8"
	pB: pA
	--assert pB/value = 12345

	--test-- "loc-point-rw-9"
	pB: foo-pointer pA
	--assert pB/value = 12345

	pointer-str: declare struct! [
		A [pointer! [integer!]]
		B [pointer! [integer!]]
		sub [
			struct! [
				C [pointer! [integer!]]
			]
		]
	]
	pointer-str/sub: declare struct! [C [pointer! [integer!]]]

	--test-- "loc-point-rw-10"
	pointer-str/A: pA
	--assert pointer-str/A/value = 12345

	--test-- "loc-point-rw-11"
	pointer-str/A/value: 258369147
	--assert p-struct/n = 258369147
	--assert p-struct/m = p-int				;-- look for memory corruption

	--test-- "loc-point-rw-12"
	pointer-str/sub/C: pA
	--assert pointer-str/sub/C/value = 258369147

	--test-- "loc-point-rw-13"
	pointer-str/sub/C/2: 987654321
	--assert p-struct/m = 987654321

	--test-- "loc-point-rw-14"
	b-pointer: declare pointer! [byte!]
	b-str: "hello"
	b-pointer: as [pointer! [byte!]] b-str
	--assert b-pointer/value = #"h"

	--test-- "loc-point-rw-15"
	b-pointer2: declare pointer! [byte!]
	b-pointer2: foo-b-pointer b-pointer
	--assert b-pointer2/value = #"h"

	--test-- "loc-point-calc-1"
	pa-struct: declare struct! [n [integer!] m [integer!] p [integer!] o [integer!]]

	pA: as [pointer! [integer!]] pa-struct
	pa-struct/n: 123456789
	pa-struct/m: 987654321
	--assert pA/value = 123456789

	--test-- "loc-point-calc-2"
	pA: pA + 1
	--assert pA/value = 987654321

	--test-- "loc-point-calc-3"
	pa-struct/o: 123
	pA: pA + 2
	--assert pA/value = 123

	--test-- "loc-point-calc-4"
	pA: pA - 3
	--assert pA/value = 123456789

	--test-- "loc-point-calc-5"
	p-idx: 3
	pA: pA + p-idx
	--assert pA/value = 123

	--test-- "loc-point-calc-6"
	p-idx: -3
	pA: pA + p-idx
	--assert pA/value = 123456789

	--test-- "loc-point-calc-7"
	pA: pA - p-idx
	--assert pA/value = 123

	--test-- "loc-point-calc-8"
	b-pointer: b-pointer + 1
	--assert b-pointer/value = #"e"
	pointer-idx: 2
	b-pointer: b-pointer + pointer-idx
	--assert b-pointer/value = #"l"

	--test-- "loc-point-calc-9"
	pA: as [pointer! [integer!]] pa-struct
	--assert pA/1 = 123456789
	--assert pA/2 = 987654321

	--test-- "loc-point-calc-10"
	pointer-idx: 1
	--assert pA/pointer-idx = 123456789

	--test-- "loc-point-calc-11"
	pointer-idx: 2
	--assert pA/pointer-idx = 987654321

	--test-- "loc-point-calc-12"
	pointer-idx: 4
	--assert pA/pointer-idx = 123
]
pointer-local-foo

===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System pointer! datatype test script"
	Author:  "Nenad Rakocevic"
	File: 	 %pointer-test.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "pointer!"

===start-group=== "Pointers simple read/write tests"

	--test-- "pointer-rw-1"
	p-struct: declare struct! [n [integer!] m [integer!]]
	pA: declare pointer! [integer!]
	pB: declare pointer! [integer!]

	p-struct/n: 123
	--assert p-struct/n = 123

	--test-- "pointer-rw-2"
	pA: as [pointer! [integer!]] p-struct
	pA/value: 987
	--assert p-struct/n = 987
	pA/1: 987
	--assert p-struct/n = 987

	--test-- "pointer-rw-3"
	p-struct/n: 12345
	--assert pA/value = 12345
	--assert pA/1 = 12345

	--test-- "pointer-rw-4"
	p-int: 456789
	pA/2: p-int
	--assert p-struct/m = p-int
	--assert p-struct/n = 12345			;-- look for memory corruption

	--test-- "pointer-rw-5"
	p-idx: 1
	pA/p-idx: 1234567890
	--assert p-struct/n = 1234567890

	--test-- "pointer-rw-6"
	p-idx: 2
	pA/p-idx: 963
	--assert p-struct/n = 1234567890
	--assert p-struct/m = 963

	--test-- "pointer-rw-7"
	p-struct/n: 12345
	p-int: 147258
	p-struct/m: p-int
	--assert pA/2 = p-int
	--assert p-struct/n = 12345			;-- look for memory corruption

	--test-- "pointer-rw-8"
	pB: pA
	--assert pB/value = 12345

	--test-- "pointer-rw-9"
	foo-pointer: func [
		a [pointer! [integer!]]
		return: [pointer! [integer!]]
	][
		a
	]

	pB: foo-pointer pA
	--assert pB/value = 12345

	pointer-str: declare struct! [
		A [pointer! [integer!]]
		B [pointer! [integer!]]
		sub [
			struct! [
				C [pointer! [integer!]]
			]
		]
	]
	pointer-str/sub: declare struct! [C [pointer! [integer!]]]

	--test-- "pointer-rw-10"
	pointer-str/A: pA
	--assert pointer-str/A/value = 12345

	--test-- "pointer-rw-11"
	pointer-str/A/value: 258369147
	--assert p-struct/n = 258369147
	--assert p-struct/m = p-int				;-- look for memory corruption

	--test-- "pointer-rw-12"
	pointer-str/sub/C: pA
	--assert pointer-str/sub/C/value = 258369147

	--test-- "pointer-rw-13"
	pointer-str/sub/C/2: 987654321
	--assert p-struct/m = 987654321

	--test-- "pointer-rw-14"
	b-pointer: declare pointer! [byte!]
	b-str: "hello"
	b-pointer: as [pointer! [byte!]] b-str
	--assert b-pointer/value = #"h"

	--test-- "pointer-rw-15"
	foo-b-pointer: func [
		a [pointer! [byte!]]
		return: [pointer! [byte!]]
	][
		a
	]
	b-pointer2: declare pointer! [byte!]

	b-pointer2: foo-b-pointer b-pointer
	--assert b-pointer2/value = #"h"

===start-group=== "Pointers arithmetic"

	--test-- "pointer-calc-1"
	pa-struct: declare struct! [n [integer!] m [integer!] p [integer!] o [integer!]]
	pA: declare pointer! [integer!]
	pB: declare pointer! [integer!]

	pA: as [pointer! [integer!]] pa-struct
	pa-struct/n: 123456789
	pa-struct/m: 987654321
	--assert pA/value = 123456789

	--test-- "pointer-calc-2"
	pA: pA + 1
	--assert pA/value = 987654321

	--test-- "pointer-calc-3"
	pa-struct/o: 123
	pA: pA + 2
	--assert pA/value = 123

	--test-- "pointer-calc-4"
	pA: pA - 3
	--assert pA/value = 123456789

	--test-- "pointer-calc-5"
	pointer-idx: 3
	pA: pA + pointer-idx
	--assert pA/value = 123

	--test-- "pointer-calc-6"
	pointer-idx: -3
	pA: pA + pointer-idx
	--assert pA/value = 123456789

	--test-- "pointer-calc-7"
	pA: pA - pointer-idx
	--assert pA/value = 123

	--test-- "pointer-calc-8"
	b-pointer: b-pointer + 1
	--assert b-pointer/value = #"e"
	pointer-idx: 2
	b-pointer: b-pointer + pointer-idx
	--assert b-pointer/value = #"l"

	--test-- "pointer-calc-9"
	pA: as [pointer! [integer!]] pa-struct
	--assert pA/1 = 123456789
	--assert pA/2 = 987654321

	--test-- "pointer-calc-10"
	pointer-idx: 1
	--assert pA/pointer-idx = 123456789

	--test-- "pointer-calc-11"
	pointer-idx: 2
	--assert pA/pointer-idx = 987654321

	--test-- "pointer-calc-12"
	pointer-idx: 4
	--assert pA/pointer-idx = 123

===end-group===

===start-group=== "Local pointers simple read/write tests"

pointer-local-foo: func [
	/local
		p-struct [struct! [n [integer!] m [integer!]]]
		pA 		 [pointer! [integer!]]
		pB 		 [pointer! [integer!]]
		p-int    [integer!]
		p-idx    [integer!]
		pointer-str [struct! [
			A [pointer! [integer!]]
			B [pointer! [integer!]]
			sub [struct! [C [pointer! [integer!]]]]
		]]
		pa-struct [struct! [n [integer!] m [integer!] p [integer!] o [integer!]]]
		b-pointer [pointer! [byte!]]
		b-str	[c-string!]
		pointer-idx [integer!]
][

	--test-- "loc-point-rw-1"
	p-struct: declare struct! [n [integer!] m [integer!]]
	pA: declare pointer! [integer!]
	pB: declare pointer! [integer!]

	p-struct/n: 123
	--assert p-struct/n = 123

	--test-- "loc-point-rw-2"
	pA: as [pointer! [integer!]] p-struct
	pA/value: 987
	--assert p-struct/n = 987
	pA/1: 987
	--assert p-struct/n = 987

	--test-- "loc-point-rw-3"
	p-struct/n: 12345
	--assert pA/value = 12345
	--assert pA/1 = 12345

	--test-- "loc-point-rw-4"
	p-int: 456789
	pA/2: p-int
	--assert p-struct/m = p-int
	--assert p-struct/n = 12345			;-- look for memory corruption

	--test-- "loc-point-rw-5"
	p-idx: 1
	pA/p-idx: 369
	--assert p-struct/n = 369

	--test-- "loc-point-rw-6"
	p-idx: 2
	pA/p-idx: 963
	--assert p-struct/m = 963

	--test-- "loc-point-rw-7"
	p-struct/n: 12345
	p-int: 147258
	p-struct/m: p-int
	--assert pA/2 = p-int
	--assert p-struct/n = 12345			;-- look for memory corruption

	--test-- "loc-point-rw-8"
	pB: pA
	--assert pB/value = 12345

	--test-- "loc-point-rw-9"
	pB: foo-pointer pA
	--assert pB/value = 12345

	pointer-str: declare struct! [
		A [pointer! [integer!]]
		B [pointer! [integer!]]
		sub [
			struct! [
				C [pointer! [integer!]]
			]
		]
	]
	pointer-str/sub: declare struct! [C [pointer! [integer!]]]

	--test-- "loc-point-rw-10"
	pointer-str/A: pA
	--assert pointer-str/A/value = 12345

	--test-- "loc-point-rw-11"
	pointer-str/A/value: 258369147
	--assert p-struct/n = 258369147
	--assert p-struct/m = p-int				;-- look for memory corruption

	--test-- "loc-point-rw-12"
	pointer-str/sub/C: pA
	--assert pointer-str/sub/C/value = 258369147

	--test-- "loc-point-rw-13"
	pointer-str/sub/C/2: 987654321
	--assert p-struct/m = 987654321

	--test-- "loc-point-rw-14"
	b-pointer: declare pointer! [byte!]
	b-str: "hello"
	b-pointer: as [pointer! [byte!]] b-str
	--assert b-pointer/value = #"h"

	--test-- "loc-point-rw-15"
	b-pointer2: declare pointer! [byte!]
	b-pointer2: foo-b-pointer b-pointer
	--assert b-pointer2/value = #"h"

	--test-- "loc-point-calc-1"
	pa-struct: declare struct! [n [integer!] m [integer!] p [integer!] o [integer!]]

	pA: as [pointer! [integer!]] pa-struct
	pa-struct/n: 123456789
	pa-struct/m: 987654321
	--assert pA/value = 123456789

	--test-- "loc-point-calc-2"
	pA: pA + 1
	--assert pA/value = 987654321

	--test-- "loc-point-calc-3"
	pa-struct/o: 123
	pA: pA + 2
	--assert pA/value = 123

	--test-- "loc-point-calc-4"
	pA: pA - 3
	--assert pA/value = 123456789

	--test-- "loc-point-calc-5"
	p-idx: 3
	pA: pA + p-idx
	--assert pA/value = 123

	--test-- "loc-point-calc-6"
	p-idx: -3
	pA: pA + p-idx
	--assert pA/value = 123456789

	--test-- "loc-point-calc-7"
	pA: pA - p-idx
	--assert pA/value = 123

	--test-- "loc-point-calc-8"
	b-pointer: b-pointer + 1
	--assert b-pointer/value = #"e"
	pointer-idx: 2
	b-pointer: b-pointer + pointer-idx
	--assert b-pointer/value = #"l"

	--test-- "loc-point-calc-9"
	pA: as [pointer! [integer!]] pa-struct
	--assert pA/1 = 123456789
	--assert pA/2 = 987654321

	--test-- "loc-point-calc-10"
	pointer-idx: 1
	--assert pA/pointer-idx = 123456789

	--test-- "loc-point-calc-11"
	pointer-idx: 2
	--assert pA/pointer-idx = 987654321

	--test-- "loc-point-calc-12"
	pointer-idx: 4
	--assert pA/pointer-idx = 123
]
pointer-local-foo

===end-group===

~~~end-file~~~


FIX: temporary fix for #416

FIX: temporary fix for #416

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 EVAL_CHECK_INPUT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
]

#define EVAL_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "evaluating argument"]
	pc: eval-expression pc end no yes					;-- eval argument
	count: count + 1
]

#define EVAL_FETCH_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "fetching argument"]
	stack/push pc
	pc: pc + 1
	count: count + 1
]

interpreter: context [
	verbose: 0

	ref-array: as int-ptr! allocate 64 * size? integer!	;-- for natives/actions refinements handling
	offset: 0											;-- refinements counter for last call
	count:  0											;-- arguments counter for last call
	return-type: -1										;-- return type for routine calls

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

	exec: func [
		native	  [red-native!]							;-- works for action! too
		/local
			index [integer!]
			call
	][
		call: as function! [] native/code
		index: 0
		if positive? offset [
			until [
				system/words/push ref-array/index
				index: index + 1
				offset: offset - 1
				zero? offset
			]
		]
		call
	]

	exec-routine: func [
		routine [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			call
	][
		s: as series! routine/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: count - 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 true]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			op	  [red-op!]
			call-op
	][
		if verbose > 0 [log "infix detected!"]

		stack/mark-native as red-word! pc + 1
		eval-expression pc end yes	yes
		pc: pc + 2										;-- skip both left operand and operator
		pc: eval-expression pc end no yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op
		either sub? [stack/unwind][stack/unwind-last]

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

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			s		  [series!]
			ref?	  [logic!]
	][
		function?: TYPE_OF(native) = TYPE_FUNCTION
		routine?:  TYPE_OF(native) = TYPE_ROUTINE

		s: as series! either any [function? routine?][
			fun: as red-function! native
			fun/spec/node/value
		][
			native/spec/value
		]
		value: s/offset
		tail:  s/tail

		count:  	 0
		offset: 	 0
		return-type: -1
		ref?:		 no

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD [
					either zero? offset [
						EVAL_ARGUMENT
					][
						either ref? [
							either any [function? routine?][
								none/push
							][
								ref-array/offset: count
								EVAL_ARGUMENT
							]
						][
							either any [function? routine?][
								none/push
							][
								ref-array/offset: -1
							]
						]
						offset: offset + 1
					]
				]
				TYPE_LIT_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_GET_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_REFINEMENT [
					ref?: no							;@@ set it correctly once path supported
					either any [function? routine?][
						;TBD: check here if refinement is used
						logic/push false
						offset: 1
					][
						ref-array/offset: -1
						offset: offset + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
					return pc
				]
				default [0]
			]
			value: value + 1
		]
		pc
	]

	eval-path: func [
		pc	 [red-value!]								;-- path to evaluate
		set? [logic!]
		/local
			path   [red-path!]
			head   [red-value!]
			tail   [red-value!]
			slot   [red-value!]
			value  [red-value!]
			result [red-value!]
			saved  [red-value!]
			int	   [red-integer!]
	][
		if verbose > 0 [print-line "eval: path"]

		path:  as red-path! pc
		head:  block/rs-head as red-block! path
		tail:  block/rs-tail as red-block! path
		slot:  head
		saved: stack/top

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

		result: null

		while [slot < tail][
			if verbose > 1 [print-line ["slot type: " TYPE_OF(slot)]]

			value: either TYPE_OF(slot) = TYPE_GET_WORD [
				_context/get as red-word! slot
			][
				slot
			]

			switch TYPE_OF(value) [
				TYPE_WORD [
					either slot = head [
						result: _context/get as red-word! value
						switch TYPE_OF(result) [
							TYPE_ACTION					;@@ replace with TYPE_ANY_FUNCTION
							TYPE_NATIVE
							TYPE_ROUTINE
							TYPE_FUNCTION [

							]
							TYPE_BLOCK 					;@@ replace with TYPE_SERIES
							TYPE_PATH
							TYPE_LIT_PATH
							TYPE_GET_PATH
							TYPE_SET_PATH
							TYPE_STRING [

							]
							;TYPE_OBJECT
							;TYPE_PORT [
							;
							;]
						]
					][
						result: either all [set? slot + 1 = tail][
							actions/find as red-series! result value null no no no null null no no no no
							value: stack/top - 1		;@@ internalize it somehow...
							actions/poke as red-series! value 2 stack/arguments

							stack/arguments
						][
							actions/select as red-series! result value null no no no null null no no
							stack/top - 1
						]
					]
				]
				TYPE_PAREN [
					--NOT_IMPLEMENTED--
				]
				TYPE_INTEGER [
					int: as red-integer! value
					result: either all [set? slot + 1 = tail][
						actions/poke as red-series! result int/value stack/arguments
						stack/arguments
					][
						actions/pick as red-series! result int/value
					]
				]
				TYPE_STRING [
					--NOT_IMPLEMENTED--
				]
			]
			slot: slot + 1
		]
		stack/top: saved
		stack/push result
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		infix	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next  [red-word!]
			value [red-value!]
			fun	  [red-function!]
			w	  [red-word!]
			s	  [series!]
	][
		next: as red-word! pc + 1

		if all [
			not infix
			next < end
			TYPE_OF(next) = TYPE_WORD
		][
			value: _context/get next
			if TYPE_OF(value) = TYPE_OP [
				return eval-infix value pc end sub?
			]
		]

		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

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

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no no
				eval-path value yes
			]
			TYPE_GET_WORD [
				word/get as red-word! pc
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				w: word/push as red-word! pc			;-- push lit-word! on stack
				w/header: TYPE_WORD						;-- set correct value type on stack
				pc: pc + 1
			]
			TYPE_WORD [
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_ACTION
					TYPE_NATIVE [
						if verbose > 0 [log "pushing action/native frame"]
						stack/mark-native as red-word! pc
						pc: eval-arguments as red-native! value pc end
						exec as red-native! value
						either sub? [stack/unwind][stack/unwind-last]

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

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: routine return type: " TYPE_OF(value)]
						]
					]
					TYPE_FUNCTION [
						if verbose > 0 [log "pushing function frame"]
						stack/mark-func as red-word! pc	;@@
						pc: eval-arguments as red-native! value pc end
						fun: as red-function! value
						s: as series! fun/more/value
						;eval as red-block! s/offset	;@@ eval body version (add an option for that)
						exec as red-native! s/offset + 2
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: function return type: " TYPE_OF(value)]
						]
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

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

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

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			stack/set-last unset-value
			exit
		]

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

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

		stack/unwind-last
	]

]

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

#define EVAL_CHECK_INPUT [
	if pc >= end [
		print-line "*** Interpreter Error: missing argument..."
		halt
	]
]

#define EVAL_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "evaluating argument"]
	pc: eval-expression pc end no yes					;-- eval argument
	count: count + 1
]

#define EVAL_FETCH_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "fetching argument"]
	stack/push pc
	pc: pc + 1
	count: count + 1
]

interpreter: context [
	verbose: 0

	ref-array: as int-ptr! allocate 64 * size? integer!	;-- for natives/actions refinements handling
	offset: 0											;-- refinements counter for last call
	count:  0											;-- arguments counter for last call
	return-type: -1										;-- return type for routine calls

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

	exec: func [
		native	  [red-native!]							;-- works for action! too
		/local
			index [integer!]
			call
	][
		call: as function! [] native/code
		index: 0
		if positive? offset [
			until [
				system/words/push ref-array/index
				index: index + 1
				offset: offset - 1
				zero? offset
			]
		]
		call
	]

	exec-routine: func [
		routine [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			call
	][
		s: as series! routine/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: count - 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 true]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			op	  [red-op!]
			call-op
	][
		if verbose > 0 [log "infix detected!"]

		stack/mark-native as red-word! pc + 1
		eval-expression pc end yes	yes
		pc: pc + 2										;-- skip both left operand and operator
		pc: eval-expression pc end no yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op
		either sub? [stack/unwind][stack/unwind-last]

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

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			s		  [series!]
			ref?	  [logic!]
	][
		function?: TYPE_OF(native) = TYPE_FUNCTION
		routine?:  TYPE_OF(native) = TYPE_ROUTINE

		s: as series! either any [function? routine?][
			fun: as red-function! native
			fun/spec/node/value
		][
			native/spec/value
		]
		value: s/offset
		tail:  s/tail

		count:  	 0
		offset: 	 0
		return-type: -1
		ref?:		 no

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD [
					either zero? offset [
						EVAL_ARGUMENT
					][
						either ref? [
							either any [function? routine?][
								none/push
							][
								ref-array/offset: count
								EVAL_ARGUMENT
							]
						][
							either any [function? routine?][
								none/push
							][
								ref-array/offset: -1
							]
						]
						offset: offset + 1
					]
				]
				TYPE_LIT_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_GET_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_REFINEMENT [
					ref?: no							;@@ set it correctly once path supported
					either any [function? routine?][
						;TBD: check here if refinement is used
						logic/push false
						offset: 1
					][
						ref-array/offset: -1
						offset: offset + 1
					]
				]
				TYPE_SET_WORD [
					if routine? [
						value: block/pick (as red-block! value + 1) 1
						assert TYPE_OF(value) = TYPE_WORD
						dt: as red-datatype! _context/get as red-word! value
						assert TYPE_OF(dt) = TYPE_DATATYPE
						return-type: dt/value
					]
					return pc
				]
				default [0]
			]
			value: value + 1
		]
		pc
	]

	eval-path: func [
		pc	 [red-value!]								;-- path to evaluate
		set? [logic!]
		/local
			path   [red-path!]
			head   [red-value!]
			tail   [red-value!]
			slot   [red-value!]
			value  [red-value!]
			result [red-value!]
			int	   [red-integer!]
	][
		if verbose > 0 [print-line "eval: path"]

		path:  as red-path! pc
		head:  block/rs-head as red-block! path
		tail:  block/rs-tail as red-block! path
		slot:  head

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

		result: null

		while [slot < tail][
			if verbose > 1 [print-line ["slot type: " TYPE_OF(slot)]]

			value: either TYPE_OF(slot) = TYPE_GET_WORD [
				_context/get as red-word! slot
			][
				slot
			]

			switch TYPE_OF(value) [
				TYPE_WORD [
					either slot = head [
						result: _context/get as red-word! value
						switch TYPE_OF(result) [
							TYPE_ACTION					;@@ replace with TYPE_ANY_FUNCTION
							TYPE_NATIVE
							TYPE_ROUTINE
							TYPE_FUNCTION [

							]
							TYPE_BLOCK 					;@@ replace with TYPE_SERIES
							TYPE_PATH
							TYPE_LIT_PATH
							TYPE_GET_PATH
							TYPE_SET_PATH
							TYPE_STRING [

							]
							;TYPE_OBJECT
							;TYPE_PORT [
							;
							;]
						]
					][
						result: either all [set? slot + 1 = tail][
							actions/find as red-series! result value null no no no null null no no no no
							value: stack/top - 1		;@@ internalize it somehow...
							actions/poke as red-series! value 2 stack/arguments

							stack/arguments
						][
							actions/select as red-series! result value null no no no null null no no
							stack/top - 1
						]
					]
				]
				TYPE_PAREN [
					--NOT_IMPLEMENTED--
				]
				TYPE_INTEGER [
					int: as red-integer! value
					result: either all [set? slot + 1 = tail][
						actions/poke as red-series! result int/value stack/arguments
						stack/arguments
					][
						actions/pick as red-series! result int/value
					]
				]
				TYPE_STRING [
					--NOT_IMPLEMENTED--
				]
			]
			slot: slot + 1
		]
		stack/set-last result
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		infix	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next  [red-word!]
			value [red-value!]
			fun	  [red-function!]
			w	  [red-word!]
			s	  [series!]
	][
		next: as red-word! pc + 1

		if all [
			not infix
			next < end
			TYPE_OF(next) = TYPE_WORD
		][
			value: _context/get next
			if TYPE_OF(value) = TYPE_OP [
				return eval-infix value pc end sub?
			]
		]

		if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]

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

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no no
				eval-path value yes
			]
			TYPE_GET_WORD [
				word/get as red-word! pc
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				w: word/push as red-word! pc			;-- push lit-word! on stack
				w/header: TYPE_WORD						;-- set correct value type on stack
				pc: pc + 1
			]
			TYPE_WORD [
				value: _context/get as red-word! pc
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_ACTION
					TYPE_NATIVE [
						if verbose > 0 [log "pushing action/native frame"]
						stack/mark-native as red-word! pc
						pc: eval-arguments as red-native! value pc end
						exec as red-native! value
						either sub? [stack/unwind][stack/unwind-last]

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

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: routine return type: " TYPE_OF(value)]
						]
					]
					TYPE_FUNCTION [
						if verbose > 0 [log "pushing function frame"]
						stack/mark-func as red-word! pc	;@@
						pc: eval-arguments as red-native! value pc end
						fun: as red-function! value
						s: as series! fun/more/value
						;eval as red-block! s/offset	;@@ eval body version (add an option for that)
						exec as red-native! s/offset + 2
						either sub? [stack/unwind][stack/unwind-last]

						if verbose > 0 [
							value: stack/arguments
							print-line ["eval: function return type: " TYPE_OF(value)]
						]
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

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

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

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			stack/set-last unset-value
			exit
		]

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

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

		stack/unwind-last
	]

]