FEAT: reduced memory usage in compressor function.

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 		18			;-- window size (17..23)
	#define CRUSH_W_SIZE 		262144		;-- 1 << CRUSH_W_BITS
	#define CRUSH_W_MASK 		262143		;-- 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		1048576		;-- 1 << 20  --> 1MB

	#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	18
	#define CRUSH_HASH2_BITS	20
	#define CRUSH_HASH1_SIZE	524288		;-- 1 << CRUSH_HASH1_BITS
	#define CRUSH_HASH2_SIZE	1048576		;-- 1 << CRUSH_HASH2_BITS
	#define CRUSH_HASH1_MASK	524287		;-- CRUSH_HASH1_SIZE - 1
	#define CRUSH_HASH2_MASK	1048575		;-- CRUSH_HASH2_SIZE - 1
	#define CRUSH_HASH1_SHIFT	7           ;-- (CRUSH_HASH1_BITS + (CRUSH_HASH1_LEN - 1)) / CRUSH_HASH1_LEN
	#define CRUSH_HASH2_SHIFT	5           ;-- (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

		assert index + 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: 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
	]
]


TESTS: added more series allocation/freeing/compacting tests

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

#include %../runtime/runtime.reds

;-- add a minimal number of memory frames
alloc-node-frame nodes-per-frame
alloc-series-frame

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

memory-stats 3

dump-series-frame memory/s-active

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

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

memory-stats 3

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

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

memory-stats 3

print [lf ">> freeing all new short series" lf]
idx: 25
until [
	idx: idx - 1
	free-series memory/s-head as int-ptr! array/idx
	zero? idx
]

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

memory-stats 3

free as byte-ptr! array
free-all

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

#include %../runtime/runtime.reds

;-- add a minimal number of memory frames
alloc-node-frame nodes-per-frame
alloc-series-frame

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

memory-stats 3

dump-series-frame memory/s-active

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

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

memory-stats 3

free-all


FEAT: updated version in head banner.

FEAT: updated version in head banner.

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

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

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

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

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

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

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

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

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

draw-vline: does [print "|"]

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

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

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

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

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

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

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

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

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

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

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

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

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

draw-vline: does [print "|"]

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

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

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

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


FIX: local words declaration removed from console script, now that FUNCTION is deep-collecting again.

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

#system-global [
	#if OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: 	 "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
			]
		]
	]
]

#include %input.red
#include %help.red

read-argument: routine [
	/local
		args [str-array!]
		str	 [red-string!]
][
	if system/args-count <> 2 [
		SET_RETURN(none-value)
		exit
	]
	args: system/args-list + 1							;-- skip binary filename
	str: simple-io/read-txt args/item
	SET_RETURN(str)
]

init-console: routine [
	str [string!]
	/local
		ret
][
	#either OS = 'Windows [
		;ret: AttachConsole -1
		;if zero? ret [print-line "ReadConsole failed!" halt]

		ret: SetConsoleTitle as c-string! string/rs-head str
		if zero? ret [print-line "SetConsoleTitle failed!" halt]
	][
		rl-bind-key as-integer tab as-integer :rl-insert-wrapper
	]
]

count-delimiters: function [
	buffer	[string!]
	return: [block!]
][
	list: copy [0 0]

	foreach c buffer [
		case [
			escaped?	[escaped?: no]
			in-comment? [if c = #"^/" [in-comment?: no]]
			'else [
				switch c [
					#"^^" [escaped?: yes]
					#";"  [if all [zero? list/2 not in-string?][in-comment?: yes]]
					#"["  [unless in-string? [list/1: list/1 + 1]]
					#"]"  [unless in-string? [list/1: list/1 - 1]]
					#"^"" [if zero? list/2 [in-string?: not in-string?]]
					#"{"  [if zero? list/2 [in-string?: yes] list/2: list/2 + 1]
					#"}"  [if 1 = list/2   [in-string?: no]  list/2: list/2 - 1]
				]
			]
		]
	]
	list
]

