FIX: Not allocate enough memory when decompress data.

Red/System [
	Title:   "Compress and decompress algorithms for Red runtime"
	Author:  "Qingtian Xie"
	File: 	 %crush.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2015 Nenad Rakocevic & Xie Qingtian. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
	Notes: {
		Thanks for Ilya Muravyov making it in the Public Domain.
		http://sourceforge.net/projects/crush/
	}
]

crush: context [							;-- LZ77

	#define CRUSH_W_BITS 		21			;-- window size (17..23)
	#define CRUSH_W_SIZE 		2097152		;-- 1 << CRUSH_W_BITS
	#define CRUSH_W_MASK 		2097151		;-- CRUSH_W_SIZE - 1
	#define CRUSH_SLOT_BITS 	4
	#define CRUSH_NUM_SLOTS 	16			;-- 1 << CRUSH_SLOT_BITS

	#define CRUSH_A_BITS		2			;-- 1 xx
	#define CRUSH_B_BITS		2			;-- 01 xx
	#define CRUSH_C_BITS		2			;-- 001 xx
	#define CRUSH_D_BITS		3			;-- 0001 xxx
	#define CRUSH_E_BITS		5			;-- 00001 xxxxx
	#define CRUSH_F_BITS		9			;-- 00000 xxxxxxxxx
	#define CRUSH_A				4			;-- 1 << A_BITS;
	#define CRUSH_B				8			;-- (1 << B_BITS) + A
	#define CRUSH_C				12			;-- (1 << C_BITS) + B
	#define CRUSH_D				20			;-- (1 << D_BITS) + C
	#define CRUSH_E				52			;-- (1 << E_BITS) + D
	#define CRUSH_F				564			;-- (1 << F_BITS) + E
	#define CRUSH_MIN_MATCH 	3
	#define CRUSH_MAX_MATCH 	566			;-- (CRUSH_F - 1) + CRUSH_MIN_MATCH

	#define CRUSH_BUF_SIZE		67108864	;-- 1 << 26

	#define CRUSH_TOO_FAR		65536		;-- 1 << 16

	#define CRUSH_HASH1_LEN		3			;-- CRUSH_MIN_MATCH
	#define CRUSH_HASH2_LEN		4			;-- CRUSH_MIN_MATCH + 1
	#define CRUSH_HASH1_BITS	21
	#define CRUSH_HASH2_BITS	24
	#define CRUSH_HASH1_SIZE	2097152		;-- 1 << CRUSH_HASH1_BITS
	#define CRUSH_HASH2_SIZE	16777216    ;-- 1 << CRUSH_HASH2_BITS
	#define CRUSH_HASH1_MASK	2097151     ;-- CRUSH_HASH1_SIZE - 1
	#define CRUSH_HASH2_MASK	16777215    ;-- CRUSH_HASH2_SIZE - 1
	#define CRUSH_HASH1_SHIFT	7           ;-- (CRUSH_HASH1_BITS + (CRUSH_HASH1_LEN - 1)) / CRUSH_HASH1_LEN
	#define CRUSH_HASH2_SHIFT	6           ;-- (CRUSH_HASH2_BITS + (CRUSH_HASH2_LEN - 1)) / CRUSH_HASH2_LEN

	crush!: alias struct! [
		bit-buf		[integer!]
		bit-count	[integer!]
		input		[byte-ptr!]
		buf			[byte-ptr!]
		buf-size	[integer!]
		index		[integer!]
	]

	init: func [
		crush	[crush!]
		size	[integer!]
		input	[byte-ptr!]
	][
		crush/input: input
		crush/bit-buf: 0
		crush/bit-count: 0
		crush/index: 0
		crush/buf-size: size
		if input <> null [crush/buf: allocate crush/buf-size]
	]

	get-buf: func [
		crush	[crush!]
		size	[integer!]
		return: [byte-ptr!]
		/local
			buf			[byte-ptr!]
			index		[integer!]
			buf-size	[integer!]
	][
		buf: crush/buf
		buf-size: crush/buf-size
		index: crush/index

		if index >= buf-size [
			buf-size: buf-size + 4194304
			buf: allocate buf-size
			move-memory buf crush/buf crush/buf-size
			free crush/buf
			crush/buf: buf
			crush/buf-size: buf-size
		]

		crush/index: index + size
		buf + index
	]

	put-bits: func [
		n		[integer!]
		x		[integer!]
		crush	[crush!]
		/local
			bit-buf		[integer!]
			bit-count	[integer!]
			buf			[byte-ptr!]
	][
		bit-buf: crush/bit-buf
		bit-count: crush/bit-count

		bit-buf: x << bit-count or bit-buf
		bit-count: bit-count + n
		while [bit-count >= 8][
			buf: get-buf crush 1
			buf/value: as byte! bit-buf
			bit-buf: bit-buf >> 8
			bit-count: bit-count - 8
		]
		crush/bit-buf: bit-buf
		crush/bit-count: bit-count
	]

	get-bits: func [
		n		[integer!]
		crush	[crush!]
		return: [integer!]
		/local
			input		[byte-ptr!]
			data		[integer!]
			bit-buf		[integer!]
			bit-count	[integer!]
	][
		input: crush/input
		bit-buf: crush/bit-buf
		bit-count: crush/bit-count

		while [bit-count < n][
			data: as-integer input/value
			input: input + 1
			bit-buf: data << bit-count or bit-buf
			bit-count: bit-count + 8
		]
		data: 1 << n - 1 and bit-buf
		crush/input: input
		crush/bit-buf: bit-buf >> n
		crush/bit-count: bit-count - n
		data
	]

	update-hash1: func [
		h		[integer!]
		c		[integer!]
		return: [integer!]
	][
		h << CRUSH_HASH1_SHIFT + c and CRUSH_HASH1_MASK
	]

	update-hash2: func [
		h		[integer!]
		c		[integer!]
		return: [integer!]
	][
		h << CRUSH_HASH2_SHIFT + c and CRUSH_HASH2_MASK
	]

	get-penalty: func [
		a		[integer!]
		b		[integer!]
		return: [integer!]
		/local
			p	[integer!]
	][
		p: 0
		while [a > b][
			a: a >> 3
			p: p + 1
		]
		p
	]

	;-- header of compressed data:
	;-- algorithm (4), compressed size (4), orignal size (4)
	compress: func [
		data	[byte-ptr!]
		length	[integer!]
		outbuf	[byte-ptr!]
		return: [integer!]
		/local
			i			[integer!]
			s			[integer!]
			ss			[integer!]
			l			[integer!]
			p			[integer!]
			pp			[integer!]
			h1			[integer!]
			h2			[integer!]
			len			[integer!]
			log			[integer!]
			size		[integer!]
			offset		[integer!]
			max-match	[integer!]
			chain-len	[integer!]
			limit		[integer!]
			hash-size	[integer!]
			head		[int-ptr!]
			prev		[int-ptr!]
			output		[int-ptr!]
			buf			[byte-ptr!]
			continue?	[logic!]
			crush		[crush!]
	][
		hash-size: CRUSH_HASH1_SIZE + CRUSH_HASH2_SIZE
		head: as int-ptr! allocate hash-size * size? integer!
		prev: as int-ptr! allocate CRUSH_W_SIZE * size? integer!
		buf: allocate CRUSH_BUF_SIZE

		crush: declare crush!
		init crush length null
		output: as int-ptr! outbuf
		output/3: length				;-- save orignal file size
		crush/buf: outbuf + 12			;-- skip header

		size: CRUSH_BUF_SIZE
		while [length > 0][
			if length < CRUSH_BUF_SIZE [size: length]
			copy-memory buf data size
			output: as int-ptr! get-buf crush 4
			output/value: size

			i: 1
			until [
				head/i: -1
				i: i + 1
				i > hash-size
			]

			h1: 0
			h2: 0
			i: 1
			until [
				h1: update-hash1 h1 as-integer buf/i
				i: i + 1
				i > CRUSH_HASH1_LEN
			]
			h1: h1 + 1
			i: 1
			until [
				h2: update-hash2 h2 as-integer buf/i
				i: i + 1
				i > CRUSH_HASH2_LEN
			]
			h2: h2 + 1

			crush/bit-buf: 0
			crush/bit-count: 0

			p: 0
			while [p < size][
				len: CRUSH_MIN_MATCH - 1
				offset: CRUSH_W_SIZE
				max-match: either CRUSH_MAX_MATCH < (size - p) [CRUSH_MAX_MATCH][size - p]
				limit: either 0 < (p - CRUSH_W_SIZE) [p - CRUSH_W_SIZE][0]

				if head/h1 >= limit [
					s: head/h1
					ss: s + 1
					pp: p + 1
					if buf/ss = buf/pp [
						l: 1
						continue?: yes
						while [all [continue? l < max-match]][
							l: l + 1
							ss: s + l
							pp: p + l
							if buf/ss <> buf/pp [l: l - 1 continue?: no]
						]
						if l > len [
							len: l
							offset: p - s
						]
					]
				]

				if len < CRUSH_MAX_MATCH [
					chain-len: 256
					ss: h2 + CRUSH_HASH1_SIZE
					s: head/ss

					while [all [chain-len <> 0 s >= limit]][
						chain-len: chain-len - 1
						ss: s + len + 1
						pp: p + len + 1
						if buf/ss = buf/pp [
							ss: s + 1
							pp: p + 1
							if buf/ss = buf/pp [
								l: 1
								continue?: yes
								while [all [continue? l < max-match]][
									l: l + 1
									ss: s + l
									pp: p + l
									if buf/ss <> buf/pp [l: l - 1 continue?: no]
								]
								if l > (len + get-penalty p - s >> 4 offset) [
									len: l
									offset: p - s
								]
								if l = max-match [chain-len: 0]
							]
						]
						ss: s and CRUSH_W_MASK + 1
						s: prev/ss
					]
				]

				if all [len = CRUSH_MIN_MATCH offset > CRUSH_TOO_FAR][len: 0]

				either len >= CRUSH_MIN_MATCH [			;-- Match
					put-bits 1 1 crush

					l: len - CRUSH_MIN_MATCH
					case [
						l < CRUSH_A [
							put-bits 1 1 crush
							put-bits CRUSH_A_BITS l crush
						]
						l < CRUSH_B [
							put-bits 2 1 << 1 crush
							put-bits CRUSH_B_BITS l - CRUSH_A crush
						]
						l < CRUSH_C [
							put-bits 3 1 << 2 crush
							put-bits CRUSH_C_BITS l - CRUSH_B crush
						]
						l < CRUSH_D [
							put-bits 4 1 << 3 crush
							put-bits CRUSH_D_BITS l - CRUSH_C crush
						]
						l < CRUSH_E [
							put-bits 5 1 << 4 crush
							put-bits CRUSH_E_BITS l - CRUSH_D crush
						]
						true [
							put-bits 5 0 crush
							put-bits CRUSH_F_BITS l - CRUSH_E crush
						]
					]

					offset: offset - 1
					log: CRUSH_W_BITS - CRUSH_NUM_SLOTS
					while [ss: 2 << log offset >= ss][log: log + 1]
					ss: CRUSH_W_BITS - CRUSH_NUM_SLOTS
					put-bits CRUSH_SLOT_BITS log - ss crush
					either log > ss [
						put-bits log offset - (1 << log) crush
					][
						ss: CRUSH_W_BITS - (CRUSH_NUM_SLOTS - 1)
						put-bits ss offset crush
					]
				][
					len: 1
					pp: p + 1
					put-bits 9 (as-integer buf/pp) << 1 crush
				]

				while [len <> 0][
					len: len - 1
					head/h1: p
					pp: p and CRUSH_W_MASK + 1
					ss: h2 + CRUSH_HASH1_SIZE
					prev/pp: head/ss
					head/ss: p
					p: p + 1
					pp: p + CRUSH_HASH1_LEN
					h1: 1 + update-hash1 h1 - 1 as-integer buf/pp
					pp: p + CRUSH_HASH2_LEN
					h2: 1 + update-hash2 h2 - 1 as-integer buf/pp
				]
			]

			put-bits 7 0 crush
			data: data + size
			length: length - CRUSH_BUF_SIZE
		]

		free as byte-ptr! head
		free as byte-ptr! prev
		free buf

		head: as int-ptr! outbuf
		head/2: crush/index				;-- save size of compressed data
		crush/index + 12
	]

	decompress: func [
		data	[byte-ptr!]
		written [int-ptr!]
		return: [byte-ptr!]
		/local
			i			[integer!]
			s			[integer!]
			ss			[integer!]
			p			[integer!]
			pp			[integer!]
			len			[integer!]
			log			[integer!]
			size		[integer!]
			length		[integer!]
			buf			[byte-ptr!]
			head		[int-ptr!]
			p4			[int-ptr!]
			crush		[crush!]
	][
		head: as int-ptr! data
		length: head/2
		crush: declare crush!
		init crush head/3 data + 12					;-- skip size of data

		head: as int-ptr! crush/input
		while [
			p4: as int-ptr! crush/input
			size: p4/value
			crush/input: as byte-ptr! p4 + 1
			(as-integer p4 - head) < length
		][
			if any [size < 1 size > CRUSH_BUF_SIZE][
				print-line ["File corrupted: size = " size]
				return null
			]

			crush/bit-buf: 0
			crush/bit-count: 0

			buf: get-buf crush size
			p: 0
			while [p < size][
				either 0 <> get-bits 1 crush [
					len: either 0 <> get-bits 1 crush [
						get-bits CRUSH_A_BITS crush
					][
						either 0 <> get-bits 1 crush [
							CRUSH_A + get-bits CRUSH_B_BITS crush
						][
							either 0 <> get-bits 1 crush [
								CRUSH_B + get-bits CRUSH_C_BITS crush
							][
								either 0 <> get-bits 1 crush [
									CRUSH_C + get-bits CRUSH_D_BITS crush
								][
									either 0 <> get-bits 1 crush [
										CRUSH_D + get-bits CRUSH_E_BITS crush
									][
										CRUSH_E + get-bits CRUSH_F_BITS crush
									]
								]
							]
						]
					]

					ss: CRUSH_W_BITS - CRUSH_NUM_SLOTS
					log: ss + get-bits CRUSH_SLOT_BITS crush
					pp: either log > ss [
						1 << log + get-bits log crush
					][
						get-bits ss + 1 crush
					]
					s: p + not pp
					if s < 0 [
						print-line ["File corrupted: s = " s]
						return null
					]

					p: p + 1
					s: s + 1
					buf/p: buf/s
					p: p + 1
					s: s + 1
					buf/p: buf/s
					p: p + 1
					s: s + 1
					buf/p: buf/s
					while [len <> 0] [
						len: len - 1
						p: p + 1
						s: s + 1
						buf/p: buf/s
					]
				][
					p: p + 1
					buf/p: as byte! get-bits 8 crush
				]
			]
		]

		unless written = null [written/value: crush/index]
		crush/buf
	]
]

