TESTS: reformatted some tests, plus additional string tests.

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

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

~~~start-file~~~ "parse"

===start-group=== "Block"

	--test-- "blk-1" 	--assert parse 		[]			[]
	--test-- "blk-2" 	--assert parse 		[a]			['a]
	--test-- "blk-3" 	--assert not parse 	[a]			['b]
	--test-- "blk-4" 	--assert parse 		[a b]		['a 'b]
	--test-- "blk-5" 	--assert parse 		[a #"b"]	['a #"b"]
	--test-- "blk-6" 	--assert parse 		[a]			[['a]]
	--test-- "blk-7" 	--assert parse 		[a b]		[['a] 'b]
	--test-- "blk-8" 	--assert parse 		[a b]		['a ['b]]
	--test-- "blk-9" 	--assert parse 		[a b]		[['a]['b]]
	--test-- "blk-10"	--assert parse 		["hello"]	["hello"]

	--test-- "blk-11"	--assert parse 		[#"a"] 		[#"b" | #"a"]
	--test-- "blk-12"	--assert not parse 	[a b]		['b | 'a]
	--test-- "blk-13"	--assert parse 		[#"a"]		[[#"b" | #"a"]]
	--test-- "blk-14"	--assert not parse 	[a b]		[['b | 'a]]
	--test-- "blk-15"	--assert parse 		[a b]		[['a | 'b]['b | 'a]]

	--test-- "blk-16"	--assert parse		[a 123]		['a integer!]
	--test-- "blk-17"	--assert not parse	[a 123]		['a char!]
	--test-- "blk-18"	--assert parse		[a 123]		[['a][integer!]]
	--test-- "blk-19"	--assert not parse	[a 123]		['a [char!]]

	--test-- "blk-20"
		res: 0
	--assert parse [] [(res: 1)]
	--assert res = 1

	--test-- "blk-21"
		res: 0
		--assert parse [a] ['a (res: 1)]
		--assert res = 1

	--test-- "blk-22"
		res: 0
		--assert not parse [a] ['b (res: 1)]
		--assert res = 0

	--test-- "blk-23"
		res: 0
		--assert parse [] [[(res: 1)]]
		--assert res = 1

	--test-- "blk-24"
		res: 0
		--assert parse [a] [['a (res: 1)]]
		--assert res = 1

	--test-- "blk-25"
		res: 0
		--assert not parse [a] [['b (res: 1)]]
		--assert res = 0

	--test-- "blk-26"
		res: 0
		--assert parse [a 123] ['a (res: 1) [char! (res: 2) | integer! (res: 3)]]
		--assert res = 3

	--test-- "blk-27"
		res: 0
		--assert not parse [a 123] ['a (res: 1) [char! (res: 2) | string! (res: 3)]]
		--assert res = 1

	--test-- "blk-28"	--assert not parse		[a a]		[1 ['a]]
   	--test-- "blk-29"	--assert parse			[a a]		[2 ['a]]
   	--test-- "blk-30"	--assert not parse		[a a]		[3 ['a]]
   	--test-- "blk-31"	--assert not parse		[a a]		[1 1 ['a]]
   	--test-- "blk-32"	--assert parse			[a a]		[1 2 ['a]]
   	--test-- "blk-33"	--assert parse			[a a]		[2 2 ['a]]
   	--test-- "blk-34"	--assert parse			[a a]		[2 3 ['a]]
   	--test-- "blk-35"	--assert not parse		[a a]		[3 4 ['a]]

	--test-- "blk-36"	--assert not parse		[a a]		[1 'a]
	--test-- "blk-37"	--assert parse			[a a]		[2 'a]
	--test-- "blk-38"	--assert not parse		[a a]		[3 'a]
	--test-- "blk-39"	--assert not parse		[a a]		[1 1 'a]
	--test-- "blk-40"	--assert parse			[a a]		[1 2 'a]
	--test-- "blk-41"	--assert parse			[a a]		[2 2 'a]
	--test-- "blk-42"	--assert parse			[a a]		[2 3 'a]
   	--test-- "blk-43"	--assert not parse		[a a]		[3 4 'a]

    --test-- "blk-44"	--assert parse			[a]			[skip]
    --test-- "blk-45"	--assert parse			[a b]		[skip skip]
    --test-- "blk-46"	--assert parse			[a b]		[skip [skip]]
    --test-- "blk-47"	--assert parse			[a b]		[[skip] [skip]]

   	--test-- "blk-48"	--assert parse			[a a]		[some ['a]]
   	--test-- "blk-49"	--assert not parse		[a a]		[some ['a] 'b]

   	--test-- "blk-50"	--assert parse			[a a b a b b b a]	[some [skip]]
   	--test-- "blk-51"	--assert parse			[a a b a b b b a]	[some ['a | 'b]]
   	--test-- "blk-52"	--assert not parse 		[a a b a b b b a]	[some ['a | 'c]]

	--test-- "blk-53"	--assert parse 			[a a]		[any ['a]]
	--test-- "blk-54"	--assert parse			[a a]		[some ['a] any ['b]]
	--test-- "blk-55"	--assert parse			[a a b b]	[2 'a 2 'b]
	--test-- "blk-56"	--assert not parse		[a a b b]	[2 'a 3 'b]
	--test-- "blk-57"	--assert parse			[a a b b]	[some 'a some 'b]
   	--test-- "blk-58"	--assert not parse		[a a b b]	[some 'a some 'c]

	--test-- "blk-59"
		p: none
		--assert parse [] [p:]
		--assert tail? p

	--test-- "blk-60"
		p: none
		--assert parse [] [[[p:]]]
		--assert tail? p

	--test-- "blk-61"
		p: none
		--assert parse [a] [p: 'a]
		--assert p = [a]

	--test-- "blk-62"
		p: none
		--assert parse [a] ['a p:]
		--assert tail? p

	--test-- "blk-63"
		p: none
		--assert parse [a] ['a [p:]]
		--assert tail? p

	--test-- "blk-64"
		p: none
		--assert not parse [a b] ['a p:]
		--assert p = [b]

	--test-- "blk-65"
		p: none
		--assert parse [a b] ['a [p:]['b | 'c]]
		--assert p = [b]

	--test-- "blk-66"
		p: none
		--assert parse [a a a b b] [3 'a p: 2 'b :p [2 'b]]
		--assert p = [b b]

===end-group===

===start-group=== "block-end"

	--test-- "blk-end-1" --assert parse 		[a] 	['a end]
	--test-- "blk-end-2" --assert not parse 	[a b] 	['a end]
	--test-- "blk-end-3" --assert parse 		[a] 	[skip end]
	--test-- "blk-end-4" --assert not parse 	[a b]	[skip end]
	--test-- "blk-end-5" --assert parse 		[]		[end]

	--test-- "blk-end-6"
		be6: 0
		--assert parse [] [end (be6: 1)]
		--assert be6 = 1

===end-group===

===start-group=== "String"

	--test-- "str-1" 	--assert parse		""			[]
	--test-- "str-2" 	--assert parse		"a"			[#"a"]
	--test-- "str-3" 	--assert parse		"a"			["a"]
	--test-- "str-4" 	--assert not parse	"a"			[#"b"]
	--test-- "str-5" 	--assert parse		"ab"		[#"a" #"b"]
	--test-- "str-6" 	--assert parse		"ab"		["ab"]
	--test-- "str-7" 	--assert parse		"a"			[[#"a"]]
	--test-- "str-8" 	--assert parse		"ab"		[[#"a"] "b"]
	--test-- "str-9" 	--assert parse		"ab"		[#"a" [#"b"]]
	--test-- "str-10" 	--assert parse		"ab"		[[#"a"][#"b"]]

	--test-- "str-11"	--assert parse		"a"			[#"b" | #"a"]
	--test-- "str-12"	--assert not parse	"ab"		[#"b" | "a"]
	--test-- "str-13"	--assert parse		"a"			[[#"b" | #"a"]]
	--test-- "str-14"	--assert not parse	"ab"		[[#"b" | "a"]]
	--test-- "str-15"	--assert parse		"ab"		[["a" | #"b"][#"b" | "a"]]

	;--test-- "str-16"	--assert parse		"123"		[integer!]

	--test-- "str-20"
		res: 0
		--assert parse "" [(res: 1)]
		--assert res = 1

	--test-- "str-21"
		res: 0
		--assert parse "a" [#"a" (res: 1)]
		--assert res = 1

	--test-- "str-22"
		res: 0
		--assert not parse "a" [#"b" (res: 1)]
		--assert res = 0

	--test-- "str-23"
		res: 0
		--assert parse "" [[(res: 1)]]
		--assert res = 1

	--test-- "str-24"
		res: 0
		--assert parse "a" [[#"a" (res: 1)]]
		--assert res = 1

	--test-- "str-25"
		res: 0
		--assert not parse "a" [[#"b" (res: 1)]]
		--assert res = 0

	--test-- "str-26"
		res: 0
		--assert parse "ab" [#"a" (res: 1) [#"c" (res: 2) | #"b" (res: 3)]]
		--assert res = 3

	--test-- "str-27"
		res: 0
		--assert not parse "ab" [#"a" (res: 1) [#"c" (res: 2) | #"d" (res: 3)]]
		--assert res = 1

	--test-- "str-28"	--assert not parse		"aa"		[1 [#"a"]]
   	--test-- "str-29"	--assert parse			"aa"		[2 [#"a"]]
   	--test-- "str-30"	--assert not parse		"aa"		[3 [#"a"]]
   	--test-- "str-31"	--assert not parse		"aa"		[1 1 [#"a"]]
   	--test-- "str-32"	--assert parse			"aa"		[1 2 [#"a"]]
   	--test-- "str-33"	--assert parse			"aa"		[2 2 [#"a"]]
   	--test-- "str-34"	--assert parse			"aa"		[2 3 [#"a"]]
   	--test-- "str-35"	--assert not parse		"aa"		[3 4 [#"a"]]

   	--test-- "str-36"	--assert not parse		"aa"		[1 #"a"]
	--test-- "str-37"	--assert parse			"aa"		[2 #"a"]
	--test-- "str-38"	--assert not parse		"aa"		[3 #"a"]
	--test-- "str-39"	--assert not parse		"aa"		[1 1 #"a"]
	--test-- "str-40"	--assert parse			"aa"		[1 2 #"a"]
	--test-- "str-41"	--assert parse			"aa"		[2 2 #"a"]
	--test-- "str-42"	--assert parse			"aa"		[2 3 #"a"]
	--test-- "str-43"	--assert not parse		"aa"		[3 4 #"a"]

    --test-- "str-44"	--assert parse			"a"			[skip]
    --test-- "str-45"	--assert parse			"ab"		[skip skip]
    --test-- "str-46"	--assert parse			"ab"		[skip [skip]]
    --test-- "str-47"	--assert parse			"ab"		[[skip] [skip]]

   	--test-- "str-48"	--assert parse			"aa"		[some [#"a"]]
   	--test-- "str-49"	--assert not parse		"aa"		[some [#"a"] #"b"]

   	--test-- "str-50"	--assert parse			"aababbba"	[some [skip]]
   	--test-- "str-51"	--assert parse			"aababbba"	[some ["a" | "b"]]
   	--test-- "str-52"	--assert not parse 		"aababbba"	[some ["a" | #"c"]]

	--test-- "str-53"	--assert parse 			"aa"		[any [#"a"]]
	--test-- "str-54"	--assert parse			"aa"		[some [#"a"] any [#"b"]]
	--test-- "str-55"	--assert parse			"aabb"		[2 #"a" 2 "b"]
	--test-- "str-56"	--assert not parse		"aabb"		[2 "a" 3 #"b"]
	--test-- "str-57"	--assert parse			"aabb"		[some #"a" some "b"]
   	--test-- "str-58"	--assert not parse		"aabb"		[some "a" some #"c"]

	--test-- "str-59"
		p: none
		--assert parse "" [p:]
		--assert tail? p

	--test-- "str-60"
		p: none
		--assert parse "" [[[p:]]]
		--assert tail? p

	--test-- "str-61"
		p: none
		--assert parse "a" [p: #"a"]
		--assert p = "a"

	--test-- "str-62"
		p: none
		--assert parse "a" [#"a" p:]
		--assert tail? p

	--test-- "str-63"
		p: none
		--assert parse "a" [#"a" [p:]]
		--assert tail? p

	--test-- "str-64"
		p: none
		--assert not parse "ab" [#"a" p:]
		--assert p = "b"

	--test-- "str-65"
		p: none
		--assert parse "ab" [#"a" [p:][#"b" | #"c"]]
		--assert p = "b"

	--test-- "str-66"
		p: none
		--assert parse "aaabb" [3 #"a" p: 2 #"b" :p [2 "b"]]
		--assert p = "bb"

===end-group===

===start-group=== "string-end"

	--test-- "str-end-1" --assert parse 		"a" 	[#"a" end]
	--test-- "str-end-2" --assert not parse 	"ab" 	[#"a" end]
	--test-- "str-end-3" --assert parse 		"a" 	[skip end]
	--test-- "str-end-4" --assert not parse 	"ab"	[skip end]
	--test-- "str-end-5" --assert parse 		""		[end]

	--test-- "str-end-6"
		be6: 0
		--assert parse "" [end (be6: 1)]
		--assert be6 = 1

===end-group===

~~~end-file~~~

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

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

~~~start-file~~~ "parse"

===start-group=== "Block"

	--test-- "blk-1" 	--assert parse 		[]			[]
	--test-- "blk-2" 	--assert parse 		[a]			['a]
	--test-- "blk-3" 	--assert not parse 	[a]			['b]
	--test-- "blk-4" 	--assert parse 		[a b]		['a 'b]
	--test-- "blk-5" 	--assert parse 		[a #"b"]	['a #"b"]
	--test-- "blk-6" 	--assert parse 		[a]			[['a]]
	--test-- "blk-7" 	--assert parse 		[a b]		[['a] 'b]
	--test-- "blk-8" 	--assert parse 		[a b]		['a ['b]]
	--test-- "blk-9" 	--assert parse 		[a b]		[['a]['b]]
	--test-- "blk-10"	--assert parse 		["hello"]	["hello"]

	--test-- "blk-11"	--assert parse 		[#"a"] 		[#"b" | #"a"]
	--test-- "blk-12"	--assert not parse 	[a b]		['b | 'a]
	--test-- "blk-13"	--assert parse 		[#"a"]		[[#"b" | #"a"]]
	--test-- "blk-14"	--assert not parse 	[a b]		[['b | 'a]]
	--test-- "blk-15"	--assert parse 		[a b]		[['a | 'b]['b | 'a]]

	--test-- "blk-16"	--assert parse		[a 123]		['a integer!]
	--test-- "blk-17"	--assert not parse	[a 123]		['a char!]
	--test-- "blk-18"	--assert parse		[a 123]		[['a][integer!]]
	--test-- "blk-19"	--assert not parse	[a 123]		['a [char!]]

	--test-- "blk-20"
		res: 0
		--assert parse [] [(res: 1)]
		--assert res = 1

	--test-- "blk-21"
		res: 0
	--assert parse [a] ['a (res: 1)]
	--assert res = 1

	--test-- "blk-22"
		res: 0
	--assert not parse [a] ['b (res: 1)]
	--assert res = 0

	--test-- "blk-23"
		res: 0
	--assert parse [] [[(res: 1)]]
	--assert res = 1

	--test-- "blk-24"
		res: 0
	--assert parse [a] [['a (res: 1)]]
	--assert res = 1

	--test-- "blk-25"
		res: 0
	--assert not parse [a] [['b (res: 1)]]
	--assert res = 0

	--test-- "blk-26"
		res: 0
	--assert parse [a 123] ['a (res: 1) [char! (res: 2) | integer! (res: 3)]]
	--assert res = 3

	--test-- "blk-27"
		res: 0
	--assert not parse [a 123] ['a (res: 1) [char! (res: 2) | string! (res: 3)]]
	--assert res = 1

	--test-- "blk-28"	--assert not parse		[a a]		[1 ['a]]
   	--test-- "blk-29"	--assert parse			[a a]		[2 ['a]]
   	--test-- "blk-30"	--assert not parse		[a a]		[3 ['a]]
   	--test-- "blk-31"	--assert not parse		[a a]		[1 1 ['a]]
   	--test-- "blk-32"	--assert parse			[a a]		[1 2 ['a]]
   	--test-- "blk-33"	--assert parse			[a a]		[2 2 ['a]]
   	--test-- "blk-34"	--assert parse			[a a]		[2 3 ['a]]
   	--test-- "blk-35"	--assert not parse		[a a]		[3 4 ['a]]

	--test-- "blk-36"	--assert not parse		[a a]		[1 'a]
	--test-- "blk-37"	--assert parse			[a a]		[2 'a]
	--test-- "blk-38"	--assert not parse		[a a]		[3 'a]
	--test-- "blk-39"	--assert not parse		[a a]		[1 1 'a]
	--test-- "blk-40"	--assert parse			[a a]		[1 2 'a]
	--test-- "blk-41"	--assert parse			[a a]		[2 2 'a]
	--test-- "blk-42"	--assert parse			[a a]		[2 3 'a]
   	--test-- "blk-43"	--assert not parse		[a a]		[3 4 'a]

    --test-- "blk-44"	--assert parse			[a]			[skip]
    --test-- "blk-45"	--assert parse			[a b]		[skip skip]
    --test-- "blk-46"	--assert parse			[a b]		[skip [skip]]
    --test-- "blk-47"	--assert parse			[a b]		[[skip] [skip]]

   	--test-- "blk-48"	--assert parse			[a a]		[some ['a]]
   	--test-- "blk-49"	--assert not parse		[a a]		[some ['a] 'b]

   	--test-- "blk-50"	--assert parse			[a a b a b b b a]	[some [skip]]
   	--test-- "blk-51"	--assert parse			[a a b a b b b a]	[some ['a | 'b]]
   	--test-- "blk-52"	--assert not parse 		[a a b a b b b a]	[some ['a | 'c]]

	--test-- "blk-53"	--assert parse 			[a a]		[any ['a]]
	--test-- "blk-54"	--assert parse			[a a]		[some ['a] any ['b]]
	--test-- "blk-55"	--assert parse			[a a b b]	[2 'a 2 'b]
	--test-- "blk-56"	--assert not parse		[a a b b]	[2 'a 3 'b]
	--test-- "blk-57"	--assert parse			[a a b b]	[some 'a some 'b]
   	--test-- "blk-58"	--assert not parse		[a a b b]	[some 'a some 'c]

	--test-- "blk-59"
		p: none
	--assert parse [] [p:]
	--assert tail? p

	--test-- "blk-60"
		p: none
	--assert parse [] [[[p:]]]
	--assert tail? p

	--test-- "blk-61"
		p: none
	--assert parse [a] [p: 'a]
	--assert p = [a]

	--test-- "blk-62"
		p: none
	--assert parse [a] ['a p:]
	--assert tail? p

	--test-- "blk-63"
		p: none
	--assert parse [a] ['a [p:]]
	--assert tail? p

	--test-- "blk-64"
		p: none
	--assert not parse [a b] ['a p:]
	--assert p = [b]

	--test-- "blk-65"
		p: none
	--assert parse [a b] ['a [p:]['b | 'c]]
	--assert p = [b]

	--test-- "blk-66"
		p: none
	--assert parse [a a a b b] [3 'a p: 2 'b :p [2 'b]]
	--assert p = [b b]

===end-group===

===start-group=== "block-end"

	--test-- "blk-end-1"
	--assert parse [a] ['a end]

	--test-- "blk-end-2"
	--assert not parse [a b] ['a end]

	--test-- "blk-end-3"
	--assert parse [a] [skip end]

	--test-- "blk-end-4"
	--assert not parse [a b] [skip end]

	--test-- "blk-end-5"
	--assert parse [] [end]

	--test-- "blk-end-6"
		be6: 0
		--assert parse [] [end (be6: 1)]
	--assert be6 = 1

===end-group===

===start-group=== "String"

	--test-- "str-1" 	--assert parse		""			[]
	--test-- "str-2" 	--assert parse		"a"			[#"a"]
	--test-- "str-3" 	--assert parse		"a"			["a"]
	--test-- "str-4" 	--assert not parse	"a"			[#"b"]
	--test-- "str-5" 	--assert parse		"ab"		[#"a" #"b"]
	--test-- "str-6" 	--assert parse		"ab"		["ab"]
	--test-- "str-7" 	--assert parse		"a"			[[#"a"]]
	--test-- "str-8" 	--assert parse		"ab"		[[#"a"] "b"]
	--test-- "str-9" 	--assert parse		"ab"		[#"a" [#"b"]]
	--test-- "str-10" 	--assert parse		"ab"		[[#"a"][#"b"]]

	--test-- "str-11"	--assert parse		"a"			[#"b" | #"a"]
	--test-- "str-12"	--assert not parse	"ab"		[#"b" | "a"]
	--test-- "str-13"	--assert parse		"a"			[[#"b" | #"a"]]
	--test-- "str-14"	--assert not parse	"ab"		[[#"b" | "a"]]
	--test-- "str-15"	--assert parse		"ab"		[["a" | #"b"][#"b" | "a"]]

	;--test-- "str-16"	--assert parse		"123"		[integer!]

	--test-- "str-20"
		res: 0
	--assert parse "" [(res: 1)]
	--assert res = 1

	--test-- "str-21"
		res: 0
	--assert parse "a" [#"a" (res: 1)]
	--assert res = 1

	--test-- "str-22"
		res: 0
	--assert not parse "a" [#"b" (res: 1)]
	--assert res = 0

	--test-- "str-23"
		res: 0
	--assert parse "" [[(res: 1)]]
	--assert res = 1

	--test-- "str-24"
		res: 0
	--assert parse "a" [[#"a" (res: 1)]]
	--assert res = 1

	--test-- "str-25"
		res: 0
	--assert not parse "a" [[#"b" (res: 1)]]
	--assert res = 0

	--test-- "str-26"
		res: 0
	--assert parse "ab" [#"a" (res: 1) [#"c" (res: 2) | #"b" (res: 3)]]
	--assert res = 3

	--test-- "str-27"
		res: 0
	--assert not parse "ab" [#"a" (res: 1) [#"c" (res: 2) | #"d" (res: 3)]]
	--assert res = 1

	--test-- "str-28"	--assert not parse		"aa"		[1 [#"a"]]
   	--test-- "str-29"	--assert parse			"aa"		[2 [#"a"]]
   	--test-- "str-30"	--assert not parse		"aa"		[3 [#"a"]]
   	--test-- "str-31"	--assert not parse		"aa"		[1 1 [#"a"]]
   	--test-- "str-32"	--assert parse			"aa"		[1 2 [#"a"]]
   	--test-- "str-33"	--assert parse			"aa"		[2 2 [#"a"]]
   	--test-- "str-34"	--assert parse			"aa"		[2 3 [#"a"]]
   	--test-- "str-35"	--assert not parse		"aa"		[3 4 [#"a"]]

   	--test-- "str-36"	--assert not parse		"aa"		[1 #"a"]
	--test-- "str-37"	--assert parse			"aa"		[2 #"a"]
	--test-- "str-38"	--assert not parse		"aa"		[3 #"a"]
	--test-- "str-39"	--assert not parse		"aa"		[1 1 #"a"]
	--test-- "str-40"	--assert parse			"aa"		[1 2 #"a"]
	--test-- "str-41"	--assert parse			"aa"		[2 2 #"a"]
	--test-- "str-42"	--assert parse			"aa"		[2 3 #"a"]
	--test-- "str-43"	--assert not parse		"aa"		[3 4 #"a"]

    --test-- "str-44"	--assert parse			"a"			[skip]
    --test-- "str-45"	--assert parse			"ab"		[skip skip]
    --test-- "str-46"	--assert parse			"ab"		[skip [skip]]
    --test-- "str-47"	--assert parse			"ab"		[[skip] [skip]]

   	--test-- "str-48"	--assert parse			"aa"		[some [#"a"]]
   	--test-- "str-49"	--assert not parse		"aa"		[some [#"a"] #"b"]

   	--test-- "str-50"	--assert parse			"aababbba"	[some [skip]]
   	--test-- "str-51"	--assert parse			"aababbba"	[some ["a" | "b"]]
   	--test-- "str-52"	--assert not parse 		"aababbba"	[some ["a" | #"c"]]

	--test-- "str-53"	--assert parse 			"aa"		[any [#"a"]]
	--test-- "str-54"	--assert parse			"aa"		[some [#"a"] any [#"b"]]
	--test-- "str-55"	--assert parse			"aabb"		[2 #"a" 2 "b"]
	--test-- "str-56"	--assert not parse		"aabb"		[2 "a" 3 #"b"]
	--test-- "str-57"	--assert parse			"aabb"		[some #"a" some "b"]
   	--test-- "str-58"	--assert not parse		"aabb"		[some "a" some #"c"]

	--test-- "str-59"
		p: none
	--assert parse "" [p:]
	--assert tail? p

	--test-- "str-60"
		p: none
	--assert parse "" [[[p:]]]
	--assert tail? p

	--test-- "str-61"
		p: none
	--assert parse "a" [p: #"a"]
	--assert p = "a"

	--test-- "str-62"
		p: none
	--assert parse "a" [#"a" p:]
	--assert tail? p

	--test-- "str-63"
		p: none
	--assert parse "a" [#"a" [p:]]
	--assert tail? p

	--test-- "str-64"
		p: none
	--assert not parse "ab" [#"a" p:]
	--assert p = "b"

	--test-- "str-65"
		p: none
	--assert parse "ab" [#"a" [p:][#"b" | #"c"]]
	--assert p = "b"

	--test-- "str-66"
		p: none
	--assert parse "aaabb" [3 #"a" p: 2 #"b" :p [2 "b"]]
	--assert p = "bb"

===end-group===

~~~end-file~~~


FIX: issue #585 (^} in string is wrongly LOADed)

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

tokenizer: context [

	#define NOT_DELIMITER?(c) [
		all [
			c <> null-byte
			c <> #" "
			c <> #"/"
			c <> #"^/"
			c <> #"^M"
			c <> #"^-"
			c <> #":"
			c <> #"^""
			c <> #"["
			c <> #"]"
			c <> #"("
			c <> #")"
			c <> #"{"
			c <> #"}"
			c <> #";"
		]
	]

	#define NOT_FILE_DELIMITER?(c) [
		all [
			c <> null-byte
			c <> #" "
			c <> #"^/"
			c <> #"^M"
			c <> #"^-"
			c <> #":"
			c <> #"^""
			c <> #"["
			c <> #"]"
			c <> #"("
			c <> #")"
			c <> #"{"
			c <> #"}"
			c <> #";"
		]
	]

	#enum errors! [
		ERR_PREMATURE_END
		ERR_STRING_DELIMIT
		ERR_MULTI_STRING_DELIMIT
		ERR_CHAR_DELIMIT
		ERR_INVALID_INTEGER
		ERR_INVALID_PATH
		ERR_INVALID_CHAR
	]

	throw-error: func [id [integer!]][
		print "*** Load Error: "
		print switch id [
			ERR_PREMATURE_END		 ["unmatched ] closing bracket"]
			ERR_STRING_DELIMIT 		 [{string ending delimiter " not found}]
			ERR_MULTI_STRING_DELIMIT ["string ending delimiter } not found"]
			ERR_CHAR_DELIMIT		 [{char ending delimiter " not found}]
			ERR_INVALID_INTEGER		 ["invalid integer"]
			ERR_INVALID_PATH		 ["invalid path"]
			ERR_INVALID_CHAR		 ["invalid char"]
		]
		print-line #"!"
	]

	preprocess: func [
		str [red-string!]
		/local
			src	 [byte-ptr!]
			tail [byte-ptr!]
			dst	 [byte-ptr!]
			s	 [series!]
			c	 [byte!]
	][
		s: 		GET_BUFFER(str)
		src:	string/rs-head str
		tail:   string/rs-tail str
		dst:	src

		while [src < tail][
			either src/1 = #"^^" [
				src: src + 1
				c: src/1
				dst/1: switch c [
					#"-"	[#"^-"]
					#"/"	[#"^/"]
					#"^""	[#"^""]
					#"^^"	[#"^^"]
					#"{"	[#"{"]
					#"}"	[#"}"]
					default [src/1 - #"@"]
				]
			][
				if dst <> src [dst/1: src/1]
			]
			src: src + 1
			dst: dst + 1
		]
		dst/1: null-byte
		s/tail:	as red-value! dst
	]

	skip-spaces: func [
		src		[c-string!]
		return: [c-string!]
		/local
			c	[byte!]
	][
		while [
			c: src/1
			any [
				c = #" "
				c = #"^/"
				c = #"^M"
				c = #"^-"
			]
		][
			if c = null-byte [return src]
			src: src + 1
		]
		src
	]

	scan-comment: func [
		s		[c-string!]
		return: [c-string!]
	][
		while [not any [s/1 = #"^/" s/1 = null-byte]][s: s + 1]
		s
	]

	scan-char: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			c	 [byte!]
			byte [byte!]
	][
		byte: either s/1 = #"^^" [
			s: s + 1
			c: s/1
			either all [#"@" <= c c <= #"Z"][
				c - #"@"
			][
				switch c [
					#"^"" [#"^""]
					#"/"  [#"^/"]
					#"-"  [#"^-"]
					#"?"  [#"^~"]
					#"^^" [#"^^"]
					default [throw-error ERR_INVALID_CHAR]
				]
			]
		][
			s/1
		]
		s: s + 1
		if s/1 <> #"^"" [throw-error ERR_CHAR_DELIMIT]

		char/load-in as-integer byte blk
		s + 1
	]

	scan-string-multi: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
			count [integer!]
	][
		s: s + 1										;-- skip opening brace
		e: s
		c: e/1
		count: 1

		while [all [c <> null-byte count > 0]][
			while [all [c <> null-byte c <> #"}"]][
				if c = #"{" [count: count + 1]
				e: e + either c = #"^^" [2][1]
				c: e/1
			]
			if c = #"}" [
				count: count - 1
				e: e + 1
				c: e/1
			]
		]
		e: e - 1
		c: e/1

		if c <> #"}" [throw-error ERR_MULTI_STRING_DELIMIT return e + 1]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		preprocess string/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		either c = #"}" [e + 1][e]
	]

	scan-string: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
	][
		s: s + 1										;-- skip first double quote
		e: s
		c: e/1

		while [all [c <> null-byte c <> #"^""]][
			e: e + either c = #"^^" [2][1]
			c: e/1
		]
		if c <> #"^"" [throw-error ERR_STRING_DELIMIT]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		preprocess string/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		either c = #"^"" [e + 1][e]
	]

	scan-file: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
	][
		s: s + 1										;-- skip first double quote
		e: s
		c: e/1

		while [NOT_FILE_DELIMITER?(c)][
			e: e + 1
			c: e/1
		]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		file/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		e
	]

	scan-integer: func [
		s		 [c-string!]
		blk		 [red-block!]
		neg?	 [logic!]
		return:  [c-string!]
		/local
			e	 [c-string!]
			c	 [byte!]
			i	 [integer!]
	][
		e: s
		c: e/1
		i: 0

		while [
			all [c <> null-byte #"0" <= c c <= #"9"]
		][
			i: i * 10
			i: i + (c - #"0")
			e: e + 1
			c: e/1
		]
		if neg? [i: 0 - i]
		integer/load-in blk i
		e
	]

	scan-minus: func [
		src		[c-string!]
		blk		[red-block!]
		return:	[c-string!]
		/local
			c	[byte!]
	][
		c: src/2
		either all [#"0" <= c c <= #"9"][
			scan-integer src + 1 blk yes
		][
			scan-word src blk TYPE_WORD no
		]
	]

	scan-word: func [
		s		  [c-string!]
		blk		  [red-block!]
		type	  [integer!]
		in-path?  [logic!]
		return:   [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
			set?  [logic!]
			path? [logic!]
	][
		e: s + 1
		c: e/1

		while [NOT_DELIMITER?(c)][
			e: e + 1
			c: e/1
		]
		set?:  all [e/1 = #":"  not in-path?]
		path?: all [e/1 = slash not in-path?]

		if all [
			type = TYPE_REFINEMENT
			s + 1 = e
		][
			type: TYPE_WORD								;-- / as word case
		]

		either path? [
			return scan-path s e blk type = TYPE_LIT_WORD
		][
			saved: e/1										;@@ allocate a new buffer instead
			e/1: null-byte
			case [
				type = TYPE_GET_WORD	[get-word/load-in s blk]
				type = TYPE_LIT_WORD	[lit-word/load-in s blk]
				type = TYPE_ISSUE		[issue/load-in s blk]
				type = TYPE_REFINEMENT	[refinement/load-in s + 1 blk]
				set?				 	[set-word/load-in s blk]
				true				 	[word/load-in s blk]
			]
			e/1: saved
			return either set? [e + 1][e]
		]
	]

	scan-path: func [
		s		 [c-string!]
		src		 [c-string!]
		blk		 [red-block!]
		lit?	 [logic!]
		return:  [c-string!]
		/local
			path  [red-block!]
			saved [byte!]
			set?  [logic!]
	][
		path: block/make-in blk 4						;-- arbitrary start size

		saved: src/1									;-- push first element
		src/1: null-byte
		word/load-in s path								;-- store undecorated word
		src/1: saved
		c: src/1
		set?: no

		while [c = #"/"][
			src: src + 1
			c: src/1
			case [
				c = #"("  [src: scan-paren src + 1 path]
				c = #":"  [src: scan-word src + 1 path TYPE_GET_WORD yes]
				c = #"-"  [src: scan-minus src path]
				all [#"0" <= c c <= #"9"][src: scan-integer src path no]
				all [#" " <  c c <= #""][src: scan-word src path TYPE_WORD yes]
				yes [throw-error ERR_INVALID_PATH]
			]
			c: src/1
			if c = #":" [set?: yes]
		]

		path/header: case [
			set? [TYPE_SET_PATH]
			lit? [TYPE_LIT_PATH]
			true [TYPE_PATH]
		]
		either set? [src + 1][src]
	]

	scan-block: func [
		src		[c-string!]
		blk		[red-block!]
		return: [c-string!]
	][
		src: scan src block/make-in blk 4				;-- arbitrary start size
		src + 1											;-- skip ] character
	]

	scan-paren: func [
		src		 [c-string!]
		blk		 [red-block!]
		return:  [c-string!]
		/local
			s	 [series!]
			slot [red-value!]
	][
		src: scan src block/make-in blk 4				;-- arbitrary start size
		s: GET_BUFFER(blk)
		slot: s/tail - 1
		slot/header: TYPE_PAREN
		src + 1											;-- skip ) character

	]

	scan: func [
		src		  [c-string!]
		parent	  [red-block!]
		return:	  [c-string!]
		/local
			blk	  [red-block!]
			start [c-string!]
			end	  [c-string!]
			c	  [byte!]
	][
		blk: either null? parent [
			block/push* 4								;-- arbitrary start size
		][
			parent
		]

		while [
			src: skip-spaces src
			c: src/1
			all [
				c <> null-byte
				c <> #"]"
				c <> #")"
			]
		][
			case [
				c = #";"  [src: scan-comment src]
				c = #"-"  [src: scan-minus src blk]
				c = #"^"" [src: scan-string src blk]
				c = #"{"  [src: scan-string-multi src blk]
				c = #"%"  [src: scan-file src blk]
				c = #"["  [src: scan-block src + 1 blk]
				c = #"("  [src: scan-paren src + 1 blk]
				c = #":"  [src: scan-word src + 1 blk TYPE_GET_WORD no]
				c = #"'"  [src: scan-word src + 1 blk TYPE_LIT_WORD no]
				c = #"/"  [src: scan-word src blk TYPE_REFINEMENT no]
				c = #"#"  [
					c: src/2
					either c = #"^"" [
						src: scan-char src + 2 blk
					][
						src: scan-word src + 1 blk TYPE_ISSUE no
					]
				]
				all [#"0" <= c c <= #"9"][src: scan-integer src blk no]
				all [#" " <  c c <= #""][src: scan-word src blk TYPE_WORD no]
			]
		]
		if null? parent [
			if src/1 <> null-byte [throw-error ERR_PREMATURE_END]
			stack/set-last as red-value! blk
		]
		src
	]

]

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

tokenizer: context [

	#define NOT_DELIMITER?(c) [
		all [
			c <> null-byte
			c <> #" "
			c <> #"/"
			c <> #"^/"
			c <> #"^M"
			c <> #"^-"
			c <> #":"
			c <> #"^""
			c <> #"["
			c <> #"]"
			c <> #"("
			c <> #")"
			c <> #"{"
			c <> #"}"
			c <> #";"
		]
	]

	#define NOT_FILE_DELIMITER?(c) [
		all [
			c <> null-byte
			c <> #" "
			c <> #"^/"
			c <> #"^M"
			c <> #"^-"
			c <> #":"
			c <> #"^""
			c <> #"["
			c <> #"]"
			c <> #"("
			c <> #")"
			c <> #"{"
			c <> #"}"
			c <> #";"
		]
	]

	#enum errors! [
		ERR_PREMATURE_END
		ERR_STRING_DELIMIT
		ERR_MULTI_STRING_DELIMIT
		ERR_CHAR_DELIMIT
		ERR_INVALID_INTEGER
		ERR_INVALID_PATH
		ERR_INVALID_CHAR
	]

	throw-error: func [id [integer!]][
		print "*** Load Error: "
		print switch id [
			ERR_PREMATURE_END		 ["unmatched ] closing bracket"]
			ERR_STRING_DELIMIT 		 [{string ending delimiter " not found}]
			ERR_MULTI_STRING_DELIMIT ["string ending delimiter } not found"]
			ERR_CHAR_DELIMIT		 [{char ending delimiter " not found}]
			ERR_INVALID_INTEGER		 ["invalid integer"]
			ERR_INVALID_PATH		 ["invalid path"]
			ERR_INVALID_CHAR		 ["invalid char"]
		]
		print-line #"!"
	]

	preprocess: func [
		str [red-string!]
		/local
			src	 [byte-ptr!]
			tail [byte-ptr!]
			dst	 [byte-ptr!]
			s	 [series!]
			c	 [byte!]
	][
		s: 		GET_BUFFER(str)
		src:	string/rs-head str
		tail:   string/rs-tail str
		dst:	src

		while [src < tail][
			either src/1 = #"^^" [
				src: src + 1
				c: src/1
				dst/1: switch c [
					#"-"	[#"^-"]
					#"/"	[#"^/"]
					#"^""	[#"^""]
					#"^^"	[#"^^"]
					#"{"	[#"{"]
					default [src/1 - #"@"]
				]
			][
				if dst <> src [dst/1: src/1]
			]
			src: src + 1
			dst: dst + 1
		]
		dst/1: null-byte
		s/tail:	as red-value! dst
	]

	skip-spaces: func [
		src		[c-string!]
		return: [c-string!]
		/local
			c	[byte!]
	][
		while [
			c: src/1
			any [
				c = #" "
				c = #"^/"
				c = #"^M"
				c = #"^-"
			]
		][
			if c = null-byte [return src]
			src: src + 1
		]
		src
	]

	scan-comment: func [
		s		[c-string!]
		return: [c-string!]
	][
		while [not any [s/1 = #"^/" s/1 = null-byte]][s: s + 1]
		s
	]

	scan-char: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			c	 [byte!]
			byte [byte!]
	][
		byte: either s/1 = #"^^" [
			s: s + 1
			c: s/1
			either all [#"@" <= c c <= #"Z"][
				c - #"@"
			][
				switch c [
					#"^"" [#"^""]
					#"/"  [#"^/"]
					#"-"  [#"^-"]
					#"?"  [#"^~"]
					#"^^" [#"^^"]
					default [throw-error ERR_INVALID_CHAR]
				]
			]
		][
			s/1
		]
		s: s + 1
		if s/1 <> #"^"" [throw-error ERR_CHAR_DELIMIT]

		char/load-in as-integer byte blk
		s + 1
	]

	scan-string-multi: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
			count [integer!]
	][
		s: s + 1										;-- skip opening brace
		e: s
		c: e/1
		count: 1

		while [all [c <> null-byte count > 0]][
			while [all [c <> null-byte c <> #"}"]][
				if c = #"{" [count: count + 1]
				e: e + either c = #"^^" [2][1]
				c: e/1
			]
			if c = #"}" [
				count: count - 1
				e: e + 1
				c: e/1
			]
		]
		e: e - 1
		c: e/1

		if c <> #"}" [throw-error ERR_MULTI_STRING_DELIMIT return e + 1]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		preprocess string/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		either c = #"}" [e + 1][e]
	]

	scan-string: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
	][
		s: s + 1										;-- skip first double quote
		e: s
		c: e/1

		while [all [c <> null-byte c <> #"^""]][
			e: e + either c = #"^^" [2][1]
			c: e/1
		]
		if c <> #"^"" [throw-error ERR_STRING_DELIMIT]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		preprocess string/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		either c = #"^"" [e + 1][e]
	]

	scan-file: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
	][
		s: s + 1										;-- skip first double quote
		e: s
		c: e/1

		while [NOT_FILE_DELIMITER?(c)][
			e: e + 1
			c: e/1
		]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		file/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		e
	]

	scan-integer: func [
		s		 [c-string!]
		blk		 [red-block!]
		neg?	 [logic!]
		return:  [c-string!]
		/local
			e	 [c-string!]
			c	 [byte!]
			i	 [integer!]
	][
		e: s
		c: e/1
		i: 0

		while [
			all [c <> null-byte #"0" <= c c <= #"9"]
		][
			i: i * 10
			i: i + (c - #"0")
			e: e + 1
			c: e/1
		]
		if neg? [i: 0 - i]
		integer/load-in blk i
		e
	]

	scan-minus: func [
		src		[c-string!]
		blk		[red-block!]
		return:	[c-string!]
		/local
			c	[byte!]
	][
		c: src/2
		either all [#"0" <= c c <= #"9"][
			scan-integer src + 1 blk yes
		][
			scan-word src blk TYPE_WORD no
		]
	]

	scan-word: func [
		s		  [c-string!]
		blk		  [red-block!]
		type	  [integer!]
		in-path?  [logic!]
		return:   [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
			set?  [logic!]
			path? [logic!]
	][
		e: s + 1
		c: e/1

		while [NOT_DELIMITER?(c)][
			e: e + 1
			c: e/1
		]
		set?:  all [e/1 = #":"  not in-path?]
		path?: all [e/1 = slash not in-path?]

		if all [
			type = TYPE_REFINEMENT
			s + 1 = e
		][
			type: TYPE_WORD								;-- / as word case
		]

		either path? [
			return scan-path s e blk type = TYPE_LIT_WORD
		][
			saved: e/1										;@@ allocate a new buffer instead
			e/1: null-byte
			case [
				type = TYPE_GET_WORD	[get-word/load-in s blk]
				type = TYPE_LIT_WORD	[lit-word/load-in s blk]
				type = TYPE_ISSUE		[issue/load-in s blk]
				type = TYPE_REFINEMENT	[refinement/load-in s + 1 blk]
				set?				 	[set-word/load-in s blk]
				true				 	[word/load-in s blk]
			]
			e/1: saved
			return either set? [e + 1][e]
		]
	]

	scan-path: func [
		s		 [c-string!]
		src		 [c-string!]
		blk		 [red-block!]
		lit?	 [logic!]
		return:  [c-string!]
		/local
			path  [red-block!]
			saved [byte!]
			set?  [logic!]
	][
		path: block/make-in blk 4						;-- arbitrary start size

		saved: src/1									;-- push first element
		src/1: null-byte
		word/load-in s path								;-- store undecorated word
		src/1: saved
		c: src/1
		set?: no

		while [c = #"/"][
			src: src + 1
			c: src/1
			case [
				c = #"("  [src: scan-paren src + 1 path]
				c = #":"  [src: scan-word src + 1 path TYPE_GET_WORD yes]
				c = #"-"  [src: scan-minus src path]
				all [#"0" <= c c <= #"9"][src: scan-integer src path no]
				all [#" " <  c c <= #""][src: scan-word src path TYPE_WORD yes]
				yes [throw-error ERR_INVALID_PATH]
			]
			c: src/1
			if c = #":" [set?: yes]
		]

		path/header: case [
			set? [TYPE_SET_PATH]
			lit? [TYPE_LIT_PATH]
			true [TYPE_PATH]
		]
		either set? [src + 1][src]
	]

	scan-block: func [
		src		[c-string!]
		blk		[red-block!]
		return: [c-string!]
	][
		src: scan src block/make-in blk 4				;-- arbitrary start size
		src + 1											;-- skip ] character
	]

	scan-paren: func [
		src		 [c-string!]
		blk		 [red-block!]
		return:  [c-string!]
		/local
			s	 [series!]
			slot [red-value!]
	][
		src: scan src block/make-in blk 4				;-- arbitrary start size
		s: GET_BUFFER(blk)
		slot: s/tail - 1
		slot/header: TYPE_PAREN
		src + 1											;-- skip ) character

	]

	scan: func [
		src		  [c-string!]
		parent	  [red-block!]
		return:	  [c-string!]
		/local
			blk	  [red-block!]
			start [c-string!]
			end	  [c-string!]
			c	  [byte!]
	][
		blk: either null? parent [
			block/push* 4								;-- arbitrary start size
		][
			parent
		]

		while [
			src: skip-spaces src
			c: src/1
			all [
				c <> null-byte
				c <> #"]"
				c <> #")"
			]
		][
			case [
				c = #";"  [src: scan-comment src]
				c = #"-"  [src: scan-minus src blk]
				c = #"^"" [src: scan-string src blk]
				c = #"{"  [src: scan-string-multi src blk]
				c = #"%"  [src: scan-file src blk]
				c = #"["  [src: scan-block src + 1 blk]
				c = #"("  [src: scan-paren src + 1 blk]
				c = #":"  [src: scan-word src + 1 blk TYPE_GET_WORD no]
				c = #"'"  [src: scan-word src + 1 blk TYPE_LIT_WORD no]
				c = #"/"  [src: scan-word src blk TYPE_REFINEMENT no]
				c = #"#"  [
					c: src/2
					either c = #"^"" [
						src: scan-char src + 2 blk
					][
						src: scan-word src + 1 blk TYPE_ISSUE no
					]
				]
				all [#"0" <= c c <= #"9"][src: scan-integer src blk no]
				all [#" " <  c c <= #""][src: scan-word src blk TYPE_WORD no]
			]
		]
		if null? parent [
			if src/1 <> null-byte [throw-error ERR_PREMATURE_END]
			stack/set-last as red-value! blk
		]
		src
	]

]


FEAT: refactored _print internal function to use SWITCH.

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

newline: "^/"

lf:  	 #"^/"								;-- Line-feed
cr:  	 #"^M"
tab: 	 #"^-"
space:	 #" "
slash:	 #"/"

;-------------------------------------------
;-- Print in console a single byte as an ASCII character
;-------------------------------------------
prin-byte: func [
	c 		[byte!]							;-- ASCII value to print
	return: [byte!]
	/local char
][
	char: " "
	char/1: c
	prin char
	c
]

;-------------------------------------------
;-- Low-level polymorphic print function
;-- (not intended to be called directly)
;-------------------------------------------
_print: func [
	count	[integer!]						;-- typed values count
	list	[typed-value!]					;-- pointer on first typed value
	spaced?	[logic!]						;-- if TRUE, insert a space between items
][
	until [
		switch list/type [
			type-logic!	   [prin either as-logic list/value ["true"]["false"]]
			type-integer!  [prin-int list/value]
			type-float!    [prin-float as-float list/value]
			type-float32!  [prin-float32 as-float32 list/value]
			type-byte!     [prin-byte as-byte list/value]
			type-c-string! [prin as-c-string list/value]
			default 	   [prin-hex list/value]
		]
		list: list + 1
		count: count - 1
		if all [spaced? count <> 0][prin " "]
		zero? count
	]
]

;-------------------------------------------
;-- Polymorphic print in console
;-- (inserts a space character between each item)
;-------------------------------------------
print-wide: func [
	[typed]	count [integer!] list [typed-value!]
][
	_print count list yes
]

;-------------------------------------------
;-- Polymorphic print in console
;-------------------------------------------
print: func [
	[typed]	count [integer!] list [typed-value!]
][
	_print count list no
]

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

newline: "^/"

lf:  	 #"^/"								;-- Line-feed
cr:  	 #"^M"
tab: 	 #"^-"
space:	 #" "
slash:	 #"/"

;-------------------------------------------
;-- Print in console a single byte as an ASCII character
;-------------------------------------------
prin-byte: func [
	c 		[byte!]							;-- ASCII value to print
	return: [byte!]
	/local char
][
	char: " "
	char/1: c
	prin char
	c
]

;-------------------------------------------
;-- Low-level polymorphic print function
;-- (not intended to be called directly)
;-------------------------------------------
_print: func [
	count	[integer!]						;-- typed values count
	list	[typed-value!]					;-- pointer on first typed value
	spaced?	[logic!]						;-- if TRUE, insert a space between items
][
	until [
		if list/type = type-logic! [
			prin either as-logic list/value ["true"]["false"]
		]
		if list/type = type-integer! [
			prin-int list/value
		]
		if list/type = type-float! [
			prin-float as-float list/value
		]
		if list/type = type-float32! [
			prin-float32 as-float32 list/value
		]
		if list/type = type-byte! [
			prin-byte as-byte list/value
		]
		if list/type = type-c-string! [
			prin as-c-string list/value
		]
		if list/type > type-c-string! [
			prin-hex list/value
		]
		list: list + 1
		count: count - 1
		if all [spaced? count <> 0][prin " "]
		zero? count
	]
]

;-------------------------------------------
;-- Polymorphic print in console
;-- (inserts a space character between each item)
;-------------------------------------------
print-wide: func [
	[typed]	count [integer!] list [typed-value!]
][
	_print count list yes
]

;-------------------------------------------
;-- Polymorphic print in console
;-------------------------------------------
print: func [
	[typed]	count [integer!] list [typed-value!]
][
	_print count list no
]


FIX: debugging code leftovers removed.

FIX: debugging code leftovers removed.

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

#include %../runtime/red.reds
#include %../runtime/debug.reds

with red [
	print [lf ">> allocating 3 series" lf]
	s1: alloc-bytes 5
	s2: alloc-bytes 100
	s3: alloc-bytes 5

	memory-stats 3

	dump-series-frame memory/s-active

	print [lf ">> freeing 2nd series" lf]
	free-series memory/s-head s2
	dump-series-frame memory/s-active
	print [lf ">> compacting frame" lf]
	compact-series-frame memory/s-active
	dump-series-frame memory/s-active

	memory-stats 3

	print [lf ">> allocating 25 series" lf]

	array: as int-ptr! allocate 25 * size? pointer!
	c: 50
	alt?: no
	series: as int-ptr! 0
	idx: 1
	until [
		series: alloc-bytes either alt? [5][100]
		unless alt? [
			array/idx: as-integer series
			print-wide [idx ":" as byte-ptr! array/idx lf]
			idx: idx + 1
		]
		alt?: not alt?
		c: c - 1
		zero? c
	]
	dump-series-frame memory/s-active

	memory-stats 3

	print [lf ">> freeing all new bigger series" lf]
	idx: 26
	until [
		idx: idx - 1
		print-wide [idx ":" as byte-ptr! array/idx lf]
		free-series memory/s-head as int-ptr! array/idx
		idx = 1
	]

	print [lf ">> compacting frame" lf]
	compact-series-frame memory/s-active
	dump-series-frame memory/s-active

	memory-stats 3

	free as byte-ptr! array
	free-all
]

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

#include %../runtime/red.reds
#include %../runtime/debug.reds

with red [
	print [lf ">> allocating 3 series" lf]
	s1: alloc-bytes 5
	s2: alloc-bytes 100
	s3: alloc-bytes 5
print-wide [s1 s2 s3 lf]
dump-hex4 as byte-ptr! s1/value
dump-hex4 as byte-ptr! s2/value
dump-hex4 as byte-ptr! s3/value

;	memory-stats 3

;	dump-series-frame memory/s-active

	print [lf ">> freeing 2nd series" lf]
	free-series memory/s-head s2
	dump-series-frame memory/s-active
	print [lf ">> compacting frame" lf]
	compact-series-frame memory/s-active
	dump-series-frame memory/s-active
dump-hex4 as byte-ptr! s1/value
dump-hex4 as byte-ptr! s2/value
dump-hex4 as byte-ptr! 001D00BCh

	memory-stats 3

	print [lf ">> allocating 25 series" lf]

	array: as int-ptr! allocate 25 * size? pointer!
	c: 50
	alt?: no
	series: as int-ptr! 0
	idx: 1
	until [
		series: alloc-bytes either alt? [5][100]
		unless alt? [
			array/idx: as-integer series
			print-wide [idx ":" as byte-ptr! array/idx lf]
			idx: idx + 1
		]
		alt?: not alt?
		c: c - 1
		zero? c
	]
	dump-series-frame memory/s-active

	memory-stats 3

	print [lf ">> freeing all new bigger series" lf]
	idx: 26
	until [
		idx: idx - 1
		print-wide [idx ":" as byte-ptr! array/idx lf]
		free-series memory/s-head as int-ptr! array/idx
		idx = 1
	]

	print [lf ">> compacting frame" lf]
	compact-series-frame memory/s-active
	dump-series-frame memory/s-active

	memory-stats 3

	free as byte-ptr! array
	free-all
]


Add FreeBSD signal handling and initialization to %freebsd.reds.

Red/System [
	Title:   "Red/System FreeBSD runtime"
	Author:  "Nenad Rakocevic"
	File: 	 %freebsd.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 OS_TYPE		6

#syscall [
	write: 4 [
		fd		[integer!]
		buffer	[c-string!]
		count	[integer!]
		return: [integer!]
	]
]

#if use-natives? = yes [
	#syscall [
		quit: 1 [							;-- "exit" syscall
			status	[integer!]
		]
	]
]

stdin:  0
stdout: 1
stderr: 2

#if use-natives? = yes [
	prin: func [s [c-string!] return: [integer!]][
		write stdout s length? s
	]
]

;-- Catching runtime errors --

;; sources:
;;  http://fxr.watson.org/fxr/source/sys/signal.h?v=FREEBSD10

#define	SIGILL		 4						;-- Illegal instruction
#define	SIGBUS		10						;-- Bus access error
#define	SIGFPE		 8						;-- Floating point error
#define	SIGSEGV		11						;-- Segmentation violation

#define SA_SIGINFO	0040h
#define SA_RESTART	0002h

#define ILL_ILLOPC		1
#define ILL_ILLOPN		2
#define ILL_ILLADR		3
#define ILL_ILLTRP		4
#define ILL_PRVOPC		5
#define ILL_PRVREG		6
#define ILL_COPROC		7
#define ILL_BADSTK		8

#define BUS_ADRALN		1
#define BUS_ADRERR		2
#define BUS_OBJERR		3

#define SEGV_MAPERR		1
#define SEGV_ACCERR		2

#define FPE_INTOVF		1
#define FPE_INTDIV		2
#define FPE_FLTDIV		3
#define FPE_FLTOVF		4
#define FPE_FLTUND		5
#define FPE_FLTRES		6
#define FPE_FLTINV		7
#define FPE_FLTSUB		8

sigaction!: alias struct! [
;	handler		[integer!]					;-- Warning: compiled as C union on most UNIX
	sigaction	[integer!]					;-- Warning: compiled as union on most UNIX
	flags		[integer!]
	mask0		[integer!]					;-- array of 4 uint32
	mask1		[integer!]
	mask2		[integer!]
	mask3		[integer!]
]

siginfo!: alias struct! [
	signal		[integer!]
	error		[integer!]
	code		[integer!]
	pid			[integer!]
	uid			[integer!]
	status		[integer!]
	address		[integer!]					;-- this field is a C union, dependent on signal
	;... remaining fields skipped
]

#import [									;-- mandatory C bindings
	LIBC-file cdecl [
		sigaction: "sigaction" [
			signum	[integer!]
			action	[sigaction!]
			oldact	[sigaction!]
			return: [integer!]
		]
	]
]

freebsd-startup-ctx: context [
	_ucontext!: alias struct! [
		sigmask0	[integer!]			;-- __sigset defined as an array of 4 uint32
		sigmask1	[integer!]
		sigmask2	[integer!]
		sigmask3	[integer!]
		onstack		[integer!]			;-- mcontext_t inlined
		mc_gs		[integer!]
		mc_fs		[integer!]
		mc_es		[integer!]
		mc_ds		[integer!]
		mc_edi		[integer!]
		mc_esi		[integer!]
		mc_ebp		[integer!]
		mc_isp		[integer!]
		mc_ebx		[integer!]
		mc_edx		[integer!]
		mc_ecx		[integer!]
		mc_eax		[integer!]
		mc_trapno	[integer!]
		mc_err		[integer!]
		mc_eip		[integer!]
		mc_cs		[integer!]
		mc_eflags	[integer!]
		mc_esp		[integer!]
		mc_ss		[integer!]
		mc_len		[integer!]
		mc_fpformat	[integer!]
		mc_ownedfp	[integer!]
		mc_flags	[integer!]
		;... remaining fields skipped
	]

	***-on-signal: func [
		[cdecl]
		signal	[integer!]
		info	[siginfo!]
		ctx		[_ucontext!]
		/local code error
	][
		error: 99								;-- default unknown error
		code: info/code

		error: switch signal [
			SIGILL [
				switch code [
					ILL_ILLOPC [17]				;-- illegal opcode
					ILL_ILLTRP [25]				;-- illegal trap
					ILL_PRVOPC [15]				;-- privileged opcode
					ILL_ILLOPN [23]				;-- illegal operand
					ILL_ILLADR [24]				;-- illegal addressing mode
					ILL_PRVREG [31]				;-- privileged register
					ILL_COPROC [26]				;-- coprocessor error
					ILL_BADSTK [19]				;-- internal stack error
					default    [99]
				]
			]
			SIGBUS [
				switch code [
					BUS_ADRALN  [2]				;-- invalid address alignment
					BUS_ADRERR  [1]				;-- non-existant physical address
					BUS_OBJERR [28]				;-- object specific hardware error
					default    [34]
				]
			]
			SIGFPE [
				switch code [
					FPE_FLTDIV  [7]				;-- floating point divide by zero
					FPE_FLTOVF [10]				;-- floating point overflow
					FPE_FLTUND [12]				;-- floating point underflow
					FPE_FLTRES  [8]				;-- floating point inexact result
					FPE_FLTINV  [9]				;-- floating point invalid operation
					FPE_FLTSUB  [5]				;-- subscript out of range
					FPE_INTDIV [13]				;-- integer divide by zero
					FPE_INTOVF [14]				;-- integer overflow
					default    [33]
				]
			]
			SIGSEGV [
				switch code [
					SEGV_MAPERR  [1]			;-- address not mapped to object
					SEGV_ACCERR [16]			;-- invalid permissions for mapped object
					default     [32]
				]
			]
		]

		***-on-quit error ctx/mc_eip
	]

	init: does [
		__sigaction-options: declare sigaction!

		__sigaction-options/sigaction: 	as-integer :***-on-signal
		__sigaction-options/flags: 		SA_SIGINFO ;or SA_RESTART
		__sigaction-options/mask0: 0
		__sigaction-options/mask1: 0
		__sigaction-options/mask2: 0
		__sigaction-options/mask3: 0

		sigaction SIGILL  __sigaction-options as sigaction! 0
		sigaction SIGBUS  __sigaction-options as sigaction! 0
		sigaction SIGFPE  __sigaction-options as sigaction! 0
		sigaction SIGSEGV __sigaction-options as sigaction! 0
	]
]

;-------------------------------------------
;-- Retrieve command-line information from stack
;-------------------------------------------
#if type = 'exe [
	#either use-natives? = yes [
		system/args-count:	pop
		system/args-list:	as str-array! system/stack/top
		system/env-vars:	system/args-list + system/args-count + 1
	][
		;-- the current stack is pointing to main(int argc, void **argv, void **envp) C layout
		;-- we avoid the double indirection by reusing our variables from %start.reds
		system/args-count:	***__argc
		system/args-list:	as str-array! ***__argv
		system/env-vars:	system/args-list + system/args-count + 1
	]
]

#switch type [
	dll [
		***-dll-entry-point: func [[cdecl]] [
			***-main
			freebsd-startup-ctx/init
			on-load
		]
	]
	exe [
		freebsd-startup-ctx/init
	]
]

Red/System [
	Title:   "Red/System FreeBSD runtime"
	Author:  "Nenad Rakocevic"
	File: 	 %freebsd.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 OS_TYPE		6

#syscall [
	write: 4 [
		fd		[integer!]
		buffer	[c-string!]
		count	[integer!]
		return: [integer!]
	]
]

#if use-natives? = yes [
	#syscall [
		quit: 1 [							;-- "exit" syscall
			status	[integer!]
		]
	]
]

;-------------------------------------------
;-- Retrieve command-line information from stack
;-------------------------------------------
#if type = 'exe [
	#either use-natives? = yes [
		system/args-count:	pop
		system/args-list:	as str-array! system/stack/top
		system/env-vars:	system/args-list + system/args-count + 1
	][
		;-- the current stack is pointing to main(int argc, void **argv, void **envp) C layout
		;-- we avoid the double indirection by reusing our variables from %start.reds
		system/args-count:	***__argc
		system/args-list:	as str-array! ***__argv
		system/env-vars:	system/args-list + system/args-count + 1
	]
]

#include %BSD.reds


FEAT: added a few comments for the previous commit fix.

Red/System [
	Title:   "Function! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %function.reds
	Tabs:	 4
	Rights:  "Copyright (C) 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
	}
]

_function: context [
	verbose: 0

	validate: func [									;-- temporary mimalist spec checking
		spec [red-block!]
		/local
			value  [red-value!]
			end	   [red-value!]
			next   [red-value!]
			block? [logic!]
	][
		value: block/rs-head spec
		end:   block/rs-tail spec

		while [value < end][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD [
					next: value + 1
					block?: all [
						next < end
						TYPE_OF(next) = TYPE_BLOCK
					]
					value: value + either block? [2][1]
				]
				TYPE_SET_WORD [
					next: value + 1
					unless all [
						next < end
						TYPE_OF(next) = TYPE_BLOCK
					][
						print-line "*** Error: return: not followed by type in function spec"
						halt
					]
					value: next
				]
				TYPE_LIT_WORD
				TYPE_REFINEMENT
				TYPE_STRING [
					value: value + 1
				]
				default [
					print-line "*** Error: invalid value in function spec"
					halt
				]
			]
		]
	]

	bind: func [
		body [red-block!]
		ctx	 [red-context!]
		/local
			value [red-value!]
			end	  [red-value!]
			w	  [red-word!]
			idx	  [integer!]
			type  [integer!]
	][
		value: block/rs-head body
		end:   block/rs-tail body

		while [value < end][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_SET_WORD
				TYPE_REFINEMENT [
					w: as red-word! value
					idx: _context/find-word ctx w/symbol
					if idx >= 0 [
						w/ctx:   ctx
						w/index: idx
					]
				]
				TYPE_BLOCK 					;@@ replace with TYPE_ANY_BLOCK
				TYPE_PAREN
				TYPE_PATH
				TYPE_LIT_PATH
				TYPE_SET_PATH
				TYPE_GET_PATH	[
					bind as red-block! value ctx
				]
				default [0]
			]
			value: value + 1
		]
	]

	init-locals: func [
		nb 	   [integer!]
		/local
			p  [red-value!]
	][
		until [
			p: stack/push*
			p/header: TYPE_NONE
			nb: nb - 1
			zero? nb
		]
	]

	push: func [
		spec	 [red-block!]
		body	 [red-block!]
		code	 [integer!]
		return:	 [red-context!]							;-- return function's local context
		/local
			cell   [red-function!]
			native [red-native!]
			more   [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_function/push"]]

		cell: as red-function! stack/push*
		cell/header: TYPE_FUNCTION						;-- implicit reset of all header flags
		cell/spec:	 spec/node
		cell/ctx:	 _context/make spec yes
		cell/more:	 alloc-cells 3

		more: as series! cell/more/value
		copy-cell
			as cell! body
			alloc-tail more

		alloc-tail more									;-- reserved place for "symbols"

		native: as red-native! alloc-tail more
		native/header: TYPE_NATIVE
		native/code: code

		bind body cell/ctx
		cell/ctx
	]

	;-- Actions --

	reflect: func [
		fun		[red-function!]
		field	[integer!]
		return:	[red-block!]
		/local
			blk [red-block!]
			s	[series!]
	][
		case [
			field = words/spec [
				blk: as red-block! stack/arguments		;-- overwrite the function slot on stack
				blk/header: TYPE_BLOCK
				blk/node: fun/spec						;-- order of assignments matters
				blk/head: 0
			]
			field = words/body [
				s: as series! fun/more/value
				blk: as red-block! s/offset
				stack/set-last as red-value! blk
			]
			field = words/words [
				--NOT_IMPLEMENTED--						;@@ build the words block from spec
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		blk												;@@ TBD: remove it when all cases implemented
	]

	form: func [
		value	[red-function!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "function/form"]]

		string/concatenate-literal buffer "?function?"
		part - 10
	]

	mold: func [
		fun		[red-function!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
		/local
			s	[series!]
			blk [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "function/mold"]]

		string/concatenate-literal buffer "func "

		blk: as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 0
		blk/node: fun/spec
		part: block/mold blk buffer only? all? flat? arg part - 5			;-- spec

		s: as series! fun/more/value
		block/mold as red-block! s/offset buffer only? all? flat? arg part	;-- body
	]

	datatype/register [
		TYPE_FUNCTION
		TYPE_CONTEXT
		"function!"
		;-- General actions --
		null			;make
		null			;random
		:reflect
		null			;to
		:form
		:mold
		null			;get-path
		null			;set-path
		null			;compare
		;-- Scalar actions --
		null			;absolute
		null			;add
		null			;divide
		null			;multiply
		null			;negate
		null			;power
		null			;remainder
		null			;round
		null			;subtract
		null			;even?
		null			;odd?
		;-- Bitwise actions --
		null			;and~
		null			;complement
		null			;or~
		null			;xor~
		;-- Series actions --
		null			;append
		null			;at
		null			;back
		null			;change
		null			;clear
		null			;copy
		null			;find
		null			;head
		null			;head?
		null			;index?
		null			;insert
		null			;length?
		null			;next
		null			;pick
		null			;poke
		null			;remove
		null			;reverse
		null			;select
		null			;sort
		null			;skip
		null			;swap
		null			;tail
		null			;tail?
		null			;take
		null			;trim
		;-- I/O actions --
		null			;create
		null			;close
		null			;delete
		null			;modify
		null			;open
		null			;open?
		null			;query
		null			;read
		null			;rename
		null			;update
		null			;write
	]
]

Red/System [
	Title:   "Function! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %function.reds
	Tabs:	 4
	Rights:  "Copyright (C) 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
	}
]

_function: context [
	verbose: 0

	validate: func [									;-- temporary mimalist spec checking
		spec [red-block!]
		/local
			value  [red-value!]
			end	   [red-value!]
			next   [red-value!]
			block? [logic!]
	][
		value: block/rs-head spec
		end:   block/rs-tail spec

		while [value < end][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD [
					next: value + 1
					block?: all [
						next < end
						TYPE_OF(next) = TYPE_BLOCK
					]
					value: value + either block? [2][1]
				]
				TYPE_SET_WORD [
					next: value + 1
					unless all [
						next < end
						TYPE_OF(next) = TYPE_BLOCK
					][
						print-line "*** Error: return: not followed by type in function spec"
						halt
					]
					value: next
				]
				TYPE_LIT_WORD
				TYPE_REFINEMENT
				TYPE_STRING [
					value: value + 1
				]
				default [
					print-line "*** Error: invalid value in function spec"
					halt
				]
			]
		]
	]

	bind: func [
		body [red-block!]
		ctx	 [red-context!]
		/local
			value [red-value!]
			end	  [red-value!]
			w	  [red-word!]
			idx	  [integer!]
			type  [integer!]
	][
		value: block/rs-head body
		end:   block/rs-tail body

		while [value < end][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_SET_WORD
				TYPE_REFINEMENT [
					w: as red-word! value
					idx: _context/find-word ctx w/symbol
					if idx >= 0 [
						w/ctx:   ctx
						w/index: idx
					]
				]
				TYPE_BLOCK 					;@@ replace with TYPE_ANY_BLOCK
				TYPE_PAREN
				TYPE_PATH
				TYPE_LIT_PATH
				TYPE_SET_PATH
				TYPE_GET_PATH	[
					bind as red-block! value ctx
				]
				default [0]
			]
			value: value + 1
		]
	]

	init-locals: func [
		nb 	   [integer!]
		/local
			p  [red-value!]
	][
		until [
			p: stack/push*
			p/header: TYPE_NONE
			nb: nb - 1
			zero? nb
		]
	]

	push: func [
		spec	 [red-block!]
		body	 [red-block!]
		code	 [integer!]
		return:	 [red-context!]							;-- return function's local context
		/local
			cell   [red-function!]
			native [red-native!]
			more   [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "_function/push"]]

		cell: as red-function! stack/push*
		cell/header: TYPE_FUNCTION						;-- implicit reset of all header flags
		cell/spec:	 spec/node
		cell/ctx:	 _context/make spec yes
		cell/more:	 alloc-cells 3

		more: as series! cell/more/value
		copy-cell
			as cell! body
			alloc-tail more

		alloc-tail more									;-- reserved place for "symbols"

		native: as red-native! alloc-tail more
		native/header: TYPE_NATIVE
		native/code: code

		bind body cell/ctx
		cell/ctx
	]

	;-- Actions --

	reflect: func [
		fun		[red-function!]
		field	[integer!]
		return:	[red-block!]
		/local
			blk [red-block!]
			s	[series!]
	][
		case [
			field = words/spec [
				blk: as red-block! stack/arguments
				blk/header: TYPE_BLOCK
				blk/node: fun/spec
				blk/head: 0
			]
			field = words/body [
				s: as series! fun/more/value
				blk: as red-block! s/offset
				stack/set-last as red-value! blk
			]
			field = words/words [
				--NOT_IMPLEMENTED--						;@@ build the words block from spec
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		blk												;@@ TBD: remove it when all cases implemented
	]

	form: func [
		value	[red-function!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "function/form"]]

		string/concatenate-literal buffer "?function?"
		part - 10
	]

	mold: func [
		fun		[red-function!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
		/local
			s	[series!]
			blk [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "function/mold"]]

		string/concatenate-literal buffer "func "

		blk: as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 0
		blk/node: fun/spec
		part: block/mold blk buffer only? all? flat? arg part - 5			;-- spec

		s: as series! fun/more/value
		block/mold as red-block! s/offset buffer only? all? flat? arg part	;-- body
	]

	datatype/register [
		TYPE_FUNCTION
		TYPE_CONTEXT
		"function!"
		;-- General actions --
		null			;make
		null			;random
		:reflect
		null			;to
		:form
		:mold
		null			;get-path
		null			;set-path
		null			;compare
		;-- Scalar actions --
		null			;absolute
		null			;add
		null			;divide
		null			;multiply
		null			;negate
		null			;power
		null			;remainder
		null			;round
		null			;subtract
		null			;even?
		null			;odd?
		;-- Bitwise actions --
		null			;and~
		null			;complement
		null			;or~
		null			;xor~
		;-- Series actions --
		null			;append
		null			;at
		null			;back
		null			;change
		null			;clear
		null			;copy
		null			;find
		null			;head
		null			;head?
		null			;index?
		null			;insert
		null			;length?
		null			;next
		null			;pick
		null			;poke
		null			;remove
		null			;reverse
		null			;select
		null			;sort
		null			;skip
		null			;swap
		null			;tail
		null			;tail?
		null			;take
		null			;trim
		;-- I/O actions --
		null			;create
		null			;close
		null			;delete
		null			;modify
		null			;open
		null			;open?
		null			;query
		null			;read
		null			;rename
		null			;update
		null			;write
	]
]


FIX: stack's bottom test too aggressive, was producing crashes.

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

stack: context [										;-- call stack
	verbose: 0

	dyn-info!: alias struct! [
		header [integer!]
		code   [integer!]
		count  [integer!]
		locals [integer!]
	]

	call-frame!: alias struct! [
		header [integer!]								;-- symbol ID of the calling function
		prev   [red-value!]								;-- previous frame base
		ctx	   [node!]									;-- context for function's name
	]

	arg-stk:		as red-block!	0					;-- argument stack (should never be relocated)
	call-stk:		as red-block!	0					;-- call stack (should never be relocated)
	args-series:	as series!		0
	calls-series:	as series!		0
	a-end: 			as red-value!	0
	c-end: 			as call-frame!	0
	arguments:		as red-value!	0
	bottom:  		as red-value!	0
	top:	 		as red-value!	0
	cbottom: 		as call-frame!	0
	ctop:	 		as call-frame! 	0

	acc-mode?: 		no									;-- YES: accumulate expressions on stack
	body-symbol:	0									;-- symbol ID
	anon-symbol:	0									;-- symbol ID

	#define MARK_STACK(type) [
		func [
			fun [red-word!]
		][
			#if debug? = yes [if verbose > 0 [print-line "stack/mark"]]

			if ctop = c-end [
				print-line ["^/*** Error: call stack overflow!^/"]
				throw RED_ERROR
			]
			ctop/header: type or (fun/symbol << 8)
			ctop/prev:	 arguments
			ctop/ctx:	 fun/ctx
			ctop: ctop + 1
			arguments: top								;-- top of stack becomes frame base

			#if debug? = yes [if verbose > 1 [dump]]
		]
	]

	#define STACK_SET_FRAME [
		either ctop = cbottom [
			arguments: bottom
			top: bottom
		][
			top: arguments + 1							;-- keep last value on stack
			arguments: ctop/prev
		]
	]

	;-- header flags
	#enum flags! [
		FLAG_FUNCTION:	80000000h						;-- function! call
		FLAG_NATIVE:	40000000h						;-- native! or action! call
		FLAG_ROUTINE:	20000000h						;--	<reserved>
		FLAG_TRY:		10000000h						;--	TRY native
		FLAG_CATCH:		08000000h						;-- CATCH native
		FLAG_THROW_ATR:	04000000h						;-- Throw function attribut
		FLAG_CATCH_ATR:	02000000h						;--	Catch function attribut
		FLAG_EVAL:		01000000h						;-- Interpreter root frame
		FLAG_LOOP:		00800000h						;-- Iterator (for BREAK/CONTINUE support)
		FLAG_DYN_CALL:	11000000h						;-- Dynamic call (alternative stack mode)
	]

	init: does [
		arg-stk:  block/make-in root 1024
		call-stk: block/make-in root 512

		set-flag arg-stk/node  flag-series-fixed or flag-series-nogc
		set-flag call-stk/node flag-series-fixed or flag-series-nogc

		;-- Shortcuts for stack buffers simpler and faster access
		;-- (stack buffers are not resizable with such approach
		;-- this can be made more flexible (but slower) if necessary
		;-- in the future)

		args-series:  GET_BUFFER(arg-stk)
		calls-series: GET_BUFFER(call-stk)

		a-end: as cell!		  (as byte-ptr! args-series)  + args-series/size
		c-end: as call-frame! (as byte-ptr! calls-series) + calls-series/size

		arguments:	args-series/tail					;@@ incorrect?!
		bottom:  	args-series/offset
		top:	 	args-series/tail					;@@ incorrect?!
		cbottom: 	as call-frame! calls-series/offset
		ctop:	 	as call-frame! calls-series/tail	;@@ incorrect?!

		body-symbol: words/_body/symbol
		anon-symbol: words/_anon/symbol
	]

	check-call: does [
		if acc-mode? [check-dyn-call]
	]

	reset: func [
		return:  [cell!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/reset"]]

		either acc-mode? [check-dyn-call][top: arguments]
		arguments
	]

	keep: func [
		return:  [cell!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/keep"]]

		top: arguments + 1								;-- keep last value in arguments slot
		if acc-mode? [check-dyn-call]
		arguments
	]

	mark-native: MARK_STACK(FLAG_NATIVE)
	mark-func:	 MARK_STACK(FLAG_FUNCTION)
	mark-try:	 MARK_STACK(FLAG_TRY)
	mark-catch:	 MARK_STACK(FLAG_CATCH)
	mark-eval:	 MARK_STACK(FLAG_EVAL)
	mark-dyn:	 MARK_STACK(FLAG_DYN_CALL)
	mark-loop:	 MARK_STACK(FLAG_LOOP)

	get-call: func [
		return: [red-word!]
		/local
			p	[call-frame!]
			sym [integer!]
	][
		p: ctop
		until [
			p: p - 1
			sym: p/header >> 8 and FFFFh
			any [
				all [sym <> body-symbol	sym <> anon-symbol]
				p < cbottom
			]
		]
		word/at p/ctx sym
	]

	revert: does [
		#if debug? = yes [if verbose > 0 [print-line "stack/revert"]]

		assert cbottom < ctop
		ctop: ctop - 1
		either ctop = cbottom [
			arguments: bottom
			top: bottom
		][
			top: arguments
			arguments: ctop/prev
		]

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind-part: does [
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind-part"]]

		assert cbottom < ctop
		ctop: ctop - 1
		either ctop = cbottom [
			arguments: bottom
		][
			arguments: ctop/prev
		]
		top: top - 1

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind: does [
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind"]]

		assert cbottom < ctop
		ctop: ctop - 1
		STACK_SET_FRAME
		if acc-mode? [check-dyn-call]

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind-last: func [
		return:  [red-value!]
		/local
			last [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind-last"]]

		last: arguments
		unwind
		copy-cell last arguments
	]

	unroll-frames: func [flags [integer!]][
		assert cbottom < ctop
		until [
			ctop: ctop - 1
			any [
				ctop <= cbottom
				flags and ctop/header = flags
			]
		]
		STACK_SET_FRAME
		ctop: ctop + 1									;-- ctop points past the current call frame
	]

	unroll: func [
		flags	 [integer!]
		/local
			last [red-value!]
			p	 [call-frame!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/unroll"]]

		last: arguments
		unroll-frames flags
		copy-cell last ctop/prev

		p: ctop + 1										;-- adjust stack pointers
		arguments: ctop/prev
		top: arguments
	]

	adjust: does [
		top: top - 1
		copy-cell top top - 1
		check-call
	]

	trace: func [
		int		[red-integer!]
		buffer	[red-string!]
		part	[integer!]
		return: [integer!]
		/local
			top	  [call-frame!]
			base  [call-frame!]
			sym	  [integer!]
	][
		top: as call-frame! int/value
		value: ALLOC_TAIL(root)
		int: as red-integer! value
		int/header: TYPE_INTEGER
		base: cbottom

		until [
			sym: base/header >> 8 and FFFFh

			if all [sym <> body-symbol sym <> anon-symbol][
				if base > cbottom [
					string/concatenate-literal buffer " "
					part: part - 4
				]
				part: word/form
					word/make-at sym value
					buffer
					null
					part
			]
			base: base + 1
			base >= top									;-- defensive test
		]
		part
	]

	set-stack: func [
		err [red-object!]
		/local
			base [red-value!]
			int	 [red-integer!]
	][
		base: object/get-values err
		int: as red-integer! base + error/get-stack-id
		int/header: TYPE_INTEGER
		int/value:  as-integer ctop
	]

	throw-error: func [
		err [red-object!]
		/local
			extra [red-value!]
			saved [red-value!]
	][
		error/set-where err as red-value! get-call
		set-stack err

		extra: top
		unroll-frames FLAG_TRY

		ctop: ctop - 1
		assert ctop >= cbottom
		top: extra

		if all [
			ctop = cbottom
			FLAG_TRY and ctop/header <> FLAG_TRY
		][
			saved: arguments
			arguments: extra							;-- use the top stack frame @@ overflows!
			set-last as red-value! err
			natives/print*
			arguments: saved
		]
		stack/push as red-value! err
		throw RED_ERROR
	]

	throw-break: func [
		return? [logic!]
		cont?	[logic!]
		/local
			result	  [red-value!]
			save-top  [red-value!]
			save-ctop [call-frame!]
			p		  [call-frame!]
	][
		result:	   arguments
		save-top:  top
		save-ctop: ctop

		;-- scan the stack to determine the outcome of an exception
		until [
			if any [
				FLAG_FUNCTION and ctop/header <> 0
				FLAG_TRY and ctop/header <> 0
			][
				ctop: save-ctop
				either cont? [fire [TO_ERROR(throw continue)]][fire [TO_ERROR(throw break)]]
			]
			ctop: ctop - 1
			any [
				ctop <= cbottom
				FLAG_LOOP and ctop/header <> 0			;-- loop found, we are fine
			]
		]
		either ctop < cbottom [
			arguments: result
			top:	   save-top
			ctop:	   save-ctop
			either cont? [fire [TO_ERROR(throw continue)]][fire [TO_ERROR(throw break)]]
		][
			ctop: ctop + 1
			p: ctop + 1									;-- + 1 for getting ctop/prev value
			arguments: ctop/prev
			top: arguments
			either all [return? not cont?][set-last result][unset/push-last]
			either cont? [
				throw RED_CONTINUE_EXCEPTION
			][
				throw RED_BREAK_EXCEPTION
			]
		]
	]

	eval?: func [
		return: [logic!]
		/local
			cframe [call-frame!]
	][
		cframe: ctop
		until [
			cframe: cframe - 1
			if FLAG_EVAL and cframe/header = FLAG_EVAL [return yes]
			cframe <= cbottom
		]
		no
	]

	set-last: func [
		last	[red-value!]
		return: [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/set-last"]]

		copy-cell last arguments
	]

	push*: func [
		return:  [red-value!]
		/local
			cell [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/push*"]]

		cell: top
		top: top + 1
		if top >= a-end [
			print-line ["^/*** Error: arguments stack overflow!^/"]
			throw RED_ERROR
		]
		cell
	]

	push: func [
		value 	  [red-value!]
		return:   [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/push"]]

		copy-cell value top
		push*
	]

	pop: func [
		positions [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/pop"]]

		top: top - positions
	]

	top-type?: func [
		return:  [integer!]
		/local
			value [red-value!]
	][
		value: top - 1
		TYPE_OF(value)
	]

	func?: func [
		return: [logic!]
		/local
			value [red-value!]
			type  [integer!]
	][
		value: top - 1
		type: TYPE_OF(value)
		any [											;@@ replace with ANY_FUNCTION?
			type = TYPE_FUNCTION
			type = TYPE_ROUTINE
		]
	]

	defer-call: func [
		name   [red-word!]
		code   [integer!]
		count  [integer!]
		octx [node!]
		/local
			info [dyn-info!]
	][
		;mark-native words/_anon
		integer/push as-integer octx					;-- store optional wrapping object pointer

		info: as dyn-info! push*
		info/header: TYPE_POINT
		info/code:   code								;-- store wrapping function pointer
		info/count:  count								;-- store caller's arity
		info/locals: -2									;-- store caller's locals count

		mark-dyn name									;-- open new frame
		acc-mode?: yes
		arguments/header: TYPE_VALUE					;-- use TYPE_VALUE to signal "no argument"
	]

	push-call: func [
		path [red-path!]
		idx  [integer!]
		code [integer!]
		octx [node!]
		/local
			fun		 [red-function!]
			p		 [red-path!]
			info	 [dyn-info!]
			counters [integer!]
	][
		;mark-native words/_anon
		fun: as red-function! top - 1

		assert any [
			TYPE_OF(fun) = TYPE_FUNCTION
			TYPE_OF(fun) = TYPE_ROUTINE
		]
		counters: _function/calc-arity path fun idx
		p: as red-path! copy-cell as red-value! path push*
		p/head: idx										;-- store path with function's index

		integer/push as-integer octx					;-- store optional wrapping object pointer

		info: as dyn-info! push*
		info/header: TYPE_POINT
		info/code:   code								;-- store wrapping function pointer
		info/count:  counters and FFFFh					;-- store caller's arity
		info/locals: counters >> 16						;-- store caller's locals count

		mark-dyn as red-word! block/rs-abs-at as red-block! path idx  ;-- open new frame
		acc-mode?: yes

		either zero? (counters and FFFFh) [
			arguments/header: TYPE_UNSET
			check-dyn-call								;-- short path to call with no arguments
		][
			arguments/header: TYPE_VALUE				;-- use TYPE_VALUE to signal "no argument"
		]
	]

	check-dyn-call: func [
		/local
			int		   [red-integer!]
			fun		   [red-function!]
			obj		   [red-object!]
			base	   [red-value!]
			last	   [red-value!]
			info	   [dyn-info!]
			ctx		   [node!]
			octx	   [node!]
			more	   [series!]
			p		   [call-frame!]
			dyn?	   [logic!]
			new-frame? [logic!]
			code
	][
		p: ctop - 1
		if p < cbottom [exit]

		if all [
			FLAG_DYN_CALL and p/header = FLAG_DYN_CALL
			TYPE_OF(arguments) <> TYPE_VALUE
		][
			info: as dyn-info! arguments - 1
			unless zero? info/count [info/count: info/count - 1]

			if zero? info/count [
				base: arguments
				either info/locals = -2 [
					fun: null
					new-frame?: no
				][
					ctx: null
					fun: as red-function! base - 4
					more: as series! fun/more/value
					int: as red-integer! more/offset + 4
					obj: as red-object! base - 5
					case [
						TYPE_OF(obj) = TYPE_OBJECT  [ctx: obj/ctx]
						TYPE_OF(int) = TYPE_INTEGER [ctx: as node! int/value]
						true						[ctx: null]
					]

					new-frame?: info/locals = -1
					case [
						info/locals > 0 [_function/init-locals info/locals]
						new-frame?		[_function/lay-frame]
						true			[0]					;-- 0 locals case, do nothing
					]
				]

				code: as function! [octx [node!]] info/code
				int: as red-integer! base - 2
				octx: as node! int/value

				acc-mode?: no							;-- temporary disable accumulative mode
				unless null? fun [_function/call fun ctx] ;-- run the detected function
				unless zero? info/code [code octx]		;-- run wrapper code (stored as function)
				if new-frame? [unwind-last]				;-- close new frame created for handling refinements

				last: arguments
				unwind									;-- close frame opened in 'push-call
				either all [
					null? fun							;-- for defered calls only
					arguments + 3 < top					;-- check if not first argument of parent call?
				][
					copy-cell last arguments + 1
					top: top - 2						;-- adjust stack to right position for next argument
				][
					copy-cell last arguments			;-- unwind-last
				]

				;base: arguments
				;unwind
				;push base
				acc-mode?: yes

				p: ctop - 1								;-- decide to keep or not the accumulative mode on
				either p < cbottom [
					acc-mode?: no						;-- bottom of stack reached, switch back to normal
				][
					dyn?: FLAG_DYN_CALL and p/header = FLAG_DYN_CALL
					either dyn? [check-dyn-call][acc-mode?: no] ;-- if another dyn call pending, keep the mode on
				]
			]
		]
	]

	#if debug? = yes [
		dump: does [									;-- debug purpose only
			print-line "^/---- Argument stack ----"
			dump-memory
				as byte-ptr! bottom
				4
				(as-integer top + 1 - bottom) >> 4
			print-line ["arguments: " arguments]
			print-line ["top: " top]

			print-line "^/---- Call stack ----"
			dump-memory
				as byte-ptr! cbottom
				4
				(as-integer ctop + 2 - cbottom) >> 4
			print-line ["ctop: " ctop]
		]
	]
]

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

stack: context [										;-- call stack
	verbose: 0

	dyn-info!: alias struct! [
		header [integer!]
		code   [integer!]
		count  [integer!]
		locals [integer!]
	]

	call-frame!: alias struct! [
		header [integer!]								;-- symbol ID of the calling function
		prev   [red-value!]								;-- previous frame base
		ctx	   [node!]									;-- context for function's name
	]

	arg-stk:		as red-block!	0					;-- argument stack (should never be relocated)
	call-stk:		as red-block!	0					;-- call stack (should never be relocated)
	args-series:	as series!		0
	calls-series:	as series!		0
	a-end: 			as red-value!	0
	c-end: 			as call-frame!	0
	arguments:		as red-value!	0
	bottom:  		as red-value!	0
	top:	 		as red-value!	0
	cbottom: 		as call-frame!	0
	ctop:	 		as call-frame! 	0

	acc-mode?: 		no									;-- YES: accumulate expressions on stack
	body-symbol:	0									;-- symbol ID
	anon-symbol:	0									;-- symbol ID

	#define MARK_STACK(type) [
		func [
			fun [red-word!]
		][
			#if debug? = yes [if verbose > 0 [print-line "stack/mark"]]

			if ctop = c-end [
				print-line ["^/*** Error: call stack overflow!^/"]
				throw RED_ERROR
			]
			ctop/header: type or (fun/symbol << 8)
			ctop/prev:	 arguments
			ctop/ctx:	 fun/ctx
			ctop: ctop + 1
			arguments: top								;-- top of stack becomes frame base

			#if debug? = yes [if verbose > 1 [dump]]
		]
	]

	#define STACK_SET_FRAME [
		either ctop = cbottom [
			arguments: bottom
			top: bottom
		][
			top: arguments + 1							;-- keep last value on stack
			arguments: ctop/prev
		]
	]

	;-- header flags
	#enum flags! [
		FLAG_FUNCTION:	80000000h						;-- function! call
		FLAG_NATIVE:	40000000h						;-- native! or action! call
		FLAG_ROUTINE:	20000000h						;--	<reserved>
		FLAG_TRY:		10000000h						;--	TRY native
		FLAG_CATCH:		08000000h						;-- CATCH native
		FLAG_THROW_ATR:	04000000h						;-- Throw function attribut
		FLAG_CATCH_ATR:	02000000h						;--	Catch function attribut
		FLAG_EVAL:		01000000h						;-- Interpreter root frame
		FLAG_LOOP:		00800000h						;-- Iterator (for BREAK/CONTINUE support)
		FLAG_DYN_CALL:	11000000h						;-- Dynamic call (alternative stack mode)
	]

	init: does [
		arg-stk:  block/make-in root 1024
		call-stk: block/make-in root 512

		set-flag arg-stk/node  flag-series-fixed or flag-series-nogc
		set-flag call-stk/node flag-series-fixed or flag-series-nogc

		;-- Shortcuts for stack buffers simpler and faster access
		;-- (stack buffers are not resizable with such approach
		;-- this can be made more flexible (but slower) if necessary
		;-- in the future)

		args-series:  GET_BUFFER(arg-stk)
		calls-series: GET_BUFFER(call-stk)

		a-end: as cell!		  (as byte-ptr! args-series)  + args-series/size
		c-end: as call-frame! (as byte-ptr! calls-series) + calls-series/size

		arguments:	args-series/tail					;@@ incorrect?!
		bottom:  	args-series/offset
		top:	 	args-series/tail					;@@ incorrect?!
		cbottom: 	as call-frame! calls-series/offset
		ctop:	 	as call-frame! calls-series/tail	;@@ incorrect?!

		body-symbol: words/_body/symbol
		anon-symbol: words/_anon/symbol
	]

	check-call: does [
		if acc-mode? [check-dyn-call]
	]

	reset: func [
		return:  [cell!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/reset"]]

		either acc-mode? [check-dyn-call][top: arguments]
		arguments
	]

	keep: func [
		return:  [cell!]
		/local
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/keep"]]

		top: arguments + 1								;-- keep last value in arguments slot
		if acc-mode? [check-dyn-call]
		arguments
	]

	mark-native: MARK_STACK(FLAG_NATIVE)
	mark-func:	 MARK_STACK(FLAG_FUNCTION)
	mark-try:	 MARK_STACK(FLAG_TRY)
	mark-catch:	 MARK_STACK(FLAG_CATCH)
	mark-eval:	 MARK_STACK(FLAG_EVAL)
	mark-dyn:	 MARK_STACK(FLAG_DYN_CALL)
	mark-loop:	 MARK_STACK(FLAG_LOOP)

	get-call: func [
		return: [red-word!]
		/local
			p	[call-frame!]
			sym [integer!]
	][
		p: ctop
		until [
			p: p - 1
			sym: p/header >> 8 and FFFFh
			any [
				all [sym <> body-symbol	sym <> anon-symbol]
				p < cbottom
			]
		]
		word/at p/ctx sym
	]

	revert: does [
		#if debug? = yes [if verbose > 0 [print-line "stack/revert"]]

		assert cbottom < ctop
		ctop: ctop - 1
		either ctop = cbottom [
			arguments: bottom
			top: bottom
		][
			top: arguments
			arguments: ctop/prev
		]

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind-part: does [
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind-part"]]

		assert cbottom < ctop
		ctop: ctop - 1
		either ctop = cbottom [
			arguments: bottom
		][
			arguments: ctop/prev
		]
		top: top - 1

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind: does [
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind"]]

		assert cbottom < ctop
		ctop: ctop - 1
		STACK_SET_FRAME
		if acc-mode? [check-dyn-call]

		#if debug? = yes [if verbose > 1 [dump]]
	]

	unwind-last: func [
		return:  [red-value!]
		/local
			last [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/unwind-last"]]

		last: arguments
		unwind
		copy-cell last arguments
	]

	unroll-frames: func [flags [integer!]][
		assert cbottom < ctop
		until [
			ctop: ctop - 1
			any [
				ctop <= cbottom
				flags and ctop/header = flags
			]
		]
		STACK_SET_FRAME
		ctop: ctop + 1									;-- ctop points past the current call frame
	]

	unroll: func [
		flags	 [integer!]
		/local
			last [red-value!]
			p	 [call-frame!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/unroll"]]

		last: arguments
		unroll-frames flags
		copy-cell last ctop/prev

		p: ctop + 1										;-- adjust stack pointers
		arguments: ctop/prev
		top: arguments
	]

	adjust: does [
		top: top - 1
		copy-cell top top - 1
		check-call
	]

	trace: func [
		int		[red-integer!]
		buffer	[red-string!]
		part	[integer!]
		return: [integer!]
		/local
			top	  [call-frame!]
			base  [call-frame!]
			sym	  [integer!]
	][
		top: as call-frame! int/value
		value: ALLOC_TAIL(root)
		int: as red-integer! value
		int/header: TYPE_INTEGER
		base: cbottom

		until [
			sym: base/header >> 8 and FFFFh

			if all [sym <> body-symbol sym <> anon-symbol][
				if base > cbottom [
					string/concatenate-literal buffer " "
					part: part - 4
				]
				part: word/form
					word/make-at sym value
					buffer
					null
					part
			]
			base: base + 1
			base >= top									;-- defensive test
		]
		part
	]

	set-stack: func [
		err [red-object!]
		/local
			base [red-value!]
			int	 [red-integer!]
	][
		base: object/get-values err
		int: as red-integer! base + error/get-stack-id
		int/header: TYPE_INTEGER
		int/value:  as-integer ctop
	]

	throw-error: func [
		err [red-object!]
		/local
			extra [red-value!]
			saved [red-value!]
	][
		error/set-where err as red-value! get-call
		set-stack err

		extra: top
		unroll-frames FLAG_TRY

		ctop: ctop - 1
		assert ctop >= cbottom
		top: extra

		if all [
			ctop = cbottom
			FLAG_TRY and ctop/header <> FLAG_TRY
		][
			saved: arguments
			arguments: extra							;-- use the top stack frame @@ overflows!
			set-last as red-value! err
			natives/print*
			arguments: saved
		]
		stack/push as red-value! err
		throw RED_ERROR
	]

	throw-break: func [
		return? [logic!]
		cont?	[logic!]
		/local
			result	  [red-value!]
			save-top  [red-value!]
			save-ctop [call-frame!]
			p		  [call-frame!]
	][
		result:	   arguments
		save-top:  top
		save-ctop: ctop

		;-- scan the stack to determine the outcome of an exception
		until [
			if any [
				FLAG_FUNCTION and ctop/header <> 0
				FLAG_TRY and ctop/header <> 0
			][
				ctop: save-ctop
				either cont? [fire [TO_ERROR(throw continue)]][fire [TO_ERROR(throw break)]]
			]
			ctop: ctop - 1
			any [
				ctop <= cbottom
				FLAG_LOOP and ctop/header <> 0			;-- loop found, we are fine
			]
		]

		either ctop <= cbottom [
			arguments: result
			top:	   save-top
			ctop:	   save-ctop
			either cont? [fire [TO_ERROR(throw continue)]][fire [TO_ERROR(throw break)]]
		][
			ctop: ctop + 1
			p: ctop + 1									;-- + 1 for getting ctop/prev value
			arguments: ctop/prev
			top: arguments
			either all [return? not cont?][set-last result][unset/push-last]
			either cont? [
				throw RED_CONTINUE_EXCEPTION
			][
				throw RED_BREAK_EXCEPTION
			]
		]
	]

	eval?: func [
		return: [logic!]
		/local
			cframe [call-frame!]
	][
		cframe: ctop
		until [
			cframe: cframe - 1
			if FLAG_EVAL and cframe/header = FLAG_EVAL [return yes]
			cframe <= cbottom
		]
		no
	]

	set-last: func [
		last	[red-value!]
		return: [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/set-last"]]

		copy-cell last arguments
	]

	push*: func [
		return:  [red-value!]
		/local
			cell [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/push*"]]

		cell: top
		top: top + 1
		if top >= a-end [
			print-line ["^/*** Error: arguments stack overflow!^/"]
			throw RED_ERROR
		]
		cell
	]

	push: func [
		value 	  [red-value!]
		return:   [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/push"]]

		copy-cell value top
		push*
	]

	pop: func [
		positions [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "stack/pop"]]

		top: top - positions
	]

	top-type?: func [
		return:  [integer!]
		/local
			value [red-value!]
	][
		value: top - 1
		TYPE_OF(value)
	]

	func?: func [
		return: [logic!]
		/local
			value [red-value!]
			type  [integer!]
	][
		value: top - 1
		type: TYPE_OF(value)
		any [											;@@ replace with ANY_FUNCTION?
			type = TYPE_FUNCTION
			type = TYPE_ROUTINE
		]
	]

	defer-call: func [
		name   [red-word!]
		code   [integer!]
		count  [integer!]
		octx [node!]
		/local
			info [dyn-info!]
	][
		;mark-native words/_anon
		integer/push as-integer octx					;-- store optional wrapping object pointer

		info: as dyn-info! push*
		info/header: TYPE_POINT
		info/code:   code								;-- store wrapping function pointer
		info/count:  count								;-- store caller's arity
		info/locals: -2									;-- store caller's locals count

		mark-dyn name									;-- open new frame
		acc-mode?: yes
		arguments/header: TYPE_VALUE					;-- use TYPE_VALUE to signal "no argument"
	]

	push-call: func [
		path [red-path!]
		idx  [integer!]
		code [integer!]
		octx [node!]
		/local
			fun		 [red-function!]
			p		 [red-path!]
			info	 [dyn-info!]
			counters [integer!]
	][
		;mark-native words/_anon
		fun: as red-function! top - 1

		assert any [
			TYPE_OF(fun) = TYPE_FUNCTION
			TYPE_OF(fun) = TYPE_ROUTINE
		]
		counters: _function/calc-arity path fun idx
		p: as red-path! copy-cell as red-value! path push*
		p/head: idx										;-- store path with function's index

		integer/push as-integer octx					;-- store optional wrapping object pointer

		info: as dyn-info! push*
		info/header: TYPE_POINT
		info/code:   code								;-- store wrapping function pointer
		info/count:  counters and FFFFh					;-- store caller's arity
		info/locals: counters >> 16						;-- store caller's locals count

		mark-dyn as red-word! block/rs-abs-at as red-block! path idx  ;-- open new frame
		acc-mode?: yes

		either zero? (counters and FFFFh) [
			arguments/header: TYPE_UNSET
			check-dyn-call								;-- short path to call with no arguments
		][
			arguments/header: TYPE_VALUE				;-- use TYPE_VALUE to signal "no argument"
		]
	]

	check-dyn-call: func [
		/local
			int		   [red-integer!]
			fun		   [red-function!]
			obj		   [red-object!]
			base	   [red-value!]
			last	   [red-value!]
			info	   [dyn-info!]
			ctx		   [node!]
			octx	   [node!]
			more	   [series!]
			p		   [call-frame!]
			dyn?	   [logic!]
			new-frame? [logic!]
			code
	][
		p: ctop - 1
		if p < cbottom [exit]

		if all [
			FLAG_DYN_CALL and p/header = FLAG_DYN_CALL
			TYPE_OF(arguments) <> TYPE_VALUE
		][
			info: as dyn-info! arguments - 1
			unless zero? info/count [info/count: info/count - 1]

			if zero? info/count [
				base: arguments
				either info/locals = -2 [
					fun: null
					new-frame?: no
				][
					ctx: null
					fun: as red-function! base - 4
					more: as series! fun/more/value
					int: as red-integer! more/offset + 4
					obj: as red-object! base - 5
					case [
						TYPE_OF(obj) = TYPE_OBJECT  [ctx: obj/ctx]
						TYPE_OF(int) = TYPE_INTEGER [ctx: as node! int/value]
						true						[ctx: null]
					]

					new-frame?: info/locals = -1
					case [
						info/locals > 0 [_function/init-locals info/locals]
						new-frame?		[_function/lay-frame]
						true			[0]					;-- 0 locals case, do nothing
					]
				]

				code: as function! [octx [node!]] info/code
				int: as red-integer! base - 2
				octx: as node! int/value

				acc-mode?: no							;-- temporary disable accumulative mode
				unless null? fun [_function/call fun ctx] ;-- run the detected function
				unless zero? info/code [code octx]		;-- run wrapper code (stored as function)
				if new-frame? [unwind-last]				;-- close new frame created for handling refinements

				last: arguments
				unwind									;-- close frame opened in 'push-call
				either all [
					null? fun							;-- for defered calls only
					arguments + 3 < top					;-- check if not first argument of parent call?
				][
					copy-cell last arguments + 1
					top: top - 2						;-- adjust stack to right position for next argument
				][
					copy-cell last arguments			;-- unwind-last
				]

				;base: arguments
				;unwind
				;push base
				acc-mode?: yes

				p: ctop - 1								;-- decide to keep or not the accumulative mode on
				either p < cbottom [
					acc-mode?: no						;-- bottom of stack reached, switch back to normal
				][
					dyn?: FLAG_DYN_CALL and p/header = FLAG_DYN_CALL
					either dyn? [check-dyn-call][acc-mode?: no] ;-- if another dyn call pending, keep the mode on
				]
			]
		]
	]

	#if debug? = yes [
		dump: does [									;-- debug purpose only
			print-line "^/---- Argument stack ----"
			dump-memory
				as byte-ptr! bottom
				4
				(as-integer top + 1 - bottom) >> 4
			print-line ["arguments: " arguments]
			print-line ["top: " top]

			print-line "^/---- Call stack ----"
			dump-memory
				as byte-ptr! cbottom
				4
				(as-integer ctop + 2 - cbottom) >> 4
			print-line ["ctop: " ctop]
		]
	]
]