FEAT: added 'debug-symbols function for debugging the symbol table.

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

;-------------------------------------------
;-- Memory stats
;-------------------------------------------
memory-info: func [
	blk		[red-block!]
	verbose [integer!]						;-- stat verbosity level (1, 2 or 3)
	/local
		n-frame s-frame b-frame free-nodes base list nodes series bigs
][
	assert all [1 <= verbose verbose <= 3]

;-- Node frames stats --
	nodes: block/make-in blk 8
	n-frame: memory/n-head

	while [n-frame <> null][
		if verbose >= 2 [
			free-nodes: (as-integer (n-frame/top - n-frame/bottom) + 1) / 4
			list: block/make-in nodes 8
			integer/load-in list n-frame/nodes - free-nodes
			integer/load-in list free-nodes
			integer/load-in list n-frame/nodes
		]
		n-frame: n-frame/next
	]

;-- Series frames stats --
	series: block/make-in blk 8
	s-frame: memory/s-head

	while [s-frame <> null][
		if verbose >= 2 [
			base: (as byte-ptr! s-frame) + size? series-frame!
			list: block/make-in series 8
			integer/load-in list as-integer s-frame/tail - as byte-ptr! s-frame/heap
			integer/load-in list as-integer (as byte-ptr! s-frame/heap) - base
			integer/load-in list  as-integer s-frame/tail - base
		]
		s-frame: s-frame/next
	]

;-- Big frames stats --
	bigs: block/make-in blk 8
	b-frame: memory/b-head

	while [b-frame <> null][
		if verbose >= 2 [
			integer/load-in bigs b-frame/size
		]
		b-frame: b-frame/next
	]
]

;===========================================
;== Debugging functions
;===========================================

#if debug? = yes [

	dump-globals: func [
		/local sym-table val-table len s symbol value w sym val syms i
	][
		sym-table: global-ctx/symbols
		val-table: global-ctx/values

		s: as series! sym-table/value
		len: (as-integer s/tail - s/offset) >> 4
		symbol: s/offset

		s: as series! val-table/value
		value: s/offset

		s: GET_BUFFER(symbols)
		syms: as red-symbol! s/offset

		print-line "Global Context"
		print-line "--------------"
		i: 0
		until [
			w: as red-word! symbol + i
			sym: syms + w/symbol - 1
			val: value + i
			print-line [i ", " w/symbol "/" sym/alias ": " sym/cache "^- : " TYPE_OF(val)]
			i: i + 1
			i + 1 = len
		]
	]

	dump-symbols: func [
		/local tail s i qym
	][
		s: GET_BUFFER(symbols)
		sym: as red-symbol! s/offset
		tail: as red-symbol! s/tail

		print-line "Symbol Table"
		print-line "--------------"
		i: 0
		until [
			print-line [i "/" sym/alias ": " sym/cache]
			sym: sym + 1
			i: i + 1
			sym = tail
		]
	]

	;-------------------------------------------
	;-- Print usage stats about a given frame
	;-------------------------------------------
	frame-stats: func [
		free	[integer!]
		used	[integer!]
		total	[integer!]
		/local percent
	][
		assert free + used = total
		percent: 100 * used / total
		if all [not zero? used zero? percent][percent: 1]

		print [
			"used = " used "/" total " ("  percent "%), "
			"free = " free "/" total " (" 100 - percent "%)" lf
		]
	]

	;-------------------------------------------
	;-- List series buffer allocated in a given series frame
	;-------------------------------------------
	list-series-buffers: func [
		frame	[series-frame!]
		/local series alt? size block count head tail
	][
		count: 1
		series: as series-buffer! (as byte-ptr! frame) + size? series-frame!
		until [
			head: as-integer ((as byte-ptr! series/offset) - (as byte-ptr! series) - size? series-buffer!)
			tail: as-integer ((as byte-ptr! series/tail) - (as byte-ptr! series) - size? series-buffer!)
			print [
				" - " series
				": size = "	series/size
				", offset pos = " head ", tail pos = " tail
				"    "
			]
			if series/flags and flag-ins-head <> 0 [print "H"]
			if series/flags and flag-ins-tail <> 0 [print "T"]
			print lf
			count: count + 1

			series: as series-buffer! (as byte-ptr! series) + series/size + size? series-buffer!
			series >= frame/heap
		]
		assert series = frame/heap
	]

	;-------------------------------------------
	;-- Displays total frames count
	;-------------------------------------------
	print-frames-count: func [count [integer!] /local s][
		s: either count > 1 ["s^/"][newline]
		print ["^/    " count " frame" s lf]
	]

	;-------------------------------------------
	;-- Dump memory statistics on screen
	;-------------------------------------------
	memory-stats: func [
		verbose [integer!]						;-- stat verbosity level (1, 2 or 3)
		/local count n-frame s-frame b-frame free-nodes base
	][
		assert all [1 <= verbose verbose <= 3]

		print [lf "====== Red Memory Stats ======" lf]

	;-- Node frames stats --
		count: 0
		n-frame: memory/n-head

		print [lf "-- Node frames --" lf]
		while [n-frame <> null][
			if verbose >= 2 [
				print ["#" count + 1 ": "]
				free-nodes: (as-integer (n-frame/top - n-frame/bottom) + 1) / 4
				frame-stats
					free-nodes
					n-frame/nodes - free-nodes
					n-frame/nodes
			]
			count: count + 1
			n-frame: n-frame/next
		]
		print-frames-count count

	;-- Series frames stats --
		count: 0
		s-frame: memory/s-head

		print ["-- Series frames --" lf]
		while [s-frame <> null][
			if verbose >= 2 [
				print ["#" count + 1 ": "]
				base: (as byte-ptr! s-frame) + size? series-frame!
				frame-stats
					as-integer s-frame/tail - as byte-ptr! s-frame/heap
					as-integer (as byte-ptr! s-frame/heap) - base
					as-integer s-frame/tail - base
				if verbose >= 3 [
					list-series-buffers s-frame
				]
			]
			count: count + 1
			s-frame: s-frame/next
		]
		print-frames-count count

	;-- Big frames stats --
		count: 0
		b-frame: memory/b-head

		print ["-- Big frames --" lf]
		while [b-frame <> null][
			if verbose >= 2 [
				print ["#" count + 1 ": "]
				prin-int b-frame/size
			]
			count: count + 1
			b-frame: b-frame/next
		]
		print-frames-count count

		print [
			"Total memory used: " memory/total " bytes" lf
			"==============================" lf
		]
	]

	;-------------------------------------------
	;-- Dump memory layout of a given series frame
	;-------------------------------------------
	dump-series-frame: func [
		frame	[series-frame!]
		/local series alt? size block
	][
		series: as series-buffer! (as byte-ptr! frame) + size? series-frame!

		print [lf "=== Series layout for frame: <" frame "h>" lf]

		alt?: no
		until [
			block: either zero? (series/flags and series-in-use) [
				"."
			][
				alt?: not alt?
				either alt? ["x"]["o"]
			]

			size: series/size / 16
			until [
				print block
				size: size - 1
				zero? size
			]

			series: as series-buffer! (as byte-ptr! series) + series/size + size? series-buffer!
			series >= frame/heap
		]
		assert series = frame/heap
		print lf
	]

]

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

;-------------------------------------------
;-- Memory stats
;-------------------------------------------
memory-info: func [
	blk		[red-block!]
	verbose [integer!]						;-- stat verbosity level (1, 2 or 3)
	/local
		n-frame s-frame b-frame free-nodes base list nodes series bigs
][
	assert all [1 <= verbose verbose <= 3]

;-- Node frames stats --
	nodes: block/make-in blk 8
	n-frame: memory/n-head

	while [n-frame <> null][
		if verbose >= 2 [
			free-nodes: (as-integer (n-frame/top - n-frame/bottom) + 1) / 4
			list: block/make-in nodes 8
			integer/load-in list n-frame/nodes - free-nodes
			integer/load-in list free-nodes
			integer/load-in list n-frame/nodes
		]
		n-frame: n-frame/next
	]

;-- Series frames stats --
	series: block/make-in blk 8
	s-frame: memory/s-head

	while [s-frame <> null][
		if verbose >= 2 [
			base: (as byte-ptr! s-frame) + size? series-frame!
			list: block/make-in series 8
			integer/load-in list as-integer s-frame/tail - as byte-ptr! s-frame/heap
			integer/load-in list as-integer (as byte-ptr! s-frame/heap) - base
			integer/load-in list  as-integer s-frame/tail - base
		]
		s-frame: s-frame/next
	]

;-- Big frames stats --
	bigs: block/make-in blk 8
	b-frame: memory/b-head

	while [b-frame <> null][
		if verbose >= 2 [
			integer/load-in bigs b-frame/size
		]
		b-frame: b-frame/next
	]
]

;===========================================
;== Debugging functions
;===========================================