Red/System [
	Title:   "Compress and decompress algorithms for Red runtime"
	Author:  "Qingtian Xie"
	File: 	 %crush.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2015 Nenad Rakocevic & Xie Qingtian. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
	Notes: {
		Thanks for Ilya Muravyov making it in the Public Domain.
		http://sourceforge.net/projects/crush/
	}
]

crush: context [							;-- LZ77

	#define CRUSH_W_BITS 		21			;-- window size (17..23)
	#define CRUSH_W_SIZE 		2097152		;-- 1 << CRUSH_W_BITS
	#define CRUSH_W_MASK 		2097151		;-- CRUSH_W_SIZE - 1
	#define CRUSH_SLOT_BITS 	4
	#define CRUSH_NUM_SLOTS 	16			;-- 1 << CRUSH_SLOT_BITS

	#define CRUSH_A_BITS		2			;-- 1 xx
	#define CRUSH_B_BITS		2			;-- 01 xx
	#define CRUSH_C_BITS		2			;-- 001 xx
	#define CRUSH_D_BITS		3			;-- 0001 xxx
	#define CRUSH_E_BITS		5			;-- 00001 xxxxx
	#define CRUSH_F_BITS		9			;-- 00000 xxxxxxxxx
	#define CRUSH_A				4			;-- 1 << A_BITS;
	#define CRUSH_B				8			;-- (1 << B_BITS) + A
	#define CRUSH_C				12			;-- (1 << C_BITS) + B
	#define CRUSH_D				20			;-- (1 << D_BITS) + C
	#define CRUSH_E				52			;-- (1 << E_BITS) + D
	#define CRUSH_F				564			;-- (1 << F_BITS) + E
	#define CRUSH_MIN_MATCH 	3
	#define CRUSH_MAX_MATCH 	566			;-- (CRUSH_F - 1) + CRUSH_MIN_MATCH

	#define CRUSH_BUF_SIZE		67108864	;-- 1 << 26

	#define CRUSH_TOO_FAR		65536		;-- 1 << 16

	#define CRUSH_HASH1_LEN		3			;-- CRUSH_MIN_MATCH
	#define CRUSH_HASH2_LEN		4			;-- CRUSH_MIN_MATCH + 1
	#define CRUSH_HASH1_BITS	21
	#define CRUSH_HASH2_BITS	24
	#define CRUSH_HASH1_SIZE	2097152		;-- 1 << CRUSH_HASH1_BITS
	#define CRUSH_HASH2_SIZE	16777216    ;-- 1 << CRUSH_HASH2_BITS
	#define CRUSH_HASH1_MASK	2097151     ;-- CRUSH_HASH1_SIZE - 1
	#define CRUSH_HASH2_MASK	16777215    ;-- CRUSH_HASH2_SIZE - 1
	#define CRUSH_HASH1_SHIFT	7           ;-- (CRUSH_HASH1_BITS + (CRUSH_HASH1_LEN - 1)) / CRUSH_HASH1_LEN
	#define CRUSH_HASH2_SHIFT	6           ;-- (CRUSH_HASH2_BITS + (CRUSH_HASH2_LEN - 1)) / CRUSH_HASH2_LEN

	crush!: alias struct! [
		bit-buf		[integer!]
		bit-count	[integer!]
		input		[byte-ptr!]
		buf			[byte-ptr!]
		buf-size	[integer!]
		index		[integer!]
	]

	init: func [
		crush	[crush!]
		size	[integer!]
		input	[byte-ptr!]
	][
		crush/input: input
		crush/bit-buf: 0
		crush/bit-count: 0
		crush/index: 0
		crush/buf-size: either input = null [size][size * 6]
		if input <> null [crush/buf: allocate crush/buf-size no]
	]

	get-buf: func [
		crush	[crush!]
		size	[integer!]
		return: [byte-ptr!]
		/local
			buf			[byte-ptr!]
			index		[integer!]
			buf-size	[integer!]
	][
		buf: crush/buf
		buf-size: crush/buf-size
		index: crush/index

		if index >= buf-size [
			buf-size: buf-size + 4194304
			buf: allocate buf-size no
			move-memory buf crush/buf crush/buf-size
			free crush/buf
			crush/buf: buf
			crush/buf-size: buf-size
		]

		crush/index: index + size
		buf + index
	]

	put-bits: func [
		n		[integer!]
		x		[integer!]
		crush	[crush!]
		/local
			bit-buf		[integer!]
			bit-count	[integer!]
			buf			[byte-ptr!]
	][
		bit-buf: crush/bit-buf
		bit-count: crush/bit-count

		bit-buf: x << bit-count or bit-buf
		bit-count: bit-count + n
		while [bit-count >= 8][
			buf: get-buf crush 1
			buf/value: as byte! bit-buf
			bit-buf: bit-buf >> 8
			bit-count: bit-count - 8
		]
		crush/bit-buf: bit-buf
		crush/bit-count: bit-count
	]

	get-bits: func [
		n		[integer!]
		crush	[crush!]
		return: [integer!]
		/local
			input		[byte-ptr!]
			data		[integer!]
			bit-buf		[integer!]
			bit-count	[integer!]
	][
		input: crush/input
		bit-buf: crush/bit-buf
		bit-count: crush/bit-count

		while [bit-count < n][
			data: as-integer input/value
			input: input + 1
			bit-buf: data << bit-count or bit-buf
			bit-count: bit-count + 8
		]
		data: 1 << n - 1 and bit-buf
		crush/input: input
		crush/bit-buf: bit-buf >> n
		crush/bit-count: bit-count - n
		data
	]

	update-hash1: func [
		h		[integer!]
		c		[integer!]
		return: [integer!]
	][
		h << CRUSH_HASH1_SHIFT + c and CRUSH_HASH1_MASK
	]

	update-hash2: func [
		h		[integer!]
		c		[integer!]
		return: [integer!]
	][
		h << CRUSH_HASH2_SHIFT + c and CRUSH_HASH2_MASK
	]

	get-penalty: func [
		a		[integer!]
		b		[integer!]
		return: [integer!]
		/local
			p	[integer!]
	][
		p: 0
		while [a > b][
			a: a >> 3
			p: p + 1
		]
		p
	]

	compress: func [
		data	[byte-ptr!]
		length	[integer!]
		outbuf	[byte-ptr!]
		return: [integer!]
		/local
			i			[integer!]
			s			[integer!]
			ss			[integer!]
			l			[integer!]
			p			[integer!]
			pp			[integer!]
			h1			[integer!]
			h2			[integer!]
			len			[integer!]
			log			[integer!]
			size		[integer!]
			offset		[integer!]
			max-match	[integer!]
			chain-len	[integer!]
			limit		[integer!]
			hash-size	[integer!]
			head		[int-ptr!]
			prev		[int-ptr!]
			output		[int-ptr!]
			buf			[byte-ptr!]
			continue?	[logic!]
			crush		[crush!]
	][
		hash-size: CRUSH_HASH1_SIZE + CRUSH_HASH2_SIZE
		head: as int-ptr! allocate hash-size * size? integer! no
		prev: as int-ptr! allocate CRUSH_W_SIZE * size? integer! no
		buf: allocate CRUSH_BUF_SIZE no

		crush: declare crush!
		init crush length null
		crush/buf: outbuf + 4			;-- skip size of compressed data

		size: CRUSH_BUF_SIZE
		while [length > 0][
			if length < CRUSH_BUF_SIZE [size: length]
			copy-memory buf data size
			output: as int-ptr! get-buf crush 4
			output/value: size

			i: 1
			until [
				head/i: -1
				i: i + 1
				i > hash-size
			]

			h1: 0
			h2: 0
			i: 1
			until [
				h1: update-hash1 h1 as-integer buf/i
				i: i + 1
				i > CRUSH_HASH1_LEN
			]
			h1: h1 + 1
			i: 1
			until [
				h2: update-hash2 h2 as-integer buf/i
				i: i + 1
				i > CRUSH_HASH2_LEN
			]
			h2: h2 + 1

			crush/bit-buf: 0
			crush/bit-count: 0

			p: 0
			while [p < size][
				len: CRUSH_MIN_MATCH - 1
				offset: CRUSH_W_SIZE
				max-match: either CRUSH_MAX_MATCH < (size - p) [CRUSH_MAX_MATCH][size - p]
				limit: either 0 < (p - CRUSH_W_SIZE) [p - CRUSH_W_SIZE][0]

				if head/h1 >= limit [
					s: head/h1
					ss: s + 1
					pp: p + 1
					if buf/ss = buf/pp [
						l: 1
						continue?: yes
						while [all [continue? l < max-match]][
							l: l + 1
							ss: s + l
							pp: p + l
							if buf/ss <> buf/pp [l: l - 1 continue?: no]
						]
						if l > len [
							len: l
							offset: p - s
						]
					]
				]

				if len < CRUSH_MAX_MATCH [
					chain-len: 256
					ss: h2 + CRUSH_HASH1_SIZE
					s: head/ss

					while [all [chain-len <> 0 s >= limit]][
						chain-len: chain-len - 1
						ss: s + len + 1
						pp: p + len + 1
						if buf/ss = buf/pp [
							ss: s + 1
							pp: p + 1
							if buf/ss = buf/pp [
								l: 1
								continue?: yes
								while [all [continue? l < max-match]][
									l: l + 1
									ss: s + l
									pp: p + l
									if buf/ss <> buf/pp [l: l - 1 continue?: no]
								]
								if l > (len + get-penalty p - s >> 4 offset) [
									len: l
									offset: p - s
								]
								if l = max-match [chain-len: 0]
							]
						]
						ss: s and CRUSH_W_MASK + 1
						s: prev/ss
					]
				]

				if all [len = CRUSH_MIN_MATCH offset > CRUSH_TOO_FAR][len: 0]

				either len >= CRUSH_MIN_MATCH [			;-- Match
					put-bits 1 1 crush

					l: len - CRUSH_MIN_MATCH
					case [
						l < CRUSH_A [
							put-bits 1 1 crush
							put-bits CRUSH_A_BITS l crush
						]
						l < CRUSH_B [
							put-bits 2 1 << 1 crush
							put-bits CRUSH_B_BITS l - CRUSH_A crush
						]
						l < CRUSH_C [
							put-bits 3 1 << 2 crush
							put-bits CRUSH_C_BITS l - CRUSH_B crush
						]
						l < CRUSH_D [
							put-bits 4 1 << 3 crush
							put-bits CRUSH_D_BITS l - CRUSH_C crush
						]
						l < CRUSH_E [
							put-bits 5 1 << 4 crush
							put-bits CRUSH_E_BITS l - CRUSH_D crush
						]
						true [
							put-bits 5 0 crush
							put-bits CRUSH_F_BITS l - CRUSH_E crush
						]
					]

					offset: offset - 1
					log: CRUSH_W_BITS - CRUSH_NUM_SLOTS
					while [ss: 2 << log offset >= ss][log: log + 1]
					ss: CRUSH_W_BITS - CRUSH_NUM_SLOTS
					put-bits CRUSH_SLOT_BITS log - ss crush
					either log > ss [
						put-bits log offset - (1 << log) crush
					][
						ss: CRUSH_W_BITS - (CRUSH_NUM_SLOTS - 1)
						put-bits ss offset crush
					]
				][
					len: 1
					pp: p + 1
					put-bits 9 (as-integer buf/pp) << 1 crush
				]

				while [len <> 0][
					len: len - 1
					head/h1: p
					pp: p and CRUSH_W_MASK + 1
					ss: h2 + CRUSH_HASH1_SIZE
					prev/pp: head/ss
					head/ss: p
					p: p + 1
					pp: p + CRUSH_HASH1_LEN
					h1: 1 + update-hash1 h1 - 1 as-integer buf/pp
					pp: p + CRUSH_HASH2_LEN
					h2: 1 + update-hash2 h2 - 1 as-integer buf/pp
				]
			]

			put-bits 7 0 crush
			data: data + size
			length: length - CRUSH_BUF_SIZE
		]

		free as byte-ptr! head
		free as byte-ptr! prev
		free buf

		head: as int-ptr! outbuf
		head/value: crush/index				;-- save size of compressed data
		crush/index
	]

	decompress: func [
		data	[byte-ptr!]
		written [int-ptr!]
		return: [byte-ptr!]
		/local
			i			[integer!]
			s			[integer!]
			ss			[integer!]
			p			[integer!]
			pp			[integer!]
			len			[integer!]
			log			[integer!]
			size		[integer!]
			length		[integer!]
			buf			[byte-ptr!]
			head		[int-ptr!]
			p4			[int-ptr!]
			crush		[crush!]
	][
		head: as int-ptr! data
		length: head/value
		crush: declare crush!
		init crush length data + 4					;-- skip size of data

		head: as int-ptr! crush/input
		while [
			p4: as int-ptr! crush/input
			size: p4/value
			crush/input: as byte-ptr! p4 + 1
			(as-integer p4 - head) < length
		][
			if any [size < 1 size > CRUSH_BUF_SIZE][
				print-line ["File corrupted: size = " size]
				return null
			]

			crush/bit-buf: 0
			crush/bit-count: 0

			buf: get-buf crush size
			p: 0
			while [p < size][
				either 0 <> get-bits 1 crush [
					len: either 0 <> get-bits 1 crush [
						get-bits CRUSH_A_BITS crush
					][
						either 0 <> get-bits 1 crush [
							CRUSH_A + get-bits CRUSH_B_BITS crush
						][
							either 0 <> get-bits 1 crush [
								CRUSH_B + get-bits CRUSH_C_BITS crush
							][
								either 0 <> get-bits 1 crush [
									CRUSH_C + get-bits CRUSH_D_BITS crush
								][
									either 0 <> get-bits 1 crush [
										CRUSH_D + get-bits CRUSH_E_BITS crush
									][
										CRUSH_E + get-bits CRUSH_F_BITS crush
									]
								]
							]
						]
					]

					ss: CRUSH_W_BITS - CRUSH_NUM_SLOTS
					log: ss + get-bits CRUSH_SLOT_BITS crush
					pp: either log > ss [
						1 << log + get-bits log crush
					][
						get-bits ss + 1 crush
					]
					s: p + not pp
					if s < 0 [
						print-line ["File corrupted: s = " s]
						return null
					]

					p: p + 1
					s: s + 1
					buf/p: buf/s
					p: p + 1
					s: s + 1
					buf/p: buf/s
					p: p + 1
					s: s + 1
					buf/p: buf/s
					while [len <> 0] [
						len: len - 1
						p: p + 1
						s: s + 1
						buf/p: buf/s
					]
				][
					p: p + 1
					buf/p: as byte! get-bits 8 crush
				]
			]
		]

		unless written = null [written/value: crush/index]
		crush/buf
	]
]


