TESTS: added and/or/xor tests to logic-test.reds

Red/System [
	Title:   "Red/System logic! datatype test script"
	Author:  "Nenad Rakocevic"
	File: 	 %logic-test.reds
	Version: 0.1.1
	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~~~ "logic"

===start-group=== "literal logic! value tests"
	--test-- "llv-1"
		--assert true

	--test-- "llv-2"
		--assert not false
===end-group===

===start-group=== "logic variable tests"
	--test-- "lv-1"
	 	a: true
	 	--assert a

	--test-- "lv-2"
	 	a: false
	 	--assert not a
===end-group===

===start-group=== "conditional expression assignment tests"
	--test-- "lce-1"
		a: 3 < 5
		--assert a

	--test-- "lce-2"
		a: 1 = 2
		--assert not a
===end-group===

===start-group=== "logic value as last conditional expression in UNTIL tests"
  --test-- "lu-1"
    a: true
    i: 0
    until [
      i: i + 1
      a
    ]
  --assert i = 1

  --test-- "lu-2"
    i: 0
    c: 3
    stop?: false
    until [
      i: i + 1
      c: c - 1
      if zero? c [stop?: true]
      stop?
    ]
  --assert c = 0
  --assert i = 3
===end-group===

===start-group=== "logic value as conditional expression in WHILE tests"
	--test-- "lw-1"
		a: false
		i: 0
		while [a][i: i + 1]
		--assert i = 0

	--test-- "lw-2"
		i: 0
		c: 3
		run?: true
		while [run?][
			i: i + 1
			c: c - 1
			if zero? c [run?: false]
		]
		--assert c = 0
		--assert i = 3
===end-group===

===start-group=== "passing logic! as function's argument tests"
	log-foo: func [a [logic!] return: [logic!]][a]

	--test-- "logic-arg-1"	--assert log-foo true
	--test-- "logic-arg-2"	--assert not log-foo false
	--test-- "logic-arg-3"	--assert log-foo 1 < 2
	--test-- "logic-arg-4"	--assert log-foo 3 <> 4
	--test-- "logic-arg-5"	--assert log-foo (1 + 1 < 3)
	--test-- "logic-arg-6"
		a: false
		if false = log-foo (2 + 2 = 5) [a: true]
		--assert a
	--test-- "logic-arg-7"
		--assert not log-foo 3 = 4

===end-group===

===start-group=== "all with logic!"

	--test-- "logic-all-1"
	 	result:  all [
	 		true
	 		true
	 	]
	 	--assert result

	--test-- "logic-all-2"
		result: all [
			false
			true
		]
		--assert not result

	--test-- "logic-all-3"
		result all [
			true
			false
		]
		--assert not result

	--test-- "logic-all-4"
		result: all [
			false
			false
		]
		--assert not result

	--test-- "logic-all-5"
		a: all [true]
		--assert a

	--test-- "logic-all-6"
		a: all [false]
		--assert not a

	--test-- "logic-all-7"
		a: all [1 < 2 false]
		--assert not a

	--test-- "logic-all-8"
		a: all [false 1 < 2]
		--assert not a

	--test-- "logic-all-9"
		a: all [true 1 = 2]
		--assert not a

	--test-- "logic-all-10"
		a: all [1 = 2 true]
		--assert not a

	--test-- "logic-all-11"
		a: all [1 < 2]
		--assert a

	--test-- "logic-all-12"
		a: all [1 = 2]
		--assert not a

	--test-- "logic-all-13"
		a: all [1 < 2 3 <> 4]
		--assert a

	--test-- "logic-all-14"
		a: all [1 = 2 3 <> 4]
		--assert not a

	--test-- "logic-all-15"
		--assert not log-foo all [1 = 2]

	--test-- "logic-all-16"
		--assert log-foo all [1 < 2 3 <> 4]

	--test-- "logic-all-17"
		--assert not log-foo all [1 = 2 3 <> 4]

	--test-- "logic-all-18"
		a: log-foo all [1 < 2]
		--assert a

	--test-- "logic-all-19"
		a: log-foo all [1 = 2]
		--assert not a

	--test-- "logic-all-20"
		a: log-foo all [1 < 2 3 <> 4]
		--assert a

	--test-- "logic-all-21"
		a: all [log-foo true]
		--assert a

===end-group===

===start-group=== "any with logic!"

	--test-- "logic-any-1"
		result: any [
			true
			true
		]
		--assert result

	--test-- "logic-any-2"
		result: any [
			false
			true
		]
		--assert result

	--test-- "logic-any-3"
		result: any [
			true
			false
		]
		--assert result

	--test-- "logic-any-4"
		result: any [
			false
			false
		]
		--assert not result

	--test-- "logic-any-5"
		a: any [true]
		--assert a

	--test-- "logic-any-6"
		a: any [false]
		--assert not a

	--test-- "logic-any-7"
		a: any [1 < 2 false]
		--assert a

	--test-- "logic-any-8"
		a: any [false 1 < 2]
		--assert a

	--test-- "logic-any-9"
		a: any [true 1 = 2]
		--assert a

	--test-- "logic-any-10"
		a: any [1 = 2 true]
		--assert a

	--test-- "logic-any-11"
		a: any [1 < 2]
		--assert a

	--test-- "logic-any-12"
		a: any [1 = 2]
		--assert not a

	--test-- "logic-any-13"
		a: any [1 < 2 3 <> 4]
		--assert a

	--test-- "logic-any-14"
		a: any [1 = 2 3 <> 4]
		--assert a

	--test-- "logic-any-15"
		--assert not log-foo any [1 = 2]

	--test-- "logic-any-16"
		--assert log-foo any [1 < 2 3 <> 4]

	--test-- "logic-any-17"
		--assert log-foo any [1 = 2 3 <> 4]

	--test-- "logic-any-18"
		a: log-foo any [1 < 2]
		--assert a

	--test-- "logic-any-19"
		a: log-foo any [1 = 2]
		--assert not a

	--test-- "logic-any-20"
		a: log-foo any [1 < 2 3 <> 4]
		--assert a

	--test-- "logic-any-21"
		a: any [log-foo true]
		--assert a

===end-group===

===start-group=== "function returning a logic value"
		lgc-test?: func [
			return: [logic!]
		][
			either 1 < 2 [true] [false]
		]

	--test-- "logic-return-1"
		--assert lgc-test?

	--test-- "logic-return-2"
		a: lgc-test?
		--assert a

		lgc-test2?: func [
			return: [logic!]
		][
			either 1 = 2 [true] [false]
		]

	--test-- "logic-return-3"
		--assert not lgc-test2?

	--test-- "logic-return-4"
		a: lgc-test2?
		--assert not a

		lgc-test3?: func [return: [logic!]][
			either true [
				1 = 3
			][
				false
			]
		]

	--test-- "logic-return-5"
		--assert not lgc-test3?

		lgc-test4?: func [return: [logic!]][
			either false [
				1 = 3
			][
				false
			]
		]

	--test-- "logic-return-6"
		--assert not lgc-test4?

		lgc-test5?: func [return: [logic!]][
			either 1 < 2 [true] [false]
		]

	--test-- "logic-return-7"
		--assert lgc-test5?

===end-group===

===start-group=== "equality lgc-tests"

	--test-- "logic-=-1"
		a: false
		--assert a = false

	--test-- "logic-=-2"
		a: true
		--assert not a = false

	--test-- "logic-=-3"
		a: false
		--assert not a <> false

	--test-- "logic-=-4"
		a: true
		--assert a <> false

	--test-- "logic-=-5"
		a: false
		b: a = false
		--assert b

	--test-- "logic-=-6"
		a: true
		b: a = false
		--assert not b

	--test-- "logic-=-7"
		a: false
		b: false <> a
		--assert not b

	--test-- "logic-=-8"
		a: true
		b: false <> a
		--assert b

	--test-- "logic-=-9"
		a: false
		--assert log-foo a = false

	--test-- "logic-=-10"
		a: false
		--assert log-foo a = false

	--test-- "logic-=-11"
		a: true
		--assert not log-foo a = false

===end-group===

===start-group=== "logic value returned by function"

		fooT: func [return: [logic!]][1 < 2]
		fooF: func [return: [logic!]][1 = 2]

	--test-- "logic-ret-1" --assert fooT
	--test-- "logic-ret-2" --assert not fooF

===end-group===

===start-group=== "logic logical operators"

	--test-- "logic-and-1"	--assert true and true
	--test-- "logic-and-2"	--assert not (true and false)
	--test-- "logic-and-3"	--assert not (false and false)
	--test-- "logic-and-4"  --assert not (false and true)
	--test-- "logic-or-1"	--assert true or true
	--test-- "logic-or-2"	--assert true or false
	--test-- "logic-or-3"	--assert not (false or false)
	--test-- "logic-or-4"	--assert false or true
	--test-- "logic-xor-1"	--assert not (true xor true)
	--test-- "logic-xor-2"	--assert true xor false
	--test-- "logic-xor-3"	--assert not (false xor false)
	--test-- "logic-xor-4"  --assert false xor true

===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System logic! datatype test script"
	Author:  "Nenad Rakocevic"
	File: 	 %logic-test.reds
	Version: 0.1.1
	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~~~ "logic"

===start-group=== "literal logic! value tests"
  --test-- "llv-1"
  --assert true

  --test-- "llv-2"
  --assert not false
===end-group===

===start-group=== "logic variable tests"
  --test-- "lv-1"
    a: true
  --assert a

  --test-- "lv-2"
    a: false
  --assert not a
===end-group===

===start-group=== "conditional expression assignment tests"
  --test-- "lce-1"
    a: 3 < 5
  --assert a

  --test-- "lce-2"
    a: 1 = 2
  --assert not a
===end-group===

===start-group=== "logic value as last conditional expression in UNTIL tests"
  --test-- "lu-1"
    a: true
    i: 0
    until [
      i: i + 1
      a
    ]
  --assert i = 1

  --test-- "lu-2"
    i: 0
    c: 3
    stop?: false
    until [
      i: i + 1
      c: c - 1
      if zero? c [stop?: true]
      stop?
    ]
  --assert c = 0
  --assert i = 3
===end-group===

===start-group=== "logic value as conditional expression in WHILE tests"
  --test-- "lw-1"
    a: false
    i: 0
    while [a][i: i + 1]
  --assert i = 0

  --test-- "lw-2"
    i: 0
    c: 3
    run?: true
    while [run?][
      i: i + 1
      c: c - 1
      if zero? c [run?: false]
    ]
  --assert c = 0
  --assert i = 3
===end-group===

===start-group=== "passing logic! as function's argument tests"
    log-foo: func [a [logic!] return: [logic!]][a]

  --test-- "logic-arg-1"
  --assert log-foo true

  --test-- "logic-arg-2"
  --assert not log-foo false

  --test-- "logic-arg-3"
  --assert log-foo 1 < 2

  --test-- "logic-arg-4"
  --assert log-foo 3 <> 4

  --test-- "logic-arg-5"
  --assert log-foo (1 + 1 < 3)

  --test-- "logic-arg-6"
    a: false
    if false = log-foo (2 + 2 = 5) [a: true]
  --assert a

  --test-- "logic-arg-7"
  --assert not log-foo 3 = 4

===end-group===

===start-group=== "all with logic!"

  --test-- "logic-all-1"
    result:  all [
      true
      true
    ]
  --assert result

  --test-- "logic-all-2"
    result: all [
      false
      true
    ]
  --assert not result

  --test-- "logic-all-3"
    result all [
      true
      false
    ]
  --assert not result

  --test-- "logic-all-4"
    result: all [
      false
      false
    ]
  --assert not result

  --test-- "logic-all-5"
    a: all [true]
  --assert a

  --test-- "logic-all-6"
    a: all [false]
  --assert not a

  --test-- "logic-all-7"
    a: all [1 < 2 false]
  --assert not a

  --test-- "logic-all-8"
    a: all [false 1 < 2]
  --assert not a

  --test-- "logic-all-9"
    a: all [true 1 = 2]
  --assert not a

  --test-- "logic-all-10"
    a: all [1 = 2 true]
  --assert not a

  --test-- "logic-all-11"
    a: all [1 < 2]
  --assert a

  --test-- "logic-all-12"
    a: all [1 = 2]
  --assert not a

  --test-- "logic-all-13"
    a: all [1 < 2 3 <> 4]
  --assert a

  --test-- "logic-all-14"
    a: all [1 = 2 3 <> 4]
  --assert not a

  --test-- "logic-all-15"
  --assert not log-foo all [1 = 2]

  --test-- "logic-all-16"
  --assert log-foo all [1 < 2 3 <> 4]

  --test-- "logic-all-17"
  --assert not log-foo all [1 = 2 3 <> 4]

  --test-- "logic-all-18"
    a: log-foo all [1 < 2]
  --assert a

  --test-- "logic-all-19"
    a: log-foo all [1 = 2]
  --assert not a

  --test-- "logic-all-20"
    a: log-foo all [1 < 2 3 <> 4]
  --assert a

    --test-- "logic-all-21"
      a: all [log-foo true]
  --assert a

===end-group===

===start-group=== "any with logic!"

  --test-- "logic-any-1"
    result: any [
      true
      true
    ]
  --assert result

  --test-- "logic-any-2"
    result: any [
      false
      true
    ]
  --assert result

  --test-- "logic-any-3"
    result: any [
      true
      false
    ]
  --assert result

  --test-- "logic-any-4"
    result: any [
      false
      false
    ]
  --assert not result

  --test-- "logic-any-5"
    a: any [true]
  --assert a

  --test-- "logic-any-6"
    a: any [false]
  --assert not a

  --test-- "logic-any-7"
    a: any [1 < 2 false]
  --assert a

  --test-- "logic-any-8"
    a: any [false 1 < 2]
  --assert a

  --test-- "logic-any-9"
    a: any [true 1 = 2]
  --assert a

  --test-- "logic-any-10"
    a: any [1 = 2 true]
  --assert a

  --test-- "logic-any-11"
  a: any [1 < 2]
  --assert a

  --test-- "logic-any-12"
    a: any [1 = 2]
  --assert not a

  --test-- "logic-any-13"
    a: any [1 < 2 3 <> 4]
  --assert a

  --test-- "logic-any-14"
    a: any [1 = 2 3 <> 4]
  --assert a

  --test-- "logic-any-15"
  --assert not log-foo any [1 = 2]

  --test-- "logic-any-16"
  --assert log-foo any [1 < 2 3 <> 4]

  --test-- "logic-any-17"
  --assert log-foo any [1 = 2 3 <> 4]

  --test-- "logic-any-18"
    a: log-foo any [1 < 2]
  --assert a

  --test-- "logic-any-19"
    a: log-foo any [1 = 2]
  --assert not a

  --test-- "logic-any-20"
    a: log-foo any [1 < 2 3 <> 4]
  --assert a

  --test-- "logic-any-21"
    a: any [log-foo true]
  --assert a

===end-group===

===start-group=== "function returning a logic value"
    lgc-test?: func [
      return: [logic!]
    ][
      either 1 < 2 [true] [false]
    ]

  --test-- "logic-return-1"
  --assert lgc-test?

  --test-- "logic-return-2"
    a: lgc-test?
  --assert a

    lgc-test2?: func [
      return: [logic!]
    ][
      either 1 = 2 [true] [false]
    ]

  --test-- "logic-return-3"
  --assert not lgc-test2?

  --test-- "logic-return-4"
    a: lgc-test2?
  --assert not a

	lgc-test3?: func [return: [logic!]][
		either true [
			1 = 3
		][
			false
		]
	]

 --test-- "logic-return-5"
 --assert not lgc-test3?

	lgc-test4?: func [return: [logic!]][
		either false [
			1 = 3
		][
			false
		]
	]

 --test-- "logic-return-6"
 --assert not lgc-test4?

	lgc-test5?: func [return: [logic!]][
		either 1 < 2 [true] [false]
	]

 --test-- "logic-return-7"
 --assert lgc-test5?

===end-group===

===start-group=== "equality lgc-tests"

  --test-- "logic-=-1"
    a: false
  --assert a = false

  --test-- "logic-=-2"
    a: true
  --assert not a = false

  --test-- "logic-=-3"
    a: false
  --assert not a <> false

  --test-- "logic-=-4"
    a: true
  --assert a <> false

  --test-- "logic-=-5"
    a: false
    b: a = false
  --assert b

  --test-- "logic-=-6"
    a: true
    b: a = false
  --assert not b

  --test-- "logic-=-7"
    a: false
    b: false <> a
  --assert not b

  --test-- "logic-=-8"
    a: true
    b: false <> a
  --assert b

  --test-- "logic-=-9"
    a: false
  --assert log-foo a = false

  --test-- "logic-=-10"
    a: false
  --assert log-foo a = false

  --test-- "logic-=-11"
    a: true
  --assert not log-foo a = false

===end-group===

===start-group=== "logic value returned by function"

	fooT: func [return: [logic!]][1 < 2]
	fooF: func [return: [logic!]][1 = 2]

	--test-- "logic-ret-1" --assert fooT
	--test-- "logic-ret-2" --assert not fooF

===end-group===

~~~end-file~~~


FEAT: version number upgraded in hello.reds script.

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

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

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

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

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

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

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

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

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

draw-vline: does [print "|"]

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

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

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

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

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

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

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

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

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

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

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

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

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

draw-vline: does [print "|"]

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

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

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

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


FEAT: added system/version mention to HELP default message.

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

help: func [
	"Get help for functions"
	'word [any-type!] "Word you are looking for"
	/local func-name desc spec tab tab4 tab8 type start attributs info fun w ref block
][
	tab: tab4: "    "
	tab8: "        "

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

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other debug functions:

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

							either any [
								string? desc: spec/1
								string? desc: spec/2					;-- attributs block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
		]
		'else [
			func-name: :word

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

			either all [
				word? func-name
				fun: get func-name
				any [action? :fun function? :fun native? :fun]
			][
		;		print ["^/" func-name "is of type" type? :fun newline]
				prin ["^/USAGE:^/" tab func-name]

				parse spec-of :fun [
					start: any [						;-- 1st pass
						/local to end
						| set w word! (prin [" " w])
						| set w [lit-word! | refinement!] (prin [" " mold w])
						| skip
					]

					:start								;-- 2nd pass
					opt [set attributs block! (prin ["^/^/ATTRIBUTS:^/" tab mold attributs])]
					opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot])]

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

					(print "REFINEMENTS:")
					any [
						/local [
							to ahead set-word! 'return set block block!
							(print ["^/RETURN:^/" mold block])
							| to end
						]
						| [
							set ref refinement! (prin [tab mold ref])
							opt [set info string! (prin [" =>" append form info dot])]
							(tab: tab8 prin lf)
							any [argument-rule]
							(tab: tab4)
						]
					]
				]
			][
				print [
					func-name "is of type"
					mold type? either word? :func-name [:fun][:func-name]
					"^/No more help available."
				]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

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

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

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

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

help: func [
	"Get help for functions"
	'word [any-type!] "Word you are looking for"
	/local func-name desc spec tab tab4 tab8 type start attributs info fun w ref block
][
	tab: tab4: "    "
	tab8: "        "

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

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other debug functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
}
		]
		datatype? get :word [						;-- HELP <datatype!>
			type: get :word
			foreach w system/words [
				if type = type? get w [
					case [
						any [function? get w native? get w action? get w][
							prin [tab w]
							spec: spec-of get w

							either any [
								string? desc: spec/1
								string? desc: spec/2					;-- attributs block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
		]
		'else [
			func-name: :word

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

			either all [
				word? func-name
				fun: get func-name
				any [action? :fun function? :fun native? :fun]
			][
		;		print ["^/" func-name "is of type" type? :fun newline]
				prin ["^/USAGE:^/" tab func-name]

				parse spec-of :fun [
					start: any [						;-- 1st pass
						/local to end
						| set w word! (prin [" " w])
						| set w [lit-word! | refinement!] (prin [" " mold w])
						| skip
					]

					:start								;-- 2nd pass
					opt [set attributs block! (prin ["^/^/ATTRIBUTS:^/" tab mold attributs])]
					opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot])]

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

					(print "REFINEMENTS:")
					any [
						/local [
							to ahead set-word! 'return set block block!
							(print ["^/RETURN:^/" mold block])
							| to end
						]
						| [
							set ref refinement! (prin [tab mold ref])
							opt [set info string! (prin [" =>" append form info dot])]
							(tab: tab8 prin lf)
							any [argument-rule]
							(tab: tab4)
						]
					]
				]
			][
				print [
					func-name "is of type"
					mold type? either word? :func-name [:fun][:func-name]
					"^/No more help available."
				]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

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

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

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


More prose

More prose

git-svn-id: 50a8ad97cae5d6ab203d2d535a9b32cd3858a8ac@303 c04ce798-636b-4ca8-9149-0f9336831111

<% @sidebar = "sidebar_contributing" %>

h1. Contributing

Contributing to CruiseControl.rb improves your karma, looks good on your CV and generally makes the world a better
place.

There are four ways you can help:
* report bugs
* create and publish your own plugins
* fix bugs and submit patches
* improve documentation

h2. Report bugs

CruiseControl.rb uses a public "JIRA bug tracker":http://jira.public.thoughtworks.org/browse/CCRB to keep track of bugs,
patches, ideas and development stories.

Before you can submit a bug, you need to
"create an account":http://jira.public.thoughtworks.org/secure/Signup!default.jspa.

Please try to be as specific as possible about the symptoms and possible root causes of the problem, include
screenshots, stack traces, quotes from log files or any other relevant information.

Also, please try to make sure that the problem is in CruiseControl.rb, not in your build or CI configuration. It can be
quite embarrassing to go through a long chain of emails, and learn at the end of it that it was your problem and you
could have easily figured it out yourself.

Please, do "read the fine manual":manual.html, and do not neglect to consult the
"troubleshooting guide":troubleshooting.html for some useful debugging techniques.

h2. Create plugins

TODO: write me

h2. Submit patches

We absolutely love receiving bug reports. After all, who doesn't? What can make us really ecstatic, however, is a bug
report coming with a patch that fixes the bug and adds unit tests to prevent it from ever happening again.
Contributing a well packaged patch that is accepted into the codebase will forever put your name into
CruiseControl.rb Hall of Fame, aka the Contributors section of README.

TODO: finish me

h2. Improve documentation

TODO: write me

<% @sidebar = "sidebar_contributing" %>

h1. Contributing

Contributing to CruiseControl.rb improves your karma, looks good on your CV and generally makes the world a better
place.

There are four ways you can help:
* report bugs
* create and publish your own plugins
* fix bugs and submit patches
* improve documentation

h2. Report bugs

CruiseControl.rb uses a public "JIRA bug tracker":http://jira.public.thoughtworks.org/browse/CCRB to keep track of bugs
and future development stories.

Before you can submit a bug, you need to
"create an account":http://jira.public.thoughtworks.org/secure/Signup!default.jspa.

Please try to be as specific as possible about the symptoms and possible root causes of the problem, include
screenshots, stack traces, quotes from log files or any other relevant information.

Also, please try to make sure that the problem is in CruiseControl.rb, not in your build or CI configuration. It can be
quite embarrassing to go through a long chain of emails, and learn at the end of it that it was your problem and you
could have easily figured it out yourself.

Please, do <strong>"read the fine manual":manual.html</strong>, and do not neglect to consult the
"troubleshooting guide":troubleshooting.html for some useful debugging techniques.

h2. Create plugins

TODO: write me

h2. Create plugins

TODO: write me

h2. Improve documentation

TODO: write me


FIX: issue #519 (COMPOSE and PRINT corrupt cascaded ROUTINE return type)

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

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

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

interpreter: context [
	verbose: 0

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

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

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

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

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

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

		while [value < tail][

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

		unless ret-set? [return-type: -1]				;-- set the default correctly in case of nested calls

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

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

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

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

	eval-path-element: func [
		slot     [red-value!]
		head     [red-value!]
		tail     [red-value!]
		result   [red-value!]
		alt-slot [red-value!]							;-- alternative element (computed from paren)
		set?     [logic!]
		return:  [red-value!]
		/local
			value  [red-value!]
			int	   [red-integer!]
	][
		value: case [
			TYPE_OF(slot) = TYPE_GET_WORD [_context/get as red-word! slot]
			null? alt-slot 				  [slot]
			true		   				  [alt-slot]
		]
		switch TYPE_OF(value) [
			TYPE_WORD [
				either slot = head [
					result: _context/get as red-word! value
					switch TYPE_OF(result) [
						TYPE_UNSET [
							return unset-value
						]
						TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
						TYPE_NATIVE
						TYPE_ROUTINE
						TYPE_FUNCTION [
							return result
						]
						TYPE_BLOCK 						;@@ replace with TYPE_SERIES
						TYPE_PATH
						TYPE_LIT_PATH
						TYPE_GET_PATH
						TYPE_SET_PATH
						TYPE_STRING
						TYPE_FILE [

						]
						;TYPE_OBJECT
						;TYPE_PORT [
						;
						;]
						default [
							;; TBD raise an error
						]
					]
				][
					result: either all [set? slot + 1 = tail][
						value: actions/find as red-series! result value null no no no null null no no no no
						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
					]
				]
			]
			TYPE_PAREN [
				stack/mark-native words/_body			;@@ ~paren
				eval as red-block! value				;-- eval paren content
				stack/unwind
				result: eval-path-element slot head tail result stack/top - 1 set?
			]
			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--
			]
		]
		result
	]

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

		path:  as red-path! value
		head:  block/rs-head as red-block! path
		tail:  block/rs-tail as red-block! path
		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)]]

			result: eval-path-element slot head tail result null set?

			switch TYPE_OF(result) [
				TYPE_UNSET [
					print-line "*** Error: word in path has no value!"
					stack/push result
					return pc
				]
				TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code result pc end yes path slot
					return pc
				]
				default [0]
			]
			slot: slot + 1
		]

		stack/top: saved
		stack/push result
		pc
	]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

]

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

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

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

