TESTS: additional PARSE tests.

TESTS: additional PARSE 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 not parse		[a a]		[1 skip]
	--test-- "blk-45"	--assert parse			[a a]		[2 skip]
	--test-- "blk-46"	--assert not parse		[a a]		[3 skip]
	--test-- "blk-47"	--assert not parse		[a a]		[1 1 skip]
	--test-- "blk-48"	--assert parse			[a a]		[1 2 skip]
	--test-- "blk-49"	--assert parse			[a a]		[2 2 skip]
	--test-- "blk-50"	--assert parse			[a a]		[2 3 skip]
   	--test-- "blk-51"	--assert not parse		[a a]		[3 4 skip]

    --test-- "blk-52"	--assert parse			[a]			[skip]
    --test-- "blk-53"	--assert parse			[a b]		[skip skip]
    --test-- "blk-54"	--assert parse			[a b]		[skip [skip]]
    --test-- "blk-55"	--assert parse			[a b]		[[skip] [skip]]

   	--test-- "blk-56"	--assert parse			[a a]		[some ['a]]
   	--test-- "blk-57"	--assert not parse		[a a]		[some ['a] 'b]

   	--test-- "blk-58"	--assert parse			[a a b a b b b a]	[some [skip]]
   	--test-- "blk-59"	--assert parse			[a a b a b b b a]	[some ['a | 'b]]
   	--test-- "blk-60"	--assert not parse 		[a a b a b b b a]	[some ['a | 'c]]

	--test-- "blk-61"	--assert parse 			[a a]		[any ['a]]
	--test-- "blk-62"	--assert parse			[a a]		[some ['a] any ['b]]
	--test-- "blk-63"	--assert parse			[a a b b]	[2 'a 2 'b]
	--test-- "blk-64"	--assert not parse		[a a b b]	[2 'a 3 'b]
	--test-- "blk-65"	--assert parse			[a a b b]	[some 'a some 'b]
   	--test-- "blk-66"	--assert not parse		[a a b b]	[some 'a some 'c]

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

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

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

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

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

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

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

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

	--test-- "blk-74"
	--assert parse [b a a a c][skip some ['a] 'c]

===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=== "block-words"

	wa: ['a]
	wb: ['b]
	wca: #"a"
	wcb: #"b"
	wra: [wa]
	wrb: [wb]
	wh: "hello"
	wrab: ['a | 'b]
	wrba: ['b | 'a]

	--test-- "blk-w1" 	--assert parse 		[a]			[wa]
	--test-- "blk-w2" 	--assert not parse 	[a]			[wb]
	--test-- "blk-w3" 	--assert parse 		[a b]		[wa wb]
	--test-- "blk-w4" 	--assert parse 		[a #"b"]	[wa wcb]
	--test-- "blk-w5" 	--assert parse 		[a]			[wra]
	--test-- "blk-w6" 	--assert parse 		[a b]		[wra 'b]
	--test-- "blk-w7" 	--assert parse 		[a b]		['a wrb]
	--test-- "blk-w8" 	--assert parse 		[a b]		[wra wrb]
	--test-- "blk-w9"	--assert parse 		["hello"]	[wh]

	--test-- "blk-w10"	--assert parse 		[#"a"] 		[wcb | wca]
	--test-- "blk-w11"	--assert not parse 	[a b]		[wb | wa]
	--test-- "blk-w12"	--assert parse 		[#"a"]		[[wcb | wca]]
	--test-- "blk-w13"	--assert not parse 	[a b]		[wrba]
	--test-- "blk-w14"	--assert parse 		[a b]		[wrab wrba]

	--test-- "blk-w15"	--assert parse		[a 123]		[wa integer!]
	--test-- "blk-w16"	--assert not parse	[a 123]		[wa char!]
	--test-- "blk-w17"	--assert parse		[a 123]		[wra [integer!]]
	--test-- "blk-w18"	--assert not parse	[a 123]		[wa  [char!]]

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

	--test-- "blk-w20"
		res: 0
		--assert not parse [a] [wb (res: 1)]
		--assert res = 0

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

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

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

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

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

===end-group===

===start-group=== "block-extraction"

	wa: ['a]
	--test-- "blk-ext1"
		res: 0
		--assert parse [a][copy res skip]
		--assert res = [a]

	--test-- "blk-ext2"
		res: 0
		--assert parse [a][copy res 'a]
		--assert res = [a]

	--test-- "blk-ext3"
		res: 0
		--assert parse [a][copy res word!]
		--assert res = [a]

	--test-- "blk-ext4"
		res:  0
		res2: 0
		--assert parse [a][copy res copy res2 'a]
		--assert res  = [a]
		--assert res2 = [a]

	--test-- "blk-ext5"
		res: 0
		--assert parse [a a][copy res 2 'a]				;@@ a instead of 'a will crash!
		--assert res = [a a]

	--test-- "blk-ext6"
		res: 0
		--assert not parse [a a][copy res 3 'a]
		--assert res = 0

	--test-- "blk-ext7"
		res: 0
		--assert parse [a][copy res ['a]]
		--assert res = [a]

	--test-- "blk-ext8"
		res: 0
		--assert parse [a][copy res wa]
		--assert res = [a]

	--test-- "blk-ext9"
		res: 0
		--assert parse [a a][copy res 2 wa]
		--assert res = [a a]

	--test-- "blk-ext10"
		res: 0
		--assert parse [a a b][skip copy res 'a skip]
		--assert res = [a]

	--test-- "blk-ext11"
		res: 0
		--assert parse [a a b][skip copy res ['a | 'b] skip]
		--assert res = [a]

	--test-- "blk-ext12"
		res: 0
		--assert not parse [a][copy res ['c | 'b]]
		--assert res = 0

	--test-- "blk-ext13"
		res: 0
		--assert parse [a][set res skip]
		--assert res = 'a

	--test-- "blk-ext14"
		res: 0
		--assert parse [a][set res 'a]
		--assert res = 'a

	--test-- "blk-ext15"
		res: 0
		--assert parse [a][set res word!]
		--assert res = 'a

	--test-- "blk-ext16"
		res:  0
		res2: 0
		--assert parse [a][set res set res2 'a]
		--assert res  = 'a
		--assert res2 = 'a

	--test-- "blk-ext17"
		res: 0
		--assert parse [a a][set res 2 'a]				;@@ a instead of 'a will crash!
		--assert res = 'a

	--test-- "blk-ext18"
		res: 0
		--assert not parse [a a][set res 3 'a]
		--assert res = 0

	--test-- "blk-ext19"
		res: 0
		--assert parse [a][set res ['a]]
		--assert res = 'a

	--test-- "blk-ext20"
		res: 0
		--assert parse [a][set res wa]
		--assert res = 'a

	--test-- "blk-ext21"
		res: 0
		--assert parse [a a][set res 2 wa]
		--assert res = 'a

	--test-- "blk-ext22"
		res: 0
		--assert parse [a a b][skip set res 'a skip]
		--assert res = 'a

	--test-- "blk-ext23"
		res: 0
		--assert parse [a a b][skip set res ['a | 'b] skip]
		--assert res = 'a

	--test-- "blk-ext24"
		res: 0
		--assert not parse [a][set res ['c | 'b]]
		--assert res = 0

	--test-- "blk-ext25"
		res: 0
		--assert parse [b a a a c][skip set res some 'a 'c]
		--assert res = 'a

	--test-- "blk-ext26"
		res: 0
		--assert parse [b a a a c][skip set res some wa 'c]
		--assert res = 'a

===end-group===

===start-group=== "block-skipping"

	--test-- "blk-sk1" 	--assert parse		[]			[to end]
	--test-- "blk-sk2" 	--assert parse		[]			[thru end]
	--test-- "blk-sk3" 	--assert parse		[a]			[to end]
	--test-- "blk-sk4" 	--assert not parse	[a]			[to 'a]
	--test-- "blk-sk5" 	--assert not parse	[a]			[to 'a end]
	--test-- "blk-sk6" 	--assert parse		[a]			[to 'a skip]
	--test-- "blk-sk7" 	--assert parse		[a]			[thru 'a]
	--test-- "blk-sk8" 	--assert parse		[a]			[thru 'a end]
	--test-- "blk-sk9" 	--assert not parse	[a]			[thru 'a skip]
	--test-- "blk-sk10" --assert parse		[a b]		[to 'b skip]
	--test-- "blk-sk11"	--assert parse		[a b]		[thru 'b]
	--test-- "blk-sk12"	--assert parse		[a a a b]	[to 'b skip]
	--test-- "blk-sk13"	--assert parse		[a a b a]	[skip to 'b 2 skip]

	--test-- "blk-sk14" --assert not parse	[a]			[to ['a]]
	--test-- "blk-sk15" --assert not parse	[a]			[to ['a] end]
	--test-- "blk-sk16" --assert parse		[a]			[to ['a] skip]
	--test-- "blk-sk17" --assert parse		[a]			[thru ['a]]
	--test-- "blk-sk18" --assert parse		[a]			[thru ['a] end]
	--test-- "blk-sk19" --assert not parse	[a]			[thru ['a] skip]
	--test-- "blk-sk20" --assert parse		[a b]		[to ['b] skip]
	--test-- "blk-sk21"	--assert parse		[a b]		[thru ['b]]
	--test-- "blk-sk22"	--assert parse		[a a a b]	[to ['b] skip]
	--test-- "blk-sk23"	--assert parse		[a a b a]	[skip to ['b] 2 skip]

	--test-- "blk-sk24"	--assert parse		[z z a b c]	[to ['c | 'b | 'a] 3 skip]
	--test-- "blk-sk25"	--assert parse		[z z a b c]	[to ['a | 'b | 'c] 3 skip]

	--test-- "blk-sk24"	--assert parse		[z z a b c]	[thru ['c | 'b | 'a] 2 skip]
	--test-- "blk-sk25"	--assert parse		[z z a b c]	[thru ['a | 'b | 'c] 2 skip]

===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 not parse		"aa"		[1 skip]
	--test-- "str-45"	--assert parse			"aa"		[2 skip]
	--test-- "str-46"	--assert not parse		"aa"		[3 skip]
	--test-- "str-47"	--assert not parse		"aa"		[1 1 skip]
	--test-- "str-48"	--assert parse			"aa"		[1 2 skip]
	--test-- "str-49"	--assert parse			"aa"		[2 2 skip]
	--test-- "str-50"	--assert parse			"aa"		[2 3 skip]
   	--test-- "str-51"	--assert not parse		"aa"		[3 4 skip]

    --test-- "str-52"	--assert parse			"a"			[skip]
    --test-- "str-53"	--assert parse			"ab"		[skip skip]
    --test-- "str-54"	--assert parse			"ab"		[skip [skip]]
    --test-- "str-55"	--assert parse			"ab"		[[skip] [skip]]

   	--test-- "str-56"	--assert parse			"aa"		[some [#"a"]]
   	--test-- "str-57"	--assert not parse		"aa"		[some [#"a"] #"b"]

   	--test-- "str-58"	--assert parse			"aababbba"	[some [skip]]
   	--test-- "str-59"	--assert parse			"aababbba"	[some ["a" | "b"]]
   	--test-- "str-60"	--assert not parse 		"aababbba"	[some ["a" | #"c"]]

	--test-- "str-61"	--assert parse 			"aa"		[any [#"a"]]
	--test-- "str-62"	--assert parse			"aa"		[some [#"a"] any [#"b"]]
	--test-- "str-63"	--assert parse			"aabb"		[2 #"a" 2 "b"]
	--test-- "str-64"	--assert not parse		"aabb"		[2 "a" 3 #"b"]
	--test-- "str-65"	--assert parse			"aabb"		[some #"a" some "b"]
   	--test-- "str-66"	--assert not parse		"aabb"		[some "a" some #"c"]

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

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

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

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

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

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

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

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

	--test-- "str-75"
	--assert parse "baaac" [skip some [#"a"] #"c"]

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

===start-group=== "string-words"

	wa: [#"a"]
	wb: [#"b"]
	wca: #"a"
	wcb: #"b"
	wra: [wa]
	wrb: [wb]
	wh: "hello"
	wrab: [#"a" | #"b"]
	wrba: [#"b" | #"a"]

	--test-- "str-w1" 	--assert parse 		"a"			[wa]
	--test-- "str-w2" 	--assert not parse 	"a"			[wb]
	--test-- "str-w3" 	--assert parse 		"ab"		[wa wb]
	--test-- "str-w5" 	--assert parse 		"a"			[wra]
	--test-- "str-w6" 	--assert parse 		"ab"		[wra #"b"]
	--test-- "str-w7" 	--assert parse 		"ab"		[#"a" wrb]
	--test-- "str-w8" 	--assert parse 		"ab"		[wra wrb]
	--test-- "str-w9"	--assert parse 		"hello"		[wh]

	--test-- "str-w10"	--assert parse 		"a" 		[wcb | wca]
	--test-- "str-w11"	--assert not parse 	"ab"		[wb | wa]
	--test-- "str-w12"	--assert parse 		"a"			[[wcb | wca]]
	--test-- "str-w13"	--assert not parse 	"ab"		[wrba]
	--test-- "str-w14"	--assert parse 		"ab"		[wrab wrba]

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

	--test-- "str-w20"
		res: 0
		--assert not parse "a" [wb (res: 1)]
		--assert res = 0

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

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

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

===end-group===

===start-group=== "string-extraction"

	wa: [#"a"]
	--test-- "str-ext1"
		res: 0
		--assert parse "a" [copy res skip]
		--assert res = "a"

	--test-- "str-ext2"
		res: 0
		--assert parse "a" [copy res #"a"]
		--assert res = "a"

	--test-- "str-ext4"
		res:  0
		res2: 0
		--assert parse "a" [copy res copy res2 #"a"]
		--assert res  = "a"
		--assert res2 = "a"

	--test-- "str-ext5"
		res: 0
		--assert parse "aa" [copy res 2 #"a"]
		--assert res = "aa"

	--test-- "str-ext6"
		res: 0
		--assert not parse "aa" [copy res 3 #"a"]
		--assert res = 0

	--test-- "str-ext7"
		res: 0
		--assert parse "a" [copy res [#"a"]]
		--assert res = "a"

	--test-- "str-ext8"
		res: 0
		--assert parse "a" [copy res wa]
		--assert res = "a"

	--test-- "str-ext9"
		res: 0
		--assert parse "aa" [copy res 2 wa]
		--assert res = "aa"

	--test-- "str-ext10"
		res: 0
		--assert parse "aab" [skip copy res #"a" skip]
		--assert res = "a"

	--test-- "str-ext11"
		res: 0
		--assert parse "aab" [skip copy res [#"a" | #"b"] skip]
		--assert res = "a"

	--test-- "str-ext12"
		res: 0
		--assert not parse "a" [copy res [#"c" | #"b"]]
		--assert res = 0

	--test-- "str-ext13"
		res: 0
		--assert parse "a" [set res skip]
		--assert res = #"a"

	--test-- "str-ext14"
		res: 0
		--assert parse "a" [set res #"a"]
		--assert res = #"a"

	--test-- "str-ext16"
		res:  0
		res2: 0
		--assert parse "a" [set res set res2 #"a"]
		--assert res  = #"a"
		--assert res2 = #"a"

	--test-- "str-ext17"
		res: 0
		--assert parse "aa" [set res 2 #"a"]
		--assert res = #"a"

	--test-- "str-ext18"
		res: 0
		--assert not parse "aa" [set res 3 #"a"]
		--assert res = 0

	--test-- "str-ext19"
		res: 0
		--assert parse "a" [set res [#"a"]]
		--assert res = #"a"

	--test-- "str-ext20"
		res: 0
		--assert parse "a" [set res wa]
		--assert res = #"a"

	--test-- "str-ext21"
		res: 0
		--assert parse "aa" [set res 2 wa]
		--assert res = #"a"

	--test-- "str-ext22"
		res: 0
		--assert parse "aab" [skip set res #"a" skip]
		--assert res = #"a"

	--test-- "str-ext23"
		res: 0
		--assert parse "aab" [skip set res [#"a" | #"b"] skip]
		--assert res = #"a"

	--test-- "str-ext24"
		res: 0
		--assert not parse "a" [set res [#"c" | #"b"]]
		--assert res = 0

	--test-- "str-ext25"
		res: 0
		--assert parse "baaac" [skip set res some #"a" #"c"]
		--assert res = #"a"

	--test-- "str-ext26"
		res: 0
		--assert parse "baaac" [skip set res some wa #"c"]
		--assert res = #"a"

===end-group===

===start-group=== "string-skipping"

	--test-- "str-sk1" 	--assert parse		""			[to end]
	--test-- "str-sk2" 	--assert parse		""			[thru end]
	--test-- "str-sk3" 	--assert parse		"a"			[to end]
	--test-- "str-sk4" 	--assert not parse	"a"			[to #"a"]
	--test-- "str-sk5" 	--assert not parse	"a"			[to #"a" end]
	--test-- "str-sk6" 	--assert parse		"a"			[to #"a" skip]
	--test-- "str-sk7" 	--assert parse		"a"			[thru #"a"]
	--test-- "str-sk8" 	--assert parse		"a"			[thru #"a" end]
	--test-- "str-sk9" 	--assert not parse	"a"			[thru #"a"skip]
	--test-- "str-sk10" --assert parse		"ab"		[to #"a" 2 skip]
	--test-- "str-sk11"	--assert parse		"ab"		[thru #"a" skip]
	--test-- "str-sk12"	--assert parse		"aaab"		[to #"a" to end]
	--test-- "str-sk13"	--assert parse		"aaba"		[skip thru #"a" 2 skip]

	--test-- "str-sk14" --assert not parse	"a"			[to [#"a"]]
	--test-- "str-sk15" --assert not parse	"a"			[to [#"a"] end]
	--test-- "str-sk16" --assert parse		"a"			[to [#"a"] skip]
	--test-- "str-sk17" --assert parse		"a"			[thru [#"a"]]
	--test-- "str-sk18" --assert parse		"a"			[thru [#"a"] end]
	--test-- "str-sk19" --assert not parse	"a"			[thru [#"a"] skip]
	--test-- "str-sk20" --assert parse		"ab"		[to [#"a"] 2 skip]
	--test-- "str-sk21"	--assert parse		"ab"		[thru [#"a"] skip]
	--test-- "str-sk22"	--assert parse		"aaab"		[to [#"a"] to end]
	--test-- "str-sk33"	--assert parse		"aaba"		[skip thru [#"a"] 2 skip]

	--test-- "str-sk24"	--assert parse		"zzabc"		[to [#"c" | #"b" | #"a"] 3 skip]
	--test-- "str-sk25"	--assert parse		"zzabc"		[to [#"a" | #"b" | #"c"] 3 skip]

	--test-- "str-sk26"	--assert parse		"zzabc"		[thru [#"c" | #"b" | #"a"] 2 skip]
	--test-- "str-sk27"	--assert parse		"zzabc"		[thru [#"a" | #"b" | #"c"] 2 skip]

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

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


FIX: bad handling of escaped characters in strings in runtime lexer (LOAD).

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 [

	#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 #"!"
	]

	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 first double quote
		e: s + 1
		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]
		]
		if c <> #"}" [throw-error ERR_MULTI_STRING_DELIMIT]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		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
		string/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		either c = #"^"" [e + 1][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 i blk
		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 [
			all [
				c <> null-byte
				c <> #" "
				c <> #"/"
				c <> #"^/"
				c <> #"^M"
				c <> #"^-"
				c <> #":"
				c <> #"^""
				c <> #"["
				c <> #"]"
				c <> #"("
				c <> #")"
				c <> #"{"
				c <> #"}"
				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 blk
		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 blk
		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
		][
			block/make-in parent 4						;-- arbitrary start size
		]

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

	#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 #"!"
	]

	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 first double quote
		e: s + 1
		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 + 1
				c: e/1
				if c = #"^^" [
					e: e + 2							;-- skip next character (escaped)
					c: e/1
				]
			]
			if c = #"}" [count: count - 1]
		]
		if c <> #"}" [throw-error ERR_MULTI_STRING_DELIMIT]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		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 + 1
			c: e/1
		]
		if c <> #"^"" [throw-error ERR_STRING_DELIMIT]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		string/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		either c = #"^"" [e + 1][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 i blk
		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 [
			all [
				c <> null-byte
				c <> #" "
				c <> #"/"
				c <> #"^/"
				c <> #"^M"
				c <> #"^-"
				c <> #":"
				c <> #"^""
				c <> #"["
				c <> #"]"
				c <> #"("
				c <> #")"
				c <> #"{"
				c <> #"}"
				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 blk
		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 blk
		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
		][
			block/make-in parent 4						;-- arbitrary start size
		]

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

]


FIX: debugging code leftover.

FIX: debugging code leftover.

Red/System [
	Title:   "Map! datatype runtime functions"
	Author:  "Qingtian Xie"
	File:	 %map.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2014-2015 Qingtian Xie. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
]

map: context [
	verbose: 0

	rs-length?: func [
		map 	[red-hash!]
		return: [integer!]
		/local
			s	 [series!]
			size [int-ptr!]
	][
		s: as series! map/table/value
		size: as int-ptr! s/offset
		size/value
	]

	serialize: func [
		map		[red-hash!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent?	[logic!]
		tabs	[integer!]
		mold?	[logic!]
		return: [integer!]
		/local
			s		[series!]
			value	[red-value!]
			next	[red-value!]
			s-tail	[red-value!]
			blank	[byte!]
	][
		if positive? rs-length? map [
			either flat? [
				indent?: no
				blank: space
			][
				if mold? [
					string/append-char GET_BUFFER(buffer) as-integer lf
					part: part - 1
				]
				blank: lf
			]

			s: GET_BUFFER(map)
			value: s/offset
			s-tail: s/tail
			while [value < s-tail][
				next: value + 1
				unless TYPE_OF(next) = TYPE_NONE [
					if indent? [part: object/do-indent buffer tabs part]

					part: actions/mold value buffer only? all? flat? arg part tabs
					string/append-char GET_BUFFER(buffer) as-integer space
					part: part - 1

					part: actions/mold next buffer only? all? flat? arg part tabs

					if any [indent? next + 1 < s-tail][			;-- no final LF when FORMed
						string/append-char GET_BUFFER(buffer) as-integer blank
						part: part - 1
					]
				]
				if all [OPTION?(arg) part <= 0][return part]
				value: value + 2
			]
		]
		part
	]

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

		copy-cell as red-value! map stack/push*
	]

	make-at: func [
		slot	[red-value!]
		blk		[red-block!]
		size	[integer!]
		return:	[red-hash!]
		/local
			table [node!]
			map	  [red-hash!]
	][
		table: _hashtable/init size blk HASH_TABLE_MAP
		map: as red-hash! slot
		map/header: TYPE_MAP							;-- implicit reset of all header flags
		map/table: table
		map
	]

	;--- Actions ---

	make: func [
		proto		[red-value!]
		spec		[red-value!]
		return:		[red-hash!]
		/local
			map		[red-hash!]
			size	[integer!]
			int		[red-integer!]
			blk		[red-block!]
			blk?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/make"]]

		blk?: no
		size: 1
		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				int: as red-integer! spec
				size: int/value
				if negative? size [fire [TO_ERROR(script out-of-range) spec]]
			]
			TYPE_BLOCK [
				size: block/rs-length? as red-block! spec
				if size % 2 <> 0 [fire [TO_ERROR(script invalid-arg) spec]]
				blk?: yes
			]
			default [--NOT_IMPLEMENTED--]
		]
		if zero? size [size: 1]
		blk: block/make-at as red-block! stack/push* size
		if blk? [block/copy as red-block! spec blk null no null]
		make-at as red-value! blk blk size
	]

	reflect: func [
		map		[red-hash!]
		field	[integer!]
		return:	[red-block!]
		/local
			blk    [red-block!]
			s-tail [red-value!]
			value  [red-value!]
			next   [red-value!]
			size   [integer!]
			s	   [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		s: GET_BUFFER(map)
		value: s/offset
		s-tail: s/tail
		size: block/rs-length? as red-block! map
		case [
			field = words/words [
				blk/node: alloc-cells size >> 1
				while [value < s-tail][
					next: value + 1
					unless TYPE_OF(next) = TYPE_NONE [
						if TYPE_OF(value) = TYPE_SET_WORD [
							value/header: TYPE_WORD
						]
						block/rs-append blk value
					]
					value: value + 2
				]
			]
			field = words/values [
				blk/node: alloc-cells size >> 1
				while [value < s-tail][
					next: value + 1
					unless TYPE_OF(next) = TYPE_NONE [
						block/rs-append blk next
					]
					value: value + 2
				]
			]
			field = words/body [
				blk/node: alloc-cells size
				while [value < s-tail][
					next: value + 1
					unless TYPE_OF(next) = TYPE_NONE [
						block/rs-append blk value
						block/rs-append blk next
					]
					value: value + 2
				]
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		as red-block! stack/set-last as red-value! blk
	]

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

		serialize map buffer no no no arg part no 0 no
	]

	mold: func [
		map		[red-hash!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent	[integer!]
		return:	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/mold"]]

		string/concatenate-literal buffer "#("
		part: serialize map buffer only? all? flat? arg part - 2 yes indent + 1 yes
		if indent > 0 [part: object/do-indent buffer indent part]
		string/append-char GET_BUFFER(buffer) as-integer #")"
		part - 1
	]

	compare: func [
		map1	   [red-hash!]							;-- first operand
		map2	   [red-hash!]							;-- second operand
		op		   [integer!]							;-- type of comparison
		return:	   [integer!]
		/local type res
	][
		#if debug? = yes [if verbose > 0 [print-line "map/compare"]]

		type: TYPE_OF(map2)
		if type <> TYPE_MAP [RETURN_COMPARE_OTHER]
		switch op [
			COMP_EQUAL
			COMP_STRICT_EQUAL
			COMP_NOT_EQUAL
			COMP_SORT
			COMP_CASE_SORT [
				res: block/compare-each as red-block! map1 as red-block! map2 op
			]
			default [
				res: -2
			]
		]
		res
	]

	eval-path: func [
		parent	[red-hash!]							;-- implicit type casting
		element	[red-value!]
		value	[red-value!]
		case?	[logic!]
		return:	[red-value!]
		/local
			table	[node!]
			key		[red-value!]
			val		[red-value!]
			s		[series!]
			size	[int-ptr!]
	][
		table: parent/table
		key: _hashtable/get table element 0 0 case? no no

		either value <> null [						;-- set value
			either TYPE_OF(value) = TYPE_NONE [		;-- delete key entry
				unless key = null [
					_hashtable/delete table key
				]
				value
			][
				either key = null [
					s: as series! parent/node/value
					key: copy-cell element as cell! alloc-tail-unit s (size? cell!) << 1
					_hashtable/put table key
				][
					val: key + 1
					if TYPE_OF(val) = TYPE_NONE [	;-- increase size of keys
						s: as series! table/value
						size: as int-ptr! s/offset
						size/value: size/value + 1
					]
				]
				copy-cell value key + 1
			]
		][
			either key = null [none-value][key + 1]
		]
	]

	;--- Reading actions ---

	pick: func [
		map		[red-hash!]
		index	[red-value!]
		boxed	[red-value!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/pick"]]

		eval-path map boxed null no
	]

	;--- Modifying actions ---

	insert: func [
		map		  [red-hash!]
		value	  [red-value!]
		part-arg  [red-value!]
		only?	  [logic!]
		dup-arg	  [red-value!]
		append?	  [logic!]
		return:	  [red-value!]
		/local
			src		[red-block!]
			cell	[red-value!]
			limit	[red-value!]
			int		[red-integer!]
			s		[series!]
			cnt		[integer!]
			part	[integer!]
			size	[integer!]
			table	[node!]
			key		[red-value!]
			val		[red-value!]
			psize	[int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/insert"]]

		if TYPE_OF(value) <> TYPE_BLOCK [
			fire [TO_ERROR(script invalid-arg) value]
		]

		part: -1

		if OPTION?(part-arg) [
			if TYPE_OF(part-arg) <> TYPE_INTEGER [
				fire [TO_ERROR(script invalid-arg) part-arg]
			]
			int: as red-integer! part-arg
			part: int/value * 2
		]

		src: as red-block! value
		size: block/rs-length? src
		if any [negative? part part > size][part: size] ;-- truncate if off-range part value
		if part % 2 > 0 [part: part - 1]

		s: GET_BUFFER(map)
		size: as-integer s/tail + part - s/offset
		if size > s/size [s: expand-series s size]

		s: GET_BUFFER(src)
		cell: s/offset + src/head
		limit: cell + part								;-- /part support

		table: map/table
		while [cell < limit][
			key: _hashtable/get table cell 0 0 yes no no
			value: cell + 1
			either TYPE_OF(value) = TYPE_NONE [			;-- delete key entry
				unless key = null [
					_hashtable/delete table key
				]
			][
				either key = null [
					s: as series! map/node/value
					key: copy-cell cell as cell! alloc-tail-unit s (size? cell!) << 1
					_hashtable/put table key
				][
					val: key + 1
					if TYPE_OF(val) = TYPE_NONE [		;-- increase size of keys
						s: as series! table/value
						psize: as int-ptr! s/offset
						psize/value: psize/value + 1
					]
				]
				copy-cell value key + 1
			]
			cell: cell + 2
		]
		as red-value! map
	]

	clear: func [
		map		[red-hash!]
		return:	[red-value!]
		/local
			s	[series!]
			value [red-value!]
			i     [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/clear"]]

		s: GET_BUFFER(map)
		i: 0
		while [
			value: s/offset + i
			value < s/tail
		][
			_hashtable/delete map/table value
			i: i + 2
		]
		as red-value! map
	]

	poke: func [
		map		[red-hash!]
		index	[red-value!]
		data	[red-value!]
		boxed	[red-value!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/poke"]]

		stack/set-last eval-path map boxed data no
	]

	;--- Property reading actions ---

	length?: func [
		map		[red-hash!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/length?"]]

		rs-length? map
	]

	;--- Navigation actions ---

	select: func [
		map		 [red-hash!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		return:	 [red-value!]
		/local
			table [node!]
			key   [red-value!]
	][
		table: map/table
		key: _hashtable/get table value 0 0 case? no no
		either key = null [none-value][key + 1]
	]

	;--- Misc actions ---

	copy: func [
		map	    	[red-hash!]
		new			[red-hash!]
		part-arg	[red-value!]
		deep?		[logic!]
		types		[red-value!]
		return:		[red-hash!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/copy"]]
		new: as red-hash! block/clone as red-block! map deep? no

		new/header: TYPE_MAP
		new/table: 	_hashtable/copy map/table new/node
		new
	]

	init: does [
		datatype/register [
			TYPE_MAP
			TYPE_VALUE
			"map!"
			;-- General actions --
			:make
			null			;random
			:reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			: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
			:clear
			:copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			:insert
			:length?
			null			;next
			:pick
			:poke
			null			;remove
			null			;reverse
			: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:   "Map! datatype runtime functions"
	Author:  "Qingtian Xie"
	File:	 %map.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2014-2015 Qingtian Xie. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
]

map: context [
	verbose: 0

	rs-length?: func [
		map 	[red-hash!]
		return: [integer!]
		/local
			s	 [series!]
			size [int-ptr!]
	][
		s: as series! map/table/value
		size: as int-ptr! s/offset
		size/value
	]

	serialize: func [
		map		[red-hash!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent?	[logic!]
		tabs	[integer!]
		mold?	[logic!]
		return: [integer!]
		/local
			s		[series!]
			value	[red-value!]
			next	[red-value!]
			s-tail	[red-value!]
			blank	[byte!]
	][
		if positive? rs-length? map [
			either flat? [
				indent?: no
				blank: space
			][
				if mold? [
					string/append-char GET_BUFFER(buffer) as-integer lf
					part: part - 1
				]
				blank: lf
			]

			s: GET_BUFFER(map)
			value: s/offset
			s-tail: s/tail
			while [value < s-tail][
				next: value + 1
				unless TYPE_OF(next) = TYPE_NONE [
					if indent? [part: object/do-indent buffer tabs part]

					part: actions/mold value buffer only? all? flat? arg part tabs
					string/append-char GET_BUFFER(buffer) as-integer space
					part: part - 1

					part: actions/mold next buffer only? all? flat? arg part tabs

					if any [indent? next + 1 < s-tail][			;-- no final LF when FORMed
						string/append-char GET_BUFFER(buffer) as-integer blank
						part: part - 1
					]
				]
				if all [OPTION?(arg) part <= 0][return part]
				value: value + 2
			]
		]
		part
	]

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

		copy-cell as red-value! map stack/push*
	]

	make-at: func [
		slot	[red-value!]
		blk		[red-block!]
		size	[integer!]
		return:	[red-hash!]
		/local
			table [node!]
			map	  [red-hash!]
	][
		table: _hashtable/map-init size blk HASH_TABLE_MAP
		map: as red-hash! slot
		map/header: TYPE_MAP							;-- implicit reset of all header flags
		map/table: table
		map
	]

	;--- Actions ---

	make: func [
		proto		[red-value!]
		spec		[red-value!]
		return:		[red-hash!]
		/local
			map		[red-hash!]
			size	[integer!]
			int		[red-integer!]
			blk		[red-block!]
			blk?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/make"]]

		blk?: no
		size: 1
		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				int: as red-integer! spec
				size: int/value
				if negative? size [fire [TO_ERROR(script out-of-range) spec]]
			]
			TYPE_BLOCK [
				size: block/rs-length? as red-block! spec
				if size % 2 <> 0 [fire [TO_ERROR(script invalid-arg) spec]]
				blk?: yes
			]
			default [--NOT_IMPLEMENTED--]
		]
		if zero? size [size: 1]
		blk: block/make-at as red-block! stack/push* size
		if blk? [block/copy as red-block! spec blk null no null]
		make-at as red-value! blk blk size
	]

	reflect: func [
		map		[red-hash!]
		field	[integer!]
		return:	[red-block!]
		/local
			blk    [red-block!]
			s-tail [red-value!]
			value  [red-value!]
			next   [red-value!]
			size   [integer!]
			s	   [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		s: GET_BUFFER(map)
		value: s/offset
		s-tail: s/tail
		size: block/rs-length? as red-block! map
		case [
			field = words/words [
				blk/node: alloc-cells size >> 1
				while [value < s-tail][
					next: value + 1
					unless TYPE_OF(next) = TYPE_NONE [
						if TYPE_OF(value) = TYPE_SET_WORD [
							value/header: TYPE_WORD
						]
						block/rs-append blk value
					]
					value: value + 2
				]
			]
			field = words/values [
				blk/node: alloc-cells size >> 1
				while [value < s-tail][
					next: value + 1
					unless TYPE_OF(next) = TYPE_NONE [
						block/rs-append blk next
					]
					value: value + 2
				]
			]
			field = words/body [
				blk/node: alloc-cells size
				while [value < s-tail][
					next: value + 1
					unless TYPE_OF(next) = TYPE_NONE [
						block/rs-append blk value
						block/rs-append blk next
					]
					value: value + 2
				]
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		as red-block! stack/set-last as red-value! blk
	]

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

		serialize map buffer no no no arg part no 0 no
	]

	mold: func [
		map		[red-hash!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent	[integer!]
		return:	[integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/mold"]]

		string/concatenate-literal buffer "#("
		part: serialize map buffer only? all? flat? arg part - 2 yes indent + 1 yes
		if indent > 0 [part: object/do-indent buffer indent part]
		string/append-char GET_BUFFER(buffer) as-integer #")"
		part - 1
	]

	compare: func [
		map1	   [red-hash!]							;-- first operand
		map2	   [red-hash!]							;-- second operand
		op		   [integer!]							;-- type of comparison
		return:	   [integer!]
		/local type res
	][
		#if debug? = yes [if verbose > 0 [print-line "map/compare"]]

		type: TYPE_OF(map2)
		if type <> TYPE_MAP [RETURN_COMPARE_OTHER]
		switch op [
			COMP_EQUAL
			COMP_STRICT_EQUAL
			COMP_NOT_EQUAL
			COMP_SORT
			COMP_CASE_SORT [
				res: block/compare-each as red-block! map1 as red-block! map2 op
			]
			default [
				res: -2
			]
		]
		res
	]

	eval-path: func [
		parent	[red-hash!]							;-- implicit type casting
		element	[red-value!]
		value	[red-value!]
		case?	[logic!]
		return:	[red-value!]
		/local
			table	[node!]
			key		[red-value!]
			val		[red-value!]
			s		[series!]
			size	[int-ptr!]
	][
		table: parent/table
		key: _hashtable/get table element 0 0 case? no no

		either value <> null [						;-- set value
			either TYPE_OF(value) = TYPE_NONE [		;-- delete key entry
				unless key = null [
					_hashtable/delete table key
				]
				value
			][
				either key = null [
					s: as series! parent/node/value
					key: copy-cell element as cell! alloc-tail-unit s (size? cell!) << 1
					_hashtable/put table key
				][
					val: key + 1
					if TYPE_OF(val) = TYPE_NONE [	;-- increase size of keys
						s: as series! table/value
						size: as int-ptr! s/offset
						size/value: size/value + 1
					]
				]
				copy-cell value key + 1
			]
		][
			either key = null [none-value][key + 1]
		]
	]

	;--- Reading actions ---

	pick: func [
		map		[red-hash!]
		index	[red-value!]
		boxed	[red-value!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/pick"]]

		eval-path map boxed null no
	]

	;--- Modifying actions ---

	insert: func [
		map		  [red-hash!]
		value	  [red-value!]
		part-arg  [red-value!]
		only?	  [logic!]
		dup-arg	  [red-value!]
		append?	  [logic!]
		return:	  [red-value!]
		/local
			src		[red-block!]
			cell	[red-value!]
			limit	[red-value!]
			int		[red-integer!]
			s		[series!]
			cnt		[integer!]
			part	[integer!]
			size	[integer!]
			table	[node!]
			key		[red-value!]
			val		[red-value!]
			psize	[int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/insert"]]

		if TYPE_OF(value) <> TYPE_BLOCK [
			fire [TO_ERROR(script invalid-arg) value]
		]

		part: -1

		if OPTION?(part-arg) [
			if TYPE_OF(part-arg) <> TYPE_INTEGER [
				fire [TO_ERROR(script invalid-arg) part-arg]
			]
			int: as red-integer! part-arg
			part: int/value * 2
		]

		src: as red-block! value
		size: block/rs-length? src
		if any [negative? part part > size][part: size] ;-- truncate if off-range part value
		if part % 2 > 0 [part: part - 1]

		s: GET_BUFFER(map)
		size: as-integer s/tail + part - s/offset
		if size > s/size [s: expand-series s size]

		s: GET_BUFFER(src)
		cell: s/offset + src/head
		limit: cell + part								;-- /part support

		table: map/table
		while [cell < limit][
			key: _hashtable/get table cell 0 0 yes no no
			value: cell + 1
			either TYPE_OF(value) = TYPE_NONE [			;-- delete key entry
				unless key = null [
					_hashtable/delete table key
				]
			][
				either key = null [
					s: as series! map/node/value
					key: copy-cell cell as cell! alloc-tail-unit s (size? cell!) << 1
					_hashtable/put table key
				][
					val: key + 1
					if TYPE_OF(val) = TYPE_NONE [		;-- increase size of keys
						s: as series! table/value
						psize: as int-ptr! s/offset
						psize/value: psize/value + 1
					]
				]
				copy-cell value key + 1
			]
			cell: cell + 2
		]
		as red-value! map
	]

	clear: func [
		map		[red-hash!]
		return:	[red-value!]
		/local
			s	[series!]
			value [red-value!]
			i     [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/clear"]]

		s: GET_BUFFER(map)
		i: 0
		while [
			value: s/offset + i
			value < s/tail
		][
			_hashtable/delete map/table value
			i: i + 2
		]
		as red-value! map
	]

	poke: func [
		map		[red-hash!]
		index	[red-value!]
		data	[red-value!]
		boxed	[red-value!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/poke"]]

		stack/set-last eval-path map boxed data no
	]

	;--- Property reading actions ---

	length?: func [
		map		[red-hash!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/length?"]]

		rs-length? map
	]

	;--- Navigation actions ---

	select: func [
		map		 [red-hash!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		return:	 [red-value!]
		/local
			table [node!]
			key   [red-value!]
	][
		table: map/table
		key: _hashtable/get table value 0 0 case? no no
		either key = null [none-value][key + 1]
	]

	;--- Misc actions ---

	copy: func [
		map	    	[red-hash!]
		new			[red-hash!]
		part-arg	[red-value!]
		deep?		[logic!]
		types		[red-value!]
		return:		[red-hash!]
	][
		#if debug? = yes [if verbose > 0 [print-line "map/copy"]]
		new: as red-hash! block/clone as red-block! map deep? no

		new/header: TYPE_MAP
		new/table: 	_hashtable/copy map/table new/node
		new
	]

	init: does [
		datatype/register [
			TYPE_MAP
			TYPE_VALUE
			"map!"
			;-- General actions --
			:make
			null			;random
			:reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			: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
			:clear
			:copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			:insert
			:length?
			null			;next
			:pick
			:poke
			null			;remove
			null			;reverse
			: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: added direct call to ***-dll-entry-point for JNI binding (until ELF emitter handles it).

Red/System [
	Title:   "JVM bridge"
	Author:  "Nenad Rakocevic, Kaj de Vos"
	File: 	 %JNI.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2013 Nenad Rakocevic, Kaj de Vos. 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 func-ptr!	integer!

#define jmethodID!	int-ptr!
#define jint!		integer!
#define jobject!	int-ptr!
#define jclass!		int-ptr!
#define jstring!	int-ptr!
#define jboolean!	int-ptr!

#define JNI-ptr!	[struct! [jni [JNI!]]]
#define JVM-ptr!	[struct! [ptr [JVM!]]]

#switch OS [
	Windows  [#define JNICALL stdcall]
	#default [#define JNICALL cdecl]
]

#define JNI_FALSE	#"^(00)"
#define JNI_TRUE  	#"^(01)"

#enum version! [
	version-1.1:	00010001h
	version-1.2:	00010002h
	version-1.4:	00010004h
	version-1.6:	00010006h
]

JVM!: alias struct! [
    reserved0					[int-ptr!]
    reserved1					[int-ptr!]
    reserved2					[int-ptr!]

    DestroyJavaVM 				[function! [[JNICALL] vm [JVM-ptr!] return: [jint!]]]
	AttachCurrentThread			[function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] args [byte-ptr!] return: [jint!]]]
	DetachCurrentThread 		[function! [[JNICALL] vm [JVM-ptr!] return: [jint!]]]
    GetEnv						[function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] version [integer!] return: [jint!]]]
    AttachCurrentThreadAsDaemon [function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] args [byte-ptr!] return: [jint!]]]
]

JNI!: alias struct! [
    reserved0					[int-ptr!]
    reserved1					[int-ptr!]
    reserved2					[int-ptr!]
    reserved3					[int-ptr!]

	GetVersion					[func-ptr!]
	DefineClass					[func-ptr!]
	FindClass					[function! [[JNICALL] env [JNI-ptr!] name [c-string!] return: [jclass!]]]
	FromReflectedMethod			[function! [[JNICALL] env [JNI-ptr!] method [jobject!] return: [jmethodID!]]]
	FromReflectedField			[func-ptr!]
	ToReflectedMethod			[func-ptr!]
	GetSuperclass				[func-ptr!]
	IsAssignableFrom			[func-ptr!]
	ToReflectedField			[func-ptr!]

	Throw						[func-ptr!]
	ThrowNew					[func-ptr!]
	ExceptionOccurred			[func-ptr!]
	ExceptionDescribe			[func-ptr!]
	ExceptionClear				[func-ptr!]
	FatalError					[func-ptr!]

	PushLocalFrame				[func-ptr!]
	PopLocalFrame				[func-ptr!]

	NewGlobalRef				[function! [[JNICALL] env [JNI-ptr!] obj [jobject!] return: [jobject!]]]
	DeleteGlobalRef				[function! [[JNICALL] env [JNI-ptr!] ref [jobject!]]]
	DeleteLocalRef				[function! [[JNICALL] env [JNI-ptr!] obj [jobject!]]]
	IsSameObject				[func-ptr!]
	NewLocalRef					[func-ptr!]
	EnsureLocalCapacity			[func-ptr!]

	AllocObject					[func-ptr!]
	NewObject					[function! [[JNICALL] return: [jobject!]]] ;-- stack frame is manually constructed
	NewObjectV					[func-ptr!]
	NewObjectA					[func-ptr!]

	GetObjectClass				[function! [[JNICALL] env [JNI-ptr!] obj [jobject!] return: [jclass!]]]
	IsInstanceOf				[func-ptr!]
	GetMethodID					[function! [[JNICALL] env [JNI-ptr!] class [jclass!] name [c-string!] sig [c-string!] return: [jmethodID!]]]

	CallObjectMethod			[function! [[JNICALL variadic] return: [jobject!]]]
	CallObjectMethodV			[func-ptr!]
	CallObjectMethodA			[func-ptr!]

	CallBooleanMethod			[func-ptr!]
	CallBooleanMethodV			[func-ptr!]
	CallBooleanMethodA			[func-ptr!]

	CallByteMethod				[func-ptr!]
	CallByteMethodV				[func-ptr!]
	CallByteMethodA				[func-ptr!]

	CallCharMethod				[func-ptr!]
	CallCharMethodV				[func-ptr!]
	CallCharMethodA				[func-ptr!]

	CallShortMethod				[func-ptr!]
	CallShortMethodV			[func-ptr!]
	CallShortMethodA			[func-ptr!]

	CallIntMethod				[func-ptr!]
	CallIntMethodV				[func-ptr!]
	CallIntMethodA				[func-ptr!]

	CallLongMethod				[func-ptr!]
	CallLongMethodV				[func-ptr!]
	CallLongMethodA				[func-ptr!]

	CallFloatMethod				[func-ptr!]
	CallFloatMethodV			[func-ptr!]
	CallFloatMethodA			[func-ptr!]

	CallDoubleMethod			[func-ptr!]
	CallDoubleMethodV			[func-ptr!]
	CallDoubleMethodA			[func-ptr!]

	CallVoidMethod				[func-ptr!]
	CallVoidMethodV				[func-ptr!]
	CallVoidMethodA				[func-ptr!]

	CallNonvirtualObjectMethod	[func-ptr!]
	CallNonvirtualObjectMethodV	[func-ptr!]
	CallNonvirtualObjectMethodA	[func-ptr!]

	CallNonvirtualBooleanMethod	 [func-ptr!]
	CallNonvirtualBooleanMethodV [func-ptr!]
	CallNonvirtualBooleanMethodA [func-ptr!]

	CallNonvirtualByteMethod	[func-ptr!]
	CallNonvirtualByteMethodV	[func-ptr!]
	CallNonvirtualByteMethodA	[func-ptr!]

	CallNonvirtualCharMethod	[func-ptr!]
	CallNonvirtualCharMethodV	[func-ptr!]
	CallNonvirtualCharMethodA	[func-ptr!]

	CallNonvirtualShortMethod	[func-ptr!]
	CallNonvirtualShortMethodV	[func-ptr!]
	CallNonvirtualShortMethodA	[func-ptr!]

	CallNonvirtualIntMethod		[func-ptr!]
	CallNonvirtualIntMethodV	[func-ptr!]
	CallNonvirtualIntMethodA	[func-ptr!]

	CallNonvirtualLongMethod	[func-ptr!]
	CallNonvirtualLongMethodV	[func-ptr!]
	CallNonvirtualLongMethodA	[func-ptr!]

	CallNonvirtualFloatMethod	[func-ptr!]
	CallNonvirtualFloatMethodV	[func-ptr!]
	CallNonvirtualFloatMethodA	[func-ptr!]

	CallNonvirtualDoubleMethod	[func-ptr!]
	CallNonvirtualDoubleMethodV	[func-ptr!]
	CallNonvirtualDoubleMethodA	[func-ptr!]

	CallNonvirtualVoidMethod	[func-ptr!]
	CallNonvirtualVoidMethodV	[func-ptr!]
	CallNonvirtualVoidMethodA	[func-ptr!]

	GetFieldID					[func-ptr!]
	GetObjectField				[func-ptr!]
	GetBooleanField				[func-ptr!]
	GetByteField				[func-ptr!]
	GetCharField				[func-ptr!]
	GetShortField				[func-ptr!]
	GetIntField					[func-ptr!]
	GetLongField				[func-ptr!]
	GetFloatField				[func-ptr!]
	GetDoubleField				[func-ptr!]

	SetObjectField				[func-ptr!]
	SetBooleanField				[func-ptr!]
	SetByteField				[func-ptr!]
	SetCharField				[func-ptr!]
	SetShortField				[func-ptr!]
	SetIntField					[func-ptr!]
	SetLongField				[func-ptr!]
	SetFloatField				[func-ptr!]
	SetDoubleField				[func-ptr!]

	GetStaticMethodID			[function! [[JNICALL] env [JNI-ptr!] class [jclass!] name [c-string!] sig [c-string!] return: [jmethodID!]]]

	CallStaticObjectMethod		[function! [[JNICALL variadic] return: [jobject!]]]
	CallStaticObjectMethodV		[func-ptr!]
	CallStaticObjectMethodA		[func-ptr!]

	CallStaticBooleanMethod		[func-ptr!]
	CallStaticBooleanMethodV	[func-ptr!]
	CallStaticBooleanMethodA	[func-ptr!]

	CallStaticByteMethod		[func-ptr!]
	CallStaticByteMethodV		[func-ptr!]
	CallStaticByteMethodA		[func-ptr!]

	CallStaticCharMethod		[func-ptr!]
	CallStaticCharMethodV		[func-ptr!]
	CallStaticCharMethodA		[func-ptr!]

	CallStaticShortMethod		[func-ptr!]
	CallStaticShortMethodV		[func-ptr!]
	CallStaticShortMethodA		[func-ptr!]

	CallStaticIntMethod			[func-ptr!]
	CallStaticIntMethodV		[func-ptr!]
	CallStaticIntMethodA		[func-ptr!]

	CallStaticLongMethod		[func-ptr!]
	CallStaticLongMethodV		[func-ptr!]
	CallStaticLongMethodA		[func-ptr!]

	CallStaticFloatMethod		[func-ptr!]
	CallStaticFloatMethodV		[func-ptr!]
	CallStaticFloatMethodA		[func-ptr!]

	CallStaticDoubleMethod		[func-ptr!]
	CallStaticDoubleMethodV		[func-ptr!]
	CallStaticDoubleMethodA		[func-ptr!]

	CallStaticVoidMethod		[func-ptr!]
	CallStaticVoidMethodV		[func-ptr!]
	CallStaticVoidMethodA		[func-ptr!]

	GetStaticFieldID			[func-ptr!]
	GetStaticObjectField		[func-ptr!]
	GetStaticBooleanField		[func-ptr!]
	GetStaticByteField			[func-ptr!]
	GetStaticCharField			[func-ptr!]
	GetStaticShortField			[func-ptr!]
	GetStaticIntField			[func-ptr!]
	GetStaticLongField			[func-ptr!]
	GetStaticFloatField			[func-ptr!]
	GetStaticDoubleField		[func-ptr!]

	SetStaticObjectField		[func-ptr!]
	SetStaticBooleanField		[func-ptr!]
	SetStaticByteField			[func-ptr!]
	SetStaticCharField			[func-ptr!]
	SetStaticShortField			[func-ptr!]
	SetStaticIntField			[func-ptr!]
	SetStaticLongField			[func-ptr!]
	SetStaticFloatField			[func-ptr!]
	SetStaticDoubleField		[func-ptr!]

	NewString					[func-ptr!]
	GetStringLength				[func-ptr!]
	GetStringChars				[func-ptr!]
	ReleaseStringChars			[func-ptr!]

	NewStringUTF				[function! [[JNICALL] env [JNI-ptr!] bytes [c-string!] return: [jobject!]]]
	GetStringUTFLength			[func-ptr!]
	GetStringUTFChars			[function! [[JNICALL] env [JNI-ptr!] str [jstring!] isCopy [struct! [c [jboolean!]]] return: [c-string!]]]
	ReleaseStringUTFChars		[function! [[JNICALL] env [JNI-ptr!] str [jstring!] buf [c-string!]]]

	GetArrayLength				[function! [[JNICALL] env [JNI-ptr!] array [jobject!] return: [jint!]]]
	NewObjectArray				[func-ptr!]
	GetObjectArrayElement		[function! [[JNICALL] env [JNI-ptr!] array [jobject!] idx [jint!] return: [jobject!]]]
	SetObjectArrayElement		[func-ptr!]
	;...
]

JNI-env!: alias JNI-ptr!

get-method: func [
	env		[JNI-env!]
	class	[jclass!]
	name	[c-string!]
	sig		[c-string!]
	return: [jmethodID!]
	/local
		id 	[jmethodID!]
][
	id: env/jni/GetMethodID env class name sig
	if null? id [print-line ["error: GetMethodID failed on " name sig]]
	id
]

get-static-method: func [
	env		[JNI-env!]
	class	[jclass!]
	name	[c-string!]
	sig		[c-string!]
	return: [jmethodID!]
	/local
		id 	[jmethodID!]
][
	id: env/jni/GetStaticMethodID env class name sig
	if null? id [print-line ["error: GetStaticMethodID failed on " name sig]]
	id
]

instantiate: func [
	[typed]
	count	[integer!]
	list	[typed-value!]
	return: [jobject!]
	/local
		env	  [JNI-env!]
		class [jclass!]
		id	  [jmethodID!]
		item  [typed-value!]
][
	env: as JNI-env! list/value
	list: list + 1
	class: as jclass! list/value
	list: list + 1
	id: get-method env class "<init>" as c-string! list/value
	list: list - 2

	while [count > 0][
		either count = 3 [
			push id										;-- replace sig by the constructor id
		][
			item: list + count - 1
			either item/type = type-c-string! [
				push env/jni/NewStringUTF env as c-string! item/value
			][
				push item/value
			]
		]
		count: count - 1
	]
	env/jni/NewObject
]

JNI_OnLoad: func [
	vm 		 [int-ptr!]
	reserved [byte-ptr!]
	return:  [integer!]
][
	#if OS <> 'Windows [***-dll-entry-point]			;@@ temporary workaround until ELF emitter handles it
	version-1.6
]

#export JNICALL [
	JNI_OnLoad
]

Red/System [
	Title:   "JVM bridge"
	Author:  "Nenad Rakocevic, Kaj de Vos"
	File: 	 %JNI.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2013 Nenad Rakocevic, Kaj de Vos. 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 func-ptr!	integer!

#define jmethodID!	int-ptr!
#define jint!		integer!
#define jobject!	int-ptr!
#define jclass!		int-ptr!
#define jstring!	int-ptr!
#define jboolean!	int-ptr!

#define JNI-ptr!	[struct! [jni [JNI!]]]
#define JVM-ptr!	[struct! [ptr [JVM!]]]

#switch OS [
	Windows  [#define JNICALL stdcall]
	#default [#define JNICALL cdecl]
]

#define JNI_FALSE	#"^(00)"
#define JNI_TRUE  	#"^(01)"

#enum version! [
	version-1.1:	00010001h
	version-1.2:	00010002h
	version-1.4:	00010004h
	version-1.6:	00010006h
]

JVM!: alias struct! [
    reserved0					[int-ptr!]
    reserved1					[int-ptr!]
    reserved2					[int-ptr!]

    DestroyJavaVM 				[function! [[JNICALL] vm [JVM-ptr!] return: [jint!]]]
	AttachCurrentThread			[function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] args [byte-ptr!] return: [jint!]]]
	DetachCurrentThread 		[function! [[JNICALL] vm [JVM-ptr!] return: [jint!]]]
    GetEnv						[function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] version [integer!] return: [jint!]]]
    AttachCurrentThreadAsDaemon [function! [[JNICALL] vm [JVM-ptr!] penv [struct! [p [int-ptr!]]] args [byte-ptr!] return: [jint!]]]
]

JNI!: alias struct! [
    reserved0					[int-ptr!]
    reserved1					[int-ptr!]
    reserved2					[int-ptr!]
    reserved3					[int-ptr!]

	GetVersion					[func-ptr!]
	DefineClass					[func-ptr!]
	FindClass					[function! [[JNICALL] env [JNI-ptr!] name [c-string!] return: [jclass!]]]
	FromReflectedMethod			[function! [[JNICALL] env [JNI-ptr!] method [jobject!] return: [jmethodID!]]]
	FromReflectedField			[func-ptr!]
	ToReflectedMethod			[func-ptr!]
	GetSuperclass				[func-ptr!]
	IsAssignableFrom			[func-ptr!]
	ToReflectedField			[func-ptr!]

	Throw						[func-ptr!]
	ThrowNew					[func-ptr!]
	ExceptionOccurred			[func-ptr!]
	ExceptionDescribe			[func-ptr!]
	ExceptionClear				[func-ptr!]
	FatalError					[func-ptr!]

	PushLocalFrame				[func-ptr!]
	PopLocalFrame				[func-ptr!]

	NewGlobalRef				[function! [[JNICALL] env [JNI-ptr!] obj [jobject!] return: [jobject!]]]
	DeleteGlobalRef				[function! [[JNICALL] env [JNI-ptr!] ref [jobject!]]]
	DeleteLocalRef				[function! [[JNICALL] env [JNI-ptr!] obj [jobject!]]]
	IsSameObject				[func-ptr!]
	NewLocalRef					[func-ptr!]
	EnsureLocalCapacity			[func-ptr!]

	AllocObject					[func-ptr!]
	NewObject					[function! [[JNICALL] return: [jobject!]]] ;-- stack frame is manually constructed
	NewObjectV					[func-ptr!]
	NewObjectA					[func-ptr!]

	GetObjectClass				[function! [[JNICALL] env [JNI-ptr!] obj [jobject!] return: [jclass!]]]
	IsInstanceOf				[func-ptr!]
	GetMethodID					[function! [[JNICALL] env [JNI-ptr!] class [jclass!] name [c-string!] sig [c-string!] return: [jmethodID!]]]

	CallObjectMethod			[function! [[JNICALL variadic] return: [jobject!]]]
	CallObjectMethodV			[func-ptr!]
	CallObjectMethodA			[func-ptr!]

	CallBooleanMethod			[func-ptr!]
	CallBooleanMethodV			[func-ptr!]
	CallBooleanMethodA			[func-ptr!]

	CallByteMethod				[func-ptr!]
	CallByteMethodV				[func-ptr!]
	CallByteMethodA				[func-ptr!]

	CallCharMethod				[func-ptr!]
	CallCharMethodV				[func-ptr!]
	CallCharMethodA				[func-ptr!]

	CallShortMethod				[func-ptr!]
	CallShortMethodV			[func-ptr!]
	CallShortMethodA			[func-ptr!]

	CallIntMethod				[func-ptr!]
	CallIntMethodV				[func-ptr!]
	CallIntMethodA				[func-ptr!]

	CallLongMethod				[func-ptr!]
	CallLongMethodV				[func-ptr!]
	CallLongMethodA				[func-ptr!]

	CallFloatMethod				[func-ptr!]
	CallFloatMethodV			[func-ptr!]
	CallFloatMethodA			[func-ptr!]

	CallDoubleMethod			[func-ptr!]
	CallDoubleMethodV			[func-ptr!]
	CallDoubleMethodA			[func-ptr!]

	CallVoidMethod				[func-ptr!]
	CallVoidMethodV				[func-ptr!]
	CallVoidMethodA				[func-ptr!]

	CallNonvirtualObjectMethod	[func-ptr!]
	CallNonvirtualObjectMethodV	[func-ptr!]
	CallNonvirtualObjectMethodA	[func-ptr!]

	CallNonvirtualBooleanMethod	 [func-ptr!]
	CallNonvirtualBooleanMethodV [func-ptr!]
	CallNonvirtualBooleanMethodA [func-ptr!]

	CallNonvirtualByteMethod	[func-ptr!]
	CallNonvirtualByteMethodV	[func-ptr!]
	CallNonvirtualByteMethodA	[func-ptr!]

	CallNonvirtualCharMethod	[func-ptr!]
	CallNonvirtualCharMethodV	[func-ptr!]
	CallNonvirtualCharMethodA	[func-ptr!]

	CallNonvirtualShortMethod	[func-ptr!]
	CallNonvirtualShortMethodV	[func-ptr!]
	CallNonvirtualShortMethodA	[func-ptr!]

	CallNonvirtualIntMethod		[func-ptr!]
	CallNonvirtualIntMethodV	[func-ptr!]
	CallNonvirtualIntMethodA	[func-ptr!]

	CallNonvirtualLongMethod	[func-ptr!]
	CallNonvirtualLongMethodV	[func-ptr!]
	CallNonvirtualLongMethodA	[func-ptr!]

	CallNonvirtualFloatMethod	[func-ptr!]
	CallNonvirtualFloatMethodV	[func-ptr!]
	CallNonvirtualFloatMethodA	[func-ptr!]

	CallNonvirtualDoubleMethod	[func-ptr!]
	CallNonvirtualDoubleMethodV	[func-ptr!]
	CallNonvirtualDoubleMethodA	[func-ptr!]

	CallNonvirtualVoidMethod	[func-ptr!]
	CallNonvirtualVoidMethodV	[func-ptr!]
	CallNonvirtualVoidMethodA	[func-ptr!]

	GetFieldID					[func-ptr!]
	GetObjectField				[func-ptr!]
	GetBooleanField				[func-ptr!]
	GetByteField				[func-ptr!]
	GetCharField				[func-ptr!]
	GetShortField				[func-ptr!]
	GetIntField					[func-ptr!]
	GetLongField				[func-ptr!]
	GetFloatField				[func-ptr!]
	GetDoubleField				[func-ptr!]

	SetObjectField				[func-ptr!]
	SetBooleanField				[func-ptr!]
	SetByteField				[func-ptr!]
	SetCharField				[func-ptr!]
	SetShortField				[func-ptr!]
	SetIntField					[func-ptr!]
	SetLongField				[func-ptr!]
	SetFloatField				[func-ptr!]
	SetDoubleField				[func-ptr!]

	GetStaticMethodID			[function! [[JNICALL] env [JNI-ptr!] class [jclass!] name [c-string!] sig [c-string!] return: [jmethodID!]]]

	CallStaticObjectMethod		[function! [[JNICALL variadic] return: [jobject!]]]
	CallStaticObjectMethodV		[func-ptr!]
	CallStaticObjectMethodA		[func-ptr!]

	CallStaticBooleanMethod		[func-ptr!]
	CallStaticBooleanMethodV	[func-ptr!]
	CallStaticBooleanMethodA	[func-ptr!]

	CallStaticByteMethod		[func-ptr!]
	CallStaticByteMethodV		[func-ptr!]
	CallStaticByteMethodA		[func-ptr!]

	CallStaticCharMethod		[func-ptr!]
	CallStaticCharMethodV		[func-ptr!]
	CallStaticCharMethodA		[func-ptr!]

	CallStaticShortMethod		[func-ptr!]
	CallStaticShortMethodV		[func-ptr!]
	CallStaticShortMethodA		[func-ptr!]

	CallStaticIntMethod			[func-ptr!]
	CallStaticIntMethodV		[func-ptr!]
	CallStaticIntMethodA		[func-ptr!]

	CallStaticLongMethod		[func-ptr!]
	CallStaticLongMethodV		[func-ptr!]
	CallStaticLongMethodA		[func-ptr!]

	CallStaticFloatMethod		[func-ptr!]
	CallStaticFloatMethodV		[func-ptr!]
	CallStaticFloatMethodA		[func-ptr!]

	CallStaticDoubleMethod		[func-ptr!]
	CallStaticDoubleMethodV		[func-ptr!]
	CallStaticDoubleMethodA		[func-ptr!]

	CallStaticVoidMethod		[func-ptr!]
	CallStaticVoidMethodV		[func-ptr!]
	CallStaticVoidMethodA		[func-ptr!]

	GetStaticFieldID			[func-ptr!]
	GetStaticObjectField		[func-ptr!]
	GetStaticBooleanField		[func-ptr!]
	GetStaticByteField			[func-ptr!]
	GetStaticCharField			[func-ptr!]
	GetStaticShortField			[func-ptr!]
	GetStaticIntField			[func-ptr!]
	GetStaticLongField			[func-ptr!]
	GetStaticFloatField			[func-ptr!]
	GetStaticDoubleField		[func-ptr!]

	SetStaticObjectField		[func-ptr!]
	SetStaticBooleanField		[func-ptr!]
	SetStaticByteField			[func-ptr!]
	SetStaticCharField			[func-ptr!]
	SetStaticShortField			[func-ptr!]
	SetStaticIntField			[func-ptr!]
	SetStaticLongField			[func-ptr!]
	SetStaticFloatField			[func-ptr!]
	SetStaticDoubleField		[func-ptr!]

	NewString					[func-ptr!]
	GetStringLength				[func-ptr!]
	GetStringChars				[func-ptr!]
	ReleaseStringChars			[func-ptr!]

	NewStringUTF				[function! [[JNICALL] env [JNI-ptr!] bytes [c-string!] return: [jobject!]]]
	GetStringUTFLength			[func-ptr!]
	GetStringUTFChars			[function! [[JNICALL] env [JNI-ptr!] str [jstring!] isCopy [struct! [c [jboolean!]]] return: [c-string!]]]
	ReleaseStringUTFChars		[function! [[JNICALL] env [JNI-ptr!] str [jstring!] buf [c-string!]]]

	GetArrayLength				[function! [[JNICALL] env [JNI-ptr!] array [jobject!] return: [jint!]]]
	NewObjectArray				[func-ptr!]
	GetObjectArrayElement		[function! [[JNICALL] env [JNI-ptr!] array [jobject!] idx [jint!] return: [jobject!]]]
	SetObjectArrayElement		[func-ptr!]
	;...
]

JNI-env!: alias JNI-ptr!

get-method: func [
	env		[JNI-env!]
	class	[jclass!]
	name	[c-string!]
	sig		[c-string!]
	return: [jmethodID!]
	/local
		id 	[jmethodID!]
][
	id: env/jni/GetMethodID env class name sig
	if null? id [print-line ["error: GetMethodID failed on " name sig]]
	id
]

get-static-method: func [
	env		[JNI-env!]
	class	[jclass!]
	name	[c-string!]
	sig		[c-string!]
	return: [jmethodID!]
	/local
		id 	[jmethodID!]
][
	id: env/jni/GetStaticMethodID env class name sig
	if null? id [print-line ["error: GetStaticMethodID failed on " name sig]]
	id
]

instantiate: func [
	[typed]
	count	[integer!]
	list	[typed-value!]
	return: [jobject!]
	/local
		env	  [JNI-env!]
		class [jclass!]
		id	  [jmethodID!]
		item  [typed-value!]
][
	env: as JNI-env! list/value
	list: list + 1
	class: as jclass! list/value
	list: list + 1
	id: get-method env class "<init>" as c-string! list/value
	list: list - 2

	while [count > 0][
		either count = 3 [
			push id										;-- replace sig by the constructor id
		][
			item: list + count - 1
			either item/type = type-c-string! [
				push env/jni/NewStringUTF env as c-string! item/value
			][
				push item/value
			]
		]
		count: count - 1
	]
	env/jni/NewObject
]

JNI_OnLoad: func [
	vm 		 [int-ptr!]
	reserved [byte-ptr!]
	return:  [integer!]
][
	version-1.6
]

#export JNICALL [
	JNI_OnLoad
]


Revert "FIX: Use Editline (libedit) instead of Readline (libreadline)"

This reverts commit dc01a5c792d685d1ede71140456ee95cff69b295.

Rollback to using GNU Readline until we have an alternative that
reliably works cross-platform.

Red [
	Title:	"Red console"
	Author: ["Nenad Rakocevic" "Kaj de Vos"]
	File: 	%console.red
	Tabs: 	4
	Rights: "Copyright (C) 2012-2013 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
	}
]

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				ReadConsole: 	 "ReadConsoleW" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
		line-buffer-size: 15 * 1024
		line-buffer: allocate line-buffer-size * 2 + 1
	][
		#switch OS [
			MacOSX [
				#define ReadLine-library "libreadline.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
				rl-bind-key: "rl_bind_key" [
					key				[integer!]
					command			[integer!]
					return:			[integer!]
				]
				rl-insert:	 "rl_insert" [
					count			[integer!]
					key				[integer!]
					return:			[integer!]
				]
			]
			#if OS <> 'MacOSX [
				History-library cdecl [
					add-history: "add_history" [  ; Add line to the history.
						line		[c-string!]
					]
				]
			]
		]

		rl-insert-wrapper: func [
			[cdecl]
			count   [integer!]
			key	    [integer!]
			return: [integer!]
		][
			rl-insert count key
		]
	]
]

ask: routine [
	prompt [string!]
	/local
		len ret str buffer line pos
][
	#either OS = 'Windows [
		print as c-string! string/rs-head prompt
		len: 0
		ret: ReadConsole stdin line-buffer line-buffer-size :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		pos: (len * 2) - 3								;-- position at lower 8bits of CR character
		line-buffer/pos: null-byte						;-- overwrite CR with NUL
		str: string/load as-c-string line-buffer len - 1 UTF-16LE
	][
		line: read-line as-c-string string/rs-head prompt
		if line = null [halt]  ; EOF

		 #if OS <> 'MacOSX [add-history line]

		str: string/load line  1 + length? line UTF-8
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

input: func [][
	ask ""
]

Red [
	Title:	"Red console"
	Author: ["Nenad Rakocevic" "Kaj de Vos"]
	File: 	%console.red
	Tabs: 	4
	Rights: "Copyright (C) 2012-2013 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
	}
]

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				ReadConsole: 	 "ReadConsoleW" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
		line-buffer-size: 15 * 1024
		line-buffer: allocate line-buffer-size * 2 + 1
	][
		#switch OS [
			MacOSX [
				#define Edit-library "libedit.dylib"
			]
			#default [
				#define Edit-library "libedit.so.2"
			]
		]
		#import [
			Edit-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
				rl-bind-key: "rl_bind_key" [
					key				[integer!]
					command			[integer!]
					return:			[integer!]
				]
				rl-insert:	 "rl_insert" [
					count			[integer!]
					key				[integer!]
					return:			[integer!]
				]
				add-history: "add_history" [  ; Add line to the history.
					line			[c-string!]
				]
			]
		]

		rl-insert-wrapper: func [
			[cdecl]
			count   [integer!]
			key	    [integer!]
			return: [integer!]
		][
			rl-insert count key
		]
	]
]

ask: routine [
	prompt [string!]
	/local
		len ret str buffer line pos
][
	#either OS = 'Windows [
		print as c-string! string/rs-head prompt
		len: 0
		ret: ReadConsole stdin line-buffer line-buffer-size :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		pos: (len * 2) - 3								;-- position at lower 8bits of CR character
		line-buffer/pos: null-byte						;-- overwrite CR with NUL
		str: string/load as-c-string line-buffer len - 1 UTF-16LE
	][
		line: read-line as-c-string string/rs-head prompt
		if line = null [halt]  ; EOF

		add-history line

		str: string/load line  1 + length? line UTF-8
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

input: func [][
	ask ""
]