do-console: function [][
	buffer: make string! 10000
	prompt: red-prompt: "red>> "
	mode:  'mono

	switch-mode: [
		mode: case [
			cnt/1 > 0 ['block]
			cnt/2 > 0 ['string]
			'else 	  [
				prompt: red-prompt
				do eval
				'mono
			]
		]
		prompt: switch mode [
			block  ["[^-"]
			string ["{^-"]
			mono   [red-prompt]
		]
	]

	eval: [
		code: load/all buffer

		unless tail? code [
			set/any 'result do code

			unless unset? :result [
				if 67 = length? result: mold/part :result 67 [	;-- optimized for width = 72
					clear back tail result
					append result "..."
				]
				print ["==" result]
			]
		]
		clear buffer
	]

	while [true][
		unless tail? line: ask prompt [
			append buffer line
			cnt: count-delimiters buffer
			append buffer lf							;-- needed for multiline modes

			switch mode [
				block  [if cnt/1 <= 0 [do switch-mode]]
				string [if cnt/2 <= 0 [do switch-mode]]
				mono   [do either any [cnt/1 > 0 cnt/2 > 0][switch-mode][eval]]
			]
		]
	]
]

q: :quit

if script: read-argument [
	script: load script
	either any [
		not script/1 == 'Red
		not block? script/2
	][
		print "*** Error: not a Red program!"
	][
		do skip script 2
	]
	quit
]
init-console "Red Console"

print {
-=== Red Console alpha version ===-
Type HELP for starting information.
}

do-console

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

#system-global [
	#if OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: 	 "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
			]
		]
	]
]

#include %input.red
#include %help.red

read-argument: routine [
	/local
		args [str-array!]
		str	 [red-string!]
][
	if system/args-count <> 2 [
		SET_RETURN(none-value)
		exit
	]
	args: system/args-list + 1							;-- skip binary filename
	str: simple-io/read-txt args/item
	SET_RETURN(str)
]

init-console: routine [
	str [string!]
	/local
		ret
][
	#either OS = 'Windows [
		;ret: AttachConsole -1
		;if zero? ret [print-line "ReadConsole failed!" halt]

		ret: SetConsoleTitle as c-string! string/rs-head str
		if zero? ret [print-line "SetConsoleTitle failed!" halt]
	][
		rl-bind-key as-integer tab as-integer :rl-insert-wrapper
	]
]

count-delimiters: function [
	buffer	[string!]
	return: [block!]
][
	list: copy [0 0]
	c: escaped?: in-comment?: in-string?: none

	foreach c buffer [
		case [
			escaped?	[escaped?: no]
			in-comment? [if c = #"^/" [in-comment?: no]]
			'else [
				switch c [
					#"^^" [escaped?: yes]
					#";"  [if all [zero? list/2 not in-string?][in-comment?: yes]]
					#"["  [unless in-string? [list/1: list/1 + 1]]
					#"]"  [unless in-string? [list/1: list/1 - 1]]
					#"^"" [if zero? list/2 [in-string?: not in-string?]]
					#"{"  [if zero? list/2 [in-string?: yes] list/2: list/2 + 1]
					#"}"  [if 1 = list/2   [in-string?: no]  list/2: list/2 - 1]
				]
			]
		]
	]
	list
]