#if debug? = yes [

	dump-globals: func [
		/local sym-table val-table len s symbol value w sym val syms i
	][
		sym-table: global-ctx/symbols
		val-table: global-ctx/values

		s: as series! sym-table/value
		len: (as-integer s/tail - s/offset) >> 4
		symbol: s/offset

		s: as series! val-table/value
		value: s/offset

		s: GET_BUFFER(symbols)
		syms: as red-symbol! s/offset

		print-line "Global Context"
		print-line "--------------"
		i: 0
		until [
			w: as red-word! symbol + i
			sym: syms + w/symbol - 1
			val: value + i
			print-line [i ": " sym/cache "^- : " TYPE_OF(val)]
			i: i + 1
			i + 1 = len
		]
	]

	;-------------------------------------------
	;-- Print usage stats about a given frame
	;-------------------------------------------
	frame-stats: func [
		free	[integer!]
		used	[integer!]
		total	[integer!]
		/local percent
	][
		assert free + used = total
		percent: 100 * used / total
		if all [not zero? used zero? percent][percent: 1]

		print [
			"used = " used "/" total " ("  percent "%), "
			"free = " free "/" total " (" 100 - percent "%)" lf
		]
	]

	;-------------------------------------------
	;-- List series buffer allocated in a given series frame
	;-------------------------------------------
	list-series-buffers: func [
		frame	[series-frame!]
		/local series alt? size block count head tail
	][
		count: 1
		series: as series-buffer! (as byte-ptr! frame) + size? series-frame!
		until [
			head: as-integer ((as byte-ptr! series/offset) - (as byte-ptr! series) - size? series-buffer!)
			tail: as-integer ((as byte-ptr! series/tail) - (as byte-ptr! series) - size? series-buffer!)
			print [
				" - " series
				": size = "	series/size
				", offset pos = " head ", tail pos = " tail
				"    "
			]
			if series/flags and flag-ins-head <> 0 [print "H"]
			if series/flags and flag-ins-tail <> 0 [print "T"]
			print lf
			count: count + 1

			series: as series-buffer! (as byte-ptr! series) + series/size + size? series-buffer!
			series >= frame/heap
		]
		assert series = frame/heap
	]

	;-------------------------------------------
	;-- Displays total frames count
	;-------------------------------------------
	print-frames-count: func [count [integer!] /local s][
		s: either count > 1 ["s^/"][newline]
		print ["^/    " count " frame" s lf]
	]

	;-------------------------------------------
	;-- Dump memory statistics on screen
	;-------------------------------------------
	memory-stats: func [
		verbose [integer!]						;-- stat verbosity level (1, 2 or 3)
		/local count n-frame s-frame b-frame free-nodes base
	][
		assert all [1 <= verbose verbose <= 3]

		print [lf "====== Red Memory Stats ======" lf]

	;-- Node frames stats --
		count: 0
		n-frame: memory/n-head

		print [lf "-- Node frames --" lf]
		while [n-frame <> null][
			if verbose >= 2 [
				print ["#" count + 1 ": "]
				free-nodes: (as-integer (n-frame/top - n-frame/bottom) + 1) / 4
				frame-stats
					free-nodes
					n-frame/nodes - free-nodes
					n-frame/nodes
			]
			count: count + 1
			n-frame: n-frame/next
		]
		print-frames-count count

	;-- Series frames stats --
		count: 0
		s-frame: memory/s-head

		print ["-- Series frames --" lf]
		while [s-frame <> null][
			if verbose >= 2 [
				print ["#" count + 1 ": "]
				base: (as byte-ptr! s-frame) + size? series-frame!
				frame-stats
					as-integer s-frame/tail - as byte-ptr! s-frame/heap
					as-integer (as byte-ptr! s-frame/heap) - base
					as-integer s-frame/tail - base
				if verbose >= 3 [
					list-series-buffers s-frame
				]
			]
			count: count + 1
			s-frame: s-frame/next
		]
		print-frames-count count

	;-- Big frames stats --
		count: 0
		b-frame: memory/b-head

		print ["-- Big frames --" lf]
		while [b-frame <> null][
			if verbose >= 2 [
				print ["#" count + 1 ": "]
				prin-int b-frame/size
			]
			count: count + 1
			b-frame: b-frame/next
		]
		print-frames-count count

		print [
			"Total memory used: " memory/total " bytes" lf
			"==============================" lf
		]
	]

	;-------------------------------------------
	;-- Dump memory layout of a given series frame
	;-------------------------------------------
	dump-series-frame: func [
		frame	[series-frame!]
		/local series alt? size block
	][
		series: as series-buffer! (as byte-ptr! frame) + size? series-frame!

		print [lf "=== Series layout for frame: <" frame "h>" lf]

		alt?: no
		until [
			block: either zero? (series/flags and series-in-use) [
				"."
			][
				alt?: not alt?
				either alt? ["x"]["o"]
			]

			size: series/size / 16
			until [
				print block
				size: size - 1
				zero? size
			]

			series: as series-buffer! (as byte-ptr! series) + series/size + size? series-buffer!
			series >= frame/heap
		]
		assert series = frame/heap
		print lf
	]

]


FEAT: deep copy key in map when key is any-string

Red/System [
	Title:	"A Hash Table Implementation"
	Author: "Xie Qingtian"
	File: 	%hashtable.reds
	Tabs:	4
	Rights: "Copyright (C) 2014-2015 Xie Qingtian. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
	Notes: {
		Algorithm: Open addressing, quadratic probing.
	}
]

#define HASH_TABLE_HASH		0
#define HASH_TABLE_MAP		1
#define HASH_TABLE_SYMBOL	2

#define _HT_HASH_UPPER		0.77

#define _BUCKET_IS_EMPTY(flags i s)			[flags/i >> s and 2 = 2]
#define _BUCKET_IS_NOT_EMPTY(flags i s)		[flags/i >> s and 2 <> 2]
#define _BUCKET_IS_DEL(flags i s)			[flags/i >> s and 1 = 1]
#define _BUCKET_IS_NOT_DEL(flags i s)		[flags/i >> s and 1 <> 1]
#define _BUCKET_IS_EITHER(flags i s)		[flags/i >> s and 3 > 0]
#define _BUCKET_IS_CLEARED(flags i s)		[flags/i >> s and 3 = 0]
#define _BUCKET_SET_DEL_TRUE(flags i s)		[flags/i: 1 << s or flags/i]
#define _BUCKET_SET_DEL_FALSE(flags i s)	[flags/i: (not 1 << s) and flags/i]
#define _BUCKET_SET_EMPTY_FALSE(flags i s)	[flags/i: (not 2 << s) and flags/i]
#define _BUCKET_SET_BOTH_FALSE(flags i s)	[flags/i: (not 3 << s) and flags/i]

#define _HT_CAL_FLAG_INDEX(i idx shift) [
	idx: i >> 4 + 1
	shift: i and 0Fh << 1
]

#define MURMUR_HASH_3_X86_32_C1		CC9E2D51h
#define MURMUR_HASH_3_X86_32_C2		1B873593h

#define MURMUR_HASH_ROTL_32(x r) [
	x << r or (x >>> (32 - r))
]

hash-string: func [
	str		[red-string!]
	case?	[logic!]
	return: [integer!]
	/local series s unit p p4 k1 h1 tail len head
][
	s: GET_BUFFER(str)
	unit: GET_UNIT(s)
	head: either TYPE_OF(str) = TYPE_SYMBOL [0][str/head]
	p: (as byte-ptr! s/offset) + (head << (unit >> 1))
	tail: as byte-ptr! s/tail
	len: (as-integer tail - p) >> (unit >> 1) << 2
	h1: 42								;-- seed

	;-- body
	while [p < tail][
		k1: switch unit [
			Latin1 [as-integer p/value]
			UCS-2  [(as-integer p/2) << 8 + p/1]
			UCS-4  [p4: as int-ptr! p p4/value]
		]
		unless case? [k1: case-folding/folding-case k1 yes]
		k1: k1 * MURMUR_HASH_3_X86_32_C1
		k1: MURMUR_HASH_ROTL_32(k1 15)
		k1: k1 * MURMUR_HASH_3_X86_32_C2

		h1: h1 xor k1
		h1: MURMUR_HASH_ROTL_32(h1 13)
		h1: h1 * 5 + E6546B64h
		p: p + unit
	]

	;-- finalization
	h1: h1 xor len
	h1: h1 >>> 16 xor h1
	h1: h1 * 85EBCA6Bh
	h1: h1 >>> 13 xor h1
	h1: h1 * C2B2AE35h
	h1: h1 >>> 16 xor h1
	h1
]

murmur3-x86-32: func [
	key		[byte-ptr!]
	len		[integer!]
	return: [integer!]
	/local data nblocks blocks p i k1 h1 tail n
][
	assert len > 0

	data: key
	nblocks: len / 4
	h1: 42								;-- seed

	;-- body
	blocks: as int-ptr! (data + (nblocks * 4))
	i: negate nblocks
	while [negative? i][
		p: blocks + i
		k1: p/value						;@@ do endian-swapping if needed
		k1: k1 * MURMUR_HASH_3_X86_32_C1
		k1: MURMUR_HASH_ROTL_32(k1 15)
		k1: k1 * MURMUR_HASH_3_X86_32_C2

		h1: h1 xor k1
		h1: MURMUR_HASH_ROTL_32(h1 13)
		h1: h1 * 5 + E6546B64h
		i: i + 1
	]

	;-- tail
	n: len and 3
	if positive? n [
		k1: 0
		tail: data + (nblocks * 4)
		if n = 3 [k1: (as-integer tail/3) << 16 xor k1]
		if n > 1 [k1: (as-integer tail/2) << 8  xor k1]
		k1: (as-integer tail/1) xor k1
		k1: k1 * MURMUR_HASH_3_X86_32_C1
		k1: MURMUR_HASH_ROTL_32(k1 15)
		k1: k1 * MURMUR_HASH_3_X86_32_C2
		h1: h1 xor k1
	]

	;-- finalization
	h1: h1 xor len
	h1: h1 >>> 16 xor h1
	h1: h1 * 85EBCA6Bh
	h1: h1 >>> 13 xor h1
	h1: h1 * C2B2AE35h
	h1: h1 >>> 16 xor h1
	h1
]

