TESTS: restore tests re: issue #555 to logic-test.reds

Red/System [
	Title:   "Red/System logic! datatype test script"
	Author:  "Nenad Rakocevic"
	File: 	 %logic-test.reds
	Version: 0.1.1
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "logic"

===start-group=== "literal logic! value tests"
	--test-- "llv-1"
		--assert true

	--test-- "llv-2"
		--assert not false
===end-group===

===start-group=== "logic variable tests"
	--test-- "lv-1"
	 	a: true
	 	--assert a

	--test-- "lv-2"
	 	a: false
	 	--assert not a
===end-group===

===start-group=== "conditional expression assignment tests"
	--test-- "lce-1"
		a: 3 < 5
		--assert a

	--test-- "lce-2"
		a: 1 = 2
		--assert not a
===end-group===

===start-group=== "logic value as last conditional expression in UNTIL tests"
  --test-- "lu-1"
    a: true
    i: 0
    until [
      i: i + 1
      a
    ]
  --assert i = 1

  --test-- "lu-2"
    i: 0
    c: 3
    stop?: false
    until [
      i: i + 1
      c: c - 1
      if zero? c [stop?: true]
      stop?
    ]
  --assert c = 0
  --assert i = 3
===end-group===

===start-group=== "logic value as conditional expression in WHILE tests"
	--test-- "lw-1"
		a: false
		i: 0
		while [a][i: i + 1]
		--assert i = 0

	--test-- "lw-2"
		i: 0
		c: 3
		run?: true
		while [run?][
			i: i + 1
			c: c - 1
			if zero? c [run?: false]
		]
		--assert c = 0
		--assert i = 3
===end-group===

===start-group=== "passing logic! as function's argument tests"
	log-foo: func [a [logic!] return: [logic!]][a]

	--test-- "logic-arg-1"	--assert log-foo true
	--test-- "logic-arg-2"	--assert not log-foo false
	--test-- "logic-arg-3"	--assert log-foo 1 < 2
	--test-- "logic-arg-4"	--assert log-foo 3 <> 4
	--test-- "logic-arg-5"	--assert log-foo (1 + 1 < 3)
	--test-- "logic-arg-6"
		a: false
		if false = log-foo (2 + 2 = 5) [a: true]
		--assert a
	--test-- "logic-arg-7"
		--assert not log-foo 3 = 4

===end-group===

===start-group=== "all with logic!"

	--test-- "logic-all-1"
	 	result:  all [
	 		true
	 		true
	 	]
	 	--assert result

	--test-- "logic-all-2"
		result: all [
			false
			true
		]
		--assert not result

	--test-- "logic-all-3"
		result all [
			true
			false
		]
		--assert not result

	--test-- "logic-all-4"
		result: all [
			false
			false
		]
		--assert not result

	--test-- "logic-all-5"
		a: all [true]
		--assert a

	--test-- "logic-all-6"
		a: all [false]
		--assert not a

	--test-- "logic-all-7"
		a: all [1 < 2 false]
		--assert not a

	--test-- "logic-all-8"
		a: all [false 1 < 2]
		--assert not a

	--test-- "logic-all-9"
		a: all [true 1 = 2]
		--assert not a

	--test-- "logic-all-10"
		a: all [1 = 2 true]
		--assert not a

	--test-- "logic-all-11"
		a: all [1 < 2]
		--assert a

	--test-- "logic-all-12"
		a: all [1 = 2]
		--assert not a

	--test-- "logic-all-13"
		a: all [1 < 2 3 <> 4]
		--assert a

	--test-- "logic-all-14"
		a: all [1 = 2 3 <> 4]
		--assert not a

	--test-- "logic-all-15"
		--assert not log-foo all [1 = 2]

	--test-- "logic-all-16"
		--assert log-foo all [1 < 2 3 <> 4]

	--test-- "logic-all-17"
		--assert not log-foo all [1 = 2 3 <> 4]

	--test-- "logic-all-18"
		a: log-foo all [1 < 2]
		--assert a

	--test-- "logic-all-19"
		a: log-foo all [1 = 2]
		--assert not a

	--test-- "logic-all-20"
		a: log-foo all [1 < 2 3 <> 4]
		--assert a

	--test-- "logic-all-21"
		a: all [log-foo true]
		--assert a

===end-group===

===start-group=== "any with logic!"

	--test-- "logic-any-1"
		result: any [
			true
			true
		]
		--assert result

	--test-- "logic-any-2"
		result: any [
			false
			true
		]
		--assert result

	--test-- "logic-any-3"
		result: any [
			true
			false
		]
		--assert result

	--test-- "logic-any-4"
		result: any [
			false
			false
		]
		--assert not result

	--test-- "logic-any-5"
		a: any [true]
		--assert a

	--test-- "logic-any-6"
		a: any [false]
		--assert not a

	--test-- "logic-any-7"
		a: any [1 < 2 false]
		--assert a

	--test-- "logic-any-8"
		a: any [false 1 < 2]
		--assert a

	--test-- "logic-any-9"
		a: any [true 1 = 2]
		--assert a

	--test-- "logic-any-10"
		a: any [1 = 2 true]
		--assert a

	--test-- "logic-any-11"
		a: any [1 < 2]
		--assert a

	--test-- "logic-any-12"
		a: any [1 = 2]
		--assert not a

	--test-- "logic-any-13"
		a: any [1 < 2 3 <> 4]
		--assert a

	--test-- "logic-any-14"
		a: any [1 = 2 3 <> 4]
		--assert a

	--test-- "logic-any-15"
		--assert not log-foo any [1 = 2]

	--test-- "logic-any-16"
		--assert log-foo any [1 < 2 3 <> 4]

	--test-- "logic-any-17"
		--assert log-foo any [1 = 2 3 <> 4]

	--test-- "logic-any-18"
		a: log-foo any [1 < 2]
		--assert a

	--test-- "logic-any-19"
		a: log-foo any [1 = 2]
		--assert not a

	--test-- "logic-any-20"
		a: log-foo any [1 < 2 3 <> 4]
		--assert a

	--test-- "logic-any-21"
		a: any [log-foo true]
		--assert a

===end-group===

===start-group=== "function returning a logic value"
		lgc-test?: func [
			return: [logic!]
		][
			either 1 < 2 [true] [false]
		]

	--test-- "logic-return-1"
		--assert lgc-test?

	--test-- "logic-return-2"
		a: lgc-test?
		--assert a

		lgc-test2?: func [
			return: [logic!]
		][
			either 1 = 2 [true] [false]
		]

	--test-- "logic-return-3"
		--assert not lgc-test2?

	--test-- "logic-return-4"
		a: lgc-test2?
		--assert not a

		lgc-test3?: func [return: [logic!]][
			either true [
				1 = 3
			][
				false
			]
		]

	--test-- "logic-return-5"
		--assert not lgc-test3?

		lgc-test4?: func [return: [logic!]][
			either false [
				1 = 3
			][
				false
			]
		]

	--test-- "logic-return-6"
		--assert not lgc-test4?

		lgc-test5?: func [return: [logic!]][
			either 1 < 2 [true] [false]
		]

	--test-- "logic-return-7"
		--assert lgc-test5?

===end-group===

===start-group=== "equality lgc-tests"

	--test-- "logic-=-1"
		a: false
		--assert a = false

	--test-- "logic-=-2"
		a: true
		--assert not a = false

	--test-- "logic-=-3"
		a: false
		--assert not a <> false

	--test-- "logic-=-4"
		a: true
		--assert a <> false

	--test-- "logic-=-5"
		a: false
		b: a = false
		--assert b

	--test-- "logic-=-6"
		a: true
		b: a = false
		--assert not b

	--test-- "logic-=-7"
		a: false
		b: false <> a
		--assert not b

	--test-- "logic-=-8"
		a: true
		b: false <> a
		--assert b

	--test-- "logic-=-9"
		a: false
		--assert log-foo a = false

	--test-- "logic-=-10"
		a: false
		--assert log-foo a = false

	--test-- "logic-=-11"
		a: true
		--assert not log-foo a = false

===end-group===

===start-group=== "logic value returned by function"

		fooT: func [return: [logic!]][1 < 2]
		fooF: func [return: [logic!]][1 = 2]

	--test-- "logic-ret-1" --assert fooT
	--test-- "logic-ret-2" --assert not fooF

===end-group===

===start-group=== "logic logical operators"
	--test-- "logic-and-1"	--assert true and true
	--test-- "logic-and-2"	--assert not (true and false)
	--test-- "logic-and-3"	--assert not (false and false)
	--test-- "logic-and-4"  --assert not (false and true)
	--test-- "logic-and-5"
		la5-l1: true
		la5-l2: true
		--assert la5-l1 and la5-l2
	--test-- "logic-and-6"
		la6-l1: true
		la6-l2: false
		--assert not (la6-l1 and la6-l2)
	--test-- "logic-and-7"
		la7-l1: false
		la7-l2: false
		--assert not (la7-l1 and la7-l2)
	--test-- "logic-and-8"
		la8-l1: false
		la8-l2: true
		--assert not (la8-l1 and la8-l2)
	--test-- "logic-or-1"	--assert true or true
	--test-- "logic-or-2"	--assert true or false
	--test-- "logic-or-3"	--assert not (false or false)
	--test-- "logic-or-4"	--assert false or true
	--test-- "logic-or-5"
		lo5-l1: true
		lo5-l2: true
		--assert lo5-l1 or lo5-l2
	--test-- "logic-or-6"
		lo6-l1: true
		lo6-l2: false
		--assert lo6-l1 or lo6-l2
	--test-- "logic-or-7"
		lo7-l1: false
		lo7-l2: false
		--assert not (lo7-l1 or lo7-l2)
	--test-- "logic-or-8"
		lo8-l1: false
		lo8-l2: true
		--assert lo8-l1 or lo8-l2
	--test-- "logic-xor-1"	--assert not (true xor true)
	--test-- "logic-xor-2"	--assert true xor false
	--test-- "logic-xor-3"	--assert not (false xor false)
	--test-- "logic-xor-4"  --assert false xor true
	--test-- "logic-xor-5"
		lx5-l1: true
		lx5-l2: true
		--assert not (lx5-l1 xor lx5-l2)
	--test-- "logic-xor-6"
		lx6-l1: true
		lx6-l2: false
		--assert lx6-l1 xor lx6-l2
	--test-- "logic-xor-7"
		lx7-l1: false
		lx7-l2: false
		--assert not (lx7-l1 xor lx7-l2)
	--test-- "logic-xor-8"
		lx8-l1: false
		lx8-l2: true
		--assert lx8-l1 xor lx8-l2

===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System logic! datatype test script"
	Author:  "Nenad Rakocevic"
	File: 	 %logic-test.reds
	Version: 0.1.1
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "logic"

===start-group=== "literal logic! value tests"
	--test-- "llv-1"
		--assert true

	--test-- "llv-2"
		--assert not false
===end-group===

===start-group=== "logic variable tests"
	--test-- "lv-1"
	 	a: true
	 	--assert a

	--test-- "lv-2"
	 	a: false
	 	--assert not a
===end-group===

===start-group=== "conditional expression assignment tests"
	--test-- "lce-1"
		a: 3 < 5
		--assert a

	--test-- "lce-2"
		a: 1 = 2
		--assert not a
===end-group===

===start-group=== "logic value as last conditional expression in UNTIL tests"
  --test-- "lu-1"
    a: true
    i: 0
    until [
      i: i + 1
      a
    ]
  --assert i = 1

  --test-- "lu-2"
    i: 0
    c: 3
    stop?: false
    until [
      i: i + 1
      c: c - 1
      if zero? c [stop?: true]
      stop?
    ]
  --assert c = 0
  --assert i = 3
===end-group===

===start-group=== "logic value as conditional expression in WHILE tests"
	--test-- "lw-1"
		a: false
		i: 0
		while [a][i: i + 1]
		--assert i = 0

	--test-- "lw-2"
		i: 0
		c: 3
		run?: true
		while [run?][
			i: i + 1
			c: c - 1
			if zero? c [run?: false]
		]
		--assert c = 0
		--assert i = 3
===end-group===

===start-group=== "passing logic! as function's argument tests"
	log-foo: func [a [logic!] return: [logic!]][a]

	--test-- "logic-arg-1"	--assert log-foo true
	--test-- "logic-arg-2"	--assert not log-foo false
	--test-- "logic-arg-3"	--assert log-foo 1 < 2
	--test-- "logic-arg-4"	--assert log-foo 3 <> 4
	--test-- "logic-arg-5"	--assert log-foo (1 + 1 < 3)
	--test-- "logic-arg-6"
		a: false
		if false = log-foo (2 + 2 = 5) [a: true]
		--assert a
	--test-- "logic-arg-7"
		--assert not log-foo 3 = 4

===end-group===

===start-group=== "all with logic!"

	--test-- "logic-all-1"
	 	result:  all [
	 		true
	 		true
	 	]
	 	--assert result

	--test-- "logic-all-2"
		result: all [
			false
			true
		]
		--assert not result

	--test-- "logic-all-3"
		result all [
			true
			false
		]
		--assert not result

	--test-- "logic-all-4"
		result: all [
			false
			false
		]
		--assert not result

	--test-- "logic-all-5"
		a: all [true]
		--assert a

	--test-- "logic-all-6"
		a: all [false]
		--assert not a

	--test-- "logic-all-7"
		a: all [1 < 2 false]
		--assert not a

	--test-- "logic-all-8"
		a: all [false 1 < 2]
		--assert not a

	--test-- "logic-all-9"
		a: all [true 1 = 2]
		--assert not a

	--test-- "logic-all-10"
		a: all [1 = 2 true]
		--assert not a

	--test-- "logic-all-11"
		a: all [1 < 2]
		--assert a

	--test-- "logic-all-12"
		a: all [1 = 2]
		--assert not a

	--test-- "logic-all-13"
		a: all [1 < 2 3 <> 4]
		--assert a

	--test-- "logic-all-14"
		a: all [1 = 2 3 <> 4]
		--assert not a

	--test-- "logic-all-15"
		--assert not log-foo all [1 = 2]

	--test-- "logic-all-16"
		--assert log-foo all [1 < 2 3 <> 4]

	--test-- "logic-all-17"
		--assert not log-foo all [1 = 2 3 <> 4]

	--test-- "logic-all-18"
		a: log-foo all [1 < 2]
		--assert a

	--test-- "logic-all-19"
		a: log-foo all [1 = 2]
		--assert not a

	--test-- "logic-all-20"
		a: log-foo all [1 < 2 3 <> 4]
		--assert a

	--test-- "logic-all-21"
		a: all [log-foo true]
		--assert a

===end-group===

===start-group=== "any with logic!"

	--test-- "logic-any-1"
		result: any [
			true
			true
		]
		--assert result

	--test-- "logic-any-2"
		result: any [
			false
			true
		]
		--assert result

	--test-- "logic-any-3"
		result: any [
			true
			false
		]
		--assert result

	--test-- "logic-any-4"
		result: any [
			false
			false
		]
		--assert not result

	--test-- "logic-any-5"
		a: any [true]
		--assert a

	--test-- "logic-any-6"
		a: any [false]
		--assert not a

	--test-- "logic-any-7"
		a: any [1 < 2 false]
		--assert a

	--test-- "logic-any-8"
		a: any [false 1 < 2]
		--assert a

	--test-- "logic-any-9"
		a: any [true 1 = 2]
		--assert a

	--test-- "logic-any-10"
		a: any [1 = 2 true]
		--assert a

	--test-- "logic-any-11"
		a: any [1 < 2]
		--assert a

	--test-- "logic-any-12"
		a: any [1 = 2]
		--assert not a

	--test-- "logic-any-13"
		a: any [1 < 2 3 <> 4]
		--assert a

	--test-- "logic-any-14"
		a: any [1 = 2 3 <> 4]
		--assert a

	--test-- "logic-any-15"
		--assert not log-foo any [1 = 2]

	--test-- "logic-any-16"
		--assert log-foo any [1 < 2 3 <> 4]

	--test-- "logic-any-17"
		--assert log-foo any [1 = 2 3 <> 4]

	--test-- "logic-any-18"
		a: log-foo any [1 < 2]
		--assert a

	--test-- "logic-any-19"
		a: log-foo any [1 = 2]
		--assert not a

	--test-- "logic-any-20"
		a: log-foo any [1 < 2 3 <> 4]
		--assert a

	--test-- "logic-any-21"
		a: any [log-foo true]
		--assert a

===end-group===

===start-group=== "function returning a logic value"
		lgc-test?: func [
			return: [logic!]
		][
			either 1 < 2 [true] [false]
		]

	--test-- "logic-return-1"
		--assert lgc-test?

	--test-- "logic-return-2"
		a: lgc-test?
		--assert a

		lgc-test2?: func [
			return: [logic!]
		][
			either 1 = 2 [true] [false]
		]

	--test-- "logic-return-3"
		--assert not lgc-test2?

	--test-- "logic-return-4"
		a: lgc-test2?
		--assert not a

		lgc-test3?: func [return: [logic!]][
			either true [
				1 = 3
			][
				false
			]
		]

	--test-- "logic-return-5"
		--assert not lgc-test3?

		lgc-test4?: func [return: [logic!]][
			either false [
				1 = 3
			][
				false
			]
		]

	--test-- "logic-return-6"
		--assert not lgc-test4?

		lgc-test5?: func [return: [logic!]][
			either 1 < 2 [true] [false]
		]

	--test-- "logic-return-7"
		--assert lgc-test5?

===end-group===

===start-group=== "equality lgc-tests"

	--test-- "logic-=-1"
		a: false
		--assert a = false

	--test-- "logic-=-2"
		a: true
		--assert not a = false

	--test-- "logic-=-3"
		a: false
		--assert not a <> false

	--test-- "logic-=-4"
		a: true
		--assert a <> false

	--test-- "logic-=-5"
		a: false
		b: a = false
		--assert b

	--test-- "logic-=-6"
		a: true
		b: a = false
		--assert not b

	--test-- "logic-=-7"
		a: false
		b: false <> a
		--assert not b

	--test-- "logic-=-8"
		a: true
		b: false <> a
		--assert b

	--test-- "logic-=-9"
		a: false
		--assert log-foo a = false

	--test-- "logic-=-10"
		a: false
		--assert log-foo a = false

	--test-- "logic-=-11"
		a: true
		--assert not log-foo a = false

===end-group===

===start-group=== "logic value returned by function"

		fooT: func [return: [logic!]][1 < 2]
		fooF: func [return: [logic!]][1 = 2]

	--test-- "logic-ret-1" --assert fooT
	--test-- "logic-ret-2" --assert not fooF

===end-group===

===start-group=== "logic logical operators"

comment { These tests will not run until Issue #555 is fixed
	--test-- "logic-and-1"	--assert true and true
	--test-- "logic-and-2"	--assert not (true and false)
	--test-- "logic-and-3"	--assert not (false and false)
	--test-- "logic-and-4"  --assert not (false and true)
}
	--test-- "logic-and-5"
		la5-l1: true
		la5-l2: true
		--assert la5-l1 and la5-l2
	--test-- "logic-and-6"
		la6-l1: true
		la6-l2: false
		--assert not (la6-l1 and la6-l2)
	--test-- "logic-and-7"
		la7-l1: false
		la7-l2: false
		--assert not (la7-l1 and la7-l2)
	--test-- "logic-and-8"
		la8-l1: false
		la8-l2: true
		--assert not (la8-l1 and la8-l2)
comment { These tests will not run until Issue #555 is fixed
	--test-- "logic-or-1"	--assert true or true
	--test-- "logic-or-2"	--assert true or false
	--test-- "logic-or-3"	--assert not (false or false)
	--test-- "logic-or-4"	--assert false or true
}
	--test-- "logic-or-5"
		lo5-l1: true
		lo5-l2: true
		--assert lo5-l1 or lo5-l2
	--test-- "logic-or-6"
		lo6-l1: true
		lo6-l2: false
		--assert lo6-l1 or lo6-l2
	--test-- "logic-or-7"
		lo7-l1: false
		lo7-l2: false
		--assert not (lo7-l1 or lo7-l2)
	--test-- "logic-or-8"
		lo8-l1: false
		lo8-l2: true
		--assert lo8-l1 or lo8-l2
comment { These tests will not run until Issue #555 is fixed
	--test-- "logic-xor-1"	--assert not (true xor true)
	--test-- "logic-xor-2"	--assert true xor false
	--test-- "logic-xor-3"	--assert not (false xor false)
	--test-- "logic-xor-4"  --assert false xor true
}
	--test-- "logic-xor-5"
		lx5-l1: true
		lx5-l2: true
		--assert not (lx5-l1 xor lx5-l2)
	--test-- "logic-xor-6"
		lx6-l1: true
		lx6-l2: false
		--assert lx6-l1 xor lx6-l2
	--test-- "logic-xor-7"
		lx7-l1: false
		lx7-l2: false
		--assert not (lx7-l1 xor lx7-l2)
	--test-- "logic-xor-8"
		lx8-l1: false
		lx8-l2: true
		--assert lx8-l1 xor lx8-l2

===end-group===

~~~end-file~~~


rebasing to resolve merge conflict

rebasing to resolve merge conflict

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, 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
	}
]