do-console: function [][
	buffer: make string! 10000
	prompt: red-prompt: "red>> "
	mode:  'mono
	code: result: line: none

	switch-mode: [
		mode: case [
			cnt/1 > 0 ['block]
			cnt/2 > 0 ['string]
			'else 	  [
				prompt: red-prompt
				do eval
				'mono
			]
		]
		prompt: switch mode [
			block  ["[^-"]
			string ["{^-"]
			mono   [red-prompt]
		]
	]

	eval: [
		code: load/all buffer

		unless tail? code [
			set/any 'result do code

			unless unset? :result [
				if 67 = length? result: mold/part :result 67 [	;-- optimized for width = 72
					clear back tail result
					append result "..."
				]
				print ["==" result]
			]
		]
		clear buffer
	]

	while [true][
		unless tail? line: ask prompt [
			append buffer line
			cnt: count-delimiters buffer
			append buffer lf							;-- needed for multiline modes

			switch mode [
				block  [if cnt/1 <= 0 [do switch-mode]]
				string [if cnt/2 <= 0 [do switch-mode]]
				mono   [do either any [cnt/1 > 0 cnt/2 > 0][switch-mode][eval]]
			]
		]
	]
]

q: :quit

if script: read-argument [
	script: load script
	either any [
		not script/1 == 'Red
		not block? script/2
	][
		print "*** Error: not a Red program!"
	][
		do skip script 2
	]
	quit
]
init-console "Red Console"

print {
-=== Red Console alpha version ===-
Type HELP for starting information.
}

do-console


FEAT: added default `pi` definition for Red/System.

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

#define zero? 		  [0 =]
#define positive?	  [0 < ]				;-- space required after the lesser-than symbol
#define negative?	  [0 > ]
#define negate		  [0 -]
#define null?		  [null =]

#define halt		  [quit 0]
#define forever		  [while [true]]
#define does		  [func []]
#define unless		  [if not]
#define	raise-error	  ***-on-quit
#define probe		  print-line

#define as-byte		  [as byte!]
#define as-logic	  [as logic!]
#define as-integer	  [as integer!]
#define as-float	  [as float!]
#define as-float32	  [as float32!]
#define as-c-string	  [as c-string!]

#define null-byte	  #"^(00)"
#define yes			  true
#define no			  false
#define on			  true
#define off			  false

#define byte-ptr!	  [pointer! [byte!]]
#define int-ptr!	  [pointer! [integer!]]
#define make-c-string [as c-string! allocate]

#define type-logic!		1					;-- type ID list for 'typeinfo attribut
#define type-integer!	2
#define type-byte!	    3
#define type-float32!	4
#define type-float64!	5					;-- float! is just an alias for float64!
#define type-float!		5
#define type-c-string!  6
#define type-byte-ptr!  7
#define type-int-ptr!	8
#define type-function!	9
#define type-struct!	1000
#define any-struct?		[1000 <=]
#define alias?  		[1001 <=]

#define CATCH_ALL		-1

;-- Global variables definition --
stdout:		-1								;-- uninitialized default value
stdin:		-1								;-- uninitialized default value
stderr:		-1								;-- uninitialized default value

newline: "^/"

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

pi: 3.141592653589793

str-array!: alias struct! [
	item [c-string!]
]

typed-value!: alias struct! [
	type	 [integer!]
	value	 [integer!]
	_padding [integer!]						;-- extra space for 64-bit values
]

typed-float!: alias struct! [
	type	 [integer!]
	value	 [float!]
]

#include %system.reds

;-------------------------------------------
;-- Convert a type ID to a c-string!
;-------------------------------------------
form-type: func [
	type 	[integer!]				  		;-- type ID
	return: [c-string!]						;-- type representation as c-string
][
	switch type [
		type-integer!   ["integer!"]
		type-c-string!  ["c-string!"]
		type-logic! 	["logic!"]
		type-byte! 	    ["byte!"]
		type-float32!   ["float32!"]
		type-float! 	["float!"]
		type-byte-ptr!  ["pointer! [byte!]"]
		type-int-ptr!   ["pointer! [integer!]"]
		type-struct!    ["struct!"]
		type-function!  ["function!"]
		default			[either alias? type ["alias"]["invalid type"]]
	]
]

#include %lib-names.reds

#either use-natives? = no [					;-- C bindings or native counterparts
	#include %libc.reds
][
	#include %lib-natives.reds
]

#switch OS [								;-- loading OS-specific bindings
	Windows  [
		#either type = 'drv [
			#include %win32-driver.reds
		][
			#include %win32.reds
		]
	]
	Syllable [#include %syllable.reds]
	MacOSX	 [#include %darwin.reds]
	Android	 [#include %android.reds]
	FreeBSD	 [#include %freebsd.reds]
	#default [#include %linux.reds]
]

#if type = 'exe [
	#switch target [
		IA-32 [
			system/fpu/control-word: 0272h		;-- default control word: division by zero, invalid op,
												;-- and overflow raise exceptions.
			system/fpu/update
		]
		ARM [
			system/fpu/option/rounding:  FPU_VFP_ROUNDING_NEAREST
			system/fpu/mask/overflow:	 yes
			system/fpu/mask/zero-divide: yes
			system/fpu/mask/invalid-op:  yes
			system/fpu/update
		]
	]
]

#if type <> 'drv [

	#include %utils.reds					;-- load additional utility functions

	#if debug? = yes [#include %debug.reds]	;-- loads optionally debug functions

	;-- Run-time error handling --

	#define RED_ERR_VMEM_RELEASE_FAILED		96
	#define RED_ERR_VMEM_OUT_OF_MEMORY		97

	***-on-quit: func [						;-- global exit handler
		status  [integer!]
		address [integer!]
		/local
			msg [c-string!]
	][
		unless zero? status [
			print [lf "*** Runtime Error " status ": "]

			msg: switch status [
				1	["access violation"]
				2	["invalid alignment"]
				3	["breakpoint"]
				4	["single step"]
				5	["bounds exceeded"]
				6	["float denormal operan"]
				7	["float divide by zero"]
				8	["float inexact result"]
				9	["float invalid operation"]
				10	["float overflow"]
				11	["float stack check"]
				12	["float underflow"]
				13	["integer divide by zero"]
				14	["integer overflow"]
				15	["privileged instruction"]
				16	["invalid virtual address"]
				17	["illegal instruction"]
				18	["non-continuable exception"]
				19	["stack error or overflow"]
				20	["invalid disposition"]
				21	["guard page"]
				22	["invalid handle"]
				23	["illegal operand"]
				24	["illegal addressing mode"]
				25	["illegal trap"]
				26	["coprocessor error"]
				27	["non-existant physical address"]
				28	["object specific hardware error"]
				29	["hardware memory error consumed AR"]
				30	["hardware memory error consumed AO"]
				31	["privileged register"]
				32	["segmentation fault"]	;-- generic SIGSEGV message
				33	["FPU error"]			;-- generic SIGFPE message
				34	["Bus error"]			;-- generic SIGBUS message

				96	["virtual memory release failed"]
				97	["out of memory"]
				98	["assertion failed"]
				99	["unknown error"]

				100	["no value matched in CASE"]
				101	["no value matched in SWITCH"]

				default ["unknown error code!"]
			]
			print msg

			#either debug? = yes [
				__print-debug-line as byte-ptr! address
			][
				print [lf "*** at: " as byte-ptr! address "h" lf]
			]
		]

		#if OS = 'Windows [					;-- special exit handler for Windows
			win32-startup-ctx/on-quit
		]
		quit status
	]
]