_hashtable: context [
	#enum hashtable-type! [
		HASH_TABLE_HASH
		HASH_TABLE_MAP
		HASH_TABLE_SYMBOL
	]
	hashtable!: alias struct! [
		size		[integer!]
		indexes		[node!]
		flags		[node!]
		keys		[node!]
		blk			[node!]
		n-occupied	[integer!]
		n-buckets	[integer!]
		upper-bound	[integer!]
		type		[integer!]
	]

	round-up: func [
		n		[integer!]
		return: [integer!]
	][
		n: n - 1
		n: n >> 1 or n
		n: n >> 2 or n
		n: n >> 4 or n
		n: n >> 8 or n
		n: n >> 16 or n
		n + 1
	]

	hash-value?: func [
		key		[red-value!]
		return:	[logic!]
	][
		switch TYPE_OF(key) [
			TYPE_WORD
			TYPE_SYMBOL
			TYPE_STRING
			TYPE_INTEGER
			TYPE_FILE
			TYPE_URL
			TYPE_CHAR
			TYPE_FLOAT
			TYPE_SET_WORD
			TYPE_LIT_WORD
			TYPE_GET_WORD
			TYPE_REFINEMENT
			TYPE_ISSUE
			TYPE_POINT
			TYPE_DATATYPE
			TYPE_PERCENT
			TYPE_TUPLE [true]
			default    [false]
		]
	]

	hash-value: func [
		key		[red-value!]
		case?	[logic!]
		return: [integer!]
		/local sym s
	][
		switch TYPE_OF(key) [
			TYPE_SYMBOL
			TYPE_STRING
			TYPE_FILE
			TYPE_URL   [
				hash-string as red-string! key case?
			]
			TYPE_CHAR
			TYPE_INTEGER [key/data2]
			TYPE_FLOAT
			TYPE_PERCENT [
				murmur3-x86-32 (as byte-ptr! key) + 8 8
			]
			TYPE_WORD
			TYPE_SET_WORD
			TYPE_LIT_WORD
			TYPE_GET_WORD
			TYPE_REFINEMENT
			TYPE_ISSUE [
				s: GET_BUFFER(symbols)
				sym: as red-string! s/offset + key/data2 - 1
				hash-string sym case?
			]
			TYPE_POINT
			TYPE_TYPESET [
				murmur3-x86-32 (as byte-ptr! key) + 4 12
			]
			TYPE_TUPLE [
				murmur3-x86-32 (as byte-ptr! key) + 4 TUPLE_SIZE(key)
			]
			TYPE_DATATYPE
			TYPE_LOGIC [key/data1]
			TYPE_ACTION
			TYPE_NATIVE
			TYPE_OP [key/data3]
			default [0]
		]
	]

	put-all: func [
		node	[node!]
		head	[integer!]
		skip	[integer!]
		/local s h i end value key val
	][
		s: as series! node/value
		h: as hashtable! s/offset

		s: as series! h/blk/value
		end: s/tail
		i: head
		while [
			value: s/offset + i
			value < end
		][
			either h/type = HASH_TABLE_MAP [
				key: get node value 0 0 yes no no
				either key = null [
					if null = put node value [
						fire [TO_ERROR(script invalid-type) datatype/push TYPE_OF(value)]
					]
				][
					copy-cell value + 1 key + 1
					move-memory
						as byte-ptr! value
						as byte-ptr! value + 2
						as-integer s/tail - (value + 2)
					s/tail: s/tail - 2
					end: s/tail
					i: i - skip
				]
			][
				put node value
			]
			i: i + skip
		]
	]

	init: func [
		size	[integer!]
		blk		[red-block!]
		type	[integer!]
		return: [node!]
		/local node s ss h f-buckets fsize i value skip end
	][
		node: alloc-bytes-filled size? hashtable! #"^(00)"
		s: as series! node/value
		h: as hashtable! s/offset
		h/type: type

		if size < 3 [size: 3]
		fsize: integer/to-float size
		f-buckets: fsize / _HT_HASH_UPPER
		skip: either type = HASH_TABLE_MAP [2][1]
		h/n-buckets: round-up float/to-integer f-buckets
		f-buckets: integer/to-float h/n-buckets
		h/upper-bound: float/to-integer f-buckets * _HT_HASH_UPPER
		h/flags: alloc-bytes-filled h/n-buckets >> 2 #"^(AA)"
		h/keys: alloc-bytes h/n-buckets * size? int-ptr!

		either blk = null [
			h/blk: alloc-cells size
		][
			h/blk: blk/node

			s: GET_BUFFER(blk)
			end: s/tail
			if type = HASH_TABLE_HASH [
				h/indexes: alloc-bytes-filled size * size? integer! #"^(FF)"
				i: (as-integer (end - s/offset)) >> 4 - blk/head
				ss: as series! h/indexes/value
				ss/tail: as cell! (as int-ptr! ss/tail) + i
			]
			put-all node blk/head skip
		]
		node
	]

	resize: func [
		node			[node!]
		new-buckets		[integer!]
		/local
			s h x k v i j site last mask step keys vals hash n-buckets blk
			new-size tmp break? flags new-flags new-flags-node ii sh f idx
			type
	][
		s: as series! node/value
		h: as hashtable! s/offset
		type: h/type
		s: as series! h/blk/value
		blk: s/offset
		s: as series! h/flags/value
		flags: as int-ptr! s/offset
		n-buckets: h/n-buckets
		j: 0
		new-buckets: round-up new-buckets
		f: integer/to-float new-buckets
		new-size: float/to-integer f * _HT_HASH_UPPER
		if new-buckets < 4 [new-buckets: 4]
		either h/size >= new-size [j: 1][
			new-flags-node: alloc-bytes-filled new-buckets >> 2 #"^(AA)"
			s: as series! new-flags-node/value
			new-flags: as int-ptr! s/offset
			if n-buckets < new-buckets [
				expand-series as series! h/keys/value new-buckets * size? int-ptr!
			]
		]
		if zero? j [
			s: as series! h/keys/value
			keys: as int-ptr! s/offset
			until [
				_HT_CAL_FLAG_INDEX(j ii sh)
				j: j + 1
				if _BUCKET_IS_CLEARED(flags ii sh) [
					idx: keys/j
					mask: new-buckets - 1
					_BUCKET_SET_DEL_TRUE(flags ii sh)
					break?: no
					until [									;-- kick-out process
						step: 0
						k: blk + (idx and 7FFFFFFFh)
						hash: hash-value k no
						i: hash and mask
						_HT_CAL_FLAG_INDEX(i ii sh)
						while [_BUCKET_IS_NOT_EMPTY(new-flags ii sh)][
							step: step + 1
							i: i + step and mask
							_HT_CAL_FLAG_INDEX(i ii sh)
						]
						i: i + 1
						_BUCKET_SET_EMPTY_FALSE(new-flags ii sh)
						either all [
							i <= n-buckets
							_BUCKET_IS_CLEARED(flags ii sh)
						][
							tmp: keys/i keys/i: idx idx: tmp
							_BUCKET_SET_DEL_TRUE(flags ii sh)
						][
							keys/i: idx
							break?: yes
						]
						break?
					]
				]
				j = n-buckets
			]
			;@@ if h/n-buckets > new-buckets []			;-- shrink the hash table
			free-series memory/s-head h/flags
			h/flags: new-flags-node
			h/n-buckets: new-buckets
			h/n-occupied: h/size
			h/upper-bound: new-size
		]
	]

	put: func [
		node	[node!]
		key 	[red-value!]
		return: [red-value!]
		/local
			s h x i site last mask step keys hash n-buckets flags op
			ii sh continue? blk idx type del? indexes end ss k
	][
		s: as series! node/value
		h: as hashtable! s/offset
		type: h/type
		if all [
			type <> HASH_TABLE_SYMBOL
			not hash-value? key
		][return null]

		if h/n-occupied >= h/upper-bound [			;-- update the hash table
			n-buckets: h/n-buckets + either h/n-buckets > (h/size << 1) [-1][1]
			resize node n-buckets
		]

		s: as series! h/blk/value
		idx: (as-integer (key - s/offset)) >> 4
		blk: s/offset

		either type = HASH_TABLE_HASH [
			ss: as series! h/indexes/value
			indexes: as int-ptr! ss/offset
		][
			if type = HASH_TABLE_MAP [
				x: TYPE_OF(key)
				switch x [
					TYPE_WORD
					TYPE_GET_WORD
					TYPE_SET_WORD
					TYPE_LIT_WORD
					TYPE_REFINEMENT
					TYPE_ISSUE	[set-type key TYPE_SET_WORD]		;-- map, convert any-word! to set-word!
					TYPE_STRING
					TYPE_FILE
					TYPE_URL	[string/copy as red-string! key as red-string! key null yes null]
					default		[0]
				]
			]
		]

		s: as series! h/keys/value
		keys: as int-ptr! s/offset
		s: as series! h/flags/value
		flags: as int-ptr! s/offset
		n-buckets: h/n-buckets + 1
		x:	  n-buckets
		site: n-buckets
		mask: n-buckets - 2
		hash: hash-value key no
		i: hash and mask
		_HT_CAL_FLAG_INDEX(i ii sh)
		i: i + 1									;-- 1-based index
		either _BUCKET_IS_EMPTY(flags ii sh) [x: i][
			step: 0
			last: i
			continue?: yes
			while [
				del?: _BUCKET_IS_DEL(flags ii sh)
				all [
					continue?
					_BUCKET_IS_NOT_EMPTY(flags ii sh)
					any [
						del?
						type = HASH_TABLE_HASH
						not actions/compare blk + keys/i key COMP_STRICT_EQUAL
					]
				]
			][
				if del? [site: i]
				if type = HASH_TABLE_HASH [
					k: blk + (keys/i and 7FFFFFFFh)
					if all [
						TYPE_OF(k) = TYPE_OF(key)
						actions/compare k key COMP_EQUAL
					][keys/i: keys/i or 80000000h]
				]

				i: i + step and mask
				_HT_CAL_FLAG_INDEX(i ii sh)
				i: i + 1
				step: step + 1
				if i = last [x: site continue?: no]
			]
			if x = n-buckets [
				x: either all [
					_BUCKET_IS_EMPTY(flags ii sh)
					site <> n-buckets
				][site][i]
			]
		]
		_HT_CAL_FLAG_INDEX((x - 1) ii sh)
		either _BUCKET_IS_EMPTY(flags ii sh) [
			keys/x: idx
			_BUCKET_SET_BOTH_FALSE(flags ii sh)
			h/size: h/size + 1
			h/n-occupied: h/n-occupied + 1
		][
			if _BUCKET_IS_DEL(flags ii sh) [
				keys/x: idx
				_BUCKET_SET_BOTH_FALSE(flags ii sh)
				h/size: h/size + 1
			]
		]
		if type = HASH_TABLE_HASH [idx: idx + 1 indexes/idx: x]
		key
	]

	get: func [
		node	 [node!]
		key		 [red-value!]
		head	 [integer!]
		skip	 [integer!]
		case?	 [logic!]
		last?	 [logic!]
		reverse? [logic!]
		return:  [red-value!]
		/local
			s h i flags last mask step keys hash n-buckets ii sh blk
			idx last-idx op find? reverse-head k type
	][
		op: either case? [COMP_STRICT_EQUAL][COMP_EQUAL]
		s: as series! node/value
		h: as hashtable! s/offset
		assert h/n-buckets > 0

		type: h/type
		if all [
			type = HASH_TABLE_MAP
			word/any-word? TYPE_OF(key)
		][
			set-type key TYPE_SET_WORD			;-- map, convert any-word! to set-word!
		]

		s: as series! h/blk/value
		if reverse? [
			last?: yes
		]
		last-idx: either last? [-1][(as-integer (s/tail - s/offset)) >> 4]
		blk: s/offset

		s: as series! h/keys/value
		keys: as int-ptr! s/offset
		s: as series! h/flags/value
		flags: as int-ptr! s/offset
		n-buckets: h/n-buckets + 1
		mask: n-buckets - 2
		hash: hash-value key no
		i: hash and mask
		_HT_CAL_FLAG_INDEX(i ii sh)
		i: i + 1
		last: i
		step: 0
		find?: no
		while [
			k: blk + keys/i
			all [
				_BUCKET_IS_NOT_EMPTY(flags ii sh)
				any [
					_BUCKET_IS_DEL(flags ii sh)
					type = HASH_TABLE_HASH
					TYPE_OF(k) <> TYPE_OF(key)
					not actions/compare k key op
				]
			]
		][
			if type = HASH_TABLE_HASH [
				idx: keys/i and 7FFFFFFFh
				k: blk + idx
				if all [
					_BUCKET_IS_NOT_DEL(flags ii sh)
					TYPE_OF(k) = TYPE_OF(key)
					actions/compare k key op
					idx - head % skip = 0
				][
					either reverse? [
						if all [idx < head idx > last-idx][last-idx: idx find?: yes]
					][
						if idx >= head [
							either last? [
								if idx > last-idx [last-idx: idx find?: yes]
							][
								if idx < last-idx [last-idx: idx find?: yes]
							]
						]
					]
					if all [keys/i and 80000000h = 0 find?][
						return blk + last-idx
					]
				]
			]

			i: i + step and mask
			_HT_CAL_FLAG_INDEX(i ii sh)
			i: i + 1
			step: step + 1
			if i = last [
				return either find? [blk + last-idx][null]
			]
		]

		if find? [return blk + last-idx]
		either _BUCKET_IS_EITHER(flags ii sh) [null][blk + keys/i]
	]

	delete: func [
		node	[node!]
		key		[red-value!]
		/local s h i ii sh flags indexes
	][
		s: as series! node/value
		h: as hashtable! s/offset
		assert h/n-buckets > 0

		either h/indexes = null [				;-- map!
			key: key + 1
			set-type key TYPE_NONE
		][										;-- hash!
			unless hash-value? key [exit]
			s: as series! h/flags/value
			flags: as int-ptr! s/offset
			s: as series! h/blk/value
			i: (as-integer key - s/offset) >> 4 + 1
			s: as series! h/indexes/value
			indexes: as int-ptr! s/offset
			i: indexes/i
			_HT_CAL_FLAG_INDEX(i ii sh)
			_BUCKET_SET_DEL_TRUE(flags ii sh)
		]
		h/size: h/size - 1
	]

	copy: func [
		node	[node!]
		blk		[node!]
		return: [node!]
		/local s h ss hh new
	][
		s: as series! node/value
		h: as hashtable! s/offset

		new: copy-series s
		ss: as series! new/value
		hh: as hashtable! ss/offset

		hh/flags: copy-series as series! h/flags/value
		hh/keys: copy-series as series! h/keys/value
		hh/blk: blk
		new
	]

	clear: func [
		node	[node!]
		head	[integer!]
		size	[integer!]
		/local s h flags n i ii sh indexes
	][
		if zero? size [exit]
		s: as series! node/value
		h: as hashtable! s/offset

		h/n-occupied: h/n-occupied - size
		h/size: h/size - size
		s: as series! h/flags/value
		flags: as int-ptr! s/offset
		s: as series! h/indexes/value
		indexes: (as int-ptr! s/offset) + head
		until [
			i: indexes/value
			if i <> -1 [
				i: i - 1
				_HT_CAL_FLAG_INDEX(i ii sh)
				_BUCKET_SET_DEL_TRUE(flags ii sh)
				indexes/value: -1
			]
			indexes: indexes + 1
			size: size - 1
			zero? size
		]
	]

	destroy: func [
		node [node!]
		/local s h
	][
		s: as series! node/value
		h: as hashtable! s/offset
		free-node h/keys
		free-node h/flags
		if h/indexes <> null [free-node h/indexes]
		free-node node
	]

	refresh: func [
		node	[node!]
		offset	[integer!]
		head	[integer!]
		/local s h indexes i end keys index part flags ii sh
	][
		s: as series! node/value
		h: as hashtable! s/offset
		assert h/indexes <> null
		assert h/n-buckets > 0

		s: as series! h/indexes/value
		indexes: as int-ptr! s/offset
		end: as int-ptr! s/tail
		if indexes = end [exit]
		s: as series! h/keys/value
		keys: as int-ptr! s/offset
		ii: head						;-- save head

		while [
			index: indexes + head
			index < end
		][
			i: index/value
			unless i = -1 [keys/i: keys/i + offset]
			head: head + 1
		]

		if negative? offset [			;-- need to delete some entries
			head: ii					;-- restore head
			part: offset
			s: as series! h/flags/value
			flags: as int-ptr! s/offset
			while [negative? part][
				index: indexes + head + part
				i: index/value - 1
				_HT_CAL_FLAG_INDEX(i ii sh)
				_BUCKET_SET_DEL_TRUE(flags ii sh)
				h/size: h/size - 1
				part: part + 1
			]
			if indexes + head < end [
				move-memory
					as byte-ptr! (indexes + head + offset)
					as byte-ptr! indexes + head
					as-integer end - (indexes + head + 1)
			]
			s: as series! h/indexes/value
			s/tail: as red-value! end + offset
		]
	]
]