help: func [
	"Get help for functions"
	'word [any-type!] "Word you are looking for"
	/local func-name desc spec tab tab4 tab8 type start attributes info fun w ref block w1 w2
][
	tab: tab4: "    "
	tab8: "        "

	case [
		unset? :word [								;-- HELP with no arguments
			print {Use HELP or ? to see built-in info:

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other debug functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
}
		]
		datatype? get :word [						;-- HELP <datatype!>
			type: get :word
			foreach w system/words [
				if type = type? get w [
					case [
						any [function? get w native? get w action? get w op? get w][
							prin [tab w]
							spec: spec-of get w

							either any [
								string? desc: spec/1
								string? desc: spec/2					;-- attributs block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
		]
		'else [
			func-name: :word

			argument-rule: [
				set word [word! | lit-word! | get-word!]
				(prin [tab mold :word])
				opt [set type block!  (prin [#" " mold type])]
				opt [set info string! (prin [" =>" append form info dot])]
				(prin lf)
			]

			either all [
				word? func-name
				fun: get func-name
				any [action? :fun function? :fun native? :fun op? :fun]
			][
				prin ["^/USAGE:^/" tab ]

				parse spec-of :fun [
					start: [						;-- 1st pass
						any [block! | string! ]
						opt [set w [word! | lit-word! | get-word!] (either op? :fun [prin [mold w func-name]][prin [func-name mold w]])]
						any [
							/local to end
							| set w [word! | lit-word! | get-word!] (prin [" " w])
							| set w refinement! (prin [" " mold w])
							| skip
						]
					]

					:start								;-- 2nd pass
					opt [set attributes block! (prin ["^/^/ATTRIBUTES:^/" tab mold attributes])]
					opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot lf tab func-name "is type:" mold type? :fun])]

					(print "^/ARGUMENTS:")
					any [argument-rule]; (prin lf)]

					(print "^/REFINEMENTS:")
					any [
						/local [
							to ahead set-word! 'return set block block!
							(print ["^/RETURN:^/" mold block])
							| to end
						]
						| [
							set ref refinement! (prin [tab mold ref])
							opt [set info string! (prin [" =>" append form info dot])]
							(tab: tab8 prin lf)
							any [argument-rule]
							(tab: tab4)
						]
					]
				]
			][
				print [
					func-name "is of type"
					mold type? either word? :func-name [:fun][:func-name]
					"^/No more help available."
				]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

what: function [
	"Lists all functions, or words of a given type"
][
	foreach w system/words [
		if any [function? get w native? get w action? get w op? get w][
			prin w
			spec: spec-of get w

			either any [
				string? desc: spec/1
				string? desc: spec/2					;-- attributes block case
			][
				print [tab "=> " desc]
			][
				prin lf
			]
		]
	]
	exit												;-- return unset value
]

source: function [
	"Print the source of a function"
	'func-name [any-word!] "The name of the function"
	/local fun
][
	print either function? get func-name [
		[append mold func-name #":" mold get func-name]
	][
		["Sorry," func-name "is a" type? :func-name "so no source is available"]
	]
]

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, 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
	}
]

help: func [
	"Get help for functions"
	'word [any-type!] "Word you are looking for"
	/local func-name desc spec tab tab4 tab8 type start attributes info fun w ref block w1 w2
][
	tab: tab4: "    "
	tab8: "        "

	case [
		unset? :word [								;-- HELP with no arguments
			print {Use HELP or ? to see built-in info:

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other debug functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
}
		]
		datatype? get :word [						;-- HELP <datatype!>
			type: get :word
			foreach w system/words [
				if type = type? get w [
					either any [function? get w native? get w action? get w][
						prin [tab w]
						spec: spec-of get w

						either any [
							string? desc: spec/1
							string? desc: spec/2					;-- attributes block case
						][
							print ["^-=> " desc]
						][
							prin lf
						]
					][
						print [tab :w "^-: " mold get w]
					]
				]
			]
		]
		'else [
			func-name: :word

			argument-rule: [
				set word [word! | lit-word! | get-word!]
				(prin [tab mold word])
				opt [set type block!  (prin [#" " mold type])]
				opt [set info string! (prin [" =>" append form info dot])]
				(prin lf)
			]

			either all [
				word? func-name
				fun: get func-name
				any [action? :fun function? :fun native? :fun op? :fun]
			][
				prin ["^/USAGE:^/" tab ]

				parse spec-of :fun [
					start: [						;-- 1st pass
						any [block! | string! ]
						opt [set w [word! | lit-word!] (either op? :fun [prin [w func-name]][prin [func-name w]])]
						any [
							/local to end
							| set w word! (prin [" " w])
							| set w [lit-word! | refinement!] (prin [" " mold w])
							| skip
						]
					]

					:start								;-- 2nd pass
					opt [set attributes block! (prin ["^/^/ATTRIBUTES:^/" tab mold attributes])]
					opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot lf tab func-name "is type:" mold type? :fun])]

					(print "^/ARGUMENTS:")
					any [argument-rule]; (prin lf)]

					(print "^/REFINEMENTS:")
					any [
						/local [
							to ahead set-word! 'return set block block!
							(print ["^/RETURN:^/" mold block])
							| to end
						]
						| [
							set ref refinement! (prin [tab mold ref])
							opt [set info string! (prin [" =>" append form info dot])]
							(tab: tab8 prin lf)
							any [argument-rule]
							(tab: tab4)
						]
					]
				]
			][
				print [
					func-name "is of type"
					mold type? either word? :func-name [:fun][:func-name]
					"^/No more help available."
				]
			]
		]
	]
	exit												;-- return unset value
]

?: :help

what: function [
	"Lists all functions, or words of a given type"
][
	foreach w system/words [
		if any [function? get w native? get w action? get w op? get w][
			prin w
			spec: spec-of get w

			either any [
				string? desc: spec/1
				string? desc: spec/2					;-- attributes block case
			][
				print [tab "=> " desc]
			][
				prin lf
			]
		]
	]
	exit												;-- return unset value
]

source: function [
	"Print the source of a function"
	'func-name [any-word!] "The name of the function"
][
	print either function? get func-name [
		[append mold func-name #":" mold get func-name]
	][
		["Sorry," func-name "is a" type? :func-name "so no source is available"]
	]
]


TESTS: fix wrong results in some modulo tests on floats.


FIX: issue #653 (Linux version cannot handle long strings in script header)

Stat64 struct is now used by default for Linux target. Older stat struct is available in the newly added Linux-Old compilation target.

Red/System [
	Title:	"Simple file IO functions (temporary)"
	Author: "Nenad Rakocevic"
	File: 	%simple-io.reds
	Tabs: 	4
	Rights: "Copyright (C) 2012-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

simple-io: context [

	#either OS = 'Windows [

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

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

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

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

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

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

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

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

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

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

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

Red/System [
	Title:	"Simple file IO functions (temporary)"
	Author: "Nenad Rakocevic"
	File: 	%simple-io.reds
	Tabs: 	4
	Rights: "Copyright (C) 2012-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

simple-io: context [

	#either OS = 'Windows [

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

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

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

		#either OS = 'MacOSX [
			stat!: alias struct! [
				st_dev		[integer!]
				st_ino		[integer!]
				st_modelink	[integer!]					;-- st_mode & st_link are both 16bit fields
				st_uid		[integer!]
				st_gid		[integer!]
				st_rdev		[integer!]
				atv_sec		[integer!]					;-- struct timespec inlined
				atv_msec	[integer!]
				mtv_sec		[integer!]					;-- struct timespec inlined
				mtv_msec	[integer!]
				ctv_sec		[integer!]					;-- struct timespec inlined
				ctv_msec	[integer!]
				st_size		[integer!]
				st_blocks	[integer!]
				st_blksize	[integer!]
				st_flags	[integer!]
				st_gen		[integer!]
			]
			#import [
				LIBC-file cdecl [
					;-- https://developer.apple.com/library/mac/documentation/Darwin/Reference/ManPages/10.6/man2/stat.2.html?useVersion=10.6
					_stat:	"fstat" [
						file		[integer!]
						restrict	[stat!]
						return:		[integer!]
					]
				]
			]
		][
			#either OS = 'Syllable [
				;-- http://glibc.sourcearchive.com/documentation/2.7-18lenny7/glibc-2_87_2bits_2stat_8h_source.html
				stat!: alias struct! [
					st_mode		[integer!]
					st_ino		[integer!]
					st_dev		[integer!]
					st_nlink	[integer!]
					st_uid		[integer!]
					st_gid		[integer!]
					filler1		[integer!]				;-- not in spec above...
					filler2		[integer!]				;-- not in spec above...
					st_size		[integer!]
					;...incomplete...
				]
			][
				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
	]
]


remove unused scalar

remove unused scalar

% genparserprint.red

% Copyright Zach Hauser and Arthur Norman, 2016

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

% $Id: $

module 'genparserprint;

symbolic procedure lalr_print_compressed_action_table action_table;
  begin
    scalar n_itemsets, row, default;
    n_itemsets := length itemset_collection;
    princ "=== ACTION TABLE ==="; terpri();
    princ "STATE"; ttab 6; princ "TERMINAL"; ttab 20; princ "ACTION"; terpri();
    for state:=0 : (sub1 n_itemsets) do <<
      row := car getv(action_table, state);
      default := cdr getv(action_table, state);
      prin state;
      for each entry in row do <<
        ttab 6; lalr_prin_symbol car entry; ttab 20;
        lalr_prin_action cdr entry; terpri() >>;
      if default then <<
        ttab 6; princ "<any>"; ttab 20;
        lalr_prin_action default; terpri() >> >>;
    terpri();
  end;

symbolic procedure lalr_print_compressed_goto_table goto_table;
  begin
    scalar code, row, default;
    princ "=== GOTO TABLE ==="; terpri();
    princ "NONTERMINAL"; ttab 20; princ "SRC"; ttab 28; princ "DEST"; terpri();
    for each nonterminal in delete('!S!', nonterminals) do <<
      code := get(nonterminal, 'lalr_nonterminal_code);
      row := car getv(goto_table, code);
      default := cdr getv(goto_table, code);
      lalr_prin_nonterminal code;
      for each entry in row do <<
        ttab 20; prin car entry; ttab 28; print cdr entry >>;
      if default then <<
        ttab 20; princ "<any>"; ttab 28; print default >> >>;
    terpri();
  end;

symbolic procedure lalr_prin_action action;
  if action = nil then
    princ " "
  else if action > 0 then <<
    princ "shift to state ";
    prin action >>
  else if action = 0 then
    princ "accept"
  else
    lalr_prin_reduction (-action);

symbolic procedure lalr_prin_reduction code;
  begin
    scalar reduction_fn, reduction_rhs_length, reduction_lhs, fn;
    reduction_fn := first reduction_info;
    reduction_rhs_length := second reduction_info;
    reduction_lhs := third reduction_info;
    princ "reduce by #"; prin code; princ ": ";
    lalr_prin_nonterminal getv16(reduction_lhs, code);
    princ " -> ["; prin getv8(reduction_rhs_length, code); princ " symbols] ";
    if (fn := getv(reduction_fn, code)) then
      prin car cdddr getd fn;
  end;

symbolic procedure lalr_print_lr0_collection;
  begin
    scalar i_goto;
    printc "=== LR(0) ITEMSET COLLECTION ==="; terpri();
    for each i_itemset in reverse itemset_collection do <<
      princ "Itemset "; prin cdr i_itemset; terpri();
      for each item in sort(car i_itemset, function ordp) do <<
        princ " "; lalr_prin_symbol car item; princ " ->";
        for each x in cdr item do << princ " "; lalr_prin_symbol x >>;
        terpri() >>;
      for each x in symbols do
        if i_goto := lalr_goto(i_itemset, x) then <<
          princ "GOTO("; lalr_prin_symbol x;
          princ ") = state "; prin cdr i_goto;
          terpri() >>;
      terpri() >>
  end;

symbolic procedure lalr_print_collection;
  begin
    scalar i_goto;
    printc "=== LALR ITEMSET COLLECTION ==="; terpri();
    for each i_itemset in reverse itemset_collection do <<
      princ "Itemset "; prin cdr i_itemset; terpri();
      for each item in sort(car i_itemset, function ordp) do <<
        princ " "; lalr_prin_symbol caar item; princ " ->";
        for each x in cdar item do << princ " "; lalr_prin_symbol x >>;
        princ " [";
        for each remaining_lookaheads on cdr item do <<
          lalr_prin_symbol car remaining_lookaheads;
          if length remaining_lookaheads = 1 then
            princ "]"
          else
            princ "/" >>;
        terpri() >>;
      for each x in symbols do
        if i_goto := lalr_goto(i_itemset, x) then <<
          princ "GOTO("; lalr_prin_symbol x; princ ") = "; prin cdr i_goto;
          terpri() >>;
      terpri() >>
  end;

symbolic procedure lalr_print_first_information;
  <<
    printc "=== FIRST sets for each nonterminal ===";
    for each nt in nonterminals do <<
      lalr_prin_symbol nt; princ ":"; ttab 20;
      for each terminal in get(nt, 'lalr_first) do <<
        lalr_prin_symbol terminal; princ " " >>;
      terpri() >>;
    terpri()
  >>;

symbolic procedure lalr_print_terminals_and_codes terminals;
  <<
    printc "=== Terminal symbols ===";
    for each terminal in terminals do <<
      princ "   "; lalr_prin_symbol terminal;
      princ " ["; prin terminal; princ "]";
      if (lalr_precedence terminal) or (lalr_associativity terminal) then <<
        princ " (precedence "; prin lalr_precedence terminal; princ ", ";
        for each c in cdr explode2 lalr_associativity terminal do princ c;
        princ " associativity)" >>;
      terpri() >>;
    terpri()
  >>;

symbolic procedure lalr_print_nonterminals_and_productions;
  <<
    print "=== Nonterminal symbols ===";
    for each nt in nonterminals do <<
      princ "["; prin get(nt, 'lalr_nonterminal_code); princ "] ";
      lalr_prin_symbol nt;
      begin
        scalar separator;
        separator := ":";
        for each production in lalr_productions nt do <<
          ttab 20; princ separator; princ " ";
          separator := "|";
          lalr_prin_rhs car production;
          if posn() > 48 then terpri(); ttab 48;
          princ "{ "; lalr_prin_semantic_action cdr production; princ " }";
          terpri() >>
      end;
      terpri() >>;
    terpri()
  >>;

symbolic procedure lalr_prin_semantic_action semantic_action;
  prin semantic_action;

symbolic procedure lalr_prin_rhs rhs;
  if rhs = nil then
    princ "<empty>"
  else
    for each sym in rhs do <<
      lalr_prin_symbol sym;
      princ " " >>;

symbolic procedure lalr_prin_symbol sym;
  if sym = 0 then
    princ "$"
  else if numberp sym then
    for each c in explode2 cdr assoc(sym, terminal_codes) do princ c
  else
    for each c in explode2uc sym do princ c;

symbolic procedure lalr_prin_nonterminal code;
  for each c in explode2uc cdr assoc(code, nonterminal_codes) do princ c;

symbolic procedure lalr_warn_reduce_reduce_conflict(reduce1, reduce2, state);
  <<
    if not zerop posn() then terpri();
    princ "+++++ Reduce/reduce conflict in itemset #"; prin state;
    princ " on lookahead "; lalr_prin_symbol car reduce1; terpri();
    princ "Reduction #1: "; lalr_prin_production cadr cadr reduce1; terpri();
    princ "Reduction #2: "; lalr_prin_production cadr cadr reduce2; terpri();
    printc "Resolved in favour of reduction #1";
    terpri()
  >>;

symbolic procedure lalr_prin_production production;
  <<
    lalr_prin_symbol car production;
    princ " -> ";
    lalr_prin_rhs cdr production
  >>;

symbolic procedure lalr_warn_shift_reduce_conflict(shift, reduce, state);
  <<
    if not zerop posn() then terpri();
    princ "+++ Shift/reduce conflict in itemset #"; prin state;
    princ " on lookahead "; lalr_prin_symbol car shift; terpri();
    princ "Reduce: "; lalr_prin_production cadr cadr reduce; terpri();
    princ "Shift: to state #"; prin cadr cadr shift; terpri();
    printc "Resolved in favour of the shift operation";
    terpri()
  >>;

endmodule;

end;

% genparserprint.red

% Copyright Zach Hauser and Arthur Norman, 2016

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

% $Id: $

module 'genparserprint;

symbolic procedure lalr_print_compressed_action_table action_table;
  begin
    scalar n_itemsets, row, default;
    n_itemsets := length itemset_collection;
    princ "=== ACTION TABLE ==="; terpri();
    princ "STATE"; ttab 6; princ "TERMINAL"; ttab 20; princ "ACTION"; terpri();
    for state:=0 : (sub1 n_itemsets) do <<
      row := car getv(action_table, state);
      default := cdr getv(action_table, state);
      prin state;
      for each entry in row do <<
        ttab 6; lalr_prin_symbol car entry; ttab 20;
        lalr_prin_action cdr entry; terpri() >>;
      if default then <<
        ttab 6; princ "<any>"; ttab 20;
        lalr_prin_action default; terpri() >> >>;
    terpri();
  end;

symbolic procedure lalr_print_compressed_goto_table goto_table;
  begin
    scalar code, row, default;
    princ "=== GOTO TABLE ==="; terpri();
    princ "NONTERMINAL"; ttab 20; princ "SRC"; ttab 28; princ "DEST"; terpri();
    for each nonterminal in delete('!S!', nonterminals) do <<
      code := get(nonterminal, 'lalr_nonterminal_code);
      row := car getv(goto_table, code);
      default := cdr getv(goto_table, code);
      lalr_prin_nonterminal code;
      for each entry in row do <<
        ttab 20; prin car entry; ttab 28; print cdr entry >>;
      if default then <<
        ttab 20; princ "<any>"; ttab 28; print default >> >>;
    terpri();
  end;

symbolic procedure lalr_prin_action action;
  if action = nil then
    princ " "
  else if action > 0 then <<
    princ "shift to state ";
    prin action >>
  else if action = 0 then
    princ "accept"
  else
    lalr_prin_reduction (-action);

symbolic procedure lalr_prin_reduction code;
  begin
    scalar reduction_fn, reduction_rhs_length, reduction_lhs, fn;
    reduction_fn := first reduction_info;
    reduction_rhs_length := second reduction_info;
    reduction_lhs := third reduction_info;
    princ "reduce by #"; prin code; princ ": ";
    lalr_prin_nonterminal getv16(reduction_lhs, code);
    princ " -> ["; prin getv8(reduction_rhs_length, code); princ " symbols] ";
    if (fn := getv(reduction_fn, code)) then
      prin car cdddr getd fn;
  end;

symbolic procedure lalr_print_lr0_collection;
  begin
    scalar i_goto;
    printc "=== LR(0) ITEMSET COLLECTION ==="; terpri();
    for each i_itemset in reverse itemset_collection do <<
      princ "Itemset "; prin cdr i_itemset; terpri();
      for each item in sort(car i_itemset, function ordp) do <<
        princ " "; lalr_prin_symbol car item; princ " ->";
        for each x in cdr item do << princ " "; lalr_prin_symbol x >>;
        terpri() >>;
      for each x in symbols do
        if i_goto := lalr_goto(i_itemset, x) then <<
          princ "GOTO("; lalr_prin_symbol x;
          princ ") = state "; prin cdr i_goto;
          terpri() >>;
      terpri() >>
  end;

symbolic procedure lalr_print_collection;
  begin
    scalar i_goto;
    printc "=== LALR ITEMSET COLLECTION ==="; terpri();
    for each i_itemset in reverse itemset_collection do <<
      princ "Itemset "; prin cdr i_itemset; terpri();
      for each item in sort(car i_itemset, function ordp) do <<
        princ " "; lalr_prin_symbol caar item; princ " ->";
        for each x in cdar item do << princ " "; lalr_prin_symbol x >>;
        princ " [";
        for each remaining_lookaheads on cdr item do <<
          lalr_prin_symbol car remaining_lookaheads;
          if length remaining_lookaheads = 1 then
            princ "]"
          else
            princ "/" >>;
        terpri() >>;
      for each x in symbols do
        if i_goto := lalr_goto(i_itemset, x) then <<
          princ "GOTO("; lalr_prin_symbol x; princ ") = "; prin cdr i_goto;
          terpri() >>;
      terpri() >>
  end;

symbolic procedure lalr_print_first_information;
  <<
    printc "=== FIRST sets for each nonterminal ===";
    for each nt in nonterminals do <<
      lalr_prin_symbol nt; princ ":"; ttab 20;
      for each terminal in get(nt, 'lalr_first) do <<
        lalr_prin_symbol terminal; princ " " >>;
      terpri() >>;
    terpri()
  >>;

symbolic procedure lalr_print_terminals_and_codes terminals;
  <<
    printc "=== Terminal symbols ===";
    for each terminal in terminals do <<
      princ "   "; lalr_prin_symbol terminal;
      princ " ["; prin terminal; princ "]";
      if (lalr_precedence terminal) or (lalr_associativity terminal) then <<
        princ " (precedence "; prin lalr_precedence terminal; princ ", ";
        for each c in cdr explode2 lalr_associativity terminal do princ c;
        princ " associativity)" >>;
      terpri() >>;
    terpri()
  >>;

symbolic procedure lalr_print_nonterminals_and_productions;
  <<
    print "=== Nonterminal symbols ===";
    for each nt in nonterminals do <<
      princ "["; prin get(nt, 'lalr_nonterminal_code); princ "] ";
      lalr_prin_symbol nt;
      begin
        scalar separator;
        separator := ":";
        for each production in lalr_productions nt do <<
          ttab 20; princ separator; princ " ";
          separator := "|";
          lalr_prin_rhs car production;
          if posn() > 48 then terpri(); ttab 48;
          princ "{ "; lalr_prin_semantic_action cdr production; princ " }";
          terpri() >>
      end;
      terpri() >>;
    terpri()
  >>;

symbolic procedure lalr_prin_semantic_action semantic_action;
  prin semantic_action;

symbolic procedure lalr_prin_rhs rhs;
  if rhs = nil then
    princ "<empty>"
  else
    for each sym in rhs do <<
      lalr_prin_symbol sym;
      princ " " >>;

symbolic procedure lalr_prin_symbol sym;
  if sym = 0 then
    princ "$"
  else if numberp sym then
    for each c in explode2 cdr assoc(sym, terminal_codes) do princ c
  else
    for each c in explode2uc sym do princ c;

symbolic procedure lalr_prin_nonterminal code;
  for each c in explode2uc cdr assoc(code, nonterminal_codes) do princ c;

symbolic procedure lalr_warn_reduce_reduce_conflict(reduce1, reduce2, state);
  <<
    if not zerop posn() then terpri();
    princ "+++++ Reduce/reduce conflict in itemset #"; prin state;
    princ " on lookahead "; lalr_prin_symbol car reduce1; terpri();
    princ "Reduction #1: "; lalr_prin_production cadr cadr reduce1; terpri();
    princ "Reduction #2: "; lalr_prin_production cadr cadr reduce2; terpri();
    printc "Resolved in favour of reduction #1";
    terpri()
  >>;

symbolic procedure lalr_prin_production production;
  <<
    lalr_prin_symbol car production;
    princ " -> ";
    lalr_prin_rhs cdr production
  >>;

symbolic procedure lalr_warn_shift_reduce_conflict(shift, reduce, state);
  begin
    scalar s;
    if not zerop posn() then terpri();
    princ "+++ Shift/reduce conflict in itemset #"; prin state;
    princ " on lookahead "; lalr_prin_symbol car shift; terpri();
    princ "Reduce: "; lalr_prin_production cadr cadr reduce; terpri();
    princ "Shift: to state #"; prin cadr cadr shift; terpri();
    printc "Resolved in favour of the shift operation";
    terpri()
  end;

endmodule;

end;


TESTS: added test of local variable with same name as an enum member

Red/System [
    Title:   "Red/System enumerations tests"
    File:      %enum-test.reds
    Rights:  "Copyright (C) 2012 Nenad Rakocevic. All rights reserved."
    License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "enumerations"

  --test-- "Enum-1"
    #enum test1! [enumA enumB]
    --assert enumA = 0
    --assert enumB = 1

  --test-- "Enum-2"
    #enum test2! [enumC: 3 enumD]
    --assert enumC = 3
    --assert enumD = 4

    --test-- "Enum-3"
    #enum test3! [
        enumE: 11
        ;empty line test
        enumF: 10
    ]
    --assert enumE = 11
    --assert enumF = 10

  --test-- "Enum-4"
        p1: declare pointer! [integer!]
        p1/value: enumE
    --assert p1/value = 11

  --test-- "Enum-5"
        p2: declare struct! [a [test1!] b [integer!]]
        p2/a: enumC
        p2/b: enumC
    --assert p2/a = 3
    --assert p2/b = 3

  --test-- "Enum-6"
        p3: declare struct! [enumA [integer!]]
        p3/enumA: 3
    --assert enumA = 0
    --assert p3/enumA = 3

  --test-- "Enum-7"
        str: "abcd"
    --assert str/3 = #"c"
    --assert str/enumC = #"c"

  --test-- "Enum-8"
        fce: func[return: [integer!]][ return enumC ]
    --assert fce = 3

  --test-- "Enum-9"
        #enum test9! [enum9: enumC]
    --assert enum9 = 3

  --test-- "Enum-10"
        #enum test10! [enum10: enum11: 10 enum12]
    --assert enum10 = 10
	--assert enum11 = 10
	--assert enum12 = 11

	--test-- "Enum-11"
	  #enum test11! [e11-a e11-b]
	  e11-f: func [
	    return: [integer!]
	    /local
	    e11-b
	  ][
	    e11-b: 3
	  ]
	--assert 3 = e11-f

~~~end-file~~~

Red/System [
    Title:   "Red/System enumerations tests"
    File:      %enum-test.reds
    Rights:  "Copyright (C) 2012 Nenad Rakocevic. All rights reserved."
    License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "enumerations"

  --test-- "Enum-1"
    #enum test1! [enumA enumB]
    --assert enumA = 0
    --assert enumB = 1

  --test-- "Enum-2"
    #enum test2! [enumC: 3 enumD]
    --assert enumC = 3
    --assert enumD = 4

    --test-- "Enum-3"
    #enum test3! [
        enumE: 11
        ;empty line test
        enumF: 10
    ]
    --assert enumE = 11
    --assert enumF = 10

  --test-- "Enum-4"
        p1: declare pointer! [integer!]
        p1/value: enumE
    --assert p1/value = 11

  --test-- "Enum-5"
        p2: declare struct! [a [test1!] b [integer!]]
        p2/a: enumC
        p2/b: enumC
    --assert p2/a = 3
    --assert p2/b = 3

  --test-- "Enum-6"
        p3: declare struct! [enumA [integer!]]
        p3/enumA: 3
    --assert enumA = 0
    --assert p3/enumA = 3

  --test-- "Enum-7"
        str: "abcd"
    --assert str/3 = #"c"
    --assert str/enumC = #"c"

  --test-- "Enum-8"
        fce: func[return: [integer!]][ return enumC ]
    --assert fce = 3

  --test-- "Enum-9"
        #enum test9! [enum9: enumC]
    --assert enum9 = 3

  --test-- "Enum-10"
        #enum test10! [enum10: enum11: 10 enum12]
    --assert enum10 = 10
	--assert enum11 = 10
	--assert enum12 = 11
~~~end-file~~~


FIX: missing debug logging instruction.

FIX: missing debug logging instruction.

Red/System [
	Title:   "Integer! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %integer.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
	}
]

integer: context [
	verbose: 0

	abs: func [
		value	[integer!]
		return: [integer!]
	][
		if value = -2147483648 [
			print-line "*** Math Error: integer overflow on ABSOLUTE"
		]
		if negative? value [value: 0 - value]
		value
	]

	get*: func [										;-- unboxing integer value from stack
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		assert TYPE_OF(int) = TYPE_INTEGER
		int/value
	]

	get-any*: func [									;-- special get* variant for SWITCH
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		either TYPE_OF(int) = TYPE_INTEGER [int/value][0] ;-- accept NONE values
	]

	get: func [											;-- unboxing integer value
		value	[red-value!]
		return: [integer!]
		/local
			int [red-integer!]
	][
		assert TYPE_OF(value) = TYPE_INTEGER
		int: as red-integer! value
		int/value
	]

	box: func [
		value	[integer!]
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/header: TYPE_INTEGER
		int/value: value
		int
	]

	form-signed: func [									;@@ replace with sprintf() call?
		i 		[integer!]
		return: [c-string!]
		/local
			s	[c-string!]
			c 	[integer!]
			n 	[logic!]
	][
		s: "-0000000000"								;-- 11 bytes wide
		if zero? i [									;-- zero special case
			s/11: #"0"
			return s + 10
		]
		if i = -2147483648 [							;-- min integer special case
			return "-2147483648"
		]
		n: negative? i
		if n [i: negate i]
		c: 11
		while [i <> 0][
			s/c: #"0" + (i // 10)
			i: i / 10
			c: c - 1
		]
		if n [s/c: #"-" c: c - 1]
		s + c
	]

	do-math: func [
		type		[math-op!]
		return:		[red-value!]
		/local
			left	[red-integer!]
			right	[red-integer!]
	][
		left: as red-integer! stack/arguments
		right: left + 1

		assert any [									;@@ replace by typeset check when possible
			TYPE_OF(left) = TYPE_INTEGER
			TYPE_OF(left) = TYPE_CHAR
		]
		assert any [
			TYPE_OF(right) = TYPE_INTEGER
			TYPE_OF(right) = TYPE_CHAR
			TYPE_OF(right) = TYPE_FLOAT
		]

		either TYPE_OF(right) = TYPE_FLOAT [
			float/do-math type
		][
			left/value: switch type [
				OP_ADD [left/value + right/value]
				OP_SUB [left/value - right/value]
				OP_MUL [left/value * right/value]
				OP_DIV [left/value / right/value]
				OP_REM [left/value % right/value]
				OP_AND [left/value and right/value]
				OP_OR  [left/value or right/value]
				OP_XOR [left/value xor right/value]
			]
		]
		as red-value! left
	]

	load-in: func [
		blk	  	[red-block!]
		value 	[integer!]
		/local
			int [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/load-in"]]

		int: as red-integer! ALLOC_TAIL(blk)
		int/header: TYPE_INTEGER
		int/value: value
	]

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

		int: as red-integer! stack/push*
		int/header: TYPE_INTEGER
		int/value: value
		int
	]

	to-float: func [
		i		[integer!]
		return: [float!]
		/local
			f	[float!]
			d	[int-ptr!]
	][
		;-- Based on this method: http://stackoverflow.com/a/429812/494472
		;-- A bit more explanation: http://lolengine.net/blog/2011/3/20/understanding-fast-float-integer-conversions
		f: 6755399441055744.0
		d: as int-ptr! :f
		d/value: i or d/value
		either i < 0 [f - 6755403736023040.0][f - 6755399441055744.0]
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/make"]]

		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				as red-integer! spec
			]
			default [
				--NOT_IMPLEMENTED--
				as red-integer! spec					;@@ just for making it compilable
			]
		]
	]

	random: func [
		int		[red-integer!]
		seed?	[logic!]
		secure? [logic!]
		only?   [logic!]
		return: [red-value!]
		/local
			n	 [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/random"]]

		either seed? [
			_random/srand int/value
			int/header: TYPE_UNSET
		][
			n: _random/rand % int/value + 1
			int/value: either negative? int/value [0 - n][n]
		]
		as red-value! int
	]

	to: func [
		type	[red-datatype!]
		spec	[red-integer!]
		return: [red-value!]
		/local
			f	[red-float!]
			buf [red-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/to"]]

		switch type/value [
			TYPE_FLOAT [
				f: as red-float! type
				f/header: TYPE_FLOAT
				f/value: to-float spec/value
			]
			TYPE_STRING [
				buf: string/rs-make-at as cell! type 1			;-- 16 bits string
				string/concatenate-literal buf form-signed spec/value
			]
			default [
				print-line "** Script error: Invalid argument for TO integer!"
				type/header: TYPE_UNSET
			]
		]
		as red-value! type
	]

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

		formed: form-signed int/value
		string/concatenate-literal buffer formed
		part - length? formed							;@@ optimize by removing length?
	]

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

		form int buffer arg part
	]

	compare: func [
		value1    [red-integer!]						;-- first operand
		value2    [red-integer!]						;-- second operand
		op	      [integer!]							;-- type of comparison
		return:   [logic!]
		/local
			char  [red-char!]
			f	  [red-float!]
			left  [integer!]
			right [integer!]
			res	  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/compare"]]

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_INTEGER [
				right: value2/value
			]
			TYPE_CHAR [
				char: as red-char! value2				;@@ could be optimized as integer! and char!
				right: char/value						;@@ structures are overlapping exactly
			]
			TYPE_FLOAT [
				f: as red-float! value1
				left: value1/value
				f/value: to-float left
				res: float/compare f as red-float! value2 op
				value1/value: left
				return res
			]
			default [RETURN_COMPARE_OTHER]
		]
		switch op [
			COMP_EQUAL 			[res: left = right]
			COMP_NOT_EQUAL 		[res: left <> right]
			COMP_STRICT_EQUAL	[res: all [TYPE_OF(value2) = TYPE_INTEGER left = right]]
			COMP_LESSER			[res: left <  right]
			COMP_LESSER_EQUAL	[res: left <= right]
			COMP_GREATER		[res: left >  right]
			COMP_GREATER_EQUAL	[res: left >= right]
		]
		res
	]

	complement: func [
		int		[red-integer!]
		return:	[red-value!]
	][
		int/value: not int/value
		as red-value! int
	]

	remainder: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/remainder"]]
		as red-value! do-math OP_REM
	]

	absolute: func [
		return: [red-integer!]
		/local
			int	  [red-integer!]
			value [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/absolute"]]

		int: as red-integer! stack/arguments
		int/value: abs int/value
		int
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/subtract"]]
		as red-value! do-math OP_SUB
	]

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

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

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

	negate: func [
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/value: 0 - int/value
		int 											;-- re-use argument slot for return value
	]

	int-power: func [
		base	[integer!]
		exp		[integer!]
		return: [integer!]
		/local
			res  [integer!]
			neg? [logic!]
	][
		res: 1
		neg?: false

		if exp < 0 [neg?: true exp: 0 - exp]
		while [exp <> 0][
			if as logic! exp and 1 [res: res * base]
			exp: exp >> 1
			base: base * base
		]
		either neg? [1 / res][res]
	]

	power: func [
		return:	 [red-value!]
		/local
			base [red-integer!]
			exp  [red-integer!]
			f	 [red-float!]
	][
		base: as red-integer! stack/arguments
		exp: base + 1
		either any [
			TYPE_OF(exp) = TYPE_FLOAT
			negative? exp/value
		][
			f: as red-float! base
			f/value: to-float base/value
			f/header: TYPE_FLOAT
			float/power
		][
			base/value: int-power base/value exp/value
		]
		as red-value! base
	]

	even?: func [
		int		[red-integer!]
		return: [logic!]
	][
		not as-logic int/value and 1
	]

	odd?: func [
		int		[red-integer!]
		return: [logic!]
	][
		as-logic int/value and 1
	]

	#define INT_TRUNC [int/value: either num > 0 [n - r][r - n]]

	#define INT_FLOOR [
		either m < 0 [
			print-line "*** Math Error: integer overflow on ROUND"
			int/header: TYPE_UNSET
		][
			int/value: either num > 0 [n - r][0 - m]
		]
	]

	#define INT_CEIL [
		either m < 0 [
			print-line "*** Math Error: integer overflow on ROUND"
			int/header: TYPE_UNSET
		][
			int/value: either num < 0 [r - n][m]
		]
	]

	#define INT_AWAY [
		either m < 0 [
			print-line "*** Math Error: integer overflow on ROUND"
			int/header: TYPE_UNSET
		][
			int/value: either num > 0 [m][0 - m]
		]
	]

	round: func [
		value		[red-value!]
		scale		[red-integer!]
		_even?		[logic!]
		down?		[logic!]
		half-down?	[logic!]
		floor?		[logic!]
		ceil?		[logic!]
		half-ceil?	[logic!]
		return:		[red-value!]
		/local
			int		[red-integer!]
			f		[red-float!]
			num		[integer!]
			sc		[integer!]
			s		[integer!]
			n		[integer!]
			m		[integer!]
			r		[integer!]
	][
		int: as red-integer! value
		num: int/value
		if num = 80000000h [return value]
		sc: 1
		if OPTION?(scale) [
			if TYPE_OF(scale) = TYPE_FLOAT [
				f: as red-float! value
				f/value: to-float num
				f/header: TYPE_FLOAT
				return float/round value as red-float! scale _even? down? half-down? floor? ceil? half-ceil?
			]
			sc: abs scale/value
		]

		if zero? sc [
			print-line "*** Math Error: integer overflow on ROUND"
			value/header: TYPE_UNSET
			return value
		]

		n: abs num
		r: n % sc
		if zero? r [return value]

		s: sc - r
		m: n + s
		case [
			down?		[INT_TRUNC]
			floor?		[INT_FLOOR]
			ceil?		[INT_CEIL ]
			r < s		[INT_TRUNC]
			r > s		[INT_AWAY ]
			_even?		[either zero? (n / sc and 1) [INT_TRUNC][INT_AWAY]]
			half-down?	[INT_TRUNC]
			half-ceil?	[INT_CEIL ]
			true		[INT_AWAY ]
		]
		value
	]

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

Red/System [
	Title:   "Integer! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %integer.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
	}
]

integer: context [
	verbose: 0

	abs: func [
		value	[integer!]
		return: [integer!]
	][
		if value = -2147483648 [
			print-line "*** Math Error: integer overflow on ABSOLUTE"
		]
		if negative? value [value: 0 - value]
		value
	]

	get*: func [										;-- unboxing integer value from stack
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		assert TYPE_OF(int) = TYPE_INTEGER
		int/value
	]

	get-any*: func [									;-- special get* variant for SWITCH
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		either TYPE_OF(int) = TYPE_INTEGER [int/value][0] ;-- accept NONE values
	]

	get: func [											;-- unboxing integer value
		value	[red-value!]
		return: [integer!]
		/local
			int [red-integer!]
	][
		assert TYPE_OF(value) = TYPE_INTEGER
		int: as red-integer! value
		int/value
	]

	box: func [
		value	[integer!]
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/header: TYPE_INTEGER
		int/value: value
		int
	]

	form-signed: func [									;@@ replace with sprintf() call?
		i 		[integer!]
		return: [c-string!]
		/local
			s	[c-string!]
			c 	[integer!]
			n 	[logic!]
	][
		s: "-0000000000"								;-- 11 bytes wide
		if zero? i [									;-- zero special case
			s/11: #"0"
			return s + 10
		]
		if i = -2147483648 [							;-- min integer special case
			return "-2147483648"
		]
		n: negative? i
		if n [i: negate i]
		c: 11
		while [i <> 0][
			s/c: #"0" + (i // 10)
			i: i / 10
			c: c - 1
		]
		if n [s/c: #"-" c: c - 1]
		s + c
	]

	do-math: func [
		type		[math-op!]
		return:		[red-value!]
		/local
			left	[red-integer!]
			right	[red-integer!]
	][
		left: as red-integer! stack/arguments
		right: left + 1

		assert any [									;@@ replace by typeset check when possible
			TYPE_OF(left) = TYPE_INTEGER
			TYPE_OF(left) = TYPE_CHAR
		]
		assert any [
			TYPE_OF(right) = TYPE_INTEGER
			TYPE_OF(right) = TYPE_CHAR
			TYPE_OF(right) = TYPE_FLOAT
		]

		either TYPE_OF(right) = TYPE_FLOAT [
			float/do-math type
		][
			left/value: switch type [
				OP_ADD [left/value + right/value]
				OP_SUB [left/value - right/value]
				OP_MUL [left/value * right/value]
				OP_DIV [left/value / right/value]
				OP_REM [left/value % right/value]
				OP_AND [left/value and right/value]
				OP_OR  [left/value or right/value]
				OP_XOR [left/value xor right/value]
			]
		]
		as red-value! left
	]

	load-in: func [
		blk	  	[red-block!]
		value 	[integer!]
		/local
			int [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/load-in"]]

		int: as red-integer! ALLOC_TAIL(blk)
		int/header: TYPE_INTEGER
		int/value: value
	]

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

		int: as red-integer! stack/push*
		int/header: TYPE_INTEGER
		int/value: value
		int
	]

	to-float: func [
		i		[integer!]
		return: [float!]
		/local
			f	[float!]
			d	[int-ptr!]
	][
		;-- Based on this method: http://stackoverflow.com/a/429812/494472
		;-- A bit more explanation: http://lolengine.net/blog/2011/3/20/understanding-fast-float-integer-conversions
		f: 6755399441055744.0
		d: as int-ptr! :f
		d/value: i or d/value
		either i < 0 [f - 6755403736023040.0][f - 6755399441055744.0]
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/make"]]

		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				as red-integer! spec
			]
			default [
				--NOT_IMPLEMENTED--
				as red-integer! spec					;@@ just for making it compilable
			]
		]
	]

	random: func [
		int		[red-integer!]
		seed?	[logic!]
		secure? [logic!]
		only?   [logic!]
		return: [red-value!]
		/local
			n	 [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/random"]]

		either seed? [
			_random/srand int/value
			int/header: TYPE_UNSET
		][
			n: _random/rand % int/value + 1
			int/value: either negative? int/value [0 - n][n]
		]
		as red-value! int
	]

	to: func [
		type	[red-datatype!]
		spec	[red-integer!]
		return: [red-value!]
		/local
			f	[red-float!]
			buf [red-string!]
	][
		switch type/value [
			TYPE_FLOAT [
				f: as red-float! type
				f/header: TYPE_FLOAT
				f/value: to-float spec/value
			]
			TYPE_STRING [
				buf: string/rs-make-at as cell! type 1			;-- 16 bits string
				string/concatenate-literal buf form-signed spec/value
			]
			default [
				print-line "** Script error: Invalid argument for TO integer!"
				type/header: TYPE_UNSET
			]
		]
		as red-value! type
	]

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

		formed: form-signed int/value
		string/concatenate-literal buffer formed
		part - length? formed							;@@ optimize by removing length?
	]

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

		form int buffer arg part
	]

	compare: func [
		value1    [red-integer!]						;-- first operand
		value2    [red-integer!]						;-- second operand
		op	      [integer!]							;-- type of comparison
		return:   [logic!]
		/local
			char  [red-char!]
			f	  [red-float!]
			left  [integer!]
			right [integer!]
			res	  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/compare"]]

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_INTEGER [
				right: value2/value
			]
			TYPE_CHAR [
				char: as red-char! value2				;@@ could be optimized as integer! and char!
				right: char/value						;@@ structures are overlapping exactly
			]
			TYPE_FLOAT [
				f: as red-float! value1
				left: value1/value
				f/value: to-float left
				res: float/compare f as red-float! value2 op
				value1/value: left
				return res
			]
			default [RETURN_COMPARE_OTHER]
		]
		switch op [
			COMP_EQUAL 			[res: left = right]
			COMP_NOT_EQUAL 		[res: left <> right]
			COMP_STRICT_EQUAL	[res: all [TYPE_OF(value2) = TYPE_INTEGER left = right]]
			COMP_LESSER			[res: left <  right]
			COMP_LESSER_EQUAL	[res: left <= right]
			COMP_GREATER		[res: left >  right]
			COMP_GREATER_EQUAL	[res: left >= right]
		]
		res
	]

	complement: func [
		int		[red-integer!]
		return:	[red-value!]
	][
		int/value: not int/value
		as red-value! int
	]

	remainder: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/remainder"]]
		as red-value! do-math OP_REM
	]

	absolute: func [
		return: [red-integer!]
		/local
			int	  [red-integer!]
			value [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/absolute"]]

		int: as red-integer! stack/arguments
		int/value: abs int/value
		int
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/subtract"]]
		as red-value! do-math OP_SUB
	]

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

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

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

	negate: func [
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/value: 0 - int/value
		int 											;-- re-use argument slot for return value
	]

	int-power: func [
		base	[integer!]
		exp		[integer!]
		return: [integer!]
		/local
			res  [integer!]
			neg? [logic!]
	][
		res: 1
		neg?: false

		if exp < 0 [neg?: true exp: 0 - exp]
		while [exp <> 0][
			if as logic! exp and 1 [res: res * base]
			exp: exp >> 1
			base: base * base
		]
		either neg? [1 / res][res]
	]

	power: func [
		return:	 [red-value!]
		/local
			base [red-integer!]
			exp  [red-integer!]
			f	 [red-float!]
	][
		base: as red-integer! stack/arguments
		exp: base + 1
		either any [
			TYPE_OF(exp) = TYPE_FLOAT
			negative? exp/value
		][
			f: as red-float! base
			f/value: to-float base/value
			f/header: TYPE_FLOAT
			float/power
		][
			base/value: int-power base/value exp/value
		]
		as red-value! base
	]

	even?: func [
		int		[red-integer!]
		return: [logic!]
	][
		not as-logic int/value and 1
	]

	odd?: func [
		int		[red-integer!]
		return: [logic!]
	][
		as-logic int/value and 1
	]

	#define INT_TRUNC [int/value: either num > 0 [n - r][r - n]]

	#define INT_FLOOR [
		either m < 0 [
			print-line "*** Math Error: integer overflow on ROUND"
			int/header: TYPE_UNSET
		][
			int/value: either num > 0 [n - r][0 - m]
		]
	]

	#define INT_CEIL [
		either m < 0 [
			print-line "*** Math Error: integer overflow on ROUND"
			int/header: TYPE_UNSET
		][
			int/value: either num < 0 [r - n][m]
		]
	]

	#define INT_AWAY [
		either m < 0 [
			print-line "*** Math Error: integer overflow on ROUND"
			int/header: TYPE_UNSET
		][
			int/value: either num > 0 [m][0 - m]
		]
	]

	round: func [
		value		[red-value!]
		scale		[red-integer!]
		_even?		[logic!]
		down?		[logic!]
		half-down?	[logic!]
		floor?		[logic!]
		ceil?		[logic!]
		half-ceil?	[logic!]
		return:		[red-value!]
		/local
			int		[red-integer!]
			f		[red-float!]
			num		[integer!]
			sc		[integer!]
			s		[integer!]
			n		[integer!]
			m		[integer!]
			r		[integer!]
	][
		int: as red-integer! value
		num: int/value
		if num = 80000000h [return value]
		sc: 1
		if OPTION?(scale) [
			if TYPE_OF(scale) = TYPE_FLOAT [
				f: as red-float! value
				f/value: to-float num
				f/header: TYPE_FLOAT
				return float/round value as red-float! scale _even? down? half-down? floor? ceil? half-ceil?
			]
			sc: abs scale/value
		]

		if zero? sc [
			print-line "*** Math Error: integer overflow on ROUND"
			value/header: TYPE_UNSET
			return value
		]

		n: abs num
		r: n % sc
		if zero? r [return value]

		s: sc - r
		m: n + s
		case [
			down?		[INT_TRUNC]
			floor?		[INT_FLOOR]
			ceil?		[INT_CEIL ]
			r < s		[INT_TRUNC]
			r > s		[INT_AWAY ]
			_even?		[either zero? (n / sc and 1) [INT_TRUNC][INT_AWAY]]
			half-down?	[INT_TRUNC]
			half-ceil?	[INT_CEIL ]
			true		[INT_AWAY ]
		]
		value
	]

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


#230 | Sidu | Switching screencasts page to refer to youtube as a temporary fix, while we create a new screencast

h1. Screencasts

  !/images/documentation/5_minute_install.png!

h3. "5 Minute Install"

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

<object width="425" height="344"><param name="movie" value="http://www.youtube.com/v/lW4eSQa9M6A&hl=en&fs=1&"></param><param name="allowFullScreen" value="true"></param><param name="allowscriptaccess" value="always"></param><embed src="http://www.youtube.com/v/lW4eSQa9M6A&hl=en&fs=1&" type="application/x-shockwave-flash" allowscriptaccess="always" allowfullscreen="true" width="425" height="344"></embed></object>

h1. Screencasts

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

h3. "5 Minute Install":http://cruisecontrolrb.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.


TESTS: added regression tests for issue #785.

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

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

~~~start-file~~~ "bitset"

===start-group=== "basic tests"

	--test-- "basic-1"	--assert "make bitset! #{00}" = mold make bitset! 1
	--test-- "basic-2"	--assert "make bitset! #{00}" = mold charset ""
	--test-- "basic-3"	--assert "make bitset! #{00}" = mold charset []
	--test-- "basic-4"	--assert "make bitset! #{80}" = mold charset #"^(00)"
	--test-- "basic-5"	--assert "make bitset! #{40}" = mold charset #"^(01)"
	--test-- "basic-6"	--assert "make bitset! #{000000000000FFC0}" = mold charset "0123456789"
	--test-- "basic-7"	--assert "make bitset! #{F0}" = mold charset [0 1 2 3]

	--test-- "basic-8"
		--assert "make bitset! #{FF800000FFFF8000048900007FFFFFE0}"
			 = mold charset [#"a" - #"z" 0 - 8 32 - #"0" "HELLO"]

	--test-- "basic-9"
		bs: make bitset! [0 1 2 3]
		--assert 8 = length? bs
		--assert true  = pick bs 0
		--assert true  = pick bs 1
		--assert true  = pick bs 2
		--assert true  = pick bs 3
		--assert false = pick bs 4
		--assert false = pick bs 256
		--assert false = pick bs 257
		--assert false = pick bs 2147483647
		--assert false = pick bs -2147483648

	--test-- "basic-10"
		bs: make bitset! [0 1 2 3]
		--assert 8 = length? bs
		--assert true  = bs/0
		--assert true  = bs/1
		--assert true  = bs/2
		--assert true  = bs/3
		--assert false = bs/4
		--assert false = bs/256
		--assert false = bs/257
		--assert false = bs/2147483647
		--assert false = bs/-2147483648

	--test-- "basic-11"
		bs: make bitset! [0 1 2 3]
		--assert 8 = length? bs
		--assert true  = pick bs #"^(00)"
		--assert true  = pick bs #"^(01)"
		--assert true  = pick bs #"^(02)"
		--assert true  = pick bs #"^(03)"
		--assert false = pick bs #"^(04)"
		--assert false = pick bs #"^(0100)"
		--assert false = pick bs #"^(0101)"

	--test-- "basic-12"
		bs: make bitset! [0100h 0102h]
		--assert 264 = length? bs
		--assert true  = pick bs 0100h
		--assert false = pick bs 0101h
		--assert true  = pick bs 0102h

	--test-- "basic-13"
		bs: make bitset! [255 257]
		--assert 264 = length? bs
		--assert true  = pick bs 255
		--assert false = pick bs 256
		--assert true  = pick bs 257

	--test-- "basic-14"
		bs: make bitset! [255 256]
		--assert 264 = length? bs
		--assert true = pick bs 255
		--assert true = pick bs 256

	--test-- "basic-15"
		bs: make bitset! [00010000h]
		--assert 65544 = length? bs
		--assert true = pick bs 00010000h

	--test-- "basic-16"
		bs: make bitset! 9
		--assert 16 = length? bs
		bs/7: yes
		--assert bs/7 = true
		--assert bs/8 = false
		bs/8: yes
		--assert bs/8 = true
		--assert bs/9 = false

	--test-- "basic-17"
		bs: make bitset! 8
		--assert 8 = length? bs
		bs/7: yes
		--assert bs/7 = true
		--assert bs/8 = false
		bs/8: yes
		--assert 16 = length? bs
		--assert bs/8 = true
		--assert bs/9 = false

===end-group===

===start-group=== "modify"

	--test-- "poke-1"
		bs: make bitset! [0 1 2 3]
		poke bs 4 true
		--assert true = pick bs 0
		--assert true = pick bs 1
		--assert true = pick bs 2
		--assert true = pick bs 3
		--assert true = pick bs 4
		--assert false = pick bs 5

	--test-- "poke-2"
		bs: make bitset! [0 1 2 3]
		--assert true = pick bs 0
		poke bs 0 false
		--assert false = pick bs 0
		poke bs 0 true
		--assert true = pick bs 0
		poke bs 0 none
		--assert false = pick bs 0
		bs/0: yes
		--assert bs/0 = true
		bs/0: no
		--assert bs/0 = false
		bs/0: yes
		--assert bs/0 = true
		bs/0: none
		--assert bs/0 = false

	--test-- "append-1"
		bs: make bitset! 8
		--assert 8 = length? bs
		append bs ["hello" #"x" - #"z"]
		--assert "make bitset! #{000000000000000000000000048900E0}" = mold bs

	--test-- "clear-1"
		clear bs
		--assert "make bitset! #{00000000000000000000000000000000}" = mold bs

	--test-- "clear-2"
		bs: charset "^(00)^(01)^(02)^(03)^(04)^(05)^(06)^(07)"
		--assert 8 = length? bs
		--assert "make bitset! #{FF}" = mold bs
		clear bs
		--assert "make bitset! #{00}" = mold bs

	--test-- "remove-1"
		bs: charset "012345789"
		--assert 64 = length? bs
		--assert "make bitset! #{000000000000FDC0}" = mold bs
		--assert "make bitset! #{0000000000007DC0}" = mold remove/part bs #"0"
		--assert "make bitset! #{0000000000003DC0}" = mold remove/part bs 49
		--assert "make bitset! #{0000000000000000}" = mold remove/part bs [#"2" - #"7" "8" #"9"]

===end-group===

===start-group=== "union"

	--test-- "u-1"
		c1: charset "0123456789"
		c2: charset [#"a" - #"z"]
		u: "make bitset! #{000000000000FFC0000000007FFFFFE0}"
		--assert u = mold union c1 c2
		--assert u = mold union c2 c1

	--test-- "u-2"
		nd: charset [not #"0" - #"9"]
		zero: charset #"0"
		nd-zero: union nd zero
		--assert not find nd #"0"
		--assert not find nd #"1"
		--assert find nd #"B"
		--assert find nd #"}"

	--test-- "u-3"
		--assert find zero #"0"
		--assert not find zero #"1"
		--assert not find zero #"B"
		--assert not find zero #"}"

	--test-- "u-4"
		--assert find nd-zero #"0"
		--assert not find nd-zero #"1"
		--assert find nd-zero #"B"
		--assert find nd-zero #"}"

===end-group===

===start-group=== "complemented"

	--test-- "comp-1"	--assert "make bitset! [not #{}]"   = mold charset [not]
	--test-- "comp-2"	--assert "make bitset! [not #{80}]" = mold charset [not #"^(00)"]
	--test-- "comp-3"	--assert "make bitset! [not #{40}]" = mold charset [not #"^(01)"]
	--test-- "comp-4"	--assert "make bitset! [not #{000000000000FFC0}]" = mold charset [not "0123456789"]
	--test-- "comp-5"	--assert "make bitset! [not #{F0}]" = mold charset [not 0 1 2 3]

	--test-- "comp-6"
		bs: make bitset! 1
		--assert false = complement? bs
		--assert "make bitset! #{00}" = mold bs
		--assert 8 = length? bs
		bs: complement bs
		--assert true = complement? bs
		--assert 8 = length? bs
		--assert "make bitset! [not #{00}]" = mold bs

	--test-- "comp-7"
		bs: charset [not "hello123" #"a" - #"z"]
		--assert 128 = length? bs
		--assert "make bitset! [not #{0000000000007000000000007FFFFFE0}]" = mold bs
		clear bs
		--assert 128 = length? bs
		--assert "make bitset! [not #{00000000000000000000000000000000}]" = mold bs

	--test-- "comp-8"
		bs: complement charset " "
		--assert 40 = length? bs
		--assert bs/31 = true
		--assert bs/32 = false
		--assert bs/33 = true
		--assert bs/200 = true

	--test-- "comp-9"
		bs/32: true
		--assert bs/32 = true
		--assert "make bitset! [not #{0000000000}]" = mold bs

	--test-- "comp-10"
		poke bs #" " none
		--assert bs/32 = false
		--assert "make bitset! [not #{0000000080}]" = mold bs

	--test-- "comp-11"
		clear bs
		--assert "make bitset! [not #{0000000000}]" = mold bs

	--test-- "comp-12"
		poke bs [32 - 40] none
		--assert "make bitset! [not #{00000000FF80}]" = mold bs
		poke bs [32 - 40] true
		--assert "make bitset! [not #{000000000000}]" = mold bs

===end-group===

~~~end-file~~~

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

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

~~~start-file~~~ "bitset"

===start-group=== "basic tests"

	--test-- "basic-1"	--assert "make bitset! #{00}" = mold make bitset! 1
	--test-- "basic-2"	--assert "make bitset! #{00}" = mold charset ""
	--test-- "basic-3"	--assert "make bitset! #{00}" = mold charset []
	--test-- "basic-4"	--assert "make bitset! #{80}" = mold charset #"^(00)"
	--test-- "basic-5"	--assert "make bitset! #{40}" = mold charset #"^(01)"
	--test-- "basic-6"	--assert "make bitset! #{000000000000FFC0}" = mold charset "0123456789"
	--test-- "basic-7"	--assert "make bitset! #{F0}" = mold charset [0 1 2 3]

	--test-- "basic-8"
		--assert "make bitset! #{FF800000FFFF8000048900007FFFFFE0}"
			 = mold charset [#"a" - #"z" 0 - 8 32 - #"0" "HELLO"]

	--test-- "basic-9"
		bs: make bitset! [0 1 2 3]
		--assert 8 = length? bs
		--assert true  = pick bs 0
		--assert true  = pick bs 1
		--assert true  = pick bs 2
		--assert true  = pick bs 3
		--assert false = pick bs 4
		--assert false = pick bs 256
		--assert false = pick bs 257
		--assert false = pick bs 2147483647
		--assert false = pick bs -2147483648

	--test-- "basic-10"
		bs: make bitset! [0 1 2 3]
		--assert 8 = length? bs
		--assert true  = bs/0
		--assert true  = bs/1
		--assert true  = bs/2
		--assert true  = bs/3
		--assert false = bs/4
		--assert false = bs/256
		--assert false = bs/257
		--assert false = bs/2147483647
		--assert false = bs/-2147483648

	--test-- "basic-11"
		bs: make bitset! [0 1 2 3]
		--assert 8 = length? bs
		--assert true  = pick bs #"^(00)"
		--assert true  = pick bs #"^(01)"
		--assert true  = pick bs #"^(02)"
		--assert true  = pick bs #"^(03)"
		--assert false = pick bs #"^(04)"
		--assert false = pick bs #"^(0100)"
		--assert false = pick bs #"^(0101)"

	--test-- "basic-12"
		bs: make bitset! [0100h 0102h]
		--assert 264 = length? bs
		--assert true  = pick bs 0100h
		--assert false = pick bs 0101h
		--assert true  = pick bs 0102h

	--test-- "basic-13"
		bs: make bitset! [255 257]
		--assert 264 = length? bs
		--assert true  = pick bs 255
		--assert false = pick bs 256
		--assert true  = pick bs 257

	--test-- "basic-14"
		bs: make bitset! [255 256]
		--assert 264 = length? bs
		--assert true = pick bs 255
		--assert true = pick bs 256

	--test-- "basic-15"
		bs: make bitset! [00010000h]
		--assert 65544 = length? bs
		--assert true = pick bs 00010000h

	--test-- "basic-16"
		bs: make bitset! 9
		--assert 16 = length? bs
		bs/7: yes
		--assert bs/7 = true
		--assert bs/8 = false
		bs/8: yes
		--assert bs/8 = true
		--assert bs/9 = false

	--test-- "basic-17"
		bs: make bitset! 8
		--assert 8 = length? bs
		bs/7: yes
		--assert bs/7 = true
		--assert bs/8 = false
		bs/8: yes
		--assert 16 = length? bs
		--assert bs/8 = true
		--assert bs/9 = false

===end-group===

===start-group=== "modify"

	--test-- "poke-1"
		bs: make bitset! [0 1 2 3]
		poke bs 4 true
		--assert true = pick bs 0
		--assert true = pick bs 1
		--assert true = pick bs 2
		--assert true = pick bs 3
		--assert true = pick bs 4
		--assert false = pick bs 5

	--test-- "poke-2"
		bs: make bitset! [0 1 2 3]
		--assert true = pick bs 0
		poke bs 0 false
		--assert false = pick bs 0
		poke bs 0 true
		--assert true = pick bs 0
		poke bs 0 none
		--assert false = pick bs 0
		bs/0: yes
		--assert bs/0 = true
		bs/0: no
		--assert bs/0 = false
		bs/0: yes
		--assert bs/0 = true
		bs/0: none
		--assert bs/0 = false

	--test-- "append-1"
		bs: make bitset! 8
		--assert 8 = length? bs
		append bs ["hello" #"x" - #"z"]
		--assert "make bitset! #{000000000000000000000000048900E0}" = mold bs

	--test-- "clear-1"
		clear bs
		--assert "make bitset! #{00000000000000000000000000000000}" = mold bs

	--test-- "clear-2"
		bs: charset "^(00)^(01)^(02)^(03)^(04)^(05)^(06)^(07)"
		--assert 8 = length? bs
		--assert "make bitset! #{FF}" = mold bs
		clear bs
		--assert "make bitset! #{00}" = mold bs

	--test-- "remove-1"
		bs: charset "012345789"
		--assert 64 = length? bs
		--assert "make bitset! #{000000000000FDC0}" = mold bs
		--assert "make bitset! #{0000000000007DC0}" = mold remove/part bs #"0"
		--assert "make bitset! #{0000000000003DC0}" = mold remove/part bs 49
		--assert "make bitset! #{0000000000000000}" = mold remove/part bs [#"2" - #"7" "8" #"9"]

===end-group===

===start-group=== "union"

	--test-- "u-1"
		c1: charset "0123456789"
		c2: charset [#"a" - #"z"]
		u: "make bitset! #{000000000000FFC0000000007FFFFFE0}"
		--assert u = mold union c1 c2
		--assert u = mold union c2 c1

===end-group===

===start-group=== "complemented"

	--test-- "comp-1"	--assert "make bitset! [not #{}]"   = mold charset [not]
	--test-- "comp-2"	--assert "make bitset! [not #{80}]" = mold charset [not #"^(00)"]
	--test-- "comp-3"	--assert "make bitset! [not #{40}]" = mold charset [not #"^(01)"]
	--test-- "comp-4"	--assert "make bitset! [not #{000000000000FFC0}]" = mold charset [not "0123456789"]
	--test-- "comp-5"	--assert "make bitset! [not #{F0}]" = mold charset [not 0 1 2 3]

	--test-- "comp-6"
		bs: make bitset! 1
		--assert false = complement? bs
		--assert "make bitset! #{00}" = mold bs
		--assert 8 = length? bs
		bs: complement bs
		--assert true = complement? bs
		--assert 8 = length? bs
		--assert "make bitset! [not #{00}]" = mold bs

	--test-- "comp-7"
		bs: charset [not "hello123" #"a" - #"z"]
		--assert 128 = length? bs
		--assert "make bitset! [not #{0000000000007000000000007FFFFFE0}]" = mold bs
		clear bs
		--assert 128 = length? bs
		--assert "make bitset! [not #{00000000000000000000000000000000}]" = mold bs

	--test-- "comp-8"
		bs: complement charset " "
		--assert 40 = length? bs
		--assert bs/31 = true
		--assert bs/32 = false
		--assert bs/33 = true
		--assert bs/200 = true

	--test-- "comp-9"
		bs/32: true
		--assert bs/32 = true
		--assert "make bitset! [not #{0000000000}]" = mold bs

	--test-- "comp-10"
		poke bs #" " none
		--assert bs/32 = false
		--assert "make bitset! [not #{0000000080}]" = mold bs

	--test-- "comp-11"
		clear bs
		--assert "make bitset! [not #{0000000000}]" = mold bs

	--test-- "comp-12"
		poke bs [32 - 40] none
		--assert "make bitset! [not #{00000000FF80}]" = mold bs
		poke bs [32 - 40] true
		--assert "make bitset! [not #{000000000000}]" = mold bs

===end-group===

~~~end-file~~~