#if type = 'exe [
	push system/stack/frame					;-- save previous frame pointer
	system/stack/frame: system/stack/top	;-- @@ reposition frame pointer just after the catch flag
]
push CATCH_ALL								;-- exceptions root barrier
push 0										;-- keep stack aligned on 64-bit

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

#define zero? 		  [0 =]
#define positive?	  [0 < ]				;-- space required after the lesser-than symbol
#define negative?	  [0 > ]
#define negate		  [0 -]
#define null?		  [null =]

#define halt		  [quit 0]
#define forever		  [while [true]]
#define does		  [func []]
#define unless		  [if not]
#define	raise-error	  ***-on-quit
#define probe		  print-line

#define as-byte		  [as byte!]
#define as-logic	  [as logic!]
#define as-integer	  [as integer!]
#define as-float	  [as float!]
#define as-float32	  [as float32!]
#define as-c-string	  [as c-string!]

#define null-byte	  #"^(00)"
#define yes			  true
#define no			  false
#define on			  true
#define off			  false

#define byte-ptr!	  [pointer! [byte!]]
#define int-ptr!	  [pointer! [integer!]]
#define make-c-string [as c-string! allocate]

#define type-logic!		1					;-- type ID list for 'typeinfo attribut
#define type-integer!	2
#define type-byte!	    3
#define type-float32!	4
#define type-float64!	5					;-- float! is just an alias for float64!
#define type-float!		5
#define type-c-string!  6
#define type-byte-ptr!  7
#define type-int-ptr!	8
#define type-function!	9
#define type-struct!	1000
#define any-struct?		[1000 <=]
#define alias?  		[1001 <=]

#define CATCH_ALL		-1

;-- Global variables definition --
stdout:		-1								;-- uninitialized default value
stdin:		-1								;-- uninitialized default value
stderr:		-1								;-- uninitialized default value

newline: "^/"

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

str-array!: alias struct! [
	item [c-string!]
]

typed-value!: alias struct! [
	type	 [integer!]
	value	 [integer!]
	_padding [integer!]						;-- extra space for 64-bit values
]

typed-float!: alias struct! [
	type	 [integer!]
	value	 [float!]
]

#include %system.reds

;-------------------------------------------
;-- Convert a type ID to a c-string!
;-------------------------------------------
form-type: func [
	type 	[integer!]				  		;-- type ID
	return: [c-string!]						;-- type representation as c-string
][
	switch type [
		type-integer!   ["integer!"]
		type-c-string!  ["c-string!"]
		type-logic! 	["logic!"]
		type-byte! 	    ["byte!"]
		type-float32!   ["float32!"]
		type-float! 	["float!"]
		type-byte-ptr!  ["pointer! [byte!]"]
		type-int-ptr!   ["pointer! [integer!]"]
		type-struct!    ["struct!"]
		type-function!  ["function!"]
		default			[either alias? type ["alias"]["invalid type"]]
	]
]

#include %lib-names.reds

#either use-natives? = no [					;-- C bindings or native counterparts
	#include %libc.reds
][
	#include %lib-natives.reds
]