Red/System [
	Title:	"A Hash Table Implementation"
	Author: "Xie Qingtian"
	File: 	%hashtable.reds
	Tabs:	4
	Rights: "Copyright (C) 2014-2015 Xie Qingtian. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
	Notes: {
		Algorithm: Open addressing, quadratic probing.
	}
]

#define HASH_TABLE_HASH		0
#define HASH_TABLE_MAP		1
#define HASH_TABLE_SYMBOL	2

#define _HT_HASH_UPPER		0.77

#define _BUCKET_IS_EMPTY(flags i s)			[flags/i >> s and 2 = 2]
#define _BUCKET_IS_NOT_EMPTY(flags i s)		[flags/i >> s and 2 <> 2]
#define _BUCKET_IS_DEL(flags i s)			[flags/i >> s and 1 = 1]
#define _BUCKET_IS_NOT_DEL(flags i s)		[flags/i >> s and 1 <> 1]
#define _BUCKET_IS_EITHER(flags i s)		[flags/i >> s and 3 > 0]
#define _BUCKET_IS_CLEARED(flags i s)		[flags/i >> s and 3 = 0]
#define _BUCKET_SET_DEL_TRUE(flags i s)		[flags/i: 1 << s or flags/i]
#define _BUCKET_SET_DEL_FALSE(flags i s)	[flags/i: (not 1 << s) and flags/i]
#define _BUCKET_SET_EMPTY_FALSE(flags i s)	[flags/i: (not 2 << s) and flags/i]
#define _BUCKET_SET_BOTH_FALSE(flags i s)	[flags/i: (not 3 << s) and flags/i]