interpreter: context [
	verbose: 0

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

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

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

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

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

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

		while [value < tail][

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

	eval-path-element: func [
		slot     [red-value!]
		head     [red-value!]
		tail     [red-value!]
		result   [red-value!]
		alt-slot [red-value!]							;-- alternative element (computed from paren)
		set?     [logic!]
		return:  [red-value!]
		/local
			value  [red-value!]
			int	   [red-integer!]
	][
		value: case [
			TYPE_OF(slot) = TYPE_GET_WORD [_context/get as red-word! slot]
			null? alt-slot 				  [slot]
			true		   				  [alt-slot]
		]
		switch TYPE_OF(value) [
			TYPE_WORD [
				either slot = head [
					result: _context/get as red-word! value
					switch TYPE_OF(result) [
						TYPE_UNSET [
							return unset-value
						]
						TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
						TYPE_NATIVE
						TYPE_ROUTINE
						TYPE_FUNCTION [
							return result
						]
						TYPE_BLOCK 						;@@ replace with TYPE_SERIES
						TYPE_PATH
						TYPE_LIT_PATH
						TYPE_GET_PATH
						TYPE_SET_PATH
						TYPE_STRING
						TYPE_FILE [

						]
						;TYPE_OBJECT
						;TYPE_PORT [
						;
						;]
						default [
							;; TBD raise an error
						]
					]
				][
					result: either all [set? slot + 1 = tail][
						value: actions/find as red-series! result value null no no no null null no no no no
						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
					]
				]
			]
			TYPE_PAREN [
				stack/mark-native words/_body			;@@ ~paren
				eval as red-block! value				;-- eval paren content
				stack/unwind
				result: eval-path-element slot head tail result stack/top - 1 set?
			]
			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--
			]
		]
		result
	]

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

		path:  as red-path! value
		head:  block/rs-head as red-block! path
		tail:  block/rs-tail as red-block! path
		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)]]

			result: eval-path-element slot head tail result null set?

			switch TYPE_OF(result) [
				TYPE_UNSET [
					print-line "*** Error: word in path has no value!"
					stack/push result
					return pc
				]
				TYPE_ACTION						;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code result pc end yes path slot
					return pc
				]
				default [0]
			]
			slot: slot + 1
		]

		stack/top: saved
		stack/push result
		pc
	]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

]