#switch OS [								;-- loading OS-specific bindings
	Windows  [
		#either type = 'drv [
			#include %win32-driver.reds
		][
			#include %win32.reds
		]
	]
	Syllable [#include %syllable.reds]
	MacOSX	 [#include %darwin.reds]
	Android	 [#include %android.reds]
	FreeBSD	 [#include %freebsd.reds]
	#default [#include %linux.reds]
]

#if type = 'exe [
	#switch target [
		IA-32 [
			system/fpu/control-word: 0272h		;-- default control word: division by zero, invalid op,
												;-- and overflow raise exceptions.
			system/fpu/update
		]
		ARM [
			system/fpu/option/rounding:  FPU_VFP_ROUNDING_NEAREST
			system/fpu/mask/overflow:	 yes
			system/fpu/mask/zero-divide: yes
			system/fpu/mask/invalid-op:  yes
			system/fpu/update
		]
	]
]

#if type <> 'drv [

	#include %utils.reds					;-- load additional utility functions

	#if debug? = yes [#include %debug.reds]	;-- loads optionally debug functions

	;-- Run-time error handling --

	#define RED_ERR_VMEM_RELEASE_FAILED		96
	#define RED_ERR_VMEM_OUT_OF_MEMORY		97

	***-on-quit: func [						;-- global exit handler
		status  [integer!]
		address [integer!]
		/local
			msg [c-string!]
	][
		unless zero? status [
			print [lf "*** Runtime Error " status ": "]

			msg: switch status [
				1	["access violation"]
				2	["invalid alignment"]
				3	["breakpoint"]
				4	["single step"]
				5	["bounds exceeded"]
				6	["float denormal operan"]
				7	["float divide by zero"]
				8	["float inexact result"]
				9	["float invalid operation"]
				10	["float overflow"]
				11	["float stack check"]
				12	["float underflow"]
				13	["integer divide by zero"]
				14	["integer overflow"]
				15	["privileged instruction"]
				16	["invalid virtual address"]
				17	["illegal instruction"]
				18	["non-continuable exception"]
				19	["stack error or overflow"]
				20	["invalid disposition"]
				21	["guard page"]
				22	["invalid handle"]
				23	["illegal operand"]
				24	["illegal addressing mode"]
				25	["illegal trap"]
				26	["coprocessor error"]
				27	["non-existant physical address"]
				28	["object specific hardware error"]
				29	["hardware memory error consumed AR"]
				30	["hardware memory error consumed AO"]
				31	["privileged register"]
				32	["segmentation fault"]	;-- generic SIGSEGV message
				33	["FPU error"]			;-- generic SIGFPE message
				34	["Bus error"]			;-- generic SIGBUS message

				96	["virtual memory release failed"]
				97	["out of memory"]
				98	["assertion failed"]
				99	["unknown error"]

				100	["no value matched in CASE"]
				101	["no value matched in SWITCH"]

				default ["unknown error code!"]
			]
			print msg

			#either debug? = yes [
				__print-debug-line as byte-ptr! address
			][
				print [lf "*** at: " as byte-ptr! address "h" lf]
			]
		]

		#if OS = 'Windows [					;-- special exit handler for Windows
			win32-startup-ctx/on-quit
		]
		quit status
	]
]

#if type = 'exe [
	push system/stack/frame					;-- save previous frame pointer
	system/stack/frame: system/stack/top	;-- @@ reposition frame pointer just after the catch flag
]
push CATCH_ALL								;-- exceptions root barrier
push 0										;-- keep stack aligned on 64-bit


TESTS: updated vector-test.red

TESTS: updated vector-test.red

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

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

~~~start-file~~~ "vector"