#define _HT_CAL_FLAG_INDEX(i idx shift) [
	idx: i >> 4 + 1
	shift: i and 0Fh << 1
]

#define MURMUR_HASH_3_X86_32_C1		CC9E2D51h
#define MURMUR_HASH_3_X86_32_C2		1B873593h

#define MURMUR_HASH_ROTL_32(x r) [
	x << r or (x >>> (32 - r))
]

hash-string: func [
	str		[red-string!]
	case?	[logic!]
	return: [integer!]
	/local series s unit p p4 k1 h1 tail len head
][
	s: GET_BUFFER(str)
	unit: GET_UNIT(s)
	head: either TYPE_OF(str) = TYPE_SYMBOL [0][str/head]
	p: (as byte-ptr! s/offset) + (head << (unit >> 1))
	tail: as byte-ptr! s/tail
	len: (as-integer tail - p) >> (unit >> 1) << 2
	h1: 42								;-- seed

	;-- body
	while [p < tail][
		k1: switch unit [
			Latin1 [as-integer p/value]
			UCS-2  [(as-integer p/2) << 8 + p/1]
			UCS-4  [p4: as int-ptr! p p4/value]
		]
		unless case? [k1: case-folding/folding-case k1 yes]
		k1: k1 * MURMUR_HASH_3_X86_32_C1
		k1: MURMUR_HASH_ROTL_32(k1 15)
		k1: k1 * MURMUR_HASH_3_X86_32_C2

		h1: h1 xor k1
		h1: MURMUR_HASH_ROTL_32(h1 13)
		h1: h1 * 5 + E6546B64h
		p: p + unit
	]

	;-- finalization
	h1: h1 xor len
	h1: h1 >>> 16 xor h1
	h1: h1 * 85EBCA6Bh
	h1: h1 >>> 13 xor h1
	h1: h1 * C2B2AE35h
	h1: h1 >>> 16 xor h1
	h1
]

murmur3-x86-32: func [
	key		[byte-ptr!]
	len		[integer!]
	return: [integer!]
	/local data nblocks blocks p i k1 h1 tail n
][
	assert len > 0

	data: key
	nblocks: len / 4
	h1: 42								;-- seed

	;-- body
	blocks: as int-ptr! (data + (nblocks * 4))
	i: negate nblocks
	while [negative? i][
		p: blocks + i
		k1: p/value						;@@ do endian-swapping if needed
		k1: k1 * MURMUR_HASH_3_X86_32_C1
		k1: MURMUR_HASH_ROTL_32(k1 15)
		k1: k1 * MURMUR_HASH_3_X86_32_C2

		h1: h1 xor k1
		h1: MURMUR_HASH_ROTL_32(h1 13)
		h1: h1 * 5 + E6546B64h
		i: i + 1
	]

	;-- tail
	n: len and 3
	if positive? n [
		k1: 0
		tail: data + (nblocks * 4)
		if n = 3 [k1: (as-integer tail/3) << 16 xor k1]
		if n > 1 [k1: (as-integer tail/2) << 8  xor k1]
		k1: (as-integer tail/1) xor k1
		k1: k1 * MURMUR_HASH_3_X86_32_C1
		k1: MURMUR_HASH_ROTL_32(k1 15)
		k1: k1 * MURMUR_HASH_3_X86_32_C2
		h1: h1 xor k1
	]

	;-- finalization
	h1: h1 xor len
	h1: h1 >>> 16 xor h1
	h1: h1 * 85EBCA6Bh
	h1: h1 >>> 13 xor h1
	h1: h1 * C2B2AE35h
	h1: h1 >>> 16 xor h1
	h1
]