FIX: issue #1067 (Hard-coded error in %typeset.reds)

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

typeset: context [
	verbose: 0

	#enum typeset-op! [
		OP_MAX											;-- calculate highest value
		OP_SET											;-- set value bits
		OP_TEST											;-- test if value bits are set
		OP_UNION
		OP_AND
		OP_OR
		OP_XOR
	]

	rs-clear: func [
		sets 	[red-typeset!]
		return: [red-typeset!]
	][
		sets/array1: 0
		sets/array2: 0
		sets/array3: 0
		sets
	]

	rs-length?: func [
		sets	[red-typeset!]
		return: [integer!]
		/local
			arr [byte-ptr!]
			pos [byte-ptr!]								;-- required by BS_TEST_BIT
			cnt [integer!]
			id  [integer!]
			set? [logic!]								;-- required by BS_TEST_BIT
	][
		id:  1
		cnt: 0
		arr: (as byte-ptr! sets) + 4
		until [
			BS_TEST_BIT(arr id set?)
			if set? [cnt: cnt + 1]
			id: id + 1
			id > datatype/top-id
		]
		cnt
	]

	create: func [
		bs1 [integer!]									;-- pre-encoded in little-endian
		bs2 [integer!]									;-- pre-encoded in little-endian
		bs3 [integer!]									;-- pre-encoded in little-endian
		return: [red-typeset!]
		/local
			ts	  [red-typeset!]
			bits  [int-ptr!]
	][
		ts: as red-typeset! ALLOC_TAIL(root)
		ts/header: TYPE_TYPESET							;-- implicit reset of all header flags

		bits: as int-ptr! ts
		bits/2: bs1
		bits/3: bs2
		bits/4: bs3
		ts
	]

	make-default: func [
		blk [red-block!]
		/local
			ts	  [red-typeset!]
			bits  [int-ptr!]
			bbits [byte-ptr!]
			pos	  [byte-ptr!]
	][
		ts: as red-typeset! ALLOC_TAIL(blk)
		ts/header: TYPE_TYPESET							;-- implicit reset of all header flags

		bits: as int-ptr! ts
		bits/2: FFFFFFFFh
		bits/3: FFFFFFFFh
		bits/4: FFFFFFFFh

		bbits: as byte-ptr! bits + 1
		BS_CLEAR_BIT(bbits TYPE_UNSET)
	]

	make-in: func [
		blk	  [red-block!]
		spec  [red-block!]
		/local
			ts	  [red-typeset!]
			ts2	  [red-typeset!]
			pos	  [red-value!]
			value [red-value!]
			end	  [red-value!]
	][
		assert TYPE_OF(spec) = TYPE_BLOCK
		ts: as red-typeset! ALLOC_TAIL(blk)
		ts/header: TYPE_TYPESET							;-- implicit reset of all header flags
		rs-clear ts

		pos: block/rs-head spec
		end: block/rs-tail spec

		while [pos < end][
			value: either TYPE_OF(pos) = TYPE_WORD [
				word/get as red-word! pos
			][
				pos
			]
			switch TYPE_OF(value) [
				TYPE_DATATYPE [
					set-type ts value
				]
				TYPE_TYPESET  [
					ts2: as red-typeset! value
					ts/array1: ts/array1 or ts2/array1
					ts/array2: ts/array2 or ts2/array2
					ts/array3: ts/array3 or ts2/array3
				]
			]
			pos: pos + 1
		]
	]

	do-bitwise: func [
		type	[integer!]
		return: [red-typeset!]
		/local
			res   [red-typeset!]
			set1  [red-typeset!]
			set2  [red-typeset!]
	][
		set1: as red-typeset! stack/arguments
		set2: set1 + 1
		res: as red-typeset! stack/push*
		res/header: TYPE_TYPESET
		rs-clear res
		if TYPE_OF(set2) = TYPE_DATATYPE [
			set-type res as red-value! set2
			set2: res
		]
		switch type [
			OP_UNION
			OP_OR	[
				res/array1: set1/array1 or set2/array1
				res/array2: set1/array2 or set2/array2
				res/array3: set1/array3 or set2/array3
			]
			OP_AND	[
				res/array1: set1/array1 and set2/array1
				res/array2: set1/array2 and set2/array2
				res/array3: set1/array3 and set2/array3
			]
			OP_XOR	[
				res/array1: set1/array1 xor set2/array1
				res/array2: set1/array2 xor set2/array2
				res/array3: set1/array3 xor set2/array3
			]
		]
		stack/set-last as red-value! res
		res
	]

	union: func [
		case?	[logic!]
		skip	[red-value!]
		return: [red-typeset!]
	][
		do-bitwise OP_UNION
	]

	and~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "typeset/and~"]]
		as red-value! do-bitwise OP_AND
	]

	or~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "typeset/or~"]]
		as red-value! do-bitwise OP_OR
	]

	xor~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "typeset/xor~"]]
		as red-value! do-bitwise OP_XOR
	]

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

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

	set-type: func [
		sets	[red-typeset!]
		value	[red-value!]
		/local
			type [red-datatype!]
			id   [integer!]
			bits [byte-ptr!]
			pos	 [byte-ptr!]
	][
		type: as red-datatype! value
		if TYPE_OF(type) = TYPE_WORD [
			type: as red-datatype! word/get as red-word! type
		]
		if TYPE_OF(type) <> TYPE_DATATYPE [
			fire [TO_ERROR(script invalid-arg) value]
		]
		id: type/value
		assert id < 96
		bits: (as byte-ptr! sets) + 4					;-- skip header
		BS_SET_BIT(bits id)
	]

	;-- Actions --

	make: func [
		proto	[red-value!]
		spec	[red-value!]
		return: [red-typeset!]
		/local
			sets [red-typeset!]
			type [red-value!]
			blk	 [red-block!]
			i	 [integer!]
			end  [red-value!]
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/make"]]

		sets: as red-typeset! stack/push*
		sets/header: TYPE_TYPESET						;-- implicit reset of all header flags
		rs-clear sets

		either TYPE_OF(spec) = TYPE_BLOCK [
			blk: as red-block! spec
			s: GET_BUFFER(blk)
			i: blk/head
			end: s/tail
			type: s/offset + i

			while [type < end][
				set-type sets type
				i: i + 1
				type: s/offset + i
			]
		][
			fire [TO_ERROR(script bad-make-arg) proto spec]
		]
		sets
	]

	form: func [
		sets	[red-typeset!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
		/local
			array	[byte-ptr!]
			pos		[byte-ptr!]							;-- required by BS_TEST_BIT
			value	[integer!]
			id		[integer!]
			base	[integer!]
			cnt		[integer!]
			s		[series!]
			part?	[logic!]
			set?	[logic!]							;-- required by BS_TEST_BIT
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/form"]]

		part?: OPTION?(arg)
		array: (as byte-ptr! sets) + 4
		id: 1
		cnt: 0
		string/concatenate-literal buffer "make typeset! ["
		part: part - 15
		until [
			BS_TEST_BIT(array id set?)
			if set? [
				if all [part? negative? part][return part]
				name: name-table + id
				string/concatenate-literal-part buffer name/buffer name/size + 1
				string/append-char GET_BUFFER(buffer) as-integer space
				part: part - name/size - 2
				cnt: cnt + 1
			]
			id: id + 1
			id > datatype/top-id
		]
		s: GET_BUFFER(buffer)
		either zero? cnt [
			string/append-char s as-integer #"]"
		][
			string/poke-char s (as byte-ptr! s/tail) - 1 as-integer #"]"
		]
		part
	]

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

		form sets buffer arg part
	]

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

		type: TYPE_OF(set2)
		if type <> TYPE_TYPESET [RETURN_COMPARE_OTHER]
		switch op [
			COMP_EQUAL
			COMP_STRICT_EQUAL
			COMP_NOT_EQUAL
			COMP_SORT
			COMP_CASE_SORT [
				res: SIGN_COMPARE_RESULT((rs-length? set1) (rs-length? set2))
			]
			default [
				res: -2
			]
		]
		res
	]

	complement: func [
		sets	[red-typeset!]
		return:	[red-value!]
		/local
			res [red-typeset!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/complement"]]

		res: as red-typeset! copy-cell as red-value! sets stack/push*
		res/array1: not res/array1
		res/array2: not res/array2
		res/array3: not res/array3
		as red-value! res
	]

	find: func [
		sets	 [red-typeset!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		tail?	 [logic!]
		match?	 [logic!]
		return:	 [red-value!]
		/local
			id	 [integer!]
			type [red-datatype!]
			set? [logic!]								;-- required by BS_TEST_BIT
			array [byte-ptr!]
			pos	  [byte-ptr!]							;-- required by BS_TEST_BIT
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/find"]]

		if TYPE_OF(value) <> TYPE_DATATYPE [
			fire [TO_ERROR(script invalid-arg) value]
		]
		array: (as byte-ptr! sets) + 4
		type: as red-datatype! value
		id: type/value
		assert id < 96
		BS_TEST_BIT(array id set?)
		as red-value! either set? [true-value][false-value]
	]

	init: does [
		datatype/register [
			TYPE_TYPESET
			TYPE_VALUE
			"typeset!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			null			;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 --
			:and~
			:complement
			:or~
			:xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			null			;copy
			:find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]

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

typeset: context [
	verbose: 0

	#enum typeset-op! [
		OP_MAX											;-- calculate highest value
		OP_SET											;-- set value bits
		OP_TEST											;-- test if value bits are set
		OP_UNION
		OP_AND
		OP_OR
		OP_XOR
	]

	rs-clear: func [
		sets 	[red-typeset!]
		return: [red-typeset!]
	][
		sets/array1: 0
		sets/array2: 0
		sets/array3: 0
		sets
	]

	rs-length?: func [
		sets	[red-typeset!]
		return: [integer!]
		/local
			arr [byte-ptr!]
			pos [byte-ptr!]								;-- required by BS_TEST_BIT
			cnt [integer!]
			id  [integer!]
			set? [logic!]								;-- required by BS_TEST_BIT
	][
		id:  1
		cnt: 0
		arr: (as byte-ptr! sets) + 4
		until [
			BS_TEST_BIT(arr id set?)
			if set? [cnt: cnt + 1]
			id: id + 1
			id > datatype/top-id
		]
		cnt
	]

	create: func [
		bs1 [integer!]									;-- pre-encoded in little-endian
		bs2 [integer!]									;-- pre-encoded in little-endian
		bs3 [integer!]									;-- pre-encoded in little-endian
		return: [red-typeset!]
		/local
			ts	  [red-typeset!]
			bits  [int-ptr!]
	][
		ts: as red-typeset! ALLOC_TAIL(root)
		ts/header: TYPE_TYPESET							;-- implicit reset of all header flags

		bits: as int-ptr! ts
		bits/2: bs1
		bits/3: bs2
		bits/4: bs3
		ts
	]

	make-default: func [
		blk [red-block!]
		/local
			ts	  [red-typeset!]
			bits  [int-ptr!]
			bbits [byte-ptr!]
			pos	  [byte-ptr!]
	][
		ts: as red-typeset! ALLOC_TAIL(blk)
		ts/header: TYPE_TYPESET							;-- implicit reset of all header flags

		bits: as int-ptr! ts
		bits/2: FFFFFFFFh
		bits/3: FFFFFFFFh
		bits/4: FFFFFFFFh

		bbits: as byte-ptr! bits + 1
		BS_CLEAR_BIT(bbits TYPE_UNSET)
	]

	make-in: func [
		blk	  [red-block!]
		spec  [red-block!]
		/local
			ts	  [red-typeset!]
			ts2	  [red-typeset!]
			pos	  [red-value!]
			value [red-value!]
			end	  [red-value!]
	][
		assert TYPE_OF(spec) = TYPE_BLOCK
		ts: as red-typeset! ALLOC_TAIL(blk)
		ts/header: TYPE_TYPESET							;-- implicit reset of all header flags
		rs-clear ts

		pos: block/rs-head spec
		end: block/rs-tail spec

		while [pos < end][
			value: either TYPE_OF(pos) = TYPE_WORD [
				word/get as red-word! pos
			][
				pos
			]
			switch TYPE_OF(value) [
				TYPE_DATATYPE [
					set-type ts value
				]
				TYPE_TYPESET  [
					ts2: as red-typeset! value
					ts/array1: ts/array1 or ts2/array1
					ts/array2: ts/array2 or ts2/array2
					ts/array3: ts/array3 or ts2/array3
				]
			]
			pos: pos + 1
		]
	]

	do-bitwise: func [
		type	[integer!]
		return: [red-typeset!]
		/local
			res   [red-typeset!]
			set1  [red-typeset!]
			set2  [red-typeset!]
	][
		set1: as red-typeset! stack/arguments
		set2: set1 + 1
		res: as red-typeset! stack/push*
		res/header: TYPE_TYPESET
		rs-clear res
		if TYPE_OF(set2) = TYPE_DATATYPE [
			set-type res as red-value! set2
			set2: res
		]
		switch type [
			OP_UNION
			OP_OR	[
				res/array1: set1/array1 or set2/array1
				res/array2: set1/array2 or set2/array2
				res/array3: set1/array3 or set2/array3
			]
			OP_AND	[
				res/array1: set1/array1 and set2/array1
				res/array2: set1/array2 and set2/array2
				res/array3: set1/array3 and set2/array3
			]
			OP_XOR	[
				res/array1: set1/array1 xor set2/array1
				res/array2: set1/array2 xor set2/array2
				res/array3: set1/array3 xor set2/array3
			]
		]
		stack/set-last as red-value! res
		res
	]

	union: func [
		case?	[logic!]
		skip	[red-value!]
		return: [red-typeset!]
	][
		do-bitwise OP_UNION
	]

	and~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "typeset/and~"]]
		as red-value! do-bitwise OP_AND
	]

	or~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "typeset/or~"]]
		as red-value! do-bitwise OP_OR
	]

	xor~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "typeset/xor~"]]
		as red-value! do-bitwise OP_XOR
	]

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

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

	set-type: func [
		sets	[red-typeset!]
		value	[red-value!]
		/local
			type [red-datatype!]
			id   [integer!]
			bits [byte-ptr!]
			pos	 [byte-ptr!]
	][
		type: as red-datatype! value
		if TYPE_OF(type) = TYPE_WORD [
			type: as red-datatype! word/get as red-word! type
		]
		if TYPE_OF(type) <> TYPE_DATATYPE [
			fire [TO_ERROR(script invalid-arg) value]
		]
		id: type/value
		assert id < 96
		bits: (as byte-ptr! sets) + 4					;-- skip header
		BS_SET_BIT(bits id)
	]

	;-- Actions --

	make: func [
		proto	[red-value!]
		spec	[red-value!]
		return: [red-typeset!]
		/local
			sets [red-typeset!]
			type [red-value!]
			blk	 [red-block!]
			i	 [integer!]
			end  [red-value!]
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/make"]]

		sets: as red-typeset! stack/push*
		sets/header: TYPE_TYPESET						;-- implicit reset of all header flags
		rs-clear sets

		either TYPE_OF(spec) = TYPE_BLOCK [
			blk: as red-block! spec
			s: GET_BUFFER(blk)
			i: blk/head
			end: s/tail
			type: s/offset + i

			while [type < end][
				set-type sets type
				i: i + 1
				type: s/offset + i
			]
		][
			fire [TO_ERROR(script bad-make-arg) proto spec]
		]
		sets
	]

	form: func [
		sets	[red-typeset!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
		/local
			array	[byte-ptr!]
			pos		[byte-ptr!]							;-- required by BS_TEST_BIT
			value	[integer!]
			id		[integer!]
			base	[integer!]
			cnt		[integer!]
			s		[series!]
			part?	[logic!]
			set?	[logic!]							;-- required by BS_TEST_BIT
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/form"]]

		part?: OPTION?(arg)
		array: (as byte-ptr! sets) + 4
		id: 1
		cnt: 0
		string/concatenate-literal buffer "make typeset! ["
		part: part - 15
		until [
			BS_TEST_BIT(array id set?)
			if set? [
				if all [part? negative? part][return part]
				name: name-table + id
				string/concatenate-literal-part buffer name/buffer name/size + 1
				string/append-char GET_BUFFER(buffer) as-integer space
				part: part - name/size - 2
				cnt: cnt + 1
			]
			id: id + 1
			id > datatype/top-id
		]
		s: GET_BUFFER(buffer)
		either zero? cnt [
			string/append-char s as-integer #"]"
		][
			string/poke-char s (as byte-ptr! s/tail) - 1 as-integer #"]"
		]
		part
	]

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

		form sets buffer arg part
	]

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

		type: TYPE_OF(set2)
		if type <> TYPE_TYPESET [RETURN_COMPARE_OTHER]
		switch op [
			COMP_EQUAL
			COMP_STRICT_EQUAL
			COMP_NOT_EQUAL
			COMP_SORT
			COMP_CASE_SORT [
				res: SIGN_COMPARE_RESULT((rs-length? set1) (rs-length? set2))
			]
			default [
				res: -2
			]
		]
		res
	]

	complement: func [
		sets	[red-typeset!]
		return:	[red-value!]
		/local
			res [red-typeset!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/complement"]]

		res: as red-typeset! copy-cell as red-value! sets stack/push*
		res/array1: not res/array1
		res/array2: not res/array2
		res/array3: not res/array3
		as red-value! res
	]

	find: func [
		sets	 [red-typeset!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		tail?	 [logic!]
		match?	 [logic!]
		return:	 [red-value!]
		/local
			id	 [integer!]
			type [red-datatype!]
			set? [logic!]								;-- required by BS_TEST_BIT
			array [byte-ptr!]
			pos	  [byte-ptr!]							;-- required by BS_TEST_BIT
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/find"]]

		if TYPE_OF(value) <> TYPE_DATATYPE [
			print-line "Find Error: invalid argument"
			return as red-value! false-value
		]
		array: (as byte-ptr! sets) + 4
		type: as red-datatype! value
		id: type/value
		assert id < 96
		BS_TEST_BIT(array id set?)
		as red-value! either set? [true-value][false-value]
	]

	init: does [
		datatype/register [
			TYPE_TYPESET
			TYPE_VALUE
			"typeset!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			null			;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 --
			:and~
			:complement
			:or~
			:xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			null			;copy
			:find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]


TESTS: new regression test for issue #159

Red/System [
	Title:   "Red/System datatype casting test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %cast-test.reds
	Rights:  "Copyright (C) 2011 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.reds

~~~start-file~~~ "cast"

===start-group=== "cast from byte!"

	--test-- "byte-cast-1"
	--assert 65 = as integer! #"A"

	--test-- "byte-cast-2"
	  cast-b: #"A"
	  cast-i: 65
	--assert cast-i = as integer! cast-b

	--test-- "byte-cast-3"
	--assert false = as logic! #"^(00)"

	--test-- "byte-cast-4"
    cast-b: #"^(00)"
	  l: false
	--assert l = as logic! cast-b

	--test-- "byte-cast-5"
	--assert true = as logic! #"A"

	--test-- "byte-cast-6"
	  cast-b: #"A"
	  l: true
	--assert l = as logic! cast-b

	--test-- "byte-cast-7"
	--assert true = as logic! #"^(FF)"

	--test-- "byte-cast-8"
	  cast-b: #"^(FF)"
	  l: true
	--assert l = as logic! cast-b

	--test-- "byte-cast-9"							;-- issue #158
	  a: as-byte 10h
	  b: as-byte 80h
	--assert 10h = as-integer a

	--test-- "byte-cast-9"							;-- issue #159
	  a: as-byte 10h
	  b: as-byte 80h
	  c: as-integer a
	--assert 10h = c

===end-group===

===start-group=== "cast from integer!"
comment {
  --test-- "int-cast-1"
  --assert #"^(00)" = as byte! 0
}
  --test-- "int-cast-2"
    i: 0
    cast-test-b: #"^(00)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-3"
  --assert #"^(01)" = as byte! 1

  --test-- "int-cast-4"
    i: 1
    cast-test-b: #"^(01)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-5"
  --assert #"^(FF)" = as byte! 255

  --test-- "int-cast-6"
    i: 255
    cast-test-b: #"^(FF)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-7"
  --assert #"^(00)" = as byte! 256

  --test-- "int-cast-8"
    i: 256
    cast-test-b: #"^(00)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-9"
  --assert false = as logic! 0

  --test-- "int-cast-10"
    i: 0
    l: false
  --assert l = as logic! i

  --test-- "int-cast-11"
  --assert true = as logic! FFFFFFFFh

  --test-- "int-cast-12"
    i: FFFFFFFFh
    l: true
  --assert l = as logic! i

  --test-- "int-cast-13"
  --assert true = as logic! 1

  --test-- "int-cast-14"
    i: 1
    l: true
  --assert l = as logic! i

  --test-- "int-cast-15"
    cs: "Hello"
    cs2: ""
    i: as integer! cs
    i: i + 1
    cs2: as c-string! i
  --assert cs2/1 = #"e"
  --assert 4 = length? cs2

  --test-- "int-cast-16"           ;; This test assumes 32-bit target
    i: 1
    p: declare pointer! [integer!]
    p: as [pointer! [integer!]] i
    P: P + 1
    i2: as integer! p
  --assert i2 = 5

  --test-- "int-cast-17"           ;; This test assumes 32-bit target
    ;; currently fails as p-int-cast is not declared
    i: 1
    p-int-cast-17: as [pointer! [integer!]] i
    P-int-cast-17: P-int-cast-17 + 1
    i2: as integer! p-int-cast-17
  --assert i2 = 5

  --test-- "int-cast-18"
    i: 1
    s: declare struct! [
      a [integer!]
      b [integer!]
    ]
    s: as [struct! [a [integer!] b [integer!]]] i
    s: s + 1
    i2: as integer! s
  --assert i2 = 9

  --test-- "int-cast-19"
    ic19-logic: either as-logic 0 [
      false
    ][
      true
    ]
  --assert ic19-logic

  --test-- "int-cast-20"
    ic20-dummy: func [return: [integer!]][0]
    ic20-logic: either as-logic ic20-dummy [
       false
    ][
      true
    ]
  --assert ic20-logic

===end-group===

===start-group=== "cast from logic!"

  --test-- "logic-cast-1"
  --assert #"^(01)" = as byte! true

  --test-- "logic-cast-2"
    cast-test-b: #"^(01)"
    l: true
  --assert cast-test-b = as byte! l

  --test-- "logic-cast-3"
  --assert #"^(00)" = as byte! false

  --test-- "logic-cast-4"
    cast-test-b: #"^(00)"
    l: false
  --assert cast-test-b = as byte! l

    --test-- "logic-cast-5"
  --assert 1 = as integer! true

  --test-- "logic-cast-6"
    i: 1
    l: true
  --assert i = as integer! l

  --test-- "logic-cast-7"
  --assert 0 = as integer! false

  --test-- "logic-cast-8"
    i: 0
    l: false
  --assert i = as integer! l

===end-group===

===start-group=== "cast c-string! tests"

  --test-- "c-string-cast-1"
    csc1-str: "Hello, Nenad"
    i: 0
    i: as integer! csc1-str
    i: i + 7
    csc1-str: as c-string! i
  --assert csc1-str/1 = #"N"
  --assert csc1-str/2 = #"e"
  --assert csc1-str/3 = #"n"
  --assert csc1-str/4 = #"a"
  --assert csc1-str/5 = #"d"
  comment {
  --test-- "c-string-cast-2"
  --assert false = as logic! ""
  }
    --test-- "c-string-cast-3"
    csc3-str: ""
  --assert false = as logic! csc3-str

  --test-- "c-string-cast-4"
  --assert true = as logic! "Any old iron, any old iron"

  --test-- "c-string-cast-5"
    csc5-str: "Why not?"
  --assert true = as logic! csc5-str

  --test-- "c-string-cast-6"
    csc6-str: "Tour de France"
    csc6-p: declare pointer! [integer!]
    csc6-p: as [pointer! [integer!]] csc6-str
    csc6-p: csc6-p + 2
    csc6-str2: as c-string! csc6-p
  --assert csc6-str2/1 = #"F"
  --assert csc6-str2/2 = #"r"
  --assert csc6-str2/3 = #"a"
  --assert csc6-str2/4 = #"n"
  --assert csc6-str2/5 = #"c"
  --assert csc6-str2/6 = #"e"

  --test-- "C-string-cast-7"
    csc7-struct: declare struct! [
      c1 [byte!]
      c2 [byte!]
      c3 [byte!]
      c4 [byte!]
      c5 [byte!]
    ]
    csc7-str: "Peter"
    csc7-struct: as [struct! [
      c1 [byte!] c2 [byte!] c3 [byte!] c4 [byte!] c5 [byte!]
    ]] csc7-str
  --assert csc7-struct/c1 = #"P"
  --assert csc7-struct/c2 = #"e"
  --assert csc7-struct/c3 = #"t"
  --assert csc7-struct/c4 = #"e"
  --assert csc7-struct/c5 = #"r"

===end-group===

===start-group=== "cast from pointer!"

  --test-- "csp-1"
    csp1-p: declare pointer! [integer!]
    csp1-p: as [pointer! [integer!]] 256
    i: 0
    i: as integer! csp1-p
  --assert i = 256

  --test-- "csp-2"
    csp2-p: declare pointer! [integer!]
    csp2-p: as [pointer! [integer!]] 0
  --assert false = as logic! csp2-p

  --test-- "csp-3"
    csp3-p: declare pointer! [integer!]
    csp3-p: as [pointer! [integer!]] 1
  --assert true = as logic! csp3-p

  --test-- "csp-4"
    csp4-p: declare pointer! [integer!]
    csp4-p: as [pointer! [integer!]] FFFFFFFFh
  --assert true = as logic! csp4-p

  --test-- "csp-5"
    csp5-p: declare pointer! [integer!]
    csp5-p: as [pointer! [integer!]] 7FFFFFFFh
  --assert true = as logic! csp5-p

  ;; No test for pointer! to c-string! as it would simply
  ;;  duplicate the one of c-string! to pointer!

  --test-- "csp-6"
    csp6-p: declare pointer! [integer!]
    csp6-s: declare struct! [
      a [integer!]
      b [integer!]
    ]
    csp6-s/a: 1
    csp6-s/b: 2
    csp6-p: as [pointer! [integer!]] csp6-s
  --assert csp6-p/value = 1
    csp6-p: csp6-p + 1
  --assert csp6-p/value = 2
    csp6-p: csp6-p - 1
    csp6-s: as [struct! [a [integer!] b [integer!]]] csp6-p
  --assert csp6-s/a = 1
    csp6-p: csp6-p + 1
    csp6-s: as [struct! [a [integer!] b [integer!]]] csp6-p
  --assert csp6-s/a = 2

===end-group===

===start-group=== "cast from struct!"

  ;; no test for cast to integer as it would simply
  ;;  duplicate the test from integer! to struct!

  --test-- "cfstruc-1"
    cfs1-struct: declare struct! [
      a [integer!]
      b [integer!]
    ]
    cfs1-struct: as [struct! [a [integer!] b [integer!]]] 0
  --assert false = as logic! cfs1-struct

  --test-- "cfstruc-2"
    cfs2-struct: declare struct! [
      a [integer!]
      b [integer!]
    ]
  --assert true = as logic! cfs2-struct

  ;; no test for cast to c-string! as it would simply
  ;;  duplicate the test from c-string! to struct!

  ;; no test for cast to pointer! as it would simply
  ;;  duplicate the test from pointer! to struct!

===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System datatype casting test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %cast-test.reds
	Rights:  "Copyright (C) 2011 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.reds

~~~start-file~~~ "cast"

===start-group=== "cast from byte!"

	--test-- "byte-cast-1"
	--assert 65 = as integer! #"A"

	--test-- "byte-cast-2"
	  cast-b: #"A"
	  cast-i: 65
	--assert cast-i = as integer! cast-b

	--test-- "byte-cast-3"
	--assert false = as logic! #"^(00)"

	--test-- "byte-cast-4"
    cast-b: #"^(00)"
	  l: false
	--assert l = as logic! cast-b

	--test-- "byte-cast-5"
	--assert true = as logic! #"A"

	--test-- "byte-cast-6"
	  cast-b: #"A"
	  l: true
	--assert l = as logic! cast-b

	--test-- "byte-cast-7"
	--assert true = as logic! #"^(FF)"

	--test-- "byte-cast-8"
	  cast-b: #"^(FF)"
	  l: true
	--assert l = as logic! cast-b

	--test-- "byte-cast-9"
		a: as-byte 10h
		b: as-byte 80h
	--assert 10h = as-integer a

===end-group===

===start-group=== "cast from integer!"
comment {
  --test-- "int-cast-1"
  --assert #"^(00)" = as byte! 0
}
  --test-- "int-cast-2"
    i: 0
    cast-test-b: #"^(00)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-3"
  --assert #"^(01)" = as byte! 1

  --test-- "int-cast-4"
    i: 1
    cast-test-b: #"^(01)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-5"
  --assert #"^(FF)" = as byte! 255

  --test-- "int-cast-6"
    i: 255
    cast-test-b: #"^(FF)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-7"
  --assert #"^(00)" = as byte! 256

  --test-- "int-cast-8"
    i: 256
    cast-test-b: #"^(00)"
  --assert cast-test-b = as byte! i

  --test-- "int-cast-9"
  --assert false = as logic! 0

  --test-- "int-cast-10"
    i: 0
    l: false
  --assert l = as logic! i

  --test-- "int-cast-11"
  --assert true = as logic! FFFFFFFFh

  --test-- "int-cast-12"
    i: FFFFFFFFh
    l: true
  --assert l = as logic! i

  --test-- "int-cast-13"
  --assert true = as logic! 1

  --test-- "int-cast-14"
    i: 1
    l: true
  --assert l = as logic! i

  --test-- "int-cast-15"
    cs: "Hello"
    cs2: ""
    i: as integer! cs
    i: i + 1
    cs2: as c-string! i
  --assert cs2/1 = #"e"
  --assert 4 = length? cs2

  --test-- "int-cast-16"           ;; This test assumes 32-bit target
    i: 1
    p: declare pointer! [integer!]
    p: as [pointer! [integer!]] i
    P: P + 1
    i2: as integer! p
  --assert i2 = 5

  --test-- "int-cast-17"           ;; This test assumes 32-bit target
    ;; currently fails as p-int-cast is not declared
    i: 1
    p-int-cast-17: as [pointer! [integer!]] i
    P-int-cast-17: P-int-cast-17 + 1
    i2: as integer! p-int-cast-17
  --assert i2 = 5

  --test-- "int-cast-18"
    i: 1
    s: declare struct! [
      a [integer!]
      b [integer!]
    ]
    s: as [struct! [a [integer!] b [integer!]]] i
    s: s + 1
    i2: as integer! s
  --assert i2 = 9

  --test-- "int-cast-19"
    ic19-logic: either as-logic 0 [
      false
    ][
      true
    ]
  --assert ic19-logic

  --test-- "int-cast-20"
    ic20-dummy: func [return: [integer!]][0]
    ic20-logic: either as-logic ic20-dummy [
       false
    ][
      true
    ]
  --assert ic20-logic

===end-group===

===start-group=== "cast from logic!"

  --test-- "logic-cast-1"
  --assert #"^(01)" = as byte! true

  --test-- "logic-cast-2"
    cast-test-b: #"^(01)"
    l: true
  --assert cast-test-b = as byte! l

  --test-- "logic-cast-3"
  --assert #"^(00)" = as byte! false

  --test-- "logic-cast-4"
    cast-test-b: #"^(00)"
    l: false
  --assert cast-test-b = as byte! l

    --test-- "logic-cast-5"
  --assert 1 = as integer! true

  --test-- "logic-cast-6"
    i: 1
    l: true
  --assert i = as integer! l

  --test-- "logic-cast-7"
  --assert 0 = as integer! false

  --test-- "logic-cast-8"
    i: 0
    l: false
  --assert i = as integer! l

===end-group===

===start-group=== "cast c-string! tests"

  --test-- "c-string-cast-1"
    csc1-str: "Hello, Nenad"
    i: 0
    i: as integer! csc1-str
    i: i + 7
    csc1-str: as c-string! i
  --assert csc1-str/1 = #"N"
  --assert csc1-str/2 = #"e"
  --assert csc1-str/3 = #"n"
  --assert csc1-str/4 = #"a"
  --assert csc1-str/5 = #"d"
  comment {
  --test-- "c-string-cast-2"
  --assert false = as logic! ""
  }
    --test-- "c-string-cast-3"
    csc3-str: ""
  --assert false = as logic! csc3-str

  --test-- "c-string-cast-4"
  --assert true = as logic! "Any old iron, any old iron"

  --test-- "c-string-cast-5"
    csc5-str: "Why not?"
  --assert true = as logic! csc5-str

  --test-- "c-string-cast-6"
    csc6-str: "Tour de France"
    csc6-p: declare pointer! [integer!]
    csc6-p: as [pointer! [integer!]] csc6-str
    csc6-p: csc6-p + 2
    csc6-str2: as c-string! csc6-p
  --assert csc6-str2/1 = #"F"
  --assert csc6-str2/2 = #"r"
  --assert csc6-str2/3 = #"a"
  --assert csc6-str2/4 = #"n"
  --assert csc6-str2/5 = #"c"
  --assert csc6-str2/6 = #"e"

  --test-- "C-string-cast-7"
    csc7-struct: declare struct! [
      c1 [byte!]
      c2 [byte!]
      c3 [byte!]
      c4 [byte!]
      c5 [byte!]
    ]
    csc7-str: "Peter"
    csc7-struct: as [struct! [
      c1 [byte!] c2 [byte!] c3 [byte!] c4 [byte!] c5 [byte!]
    ]] csc7-str
  --assert csc7-struct/c1 = #"P"
  --assert csc7-struct/c2 = #"e"
  --assert csc7-struct/c3 = #"t"
  --assert csc7-struct/c4 = #"e"
  --assert csc7-struct/c5 = #"r"

===end-group===

===start-group=== "cast from pointer!"

  --test-- "csp-1"
    csp1-p: declare pointer! [integer!]
    csp1-p: as [pointer! [integer!]] 256
    i: 0
    i: as integer! csp1-p
  --assert i = 256

  --test-- "csp-2"
    csp2-p: declare pointer! [integer!]
    csp2-p: as [pointer! [integer!]] 0
  --assert false = as logic! csp2-p

  --test-- "csp-3"
    csp3-p: declare pointer! [integer!]
    csp3-p: as [pointer! [integer!]] 1
  --assert true = as logic! csp3-p

  --test-- "csp-4"
    csp4-p: declare pointer! [integer!]
    csp4-p: as [pointer! [integer!]] FFFFFFFFh
  --assert true = as logic! csp4-p

  --test-- "csp-5"
    csp5-p: declare pointer! [integer!]
    csp5-p: as [pointer! [integer!]] 7FFFFFFFh
  --assert true = as logic! csp5-p

  ;; No test for pointer! to c-string! as it would simply
  ;;  duplicate the one of c-string! to pointer!

  --test-- "csp-6"
    csp6-p: declare pointer! [integer!]
    csp6-s: declare struct! [
      a [integer!]
      b [integer!]
    ]
    csp6-s/a: 1
    csp6-s/b: 2
    csp6-p: as [pointer! [integer!]] csp6-s
  --assert csp6-p/value = 1
    csp6-p: csp6-p + 1
  --assert csp6-p/value = 2
    csp6-p: csp6-p - 1
    csp6-s: as [struct! [a [integer!] b [integer!]]] csp6-p
  --assert csp6-s/a = 1
    csp6-p: csp6-p + 1
    csp6-s: as [struct! [a [integer!] b [integer!]]] csp6-p
  --assert csp6-s/a = 2

===end-group===

===start-group=== "cast from struct!"

  ;; no test for cast to integer as it would simply
  ;;  duplicate the test from integer! to struct!

  --test-- "cfstruc-1"
    cfs1-struct: declare struct! [
      a [integer!]
      b [integer!]
    ]
    cfs1-struct: as [struct! [a [integer!] b [integer!]]] 0
  --assert false = as logic! cfs1-struct

  --test-- "cfstruc-2"
    cfs2-struct: declare struct! [
      a [integer!]
      b [integer!]
    ]
  --assert true = as logic! cfs2-struct

  ;; no test for cast to c-string! as it would simply
  ;;  duplicate the test from c-string! to struct!

  ;; no test for cast to pointer! as it would simply
  ;;  duplicate the test from pointer! to struct!

===end-group===

~~~end-file~~~


TESTS: reformat c-string-test.reds

TESTS: reformat c-string-test.reds

Red/System [
	Title:   "Red/System c-string! datatype test script"
	Author:  "Nenad Rakocevic"
	File: 	 %c-string-test.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/red/red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "c-string!"

===start-group=== "String arithmetic tests"

	--test-- "string-math-1"
		stringA: "test"
		stringB: stringA + 1
		--assert stringB/1 = #"e"
		stringB: stringA + 2
		--assert stringB/1 = #"s"
		stringB: stringA + 3
		--assert stringB/1 = #"t"
		stringB: stringA + 4
		--assert stringB/1 = #"^@"

	--test-- "string-math-2"
		stringC: stringB - 1
		--assert stringC/1 = #"t"
		stringC: stringB - 2
		--assert stringC/1 = #"s"
		stringC: stringB - 3
		--assert stringC/1 = #"e"
		stringC: stringB - 4
		--assert stringC/1 = #"t"

	--test-- "string-math-3"
		string-idx: 2
		stringB: stringA + string-idx
		--assert stringB/1 = #"s"

	--test-- "string-math-4"
		string-idx: -3
		stringB: stringA + 4
		stringC: stringB + string-idx
		--assert stringC/1 = #"e"

===end-group===

===start-group=== "Local string arithmetic tests"

	string-local-foo: func [
		/local
			stringA 	[c-string!]
			stringB 	[c-string!]
			stringC 	[c-string!]
			string-idx 	[integer!]
	][
	--test-- "loc-str-math-1"
		stringA: "test"
		stringB: stringA + 1
		--assert stringB/1 = #"e"
		stringB: stringA + 2
		--assert stringB/1 = #"s"
		stringB: stringA + 3
		--assert stringB/1 = #"t"
		stringB: stringA + 4
		--assert stringB/1 = #"^@"

	--test-- "loc-str-math-2"
		stringC: stringB - 1
		--assert stringC/1 = #"t"
		stringC: stringB - 2
		--assert stringC/1 = #"s"
		stringC: stringB - 3
		--assert stringC/1 = #"e"
		stringC: stringB - 4
		--assert stringC/1 = #"t"

	--test-- "loc-str-math-3"
		string-idx: 2
		stringB: stringA + string-idx
		--assert stringB/1 = #"s"

	--test-- "loc-str-math-4"
		string-idx: -3
		stringB: stringA + 4
		stringC: stringB + string-idx
		--assert stringC/1 = #"e"
	]
	string-local-foo

===end-group===

===start-group=== "reported issues"

===end-group===

~~~end-file~~~