===start-group=== "make"

	vector-make-test: func [
		name [string!]
		type [datatype!]
		spec [block!]
		len [integer!]
		test-value [char! float! integer!]
		/local
			vm-v
	][
		--test-- name
		vm-v: make vector! spec
		--assert len = length? vm-v
		foreach v vm-v [
			test-value: test-value + 1
			--assert test-value = v
			--assert type = type? v
		]
		--assert none = vm-v/0
		--assert none = vm-v/(len + 1)
	]

	--test-- "vector-make-1"
		vm1-v: make vector! 10
		--assert 10 = length? vm1-v
		foreach v vm1-v [
			--assert v = 0
			--assert integer! = type? v
		]
		--assert none = vm1-v/0
		--assert none = vm1-v/11

	vector-make-test "vector-make-2" integer! [1 2 3 4 5] 5 0

	vector-make-test "vector-make-3" char! [#"b" #"c" #"d" #"e"] 4 #"a"

	vector-make-test "vector-make-4" float! [1.0 2.0 3.0 4.0 5.0] 5 0.0

	vector-make-test "vector-make-5" integer! [integer! 8 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-6" integer! [integer! 16 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-7" integer! [integer! 32 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-8" float! [float! 64 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

	vector-make-test "vector-make-9" float! [float! 32 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

===end-group===

===start-group=== "vector-truncate"

	--test-- "vector-trunc-1"
		vt1-v: make vector! [char! 8 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt1-v #"^(0100)"
		--assert 4 = length? vt1-v
		--assert #"^(00)" = vt1-v/4
		--assert none = vt1-v/5

	--test-- "vector-trunc-2"
		vt2-v: make vector! [char! 16 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt2-v #"^(100100)"
		--assert 4 = length? vt2-v
		--assert #"^(0100)" = vt2-v/4
		--assert none = vt2-v/5

	--test-- "vector-trunc-3"
		vt3-v: make vector! [integer! 8 [0 1 2]]
		append vt3-v 256
		--assert 4 = length? vt3-v
		--assert 0 = vt3-v/4
		--assert none = vt3-v/5

	--test-- "vector-trunc-4"
		vt4-v: make vector! [integer! 16 [0 1 2]]
		append vt4-v 65536
		--assert 4 = length? vt4-v
		--assert 0 = vt4-v/4
		--assert none = vt4-v/5

	--test-- "vector-trunc-6"
		vt5-v: make vector! [float! 32 [0.0 1.0 2.0]]
		append vt5-v 1.23456789012345678901234567
		--assert 1.2345679 = round/to vt5-v/4 0.0000001

===end-group===

===start-group=== "vector path notation"

	--test-- "vector-path-1"
		vp1-v: [0 1 2 3 4]
		--assert none = vp1-v/0
		--assert 0 = vp1-v/1
		--assert 1 = vp1-v/2
		--assert 2 = vp1-v/3
		--assert 3 = vp1-v/4
		--assert 4 = vp1-v/5
		--assert none = vp1-v/6
		--assert none = vp1-v/-1

===end-group===

~~~end-file~~~

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

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

~~~start-file~~~ "vector"

===start-group=== "make"

	vector-make-test: func [
		name [string!]
		type [datatype!]
		spec [block!]
		len [integer!]
		test-value [char! float! integer!]
		/local
			vm-v
	][
		--test-- name
		vm-v: make vector! spec
		--assert len = length? vm-v
		foreach v vm-v [
			test-value: test-value + 1
			--assert test-value = v
			--assert type = type? v
		]
		--assert none = vm-v/0
		--assert none = vm-v/(len + 1)
	]

	--test-- "vector-make-1"
		vm1-v: make vector! 10
		--assert 10 = length? vm1-v
		foreach v vm1-v [
			--assert v = 0
			--assert integer! = type? v
		]
		--assert none = vm1-v/0
		--assert none = vm1-v/11

	vector-make-test "vector-make-2" integer! [1 2 3 4 5] 5 0

	vector-make-test "vector-make-3" char! [#"b" #"c" #"d" #"e"] 4 #"a"

	vector-make-test "vector-make-4" float! [1.0 2.0 3.0 4.0 5.0] 5 0.0

	vector-make-test "vector-make-5" integer! [integer! 8 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-6" integer! [integer! 16 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-7" integer! [integer! 32 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-8" float! [float! 64 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

	vector-make-test "vector-make-9" float! [float! 32 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

===end-group===

===start-group=== "vector-truncate"

	--test-- "vector-trunc-1"
		vt1-v: make vector! [char! 8 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt1-v #"^(0100)"
		--assert 4 = length? vt1-v
		--assert #"^(00)" = vt1-v/4
		--assert none = vt1-v/5

	--test-- "vector-trunc-2"
		vt2-v: make vector! [char! 16 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt2-v #"^(100100)"
		--assert 4 = length? vt2-v
		--assert #"^(0100)" = vt2-v/4
		--assert none = vt2-v/5

	--test-- "vector-trunc-3"
		vt3-v: make vector! [integer! 8 [0 1 2]]
		append vt3-v 256
		--assert 4 = length? vt3-v
		--assert 0 = vt3-v/4
		--assert none = vt3-v/5

	--test-- "vector-trunc-4"
		vt4-v: make vector! [integer! 16 [0 1 2]]
		append vt4-v 65536
		--assert 4 = length? vt4-v
		--assert 0 = vt4-v/4
		--assert none = vt4-v/5

	--test-- "vector-trunc-6"
		vt5-v: make vector! [float! 32 [0.0 1.0 2.0]]
		append vt5-v 1.23456789012345678901234567
		--assert 1.234567880630493 = vt5-v/4

===end-group===

===start-group=== "vector path notation"

	--test-- "vector-path-1"
		vp1-v: [0 1 2 3 4]
		--assert none = vp1-v/0
		--assert 0 = vp1-v/1
		--assert 1 = vp1-v/2
		--assert 2 = vp1-v/3
		--assert 3 = vp1-v/4
		--assert 4 = vp1-v/5
		--assert none = vp1-v/6
		--assert none = vp1-v/-1

===end-group===

~~~end-file~~~


FIX: replaced __xstat() binding by the simpler __fxstat().

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!]
					]
				]
			]
		][
			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!]
			]
			#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
		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!]
					]
				]
			]
		][
			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!]
			]
			#import [
				LIBC-file cdecl [
					;--- http://refspecs.linuxbase.org/LSB_3.0.0/LSB-Core-generic/LSB-Core-generic/baselib-xstat-1.html
					_stat:	"__xstat" [
						version		[integer!]
						filename	[c-string!]
						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!]
		filename [c-string!]
		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 filename 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 filename
		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
		free buffer
		str
	]
]