_hashtable: context [
	#enum hashtable-type! [
		HASH_TABLE_HASH
		HASH_TABLE_MAP
		HASH_TABLE_SYMBOL
	]
	hashtable!: alias struct! [
		size		[integer!]
		indexes		[node!]
		flags		[node!]
		keys		[node!]
		blk			[node!]
		n-occupied	[integer!]
		n-buckets	[integer!]
		upper-bound	[integer!]
		type		[integer!]
	]

	round-up: func [
		n		[integer!]
		return: [integer!]
	][
		n: n - 1
		n: n >> 1 or n
		n: n >> 2 or n
		n: n >> 4 or n
		n: n >> 8 or n
		n: n >> 16 or n
		n + 1
	]

	hash-value?: func [
		key		[red-value!]
		return:	[logic!]
	][
		switch TYPE_OF(key) [
			TYPE_WORD
			TYPE_SYMBOL
			TYPE_STRING
			TYPE_INTEGER
			TYPE_FILE
			TYPE_URL
			TYPE_CHAR
			TYPE_FLOAT
			TYPE_SET_WORD
			TYPE_LIT_WORD
			TYPE_GET_WORD
			TYPE_REFINEMENT
			TYPE_ISSUE
			TYPE_POINT
			TYPE_DATATYPE
			TYPE_PERCENT
			TYPE_TUPLE [true]
			default    [false]
		]
	]

	hash-value: func [
		key		[red-value!]
		case?	[logic!]
		return: [integer!]
		/local sym s
	][
		switch TYPE_OF(key) [
			TYPE_SYMBOL
			TYPE_STRING
			TYPE_FILE
			TYPE_URL   [
				hash-string as red-string! key case?
			]
			TYPE_CHAR
			TYPE_INTEGER [key/data2]
			TYPE_FLOAT
			TYPE_PERCENT [
				murmur3-x86-32 (as byte-ptr! key) + 8 8
			]
			TYPE_WORD
			TYPE_SET_WORD
			TYPE_LIT_WORD
			TYPE_GET_WORD
			TYPE_REFINEMENT
			TYPE_ISSUE [
				s: GET_BUFFER(symbols)
				sym: as red-string! s/offset + key/data2 - 1
				hash-string sym case?
			]
			TYPE_POINT
			TYPE_TYPESET [
				murmur3-x86-32 (as byte-ptr! key) + 4 12
			]
			TYPE_TUPLE [
				murmur3-x86-32 (as byte-ptr! key) + 4 TUPLE_SIZE(tp)
			]
			TYPE_DATATYPE
			TYPE_LOGIC [key/data1]
			TYPE_ACTION
			TYPE_NATIVE
			TYPE_OP [key/data3]
			default [0]
		]
	]

	put-all: func [
		node	[node!]
		head	[integer!]
		skip	[integer!]
		/local s h i end value key val
	][
		s: as series! node/value
		h: as hashtable! s/offset

		s: as series! h/blk/value
		end: s/tail
		i: head
		while [
			value: s/offset + i
			value < end
		][
			either h/type = HASH_TABLE_MAP [
				key: get node value 0 0 yes no no
				either key = null [
					if null = put node value [
						fire [TO_ERROR(script invalid-type) datatype/push TYPE_OF(value)]
					]
				][
					copy-cell value + 1 key + 1
					move-memory
						as byte-ptr! value
						as byte-ptr! value + 2
						as-integer s/tail - (value + 2)
					s/tail: s/tail - 2
					end: s/tail
					i: i - skip
				]
			][
				put node value
			]
			i: i + skip
		]
	]

	init: func [
		size	[integer!]
		blk		[red-block!]
		type	[integer!]
		return: [node!]
		/local node s ss h f-buckets fsize i value skip end
	][
		node: alloc-bytes-filled size? hashtable! #"^(00)"
		s: as series! node/value
		h: as hashtable! s/offset
		h/type: type

		if size < 3 [size: 3]
		fsize: integer/to-float size
		f-buckets: fsize / _HT_HASH_UPPER
		skip: either type = HASH_TABLE_MAP [2][1]
		h/n-buckets: round-up float/to-integer f-buckets
		f-buckets: integer/to-float h/n-buckets
		h/upper-bound: float/to-integer f-buckets * _HT_HASH_UPPER
		h/flags: alloc-bytes-filled h/n-buckets >> 2 #"^(AA)"
		h/keys: alloc-bytes h/n-buckets * size? int-ptr!

		either blk = null [
			h/blk: alloc-cells size
		][
			h/blk: blk/node

			s: GET_BUFFER(blk)
			end: s/tail
			if type = HASH_TABLE_HASH [
				h/indexes: alloc-bytes-filled size * size? integer! #"^(FF)"
				i: (as-integer (end - s/offset)) >> 4 - blk/head
				ss: as series! h/indexes/value
				ss/tail: as cell! (as int-ptr! ss/tail) + i
			]
			put-all node blk/head skip
		]
		node
	]

	resize: func [
		node			[node!]
		new-buckets		[integer!]
		/local
			s h x k v i j site last mask step keys vals hash n-buckets blk
			new-size tmp break? flags new-flags new-flags-node ii sh f idx
			type case?
	][
		s: as series! node/value
		h: as hashtable! s/offset
		type: h/type
		s: as series! h/blk/value
		blk: s/offset
		s: as series! h/flags/value
		flags: as int-ptr! s/offset
		n-buckets: h/n-buckets
		j: 0
		new-buckets: round-up new-buckets
		f: integer/to-float new-buckets
		new-size: float/to-integer f * _HT_HASH_UPPER
		if new-buckets < 4 [new-buckets: 4]
		either h/size >= new-size [j: 1][
			new-flags-node: alloc-bytes-filled new-buckets >> 2 #"^(AA)"
			s: as series! new-flags-node/value
			new-flags: as int-ptr! s/offset
			if n-buckets < new-buckets [
				expand-series as series! h/keys/value new-buckets * size? int-ptr!
			]
		]
		if zero? j [
			s: as series! h/keys/value
			keys: as int-ptr! s/offset
			until [
				_HT_CAL_FLAG_INDEX(j ii sh)
				j: j + 1
				if _BUCKET_IS_CLEARED(flags ii sh) [
					idx: keys/j
					mask: new-buckets - 1
					_BUCKET_SET_DEL_TRUE(flags ii sh)
					break?: no
					until [									;-- kick-out process
						step: 0
						k: blk + (idx and 7FFFFFFFh)
						case?: either all [
							type = HASH_TABLE_MAP
							not word/any-word? TYPE_OF(k)
						][yes][no]
						hash: hash-value k case?
						i: hash and mask
						_HT_CAL_FLAG_INDEX(i ii sh)
						while [_BUCKET_IS_NOT_EMPTY(new-flags ii sh)][
							step: step + 1
							i: i + step and mask
							_HT_CAL_FLAG_INDEX(i ii sh)
						]
						i: i + 1
						_BUCKET_SET_EMPTY_FALSE(new-flags ii sh)
						either all [
							i <= n-buckets
							_BUCKET_IS_CLEARED(flags ii sh)
						][
							tmp: keys/i keys/i: idx idx: tmp
							_BUCKET_SET_DEL_TRUE(flags ii sh)
						][
							keys/i: idx
							break?: yes
						]
						break?
					]
				]
				j = n-buckets
			]
			;@@ if h/n-buckets > new-buckets []			;-- shrink the hash table
			free-series memory/s-head h/flags
			h/flags: new-flags-node
			h/n-buckets: new-buckets
			h/n-occupied: h/size
			h/upper-bound: new-size
		]
	]

	put: func [
		node	[node!]
		key 	[red-value!]
		return: [red-value!]
		/local
			s h x i site last mask step keys hash n-buckets flags op
			ii sh continue? blk idx type del? indexes end ss k case?
	][
		s: as series! node/value
		h: as hashtable! s/offset
		type: h/type
		if all [
			type <> HASH_TABLE_SYMBOL
			not hash-value? key
		][return null]

		if h/n-occupied >= h/upper-bound [			;-- update the hash table
			n-buckets: h/n-buckets + either h/n-buckets > (h/size << 1) [-1][1]
			resize node n-buckets
		]

		s: as series! h/blk/value
		idx: (as-integer (key - s/offset)) >> 4
		blk: s/offset

		case?: no
		either type = HASH_TABLE_HASH [
			ss: as series! h/indexes/value
			indexes: as int-ptr! ss/offset
		][
			if type = HASH_TABLE_MAP [
				either word/any-word? TYPE_OF(key) [
					set-type key TYPE_SET_WORD		;-- map, convert any-word! to set-word!
				][
					case?: yes
				]
			]
		]

		s: as series! h/keys/value
		keys: as int-ptr! s/offset
		s: as series! h/flags/value
		flags: as int-ptr! s/offset
		n-buckets: h/n-buckets + 1
		x:	  n-buckets
		site: n-buckets
		mask: n-buckets - 2
		hash: hash-value key case?
		i: hash and mask
		_HT_CAL_FLAG_INDEX(i ii sh)
		i: i + 1									;-- 1-based index
		either _BUCKET_IS_EMPTY(flags ii sh) [x: i][
			step: 0
			last: i
			continue?: yes
			while [
				del?: _BUCKET_IS_DEL(flags ii sh)
				all [
					continue?
					_BUCKET_IS_NOT_EMPTY(flags ii sh)
					any [
						del?
						type = HASH_TABLE_HASH
						not actions/compare blk + keys/i key COMP_STRICT_EQUAL
					]
				]
			][
				if del? [site: i]
				if type = HASH_TABLE_HASH [
					k: blk + (keys/i and 7FFFFFFFh)
					if all [
						TYPE_OF(k) = TYPE_OF(key)
						actions/compare k key COMP_EQUAL
					][keys/i: keys/i or 80000000h]
				]

				i: i + step and mask
				_HT_CAL_FLAG_INDEX(i ii sh)
				i: i + 1
				step: step + 1
				if i = last [x: site continue?: no]
			]
			if x = n-buckets [
				x: either all [
					_BUCKET_IS_EMPTY(flags ii sh)
					site <> n-buckets
				][site][i]
			]
		]
		_HT_CAL_FLAG_INDEX((x - 1) ii sh)
		either _BUCKET_IS_EMPTY(flags ii sh) [
			keys/x: idx
			_BUCKET_SET_BOTH_FALSE(flags ii sh)
			h/size: h/size + 1
			h/n-occupied: h/n-occupied + 1
		][
			if _BUCKET_IS_DEL(flags ii sh) [
				keys/x: idx
				_BUCKET_SET_BOTH_FALSE(flags ii sh)
				h/size: h/size + 1
			]
		]
		if type = HASH_TABLE_HASH [idx: idx + 1 indexes/idx: x]
		key
	]

	get: func [
		node	 [node!]
		key		 [red-value!]
		head	 [integer!]
		skip	 [integer!]
		case?	 [logic!]
		last?	 [logic!]
		reverse? [logic!]
		return:  [red-value!]
		/local
			s h i flags last mask step keys hash n-buckets ii sh blk hash-case?
			idx last-idx op find? reverse-head k type
	][
		op: either case? [COMP_STRICT_EQUAL][COMP_EQUAL]
		s: as series! node/value
		h: as hashtable! s/offset
		assert h/n-buckets > 0

		type: h/type
		hash-case?: no
		if type = HASH_TABLE_MAP [
			either word/any-word? TYPE_OF(key) [
				set-type key TYPE_SET_WORD		;-- map, convert any-word! to set-word!
			][
				hash-case?: yes
			]
		]

		s: as series! h/blk/value
		if reverse? [
			last?: yes
		]
		last-idx: either last? [-1][(as-integer (s/tail - s/offset)) >> 4]
		blk: s/offset

		s: as series! h/keys/value
		keys: as int-ptr! s/offset
		s: as series! h/flags/value
		flags: as int-ptr! s/offset
		n-buckets: h/n-buckets + 1
		mask: n-buckets - 2
		hash: hash-value key hash-case?
		i: hash and mask
		_HT_CAL_FLAG_INDEX(i ii sh)
		i: i + 1
		last: i
		step: 0
		find?: no
		while [
			k: blk + keys/i
			all [
				_BUCKET_IS_NOT_EMPTY(flags ii sh)
				any [
					_BUCKET_IS_DEL(flags ii sh)
					type = HASH_TABLE_HASH
					TYPE_OF(k) <> TYPE_OF(key)
					not actions/compare k key op
				]
			]
		][
			if type = HASH_TABLE_HASH [
				idx: keys/i and 7FFFFFFFh
				k: blk + idx
				if all [
					_BUCKET_IS_NOT_DEL(flags ii sh)
					TYPE_OF(k) = TYPE_OF(key)
					actions/compare k key op
					idx - head % skip = 0
				][
					either reverse? [
						if all [idx < head idx > last-idx][last-idx: idx find?: yes]
					][
						if idx >= head [
							either last? [
								if idx > last-idx [last-idx: idx find?: yes]
							][
								if idx < last-idx [last-idx: idx find?: yes]
							]
						]
					]
					if all [keys/i and 80000000h = 0 find?][
						return blk + last-idx
					]
				]
			]

			i: i + step and mask
			_HT_CAL_FLAG_INDEX(i ii sh)
			i: i + 1
			step: step + 1
			if i = last [
				return either find? [blk + last-idx][null]
			]
		]

		if find? [return blk + last-idx]
		either _BUCKET_IS_EITHER(flags ii sh) [null][blk + keys/i]
	]

	delete: func [
		node	[node!]
		key		[red-value!]
		/local s h i ii sh flags indexes
	][
		s: as series! node/value
		h: as hashtable! s/offset
		assert h/n-buckets > 0

		either h/indexes = null [				;-- map!
			key: key + 1
			set-type key TYPE_NONE
		][										;-- hash!
			unless hash-value? key [exit]
			s: as series! h/flags/value
			flags: as int-ptr! s/offset
			s: as series! h/blk/value
			i: (as-integer key - s/offset) >> 4 + 1
			s: as series! h/indexes/value
			indexes: as int-ptr! s/offset
			i: indexes/i
			_HT_CAL_FLAG_INDEX(i ii sh)
			_BUCKET_SET_DEL_TRUE(flags ii sh)
		]
		h/size: h/size - 1
	]

	copy: func [
		node	[node!]
		blk		[node!]
		return: [node!]
		/local s h ss hh new
	][
		s: as series! node/value
		h: as hashtable! s/offset

		new: copy-series s
		ss: as series! new/value
		hh: as hashtable! ss/offset

		hh/flags: copy-series as series! h/flags/value
		hh/keys: copy-series as series! h/keys/value
		hh/blk: blk
		new
	]

	clear: func [
		node	[node!]
		head	[integer!]
		size	[integer!]
		/local s h flags n i ii sh indexes
	][
		if zero? size [exit]
		s: as series! node/value
		h: as hashtable! s/offset

		h/n-occupied: h/n-occupied - size
		h/size: h/size - size
		s: as series! h/flags/value
		flags: as int-ptr! s/offset
		s: as series! h/indexes/value
		indexes: (as int-ptr! s/offset) + head
		until [
			i: indexes/value
			if i <> -1 [
				i: i - 1
				_HT_CAL_FLAG_INDEX(i ii sh)
				_BUCKET_SET_DEL_TRUE(flags ii sh)
				indexes/value: -1
			]
			indexes: indexes + 1
			size: size - 1
			zero? size
		]
	]

	destroy: func [
		node [node!]
		/local s h
	][
		s: as series! node/value
		h: as hashtable! s/offset
		free-node h/keys
		free-node h/flags
		if h/indexes <> null [free-node h/indexes]
		free-node node
	]

	refresh: func [
		node	[node!]
		offset	[integer!]
		head	[integer!]
		/local s h indexes i end keys index part flags ii sh
	][
		s: as series! node/value
		h: as hashtable! s/offset
		assert h/indexes <> null
		assert h/n-buckets > 0

		s: as series! h/indexes/value
		indexes: as int-ptr! s/offset
		end: as int-ptr! s/tail
		if indexes = end [exit]
		s: as series! h/keys/value
		keys: as int-ptr! s/offset
		ii: head						;-- save head

		while [
			index: indexes + head
			index < end
		][
			i: index/value
			unless i = -1 [keys/i: keys/i + offset]
			head: head + 1
		]

		if negative? offset [			;-- need to delete some entries
			head: ii					;-- restore head
			part: offset
			s: as series! h/flags/value
			flags: as int-ptr! s/offset
			while [negative? part][
				index: indexes + head + part
				i: index/value - 1
				_HT_CAL_FLAG_INDEX(i ii sh)
				_BUCKET_SET_DEL_TRUE(flags ii sh)
				h/size: h/size - 1
				part: part + 1
			]
			if indexes + head < end [
				move-memory
					as byte-ptr! (indexes + head + offset)
					as byte-ptr! indexes + head
					as-integer end - (indexes + head + 1)
			]
			s: as series! h/indexes/value
			s/tail: as red-value! end + offset
		]
	]
]