FIX: chained infix expressions now correctly handled by the interpreter.

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_FETCH_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "fetching argument"]
	stack/push pc
	pc: pc + 1
	count: count + 1
]

#define CHECK_INFIX [
	next: as red-word! pc

	if all [
		next < end
		TYPE_OF(next) = TYPE_WORD
	][
		value: _context/get next
		if TYPE_OF(value) = TYPE_OP [
			if verbose > 0 [log "infix detected!"]
			pc: eval-infix value pc end
		]
	]
]

interpreter: context [
	verbose: 0

	return-type: -1										;-- return type for routine calls

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

	find-refinement?: func [
		ref		[red-word!]
		path	[red-path!]
		slot	[red-word!]
		end		[red-value!]
		return: [logic!]
	][
		while [slot < end][
			if TYPE_OF(slot) <> TYPE_WORD [
				print-line "*** Error: function call with non-word refinement!"
				halt
			]
			if (symbol/resolve slot/symbol) = (symbol/resolve ref/symbol) [
				return yes
			]
			slot: slot + 1
		]
		no
	]

	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!]
		return:   [red-value!]
		/local
			next  [red-word!]
			op	  [red-op!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value
		call-op: as function! [] op/code
		call-op

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

		CHECK_INFIX
		pc
	]

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

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

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

		count:  	 0									;-- nb of fetched arguments (used as offset)
		index: 	 	 1
		return-type: -1
		ref?:		 no
		required?:	 yes								;-- yes: processing mandatory args, no: optonal args

		size: as-integer tail - value
		ref-array: system/stack/top - size
		system/stack/top: ref-array						;-- reserve space on native stack for refs array

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD [
					unless required? [
						either ref? [
							unless function? [
								prev: index - 1			;-- overwrite previous entry if it was a ref marker
								either negative? ref-array/prev [
									ref-array/prev: count
									index: prev
								][
									ref-array/index: count
								]

							]
						][
							either function? [
								none/push
							][
								ref-array/index: -1
							]
						]
						index: index + 1
					]
					if any [required? ref?][
						EVAL_CHECK_INPUT
						if verbose > 0 [log "evaluating argument"]
						pc: eval-expression pc end no yes	;-- eval argument
						count: count + 1
					]
				]
				TYPE_LIT_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_GET_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_REFINEMENT [
					if required? [required?: no]		;-- no more mandatory arguments

					ref?: either null? path [no][
						find-refinement? as red-word! value path as red-word! pos path-end
					]

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

		unless 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-element: func [
		slot     [red-value!]
		head     [red-value!]
		tail     [red-value!]
		result   [red-value!]
		alt-slot [red-value!]							;-- alternative element (computed from paren)
		set?     [logic!]
		return:  [red-value!]
		/local
			value  [red-value!]
			int	   [red-integer!]
	][
		value: case [
			TYPE_OF(slot) = TYPE_GET_WORD [_context/get as red-word! slot]
			null? alt-slot 				  [slot]
			true		   				  [alt-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 [
							return result
						]
						TYPE_BLOCK 						;@@ replace with TYPE_SERIES
						TYPE_PATH
						TYPE_LIT_PATH
						TYPE_GET_PATH
						TYPE_SET_PATH
						TYPE_STRING [

						]
						;TYPE_OBJECT
						;TYPE_PORT [
						;
						;]
						default [
							;; TBD raise an error
						]
					]
				][
					result: either all [set? slot + 1 = tail][
						value: actions/find as red-series! result value null no no no null null no no no no
						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
					]
				]
			]
			TYPE_PAREN [
				stack/mark-native words/_body			;@@ ~paren
				eval as red-block! value				;-- eval paren content
				stack/unwind
				result: eval-path-element slot head tail result stack/top - 1 set?
			]
			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--
			]
		]
		result
	]

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

		path:  as red-path! value
		head:  block/rs-head as red-block! path
		tail:  block/rs-tail as red-block! path
		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)]]

			result: eval-path-element slot head tail result null set?

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

		stack/top: saved
		stack/push result
		pc
	]

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

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

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

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

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		prefix	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next  [red-word!]
			value [red-value!]
			w	  [red-word!]
	][
		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
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no yes		;-- yes: push value on top of stack
				pc: eval-path value pc end yes
			]
			TYPE_GET_WORD [
				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							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

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

		unless prefix [CHECK_INFIX]
		pc
	]

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

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
	][
		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_FETCH_ARGUMENT [
	EVAL_CHECK_INPUT
	if verbose > 0 [log "fetching argument"]
	stack/push pc
	pc: pc + 1
	count: count + 1
]

interpreter: context [
	verbose: 0

	return-type: -1										;-- return type for routine calls

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

	find-refinement?: func [
		ref		[red-word!]
		path	[red-path!]
		slot	[red-word!]
		end		[red-value!]
		return: [logic!]
	][
		while [slot < end][
			if TYPE_OF(slot) <> TYPE_WORD [
				print-line "*** Error: function call with non-word refinement!"
				halt
			]
			if (symbol/resolve slot/symbol) = (symbol/resolve ref/symbol) [
				return yes
			]
			slot: slot + 1
		]
		no
	]

	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
			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!]
		path	[red-path!]
		pos 	[red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			dt		  [red-datatype!]
			path-end  [red-value!]
			s		  [series!]
			required? [logic!]
			ref?	  [logic!]
			index	  [integer!]
			count	  [integer!]
			prev	  [integer!]
			size	  [integer!]
			ref-array [int-ptr!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]

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

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

		count:  	 0									;-- nb of fetched arguments (used as offset)
		index: 	 	 1
		return-type: -1
		ref?:		 no
		required?:	 yes								;-- yes: processing mandatory args, no: optonal args

		size: as-integer tail - value
		ref-array: system/stack/top - size
		system/stack/top: ref-array						;-- reserve space on native stack for refs array

		while [value < tail][
			if verbose > 0 [print-line ["eval: spec entry type: " TYPE_OF(value)]]
			switch TYPE_OF(value) [
				TYPE_WORD [
					unless required? [
						either ref? [
							unless function? [
								prev: index - 1			;-- overwrite previous entry if it was a ref marker
								either negative? ref-array/prev [
									ref-array/prev: count
									index: prev
								][
									ref-array/index: count
								]

							]
						][
							either function? [
								none/push
							][
								ref-array/index: -1
							]
						]
						index: index + 1
					]
					if any [required? ref?][
						EVAL_CHECK_INPUT
						if verbose > 0 [log "evaluating argument"]
						pc: eval-expression pc end no yes	;-- eval argument
						count: count + 1
					]
				]
				TYPE_LIT_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_GET_WORD [EVAL_FETCH_ARGUMENT]
				TYPE_REFINEMENT [
					if required? [required?: no]		;-- no more mandatory arguments

					ref?: either null? path [no][
						find-refinement? as red-word! value path as red-word! pos path-end
					]

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

		unless 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-element: func [
		slot     [red-value!]
		head     [red-value!]
		tail     [red-value!]
		result   [red-value!]
		alt-slot [red-value!]							;-- alternative element (computed from paren)
		set?     [logic!]
		return:  [red-value!]
		/local
			value  [red-value!]
			int	   [red-integer!]
	][
		value: case [
			TYPE_OF(slot) = TYPE_GET_WORD [_context/get as red-word! slot]
			null? alt-slot 				  [slot]
			true		   				  [alt-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 [
							return result
						]
						TYPE_BLOCK 						;@@ replace with TYPE_SERIES
						TYPE_PATH
						TYPE_LIT_PATH
						TYPE_GET_PATH
						TYPE_SET_PATH
						TYPE_STRING [

						]
						;TYPE_OBJECT
						;TYPE_PORT [
						;
						;]
						default [
							;; TBD raise an error
						]
					]
				][
					result: either all [set? slot + 1 = tail][
						value: actions/find as red-series! result value null no no no null null no no no no
						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
					]
				]
			]
			TYPE_PAREN [
				stack/mark-native words/_body			;@@ ~paren
				eval as red-block! value				;-- eval paren content
				stack/unwind
				result: eval-path-element slot head tail result stack/top - 1 set?
			]
			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--
			]
		]
		result
	]

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

		path:  as red-path! value
		head:  block/rs-head as red-block! path
		tail:  block/rs-tail as red-block! path
		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)]]

			result: eval-path-element slot head tail result null set?

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

		stack/top: saved
		stack/push result
		pc
	]

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

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

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

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

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		infix	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next  [red-word!]
			value [red-value!]
			w	  [red-word!]
	][
		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
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]

				if verbose > 0 [
					value: stack/arguments
					print-line ["eval: set-word return type: " TYPE_OF(value)]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no yes		;-- yes: push value on top of stack
				pc: eval-path value pc end yes
			]
			TYPE_GET_WORD [
				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							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null
					]
					default [
						if verbose > 0 [log "getting word value"]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]

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

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

	eval: func [
		code	  [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
	][
		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
	]

]