r348: Screencasts link

r348: Screencasts link

h1. Screencasts

<div class="screencast_image">
  !/images/documentation/5_minute_install.png!:http://www.cruisecontrolrb.com.php5-1.websitetestlink.com/5_minute_install.mov
</div>

h3. "5 Minute Install":http://www.cruisecontrolrb.com.php5-1.websitetestlink.com/5_minute_install.mov

This is a 5 minute video that takes you through the steps of getting cruise control up and running with a rails project.

h1. Screencasts

<div class="screencast_image">
  !/images/documentation/5_minute_install.png!:http://cruisecontrolrb.thoughtworks.com.nyud.net:8080/screencasts/5_minute_install.mov
</div>

h3. "5 Minute Install":http://cruisecontrolrb.thoughtworks.com.nyud.net:8080/screencasts/5_minute_install.mov

This is a 5 minute video that takes you through the steps of getting cruise control up and running with a rails project.


removed unneeded lines

removed unneeded lines

Red []

{
subleq a, b, c   ; Mem[b] = Mem[b] - Mem[a]
                 ; if (Mem[b] = 0) goto c

. at start means it's not an instruction
. a:b defines a label a to be b
. a:  defines a label for a position
z always = 0

? ; jump to next line
a ; same as a a ?
a b ; same as a b ?

a = 0
a a  => a = a - a = 0
a a

jmp c
Z Z c ; 0-0=0, jmp c

add a, b
a Z ; Z = Z - a = -a
Z b ; b = b - z = b - -a = b + a
Z Z ; Z = Z - Z = 0

mov a, b
b b ; b = 0
a Z ; Z = -a
Z b ; b = a + 0 = a
Z Z ; Z = 0
}

apply: func [f block [block!]] [
    while [not tail? block] [
        block: change block f first block
    ]
]