Restructure simple-io.

Restructure simple-io.

Red/System [
	Title:	"Simple file IO functions (temporary)"
	Author: "Nenad Rakocevic"
	File: 	%simple-io.reds
	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
	}
]

simple-io: context [

	#either OS = 'Windows [

		#define GENERIC_READ 			80000000h
		#define FILE_SHARE_READ			00000001h
		#define OPEN_EXISTING			00000003h
		#define FILE_ATTRIBUTE_NORMAL	00000080h

		#import [
			"kernel32.dll" stdcall [
				CreateFile:	"CreateFileA" [
					filename	[c-string!]
					access		[integer!]
					share		[integer!]
					security	[int-ptr!]
					disposition	[integer!]
					flags		[integer!]
					template	[int-ptr!]
					return:		[integer!]
				]
				ReadFile:	"ReadFile" [
					file		[integer!]
					buffer		[byte-ptr!]
					bytes		[integer!]
					read		[int-ptr!]
					overlapped	[int-ptr!]
					return:		[integer!]
				]
				GetFileSize: "GetFileSize" [
					file		[integer!]
					high-size	[integer!]
					return:		[integer!]
				]
				CloseHandle:	"CloseHandle" [
					obj			[integer!]
					return:		[integer!]
				]
			]
		]
	][
		#define O_RDONLY	0

		#import [
			LIBC-file cdecl [
				_open:	"open" [
					filename	[c-string!]
					flags		[integer!]
					mode		[integer!]
					return:		[integer!]
				]
				_read:	"read" [
					file		[integer!]
					buffer		[byte-ptr!]
					bytes		[integer!]
					return:		[integer!]
				]
				_close:	"close" [
					file		[integer!]
					return:		[integer!]
				]
			]
		]

		#case [
			OS = 'MacOSX [
				stat!: alias struct! [
					st_dev		[integer!]
					st_ino		[integer!]
					st_modelink	[integer!]					;-- st_mode & st_link are both 16bit fields
					st_uid		[integer!]
					st_gid		[integer!]
					st_rdev		[integer!]
					atv_sec		[integer!]					;-- struct timespec inlined
					atv_msec	[integer!]
					mtv_sec		[integer!]					;-- struct timespec inlined
					mtv_msec	[integer!]
					ctv_sec		[integer!]					;-- struct timespec inlined
					ctv_msec	[integer!]
					st_size		[integer!]
					st_blocks	[integer!]
					st_blksize	[integer!]
					st_flags	[integer!]
					st_gen		[integer!]
				]
			]
			OS = 'Syllable [
				;-- http://glibc.sourcearchive.com/documentation/2.7-18lenny7/glibc-2_87_2bits_2stat_8h_source.html
				stat!: alias struct! [
					st_mode		[integer!]
					st_ino		[integer!]
					st_dev		[integer!]
					st_nlink	[integer!]
					st_uid		[integer!]
					st_gid		[integer!]
					filler1		[integer!]				;-- not in spec above...
					filler2		[integer!]				;-- not in spec above...
					st_size		[integer!]
					;...incomplete...
				]
			]
			all [legacy find legacy 'stat32] [
				stat!: alias struct! [
					st_dev		[integer!]
					st_ino		[integer!]
					st_mode		[integer!]
					st_nlink	[integer!]
					st_uid		[integer!]
					st_gid		[integer!]
					st_rdev		[integer!]
					st_size		[integer!]
					st_blksize	[integer!]
					st_blocks	[integer!]
					st_atime	[integer!]
					st_mtime	[integer!]
					st_ctime	[integer!]
				]
			]
			true [ ; else
				;-- http://lxr.free-electrons.com/source/arch/x86/include/uapi/asm/stat.h
				stat!: alias struct! [				;-- stat64 struct
					st_dev_l	  [integer!]
					st_dev_h	  [integer!]
					pad0		  [integer!]
					__st_ino	  [integer!]
					st_mode		  [integer!]
					st_nlink	  [integer!]
					st_uid		  [integer!]
					st_gid		  [integer!]
					st_rdev_l	  [integer!]
					st_rdev_h	  [integer!]
					pad1		  [integer!]
					st_size		  [integer!]
					st_size_h	  [integer!]
					st_blksize	  [integer!]
					st_blocks	  [integer!]
					st_atime	  [integer!]
					st_atime_nsec [integer!]
					st_mtime	  [integer!]
					st_mtime_nsec [integer!]
					st_ctime	  [integer!]
					st_ctime_nsec [integer!]
					st_ino_h	  [integer!]
					st_ino_l	  [integer!]
					;...optional padding skipped
				]
			]
		]

		#case [
			any [OS = 'MacOSX OS = 'FreeBSD] [
				#import [
					LIBC-file cdecl [
						;-- https://developer.apple.com/library/mac/documentation/Darwin/Reference/ManPages/10.6/man2/stat.2.html?useVersion=10.6
						_stat:	"fstat" [
							file		[integer!]
							restrict	[stat!]
							return:		[integer!]
						]
					]
				]
			]
			true [
				#import [
					LIBC-file cdecl [
						;-- http://refspecs.linuxbase.org/LSB_3.0.0/LSB-Core-generic/LSB-Core-generic/baselib-xstat-1.html
						_stat:	"__fxstat" [
							version		[integer!]
							file		[integer!]
							restrict	[stat!]
							return:		[integer!]
						]
					]
				]
			]

		]
	]

	open-file: func [
		filename [c-string!]
		return:	 [integer!]
		/local
			file [integer!]
	][
		#either OS = 'Windows [
			file: CreateFile
				filename
				GENERIC_READ
				FILE_SHARE_READ
				null
				OPEN_EXISTING
				FILE_ATTRIBUTE_NORMAL
				null
		][
			file: _open filename O_RDONLY 0
		]
		if file = -1 [
			print-line "*** Error: File not found"
			quit -1
		]
		file
	]

	file-size?: func [
		file	 [integer!]
		return:	 [integer!]
		/local s
	][
		#case [
			OS = 'Windows [
				GetFileSize file null
			]
			any [OS = 'MacOSX OS = 'FreeBSD] [
				s: declare stat!
				_stat file s
				s/st_size
			]
			true [ ; else
				s: declare stat!
				_stat 3 file s
				s/st_size
			]
		]
	]

	read-file: func [
		file	[integer!]
		buffer	[byte-ptr!]
		size	[integer!]
		return:	[integer!]
		/local
			read-sz [integer!]
			res		[integer!]
			error?	[logic!]
	][
		#either OS = 'Windows [
			read-sz: -1
			res: ReadFile file buffer size :read-sz null
			error?: any [zero? res read-sz <> size]
		][
			res: _read file buffer size
			error?: res <= 0
		]
		if error? [
			print-line "*** Error: cannot read file"
			quit -3
		]
		res
	]

	close-file: func [
		file	[integer!]
		return:	[integer!]
	][
		#either OS = 'Windows [
			CloseHandle file
		][
			_close file
		]
	]

	read-txt: func [
		filename [c-string!]
		return:	 [red-string!]
		/local
			buffer	[byte-ptr!]
			file	[integer!]
			size	[integer!]
			str		[red-string!]
	][
		file: open-file filename
		size: file-size? file
		if size <= 0 [
			print-line "*** Error: empty file"
			quit -2
		]

		buffer: allocate size + 1						;-- account for terminal NUL
		read-file file buffer size
		close-file file

		size: size + 1
		buffer/size: null-byte
		str: string/load as-c-string buffer size UTF-8
		free buffer
		str
	]
]

Red/System [
	Title:	"Simple file IO functions (temporary)"
	Author: "Nenad Rakocevic"
	File: 	%simple-io.reds
	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
	}
]