parser: func [lines [string!]][
    memory: copy []
    label-table: make map! []
    patching-table: make map! []

    space:      charset " "
    minus:      charset "-"
    digit:      charset "0123456789"
    letters:    charset [#"A" - #"Z" #"a" - #"z" ]
    alphanum:   union letters digit

    number:     [some digit]
    address:    [number | minus number]
    variable:   [some alphanum]
    thing:      [address | variable]

    label-left: [
        copy data
        some alphanum
        (label-table/(data): length? memory)
    ]

    label-right: [
        copy data
        any [":" any space some alphanum]
        (
            label-data: trim pick split data ":" 2
            append memory label-data
        )
    ]

    label: [
        any space "." any space label-left any space label-right
    ]

    thing-with-action: [
            copy data
            address
            (append memory data)
        |
            copy data
            variable
            (
                append memory 0
                patching-table/(length? memory ): data
            )
    ]

    three: [thing space thing space thing]
    two: [thing space thing]
    one: [thing]

    command: [
            copy data
            three
            (
                parse data [thing-with-action space thing-with-action space thing-with-action]
            )
        |
            copy data
            two
            (
                parse data [thing-with-action space thing-with-action]
                append memory add length? memory 2
            )
        |
            copy data
            one
            (
                loop 2 [parse data [thing-with-action]]
                append memory add length? memory 2
            )
    ]

    rules: [
        some [
            [label | command] opt thru newline
        ]
    ]

    parse lines rules
    foreach key keys-of patching-table [
        poke memory key label-table/(patching-table/(key))
    ]

    apply :to-integer memory
    memory
]

vm: func [memory [block!]][
    probe memory

    pc: 0
    while [lesser? pc length? memory] [
        ask ""
        if error? err: try [
            a: pick memory add pc 1
            b: pick memory add pc 2
            c: pick memory add pc 3

            print copy ""
            print append copy "pc: " pc
            print append copy "a: " a
            print append copy "b: " b
            print append copy "c: " c

            either (equal? b -1) [
                if error? poke memory a to-int input [
                    poke memory (add a 1) to-int to-string input
                ]
            ] [
                either (equal? b -2) [
                    print pick memory (add a 1)
                    attempt print to-string pick memory (add a 1)
                ] [
                    poke memory (add b 1) subtract pick memory (add b 1) pick memory (add a 1)
                ]
            ]

            if (lesser? c -1) [
                print "c < -1" break
            ]

            either and~ (lesser-or-equal? (pick memory (add b 1)) 0) (greater-or-equal? c 0) [
                pc: c
            ] [
                pc: add pc 3
            ]
        ] [
            print append "error: " err break
        ]

    ]
    probe memory
]

input_code: {3 4 6
7 7 7
0 0 0}

tokens: parser input_code
vm tokens

Red []

{
subleq a, b, c   ; Mem[b] = Mem[b] - Mem[a]
                 ; if (Mem[b] = 0) goto c

. at start means it's not an instruction
. a:b defines a label a to be b
. a:  defines a label for a position
z always = 0

? ; jump to next line
a ; same as a a ?
a b ; same as a b ?

a = 0
a a  => a = a - a = 0
a a

jmp c
Z Z c ; 0-0=0, jmp c

add a, b
a Z ; Z = Z - a = -a
Z b ; b = b - z = b - -a = b + a
Z Z ; Z = Z - Z = 0

mov a, b
b b ; b = 0
a Z ; Z = -a
Z b ; b = a + 0 = a
Z Z ; Z = 0
}

apply: func [f block [block!]] [
    while [not tail? block] [
        block: change block f first block
    ]
]

parser: func [lines [string!]][
    memory: copy []
    label-table: make map! []
    patching-table: make map! []

    space:      charset " "
    minus:      charset "-"
    digit:      charset "0123456789"
    letters:    charset [#"A" - #"Z" #"a" - #"z" ]
    alphanum:   union letters digit

    number:     [some digit]
    address:    [number | minus number]
    variable:   [some alphanum]
    thing:      [address | variable]

    label-left: [
        copy data
        some alphanum
        (label-table/(data): length? memory)
    ]

    label-right: [
        copy data
        any [":" any space some alphanum]
        (
            label-data: trim pick split data ":" 2
            append memory label-data
        )
    ]

    label: [
        any space "." any space label-left any space label-right
    ]

    thing-with-action: [
            copy data
            address
            (append memory data)
        |
            copy data
            variable
            (
                append memory 0
                patching-table/(length? memory ): data
            )
    ]

    three: [thing space thing space thing]
    two: [thing space thing]
    one: [thing]

    command: [
            copy data
            three
            (
                parse data [thing-with-action space thing-with-action space thing-with-action]
            )
        |
            copy data
            two
            (
                parse data [thing-with-action space thing-with-action]
                append memory add length? memory 2
            )
        |
            copy data
            one
            (
                loop 2 [parse data [thing-with-action]]
                append memory add length? memory 2
            )
    ]

    rules: [
        some [
            [label | command] opt thru newline
        ]
    ]

    parse lines rules

    probe label-table
    probe patching-table

    foreach key keys-of patching-table [
        probe key
        probe memory/(key)
        probe patching-table/(key)
        poke memory key label-table/(patching-table/(key))
    ]

    apply :to-integer memory
    memory
]

vm: func [memory [block!]][
    probe memory

    pc: 0
    while [lesser? pc length? memory] [
        ask ""
        if error? err: try [
            a: pick memory add pc 1
            b: pick memory add pc 2
            c: pick memory add pc 3

            print copy ""
            print append copy "pc: " pc
            print append copy "a: " a
            print append copy "b: " b
            print append copy "c: " c

            either (equal? b -1) [
                if error? poke memory a to-int input [
                    poke memory (add a 1) to-int to-string input
                ]
            ] [
                either (equal? b -2) [
                    print pick memory (add a 1)
                    attempt print to-string pick memory (add a 1)
                ] [
                    poke memory (add b 1) subtract pick memory (add b 1) pick memory (add a 1)
                ]
            ]

            if (lesser? c -1) [
                print "c < -1" break
            ]

            either and~ (lesser-or-equal? (pick memory (add b 1)) 0) (greater-or-equal? c 0) [
                pc: c
            ] [
                pc: add pc 3
            ]
        ] [
            print append "error: " err break
        ]

    ]
    probe memory
]

input_code: {3 4 6
7 7 7
0 0 0}

tokens: parser input_code
vm tokens


FEAT: added data size in compressed 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: 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
	]
]

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

		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

		crush/index
	]

	decompress: func [
		data	[byte-ptr!]
		length	[integer!]
		written [int-ptr!]
		return: [byte-ptr!]
		/local
			i			[integer!]
			s			[integer!]
			ss			[integer!]
			p			[integer!]
			pp			[integer!]
			len			[integer!]
			log			[integer!]
			size		[integer!]
			buf			[byte-ptr!]
			head		[int-ptr!]
			p4			[int-ptr!]
			crush		[crush!]
	][
		crush: declare crush!
		init crush length 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
				]
			]
		]

		written/value: crush/index
		crush/buf
	]
]