simple-io: context [

	#either OS = 'Windows [

		#define GENERIC_READ 			80000000h
		#define FILE_SHARE_READ			00000001h
		#define OPEN_EXISTING			00000003h
		#define FILE_ATTRIBUTE_NORMAL	00000080h

		#import [
			"kernel32.dll" stdcall [
				CreateFile:	"CreateFileA" [
					filename	[c-string!]
					access		[integer!]
					share		[integer!]
					security	[int-ptr!]
					disposition	[integer!]
					flags		[integer!]
					template	[int-ptr!]
					return:		[integer!]
				]
				ReadFile:	"ReadFile" [
					file		[integer!]
					buffer		[byte-ptr!]
					bytes		[integer!]
					read		[int-ptr!]
					overlapped	[int-ptr!]
					return:		[integer!]
				]
				GetFileSize: "GetFileSize" [
					file		[integer!]
					high-size	[integer!]
					return:		[integer!]
				]
				CloseHandle:	"CloseHandle" [
					obj			[integer!]
					return:		[integer!]
				]
			]
		]
	][
		#define O_RDONLY	0

		#import [
			LIBC-file cdecl [
				_open:	"open" [
					filename	[c-string!]
					flags		[integer!]
					mode		[integer!]
					return:		[integer!]
				]
				_read:	"read" [
					file		[integer!]
					buffer		[byte-ptr!]
					bytes		[integer!]
					return:		[integer!]
				]
				_close:	"close" [
					file		[integer!]
					return:		[integer!]
				]
			]
		]

		#either OS = 'MacOSX [
			stat!: alias struct! [
				st_dev		[integer!]
				st_ino		[integer!]
				st_modelink	[integer!]					;-- st_mode & st_link are both 16bit fields
				st_uid		[integer!]
				st_gid		[integer!]
				st_rdev		[integer!]
				atv_sec		[integer!]					;-- struct timespec inlined
				atv_msec	[integer!]
				mtv_sec		[integer!]					;-- struct timespec inlined
				mtv_msec	[integer!]
				ctv_sec		[integer!]					;-- struct timespec inlined
				ctv_msec	[integer!]
				st_size		[integer!]
				st_blocks	[integer!]
				st_blksize	[integer!]
				st_flags	[integer!]
				st_gen		[integer!]
			]
			#import [
				LIBC-file cdecl [
					;-- https://developer.apple.com/library/mac/documentation/Darwin/Reference/ManPages/10.6/man2/stat.2.html?useVersion=10.6
					_stat:	"fstat" [
						file		[integer!]
						restrict	[stat!]
						return:		[integer!]
					]
				]
			]
		][
			#either OS = 'Syllable [
				;-- http://glibc.sourcearchive.com/documentation/2.7-18lenny7/glibc-2_87_2bits_2stat_8h_source.html
				stat!: alias struct! [
					st_mode		[integer!]
					st_ino		[integer!]
					st_dev		[integer!]
					st_nlink	[integer!]
					st_uid		[integer!]
					st_gid		[integer!]
					filler1		[integer!]				;-- not in spec above...
					filler2		[integer!]				;-- not in spec above...
					st_size		[integer!]
					;...incomplete...
				]
			][
				#either legacy contains 'stat32 [
					stat!: alias struct! [
						st_dev		[integer!]
						st_ino		[integer!]
						st_mode		[integer!]
						st_nlink	[integer!]
						st_uid		[integer!]
						st_gid		[integer!]
						st_rdev		[integer!]
						st_size		[integer!]
						st_blksize	[integer!]
						st_blocks	[integer!]
						st_atime	[integer!]
						st_mtime	[integer!]
						st_ctime	[integer!]
					]
				][
					;-- http://lxr.free-electrons.com/source/arch/x86/include/uapi/asm/stat.h
					stat!: alias struct! [				;-- stat64 struct
						st_dev_l	  [integer!]
						st_dev_h	  [integer!]
						pad0		  [integer!]
						__st_ino	  [integer!]
						st_mode		  [integer!]
						st_nlink	  [integer!]
						st_uid		  [integer!]
						st_gid		  [integer!]
						st_rdev_l	  [integer!]
						st_rdev_h	  [integer!]
						pad1		  [integer!]
						st_size		  [integer!]
						st_size_h	  [integer!]
						st_blksize	  [integer!]
						st_blocks	  [integer!]
						st_atime	  [integer!]
						st_atime_nsec [integer!]
						st_mtime	  [integer!]
						st_mtime_nsec [integer!]
						st_ctime	  [integer!]
						st_ctime_nsec [integer!]
						st_ino_h	  [integer!]
						st_ino_l	  [integer!]
						;...optional padding skipped
					]
				]
			]
			#import [
				LIBC-file cdecl [
					;-- http://refspecs.linuxbase.org/LSB_3.0.0/LSB-Core-generic/LSB-Core-generic/baselib-xstat-1.html
					_stat:	"__fxstat" [
						version		[integer!]
						file		[integer!]
						restrict	[stat!]
						return:		[integer!]
					]
				]
			]
		]
	]

	open-file: func [
		filename [c-string!]
		return:	 [integer!]
		/local
			file [integer!]
	][
		#either OS = 'Windows [
			file: CreateFile
				filename
				GENERIC_READ
				FILE_SHARE_READ
				null
				OPEN_EXISTING
				FILE_ATTRIBUTE_NORMAL
				null
		][
			file: _open filename O_RDONLY 0
		]
		if file = -1 [
			print-line "*** Error: File not found"
			quit -1
		]
		file
	]

	file-size?: func [
		file	 [integer!]
		return:	 [integer!]
		/local s
	][
		#switch OS [
			Windows [
				GetFileSize file null
			]
			MacOSX [
				s: declare stat!
				_stat file s
				s/st_size
			]
			#default [
				s: declare stat!
				_stat 3 file s
				s/st_size
			]
		]
	]

	read-file: func [
		file	[integer!]
		buffer	[byte-ptr!]
		size	[integer!]
		return:	[integer!]
		/local
			read-sz [integer!]
			res		[integer!]
			error?	[logic!]
	][
		#either OS = 'Windows [
			read-sz: -1
			res: ReadFile file buffer size :read-sz null
			error?: any [zero? res read-sz <> size]
		][
			res: _read file buffer size
			error?: res <= 0
		]
		if error? [
			print-line "*** Error: cannot read file"
			quit -3
		]
		res
	]

	close-file: func [
		file	[integer!]
		return:	[integer!]
	][
		#either OS = 'Windows [
			CloseHandle file
		][
			_close file
		]
	]

	read-txt: func [
		filename [c-string!]
		return:	 [red-string!]
		/local
			buffer	[byte-ptr!]
			file	[integer!]
			size	[integer!]
			str		[red-string!]
	][
		file: open-file filename
		size: file-size? file
		if size <= 0 [
			print-line "*** Error: empty file"
			quit -2
		]

		buffer: allocate size + 1						;-- account for terminal NUL
		read-file file buffer size
		close-file file

		size: size + 1
		buffer/size: null-byte
		str: string/load as-c-string buffer size UTF-8
		free buffer
		str
	]
]


FIX: issue #647 (Interpreter thinks '1 is a lit-word!)

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

tokenizer: context [

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

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

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

	throw-error: func [id [integer!]][
		print "*** Load Error: "
		print switch id [
			ERR_PREMATURE_END		 ["unmatched closing ] or )"]
			ERR_BLOCK_END			 ["unmatched ] closing bracket"]
			ERR_PAREN_END			 ["unmatched ) closing paren"]
			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"]
			ERR_INVALID_DIGIT_WORD	 ["word cannot start with a digit"]
		]
		print-line #"!"
	]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

	scan-word: func [
		s		  [c-string!]
		blk		  [red-block!]
		type	  [integer!]
		in-path?  [logic!]
		return:   [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
			set?  [logic!]
			path? [logic!]
	][
		c: s/1
		if all [#"0" <= c c <= #"9"][
			throw-error ERR_INVALID_DIGIT_WORD
			return s
		]
		e: s + 1
		c: e/1

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

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

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

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

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

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

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

	scan-block: func [
		src		[c-string!]
		blk		[red-block!]
		return: [c-string!]
	][
		src: scan src block/make-in blk 4				;-- arbitrary start size
		if src/1 <> #"]" [throw-error ERR_PREMATURE_END]
		src + 1											;-- skip ] character
	]

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

	]

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

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

]

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

tokenizer: context [

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

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

	#enum errors! [
		ERR_PREMATURE_END
		ERR_BLOCK_END
		ERR_PAREN_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 ] or )"]
			ERR_BLOCK_END			 ["unmatched ] closing bracket"]
			ERR_PAREN_END			 ["unmatched ) closing paren"]
			ERR_STRING_DELIMIT 		 [{string ending delimiter " not found}]
			ERR_MULTI_STRING_DELIMIT ["string ending delimiter } not found"]
			ERR_CHAR_DELIMIT		 [{char ending delimiter " not found}]
			ERR_INVALID_INTEGER		 ["invalid integer"]
			ERR_INVALID_PATH		 ["invalid path"]
			ERR_INVALID_CHAR		 ["invalid char"]
		]
		print-line #"!"
	]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

	scan-block: func [
		src		[c-string!]
		blk		[red-block!]
		return: [c-string!]
	][
		src: scan src block/make-in blk 4				;-- arbitrary start size
		if src/1 <> #"]" [throw-error ERR_PREMATURE_END]
		src + 1											;-- skip ] character
	]

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

	]

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

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

]