Revert "Partial fixes for call"

Revert "Partial fixes for call"

This reverts commit 51c43601d8db5057aa5d67cfa6aec56df0ec8e22.

Red [
	Title:  "Red call binding"
	Author: "Bruno Anselme"
	EMail:  "be.red@free.fr"
	File:   %call.red
	Rights: "Copyright (c) 2014-2015 Bruno Anselme"
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
	Needs: {
		Red/System >= 0.4.1
		%call.reds
	}
]

#system-global [ #include %call.reds ]

; Routines definitions
redsys-call: routine [ "Set IO buffers if needed, execute call"
	cmd        [string!]  "Command"
	waitend    [logic!]   "Wait for end of child process"
	console    [logic!]   "Runs command with I/O redirected to console"
	shell      [logic!]   "Forces command to be run from shell"
	redirin    [logic!]   "Input redirection"
	in-str     [string!]  "Input data"
	redirout   [logic!]   "Output redirection"
	redirerr   [logic!]   "Error redirection"
	return:    [integer!]
	/local
	inp out err s
][
	either redirin [
		inp: declare p-buffer!
		inp/buffer: string/rs-head in-str
		s: GET_BUFFER(in-str)
		inp/count:  GET_UNIT(s) * string/rs-length? in-str
		#if OS = 'Windows [ system-call/to-ascii inp ]
	][
		inp: null
	]
	either redirout [
		out:  declare p-buffer!
		out/buffer: null
		out/count:  0
	][
		out: null
	]
	either redirerr [
		err:  declare p-buffer!
		err/buffer: null
		err/count:  0
	][
		err: null
	]
	system-call/call (as-c-string string/rs-head cmd) waitend console shell inp out err
]

get-out: routine [ "Returns redirected stdout"
	/local
		sout   [red-string!]
		str    [c-string!]
		result [integer!]
][
	with system-call [
		#either OS = 'Windows [
			result: IS_TEXT_UNICODE_UNICODE_MASK
			is-text-unicode outputs/out/buffer outputs/out/count :result
			either result = 0 [
				to-ascii outputs/out
				sout: string/load as-c-string outputs/out/buffer (1 + outputs/out/count) UTF-8
			][
				sout: string/load as-c-string outputs/out/buffer (1 + (outputs/out/count / 2)) UTF-16LE
			]
		][
			sout: string/load as-c-string outputs/out/buffer (1 + outputs/out/count) UTF-8
		]
		free outputs/out/buffer
		SET_RETURN(sout)
	]
]

get-err: routine [ "Returns redirected stderr"
	/local
		serr	[red-string!]
		result	[integer!]
][
	with system-call [
		#either OS = 'Windows [
			result: IS_TEXT_UNICODE_UNICODE_MASK
			is-text-unicode outputs/err/buffer outputs/err/count :result
			either result = 0 [
				to-ascii outputs/err
				serr: string/load as-c-string outputs/err/buffer (1 + outputs/err/count) UTF-8
			][
				serr: string/load as-c-string outputs/err/buffer (1 + (outputs/err/count / 2)) UTF-16LE
			]
		][
			serr: string/load as-c-string outputs/err/buffer (1 + outputs/err/count) UTF-8
		]
		free outputs/err/buffer
		SET_RETURN(serr)
	]
]

print-to-stderr: routine [ "Call to low level print to stderr"
	mesg	[string!]
][
	system-call/print-error [ as-c-string string/rs-head mesg ]
]

print-error: func [
	mesg			[string! block!]	"A shell command, an executable file or a block"
][
	if block? mesg [ mesg: form mesg ]
	print-to-stderr mesg
]

call: func [ "Executes a shell command to run another process."
	cmd			[string! block!]	"A shell command, an executable file or a block"
	/wait							"Runs command and waits for exit"
	/console						"Runs command with I/O redirected to console"
	/shell							"Forces command to be run from shell"
	/input	in	[string! block!]	"Redirects in to stdin"
	/output	out	[string! block!]	"Redirects stdout to out"
	/error	err	[string! block!]	"Redirects stderr to err"
	return:		[integer!]			"0 if success, -1 if error, or a process ID"
	/local
		pid		[integer!]
		str		[string!]
		do-in do-out do-err
][
	pid: 0
	if block? cmd [ cmd: form cmd ]
	either input  [
		if block? in [ in: form in ]
		str: in
	][
		str: ""
	]
	pid: redsys-call cmd wait console shell input str output error
	if output [
		str: get-out
		parse str [ while [ ahead crlf remove cr | skip ] ]
		out: head insert out str
	]
	if error [
		str: get-err
		parse str [ while [ ahead crlf remove cr | skip ] ]
		err: head insert err str
	]
	pid
]

Red [
	Title:  "Red call binding"
	Author: "Bruno Anselme"
	EMail:  "be.red@free.fr"
	File:   %call.red
	Rights: "Copyright (c) 2014-2015 Bruno Anselme"
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
	Needs: {
		Red/System >= 0.4.1
		%call.reds
	}
]

#system-global [ #include %call.reds ]

; Routines definitions
redsys-call: routine [ "Set IO buffers if needed, execute call"
	cmd        [string!]  "Command"
	waitend    [logic!]   "Wait for end of child process"
	console    [logic!]   "Runs command with I/O redirected to console"
	shell      [logic!]   "Forces command to be run from shell"
	redirin    [logic!]   "Input redirection"
	in-str     [string!]  "Input data"
	redirout   [logic!]   "Output redirection"
	redirerr   [logic!]   "Error redirection"
	return:    [integer!]
	/local
	inp out err s
][
	either redirin [
		inp: declare p-buffer!
		inp/buffer: string/rs-head in-str
		s: GET_BUFFER(in-str)
		inp/count:  GET_UNIT(s) * string/rs-length? in-str
		#if OS = 'Windows [ system-call/to-ascii inp ]
	][
		inp: null
	]
	either redirout [
		out:  declare p-buffer!
		out/buffer: null
		out/count:  0
	][
		out: null
	]
	either redirerr [
		err:  declare p-buffer!
		err/buffer: null
		err/count:  0
	][
		err: null
	]
	system-call/call (as-c-string string/rs-head cmd) waitend console shell inp out err
]

get-out: routine [ "Returns redirected stdout"
	/local
		sout   [red-string!]
		str    [c-string!]
		result [integer!]
][
	with system-call [
		#either OS = 'Windows [
			result: IS_TEXT_UNICODE_UNICODE_MASK
			is-text-unicode outputs/out/buffer outputs/out/count :result
			either result = 0 [
				to-ascii outputs/out
				sout: string/load as-c-string outputs/out/buffer (outputs/out/count) UTF-8
			][
				sout: string/load as-c-string outputs/out/buffer ((outputs/out/count / 2)) UTF-16LE
			]
		][
			sout: string/load as-c-string outputs/out/buffer (outputs/out/count) UTF-8
		]
		free outputs/out/buffer
		SET_RETURN(sout)
	]
]

get-err: routine [ "Returns redirected stderr"
	/local
		serr	[red-string!]
		result	[integer!]
][
	with system-call [
		#either OS = 'Windows [
			result: IS_TEXT_UNICODE_UNICODE_MASK
			is-text-unicode outputs/err/buffer outputs/err/count :result
			either result = 0 [
				to-ascii outputs/err
				serr: string/load as-c-string outputs/err/buffer (outputs/err/count) UTF-8
			][
				serr: string/load as-c-string outputs/err/buffer ((outputs/err/count / 2)) UTF-16LE
			]
		][
			serr: string/load as-c-string outputs/err/buffer (outputs/err/count) UTF-8
		]
		free outputs/err/buffer
		SET_RETURN(serr)
	]
]

print-to-stderr: routine [ "Call to low level print to stderr"
	mesg	[string!]
][
	system-call/print-error [ as-c-string string/rs-head mesg ]
]

print-error: func [
	mesg			[string! block!]	"A shell command, an executable file or a block"
][
	if block? mesg [ mesg: form mesg ]
	print-to-stderr mesg
]

call: func [ "Executes a shell command to run another process."
	cmd			[string! block!]	"A shell command, an executable file or a block"
	/wait							"Runs command and waits for exit"
	/console						"Runs command with I/O redirected to console"
	/shell							"Forces command to be run from shell"
	/input	in*	[string! block!]	"Redirects in to stdin"
	/output	out	[string! block!]	"Redirects stdout to out"
	/error	err	[string! block!]	"Redirects stderr to err"
	return:		[integer!]			"0 if success, -1 if error, or a process ID"
	/local
		pid		[integer!]
		str		[string!]
		do-in do-out do-err
][
	pid: 0
	if block? cmd [ cmd: form cmd ]
	either input  [
		if block? in* [ in*: form in* ]
		str: in*
	][
		str: ""
	]
	pid: redsys-call cmd wait console shell input str output error
	if output [
		str: get-out
		parse str [ while [ ahead crlf remove cr | skip ] ]
		out: head insert out str
	]
	if error [
		str: get-err
		parse str [ while [ ahead crlf remove cr | skip ] ]
		err: head insert err str
	]
	pid
]


TESTS: more regression tests added for issue #272.

Red/System [
	Title:   "Red/System logic! datatype test script"
	Author:  "Nenad Rakocevic"
	File: 	 %logic-test.reds
	Version: 0.1.1
	Rights:  "Copyright (C) 2011 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===

~~~end-file~~~

Red/System [
	Title:   "Red/System logic! datatype test script"
	Author:  "Nenad Rakocevic"
	File: 	 %logic-test.reds
	Version: 0.1.1
	Rights:  "Copyright (C) 2011 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

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

~~~end-file~~~


FIX: wrong free? flag in series frame compacting function

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

;-- New built-in natives worth adding to Red/System??
; get-bit n value
; set-bit n value
; clear-bit n value
; bit-set? n value

;-- cell header bits layout --
;   31:		mark							;-- mark as referenced for the GC (mark phase)
;   30:		lock							;-- lock slot for active thread access only
;   29:		immutable						;-- mark as read-only (series only)
;   28:		new-line						;-- new-line (LF) marker (before the slot)
;   27:		big								;-- indicates a big series (big-frame!)
;	26:		stack							;-- series buffer is allocated on stack (series only)
;   25:		permanent						;-- protected from GC (system-critical series)
;   25-8:	<reserved>
;   7-0:	datatype ID						;-- datatype number

#define _128KB				131072			; @@ create a dedicated datatype?
#define _2MB				2097152
#define _16MB				16777216
#define nodes-per-frame		5000
#define node-frame-size		[((nodes-per-frame * 2 * size? pointer!) + size? node-frame!)]

#define series-in-use		80000000h		;-- mark a series as used (not collectable by the GC)
#define flag-series-big		40000000h		;-- 1 = big, 0 = series
#define flag-ins-head		10000000h		;-- optimize for head insertions
#define flag-ins-tail		20000000h		;-- optimize for tail insertions
#define flag-ins-both		30000000h		;-- optimize for both head & tail insertions
#define s-size-mask			00FFFFFFh		;-- mask for 24-bit size field

int-array!: alias struct! [ptr [int-ptr!]]

cell!: alias struct! [
	header	[integer!]						;-- cell's header flags
	data1	[integer!]						;-- placeholders to make a 128-bit cell
	data2	[integer!]
	data3	[integer!]
]

series-buffer!: alias struct! [
	size	[integer!]						;-- bitfield (see below)
	node	[int-ptr!]						;-- point back to referring node
	head	[integer!]						;-- series buffer head index
	tail	[integer!]						;-- series buffer tail index
]
;; size bitfield:
;; 31: 		used (1 = used, 0 = free)
;; 30: 		type (always 0 for series-buffer!)
;; 29-28: 	insert-opt (2 = head, 1 = tail, 0 = both)
;; 27-24: 	reserved
;; 23-0: 	size of allocated buffer

series-frame!: alias struct! [				;-- series frame header
	next	[series-frame!]					;-- next frame or null
	prev	[series-frame!]					;-- previous frame or null
	heap	[series-buffer!]				;-- point to allocatable region
	tail	[byte-ptr!]						;-- point to last byte in allocatable region
]

node-frame!: alias struct! [				;-- node frame header
	next	[node-frame!]					;-- next frame or null
	prev	[node-frame!]					;-- previous frame or null
	nodes	[integer!]						;-- number of nodes
	bottom	[int-ptr!]						;-- bottom of stack (last entry, fixed)
	top		[int-ptr!]						;-- top of stack (first entry, moving)
]

big-frame!: alias struct! [					;-- big frame header (for >= 2MB series)
	flags	[integer!]						;-- bit 30: 1 (type = big)
	next	[big-frame!]					;-- next frame or null
	size	[integer!]						;-- size (up to 4GB - size? header)
	padding [integer!]						;-- make this header same size as series-buffer! header
]

memory: declare struct! [					; TBD: instanciate this structure per OS thread
	total	 [integer!]						;-- total memory size allocated (in bytes)
	n-head	 [node-frame!]					;-- head of node frames list
	n-active [node-frame!]					;-- actively used node frame
	n-tail	 [node-frame!]					;-- tail of node frames list
	s-head	 [series-frame!]				;-- head of series frames list
	s-active [series-frame!]				;-- actively used series frame
	s-tail	 [series-frame!]				;-- tail of series frames list
	s-start	 [integer!]						;-- start size for new series frame		(1)
	s-size	 [integer!]						;-- current size for new series frame	(1)
	s-max	 [integer!]						;-- max size for new series frames		(1)
	b-head	 [big-frame!]					;-- head of big frames list
]

memory/total: 	0
memory/s-start: _128KB
memory/s-max: 	_2MB
memory/s-size: 	memory/s-start
;; (1) Series frames size will grow from 128KB up to 2MB (arbitrary selected). This
;; range will need fine-tuning with real Red apps. This growing size, with low starting value
;; will allow small apps to not consume much memory while avoiding to penalize big apps.

;-------------------------------------------
;-- Allocate paged virtual memory region
;-------------------------------------------
allocate-virtual: func [
	size 	[integer!]						;-- allocated size in bytes (page size multiple)
	exec? 	[logic!]						;-- TRUE => executable region
	return: [int-ptr!]						;-- allocated memory region pointer
	/local ptr
][
	size: round-to size + 4	OS-page-size	;-- account for header (one word)
	memory/total: memory/total + size
	ptr: OS-allocate-virtual size exec?
	ptr/value: size							;-- store size in header
	ptr + 1									;-- return pointer after header
]

;-------------------------------------------
;-- Free paged virtual memory region from OS
;-------------------------------------------
free-virtual: func [
	ptr [int-ptr!]							;-- address of memory region to release
][
	ptr: ptr - 1							;-- return back to header
	memory/total: memory/total - ptr/value
	OS-free-virtual ptr
]

;-------------------------------------------
;-- Free all frames (part of Red's global exit handler)
;-------------------------------------------
free-all: func [
	/local n-frame s-frame b-frame
][
	n-frame: memory/n-head
	while [n-frame <> null][
		free-virtual as int-ptr! n-frame
		n-frame: n-frame/next
	]

	s-frame: memory/s-head
	while [s-frame <> null][
		free-virtual as int-ptr! s-frame
		s-frame: s-frame/next
	]

	b-frame: memory/b-head
	while [b-frame <> null][
		free-virtual as int-ptr! b-frame
		b-frame: b-frame/next
	]
]

;-------------------------------------------
;-- Format the node frame stack by filling it with pointers to all nodes
;-------------------------------------------
format-node-stack: func [
	frame [node-frame!]						;-- node frame to format
	/local node ptr
][
	ptr: frame/bottom						;-- point to bottom of stack
	node: ptr + frame/nodes					;-- first free node address
	until [
		ptr/value: as-integer node			;-- store free node address on stack
		node: node + 1
		ptr: ptr + 1
		ptr > frame/top						;-- until the stack is filled up
	]
]

;-------------------------------------------
;-- Allocate a node frame buffer and initialize it
;-------------------------------------------
alloc-node-frame: func [
	size 	[integer!]						;-- nb of nodes
	return:	[node-frame!]					;-- newly initialized frame
	/local sz frame
][
	assert positive? size
	sz: size * 2 * (size? pointer!) + (size? node-frame!) ;-- total required size for a node frame
	frame: as node-frame! allocate-virtual sz no ;-- R/W only

	frame/prev:  null
	frame/next:  null
	frame/nodes: size

	frame/bottom: as int-ptr! (as byte-ptr! frame) + size? node-frame!
	frame/top: frame/bottom + size - 1		;-- point to the top element

	either null? memory/n-head [
		memory/n-head: frame				;-- first item in the list
		memory/n-tail: frame
		memory/n-active: frame
	][
		memory/n-tail/next: frame			;-- append new item at tail of the list
		frame/prev: memory/n-tail			;-- link back to previous tail
		memory/n-tail: frame				;-- now tail is the new item
	]

	format-node-stack frame					;-- prepare the node frame for use
	frame
]

;-------------------------------------------
;-- Release a node frame buffer
;-------------------------------------------
free-node-frame: func [
	frame [node-frame!]						;-- frame to release
][
	either null? frame/prev [				;-- if frame = head
		memory/n-head: frame/next			;-- head now points to next one
	][
		either null? frame/next [			;-- if frame = tail
			memory/n-tail: frame/prev		;-- tail is now at one position back
		][
			frame/prev/next: frame/next		;-- link preceding frame to next frame
			frame/next/prev: frame/prev		;-- link back next frame to preceding frame
		]
	]
	if memory/n-active = frame [
		memory/n-active: memory/n-tail		;-- reset active frame to last one @@
	]

	assert not all [						;-- ensure that list is not empty
		null? memory/n-head
		null? memory/n-tail
	]

	free-virtual as int-ptr! frame			;-- release the memory to the OS
]

;-------------------------------------------
;-- Obtain a free node from a node frame
;-------------------------------------------
alloc-node: func [
	return: [int-ptr!]						;-- return a free node pointer
	/local frame node
][
	frame: memory/n-active					;-- take node from active node frame
	node: as int-ptr! frame/top/value		;-- pop free node address from stack
	frame/top: frame/top - 1

	if frame/top = frame/bottom [
		; TBD: trigger a "light" GC pass from here and update memory/n-active
		frame: alloc-node-frame nodes-per-frame	;-- allocate a new frame
		memory/n-active: frame				;@@ to be removed once GC implemented
		node: as int-ptr! frame/top/value	;-- pop free node address from stack
		frame/top: frame/top - 1
	]
	node
]

;-------------------------------------------
;-- Release a used node
;-------------------------------------------
free-node: func [
	node [int-ptr!]							;-- node to release
	/local frame offset
][
	assert not null? node

	frame: memory/n-active
	offset: as-integer node - frame

	unless all [
		positive? offset					;-- check if node address is part of active frame
		offset < node-frame-size
	][										;@@ following code not be needed if freed only by the GC...
		frame: memory/n-head				;-- search for right frame from head of the list
		while [								; @@ could be optimized by searching backward/forward from active frame
			offset: as-integer node - frame
			not all [						;-- test if node address is part of that frame
				positive? offset
				offset < node-frame-size	; @@ check upper bound case
			]
		][
			frame: frame/next
			assert frame <> null			;-- should found the right one before the list end
		]
	]

	frame/top: frame/top + 1				;-- free node by pushing its address on stack
	frame/top/value: as-integer node

	assert frame/top < (frame/bottom + frame/nodes)	;-- top should not overflow
]

;-------------------------------------------
;-- Allocate a series frame buffer
;-------------------------------------------
alloc-series-frame: func [
	return:	[series-frame!]					;-- newly initialized frame
	/local size frame
][
	size: memory/s-size
	if size < memory/s-max [memory/s-size: size * 2]

	size: size + size? series-frame! 		;-- total required size for a series frame
	frame: as series-frame! allocate-virtual size no ;-- R/W only

	either null? memory/s-head [
		memory/s-head: frame				;-- first item in the list
		memory/s-tail: frame
		memory/s-active: frame
		frame/prev:  null
	][
		memory/s-tail/next: frame			;-- append new item at tail of the list
		frame/prev: memory/s-tail			;-- link back to previous tail
		memory/s-tail: frame				;-- now tail is the new item
	]

	frame/next: null
	frame/heap: as series-buffer! (as byte-ptr! frame) + size? series-frame!
	frame/tail: (as byte-ptr! frame) + size	;-- point to last byte in frame
	frame
]

;-------------------------------------------
;-- Release a series frame buffer
;-------------------------------------------
free-series-frame: func [
	frame [series-frame!]					;-- frame to release
][
	either null? frame/prev [				;-- if frame = head
		memory/s-head: frame/next			;-- head now points to next one
	][
		either null? frame/next [			;-- if frame = tail
			memory/s-tail: frame/prev		;-- tail is now at one position back
		][
			frame/prev/next: frame/next		;-- link preceding frame to next frame
			frame/next/prev: frame/prev		;-- link back next frame to preceding frame
		]
	]
	if memory/s-active = frame [
		memory/s-active: memory/s-tail		;-- reset active frame to last one @@
	]

	assert not all [						;-- ensure that list is not empty
		null? memory/s-head
		null? memory/s-tail
	]

	free-virtual as int-ptr! frame			;-- release the memory to the OS
]

;-------------------------------------------
;-- Update node back-reference from moved series buffers
;-------------------------------------------
update-series-nodes: func [
	series	[series-buffer!]				;-- start of series region with nodes to re-sync
][
	until [
		;-- update the node pointer to the new series address
		series/node/value: as-integer (as byte-ptr! series) + size? series-buffer!

		;-- advance to the next series buffer
		series: as series-buffer! (as byte-ptr! series) + (series/size and s-size-mask)

		;-- exit when a freed series is met (<=> end of region)
		zero? (series/size and series-in-use)
	]
]

;-------------------------------------------
;-- Compact a series frame by moving down in-use series buffer regions
;-------------------------------------------
#define SM1_INIT		1					;-- enter the state machine
#define SM1_HOLE		2					;-- begin of contiguous region of freed buffers (hole)
#define SM1_HOLE_END	3					;-- end of freed buffers region
#define SM1_USED		4					;-- begin of contiguous region of buffers in use
#define SM1_USED_END	5					;-- end of used buffers region

compact-series-frame: func [
	frame [series-frame!]					;-- series frame to compact
	/local heap series state
		free? [logic!] src [byte-ptr!] dst [byte-ptr!]
][
	series: as series-buffer! (as byte-ptr! frame) + size? series-frame! ;-- point to first series buffer
	free?: zero? (series/size and series-in-use)  ;-- true: series is not used
	heap: frame/heap

	src: null								;-- src will point to start of buffer region to move down
	dst: null								;-- dst will point to start of free region
	state: SM1_INIT

	until [
		if all [state = SM1_INIT free?][
			dst: as byte-ptr! series		 ;-- start of "hole" region
			state: SM1_HOLE
		]
		if all [state = SM1_HOLE not free?][ ;-- search for first used series (<=> end of hole)
			state: SM1_HOLE_END
		]
		if state = SM1_HOLE_END [
			src: as byte-ptr! series		 ;-- start of new "alive" region
			state: SM1_USED
		]
	 	;-- point to next series buffer
		series: as series-buffer! (as byte-ptr! series) + (series/size and s-size-mask)
		free?: zero? (series/size and series-in-use)  ;-- true: series is not used

		if all [state = SM1_USED any [free? series >= heap]][	;-- handle both normal and "exit" states
			state: SM1_USED_END
		]
		if state = SM1_USED_END [
			assert dst < src				 ;-- regions are moved down in memory
			assert src < as byte-ptr! series ;-- src should point at least at series - series/size
			copy-memory dst	src as-integer series - src
			update-series-nodes as series-buffer! dst
			dst: dst + (as-integer series - src) ;-- points after moved region (ready for next move)
			state: SM1_HOLE
		]
		series >= heap						;-- exit state machine
	]

	unless null? dst [						;-- no compaction occurred, all series were in use
		frame/heap: as series-buffer! dst	;-- set new heap after last moved region
	]
]

;-------------------------------------------
;-- Allocate a series from the active series frame, return the series
;-------------------------------------------
alloc-series-buffer: func [
	size	[integer!]						;-- size in bytes
	return: [series-buffer!]				;-- return the new series buffer
	/local series frame sz
][
	assert positive? size					;-- size is not zero or negative
	size: round-to size 16					;-- size is a multiple of 16 (one cell! size)

	frame: memory/s-active
	sz: size + size? series-buffer!			;-- add series header size

	;-- size should not be greater than the frame capacity
	assert sz < as-integer (frame/tail - ((as byte-ptr! frame) + size? series-frame!))

	series: frame/heap
	if ((as byte-ptr! series) + sz) >= frame/tail [
		; TBD: trigger a GC pass from here and update memory/s-active
		frame: alloc-series-frame
		memory/s-active: frame				;@@ to be removed once GC implemented
		series: frame/heap
	]

	assert sz < _16MB						;-- max series size allowed in a series frame

	frame/heap: as series-buffer! (as byte-ptr! frame/heap) + sz

	series/size: sz
		or series-in-use 					;-- mark series as in-use
		or flag-ins-both					;-- optimize for both head & tail insertions (default)
		and not flag-series-big				;-- set type bit to 0 (= series)

	series/head: size / 2					;-- position empty series at middle of buffer
	series/tail: series/head
	series
]

;-------------------------------------------
;-- Allocate a node and a series from the active series frame, return the node
;-------------------------------------------
alloc-series: func [
	size	[integer!]						;-- size in multiple of 16 bytes (cell! size)
	return: [int-ptr!]						;-- return a new node pointer (pointing to the newly allocated series buffer)
	/local series node
][
	series: alloc-series-buffer size
	node: alloc-node						;-- get a new node
	series/node: node						;-- link back series to node
	;-- make node points to first usable byte of series buffer
	node/value: as-integer (as byte-ptr! series) + size? series-buffer!
	node									;-- return the node pointer
]

;-------------------------------------------
;-- Release a series
;-------------------------------------------
free-series: func [
	frame	[series-frame!]					;-- frame containing the series (should be provided by the GC)
	node	[int-ptr!]						;-- series' node pointer
	/local series
][
	assert not null? frame
	assert not null? node

	series: as series-buffer! ((as byte-ptr! node/value) - size? series-buffer!) ;-- point back to series header

	assert not zero? (series/size and not series-in-use) ;-- ensure that 'used bit is set
	series/size: series/size xor series-in-use	;-- clear 'used bit (enough to free the series)

	if frame/heap = as series-buffer! (		;-- test if series is on top of heap
		(as byte-ptr! node/value) +  (series/size and s-size-mask)
	) [
		frame/heap = series					;-- cheap collecting of last allocated series
	]

	free-node node
]

;-------------------------------------------
;-- Expand a series to a new size
;-------------------------------------------
expand-series: func [
	series  [series-buffer!]				;-- series to expand
	new-sz	[integer!]						;-- new size
	return: [series-buffer!]				;-- return new series with new size
	/local new
][
	assert not null? series
	assert new-sz > (series/size and s-size-mask)  ;-- ensure requested size is bigger than current one

	new: alloc-series-buffer new-sz
	series/node/value: as-integer new		;-- link node to new series buffer

	;TBD: honor flag-ins-head and flag-ins-tail when copying!

	copy-memory 							;-- copy old series in new buffer (including header)
		as byte-ptr! new
		as byte-ptr! series
		series/size + size? series-buffer!

	assert not zero? (series/size and not series-in-use) ;-- ensure that 'used bit is set
	series/size: series/size xor series-in-use	;-- clear 'used bit (enough to free the series)
	new
]

;-------------------------------------------
;-- Shrink a series to a smaller size (not needed for now)
;-------------------------------------------
;shrink-series: func [
;	series  [series-buffer!]
;	return: [series-buffer!]
;][
;
;]

;-------------------------------------------
;-- Allocate a big series
;-------------------------------------------
alloc-big: func [
	size [integer!]							;-- buffer size to allocate (in bytes)
	return: [byte-ptr!]						;-- return allocated buffer pointer
	/local sz frame frm
][
	assert positive? size
	assert size >= _2MB						;-- should be bigger than a series frame

	sz: size + size? big-frame! 			;-- total required size for a big frame
	frame: as big-frame! allocate-virtual sz no ;-- R/W only

	frame/next: null
	frame/size: size

	either null? memory/b-head [
		memory/b-head: frame				;-- first item in the list
	][
		frm: memory/b-head					;-- search for tail of list (@@ might want to save it?)
		until [frm: frm/next null? frm/next]
		assert not null? frm

		frm/next: frame						;-- append new item at tail of the list
	]

	as byte-ptr! ((as byte-ptr! frame) + size? big-frame!)	;-- return a pointer to the requested buffer
]

;-------------------------------------------
;-- Release a big series
;-------------------------------------------
free-big: func [
	buffer	[byte-ptr!]						;-- big buffer to release
	/local frame frm
][
	assert not null? buffer

	frame: as big-frame! (buffer - size? big-frame!)  ;-- point to frame header

	either frame = memory/b-head [
		memory/b-head: null
	][
		frm: memory/b-head					;-- search for frame position in list
		while [frm/next <> frame][			;-- frm should point to one item behind frame on exit
			frm: frm/next
			assert not null? frm			;-- ensure tail of list is not passed
		]
		frm/next: frame/next				;-- remove frame from list
	]

	free-virtual as int-ptr! frame			;-- release the memory to the OS
]

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

#if debug? = yes [

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

			size: ((series/size and s-size-mask) - size? series-buffer!) / 16
			until [
				print block
				size: size - 1
				zero? size
			]

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

]

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

;-- New built-in natives worth adding to Red/System??
; get-bit n value
; set-bit n value
; clear-bit n value
; bit-set? n value

;-- cell header bits layout --
;   31:		mark							;-- mark as referenced for the GC (mark phase)
;   30:		lock							;-- lock slot for active thread access only
;   29:		immutable						;-- mark as read-only (series only)
;   28:		new-line						;-- new-line (LF) marker (before the slot)
;   27:		big								;-- indicates a big series (big-frame!)
;	26:		stack							;-- series buffer is allocated on stack (series only)
;   25:		permanent						;-- protected from GC (system-critical series)
;   25-8:	<reserved>
;   7-0:	datatype ID						;-- datatype number

#define _128KB				131072			; @@ create a dedicated datatype?
#define _2MB				2097152
#define _16MB				16777216
#define nodes-per-frame		5000
#define node-frame-size		[((nodes-per-frame * 2 * size? pointer!) + size? node-frame!)]

#define series-in-use		80000000h		;-- mark a series as used (not collectable by the GC)
#define flag-series-big		40000000h		;-- 1 = big, 0 = series
#define flag-ins-head		10000000h		;-- optimize for head insertions
#define flag-ins-tail		20000000h		;-- optimize for tail insertions
#define flag-ins-both		30000000h		;-- optimize for both head & tail insertions
#define s-size-mask			00FFFFFFh		;-- mask for 24-bit size field

int-array!: alias struct! [ptr [int-ptr!]]

cell!: alias struct! [
	header	[integer!]						;-- cell's header flags
	data1	[integer!]						;-- placeholders to make a 128-bit cell
	data2	[integer!]
	data3	[integer!]
]

series-buffer!: alias struct! [
	size	[integer!]						;-- bitfield (see below)
	node	[int-ptr!]						;-- point back to referring node
	head	[integer!]						;-- series buffer head index
	tail	[integer!]						;-- series buffer tail index
]
;; size bitfield:
;; 31: 		used (1 = used, 0 = free)
;; 30: 		type (always 0 for series-buffer!)
;; 29-28: 	insert-opt (2 = head, 1 = tail, 0 = both)
;; 27-24: 	reserved
;; 23-0: 	size of allocated buffer

series-frame!: alias struct! [				;-- series frame header
	next	[series-frame!]					;-- next frame or null
	prev	[series-frame!]					;-- previous frame or null
	heap	[series-buffer!]				;-- point to allocatable region
	tail	[byte-ptr!]						;-- point to last byte in allocatable region
]

node-frame!: alias struct! [				;-- node frame header
	next	[node-frame!]					;-- next frame or null
	prev	[node-frame!]					;-- previous frame or null
	nodes	[integer!]						;-- number of nodes
	bottom	[int-ptr!]						;-- bottom of stack (last entry, fixed)
	top		[int-ptr!]						;-- top of stack (first entry, moving)
]

big-frame!: alias struct! [					;-- big frame header (for >= 2MB series)
	flags	[integer!]						;-- bit 30: 1 (type = big)
	next	[big-frame!]					;-- next frame or null
	size	[integer!]						;-- size (up to 4GB - size? header)
	padding [integer!]						;-- make this header same size as series-buffer! header
]

memory: declare struct! [					; TBD: instanciate this structure per OS thread
	total	 [integer!]						;-- total memory size allocated (in bytes)
	n-head	 [node-frame!]					;-- head of node frames list
	n-active [node-frame!]					;-- actively used node frame
	n-tail	 [node-frame!]					;-- tail of node frames list
	s-head	 [series-frame!]				;-- head of series frames list
	s-active [series-frame!]				;-- actively used series frame
	s-tail	 [series-frame!]				;-- tail of series frames list
	s-start	 [integer!]						;-- start size for new series frame		(1)
	s-size	 [integer!]						;-- current size for new series frame	(1)
	s-max	 [integer!]						;-- max size for new series frames		(1)
	b-head	 [big-frame!]					;-- head of big frames list
]

memory/total: 	0
memory/s-start: _128KB
memory/s-max: 	_2MB
memory/s-size: 	memory/s-start
;; (1) Series frames size will grow from 128KB up to 2MB (arbitrary selected). This
;; range will need fine-tuning with real Red apps. This growing size, with low starting value
;; will allow small apps to not consume much memory while avoiding to penalize big apps.

;-------------------------------------------
;-- Allocate paged virtual memory region
;-------------------------------------------
allocate-virtual: func [
	size 	[integer!]						;-- allocated size in bytes (page size multiple)
	exec? 	[logic!]						;-- TRUE => executable region
	return: [int-ptr!]						;-- allocated memory region pointer
	/local ptr
][
	size: round-to size + 4	OS-page-size	;-- account for header (one word)
	memory/total: memory/total + size
	ptr: OS-allocate-virtual size exec?
	ptr/value: size							;-- store size in header
	ptr + 1									;-- return pointer after header
]

;-------------------------------------------
;-- Free paged virtual memory region from OS
;-------------------------------------------
free-virtual: func [
	ptr [int-ptr!]							;-- address of memory region to release
][
	ptr: ptr - 1							;-- return back to header
	memory/total: memory/total - ptr/value
	OS-free-virtual ptr
]

;-------------------------------------------
;-- Free all frames (part of Red's global exit handler)
;-------------------------------------------
free-all: func [
	/local n-frame s-frame b-frame
][
	n-frame: memory/n-head
	while [n-frame <> null][
		free-virtual as int-ptr! n-frame
		n-frame: n-frame/next
	]

	s-frame: memory/s-head
	while [s-frame <> null][
		free-virtual as int-ptr! s-frame
		s-frame: s-frame/next
	]

	b-frame: memory/b-head
	while [b-frame <> null][
		free-virtual as int-ptr! b-frame
		b-frame: b-frame/next
	]
]

;-------------------------------------------
;-- Format the node frame stack by filling it with pointers to all nodes
;-------------------------------------------
format-node-stack: func [
	frame [node-frame!]						;-- node frame to format
	/local node ptr
][
	ptr: frame/bottom						;-- point to bottom of stack
	node: ptr + frame/nodes					;-- first free node address
	until [
		ptr/value: as-integer node			;-- store free node address on stack
		node: node + 1
		ptr: ptr + 1
		ptr > frame/top						;-- until the stack is filled up
	]
]

;-------------------------------------------
;-- Allocate a node frame buffer and initialize it
;-------------------------------------------
alloc-node-frame: func [
	size 	[integer!]						;-- nb of nodes
	return:	[node-frame!]					;-- newly initialized frame
	/local sz frame
][
	assert positive? size
	sz: size * 2 * (size? pointer!) + (size? node-frame!) ;-- total required size for a node frame
	frame: as node-frame! allocate-virtual sz no ;-- R/W only

	frame/prev:  null
	frame/next:  null
	frame/nodes: size

	frame/bottom: as int-ptr! (as byte-ptr! frame) + size? node-frame!
	frame/top: frame/bottom + size - 1		;-- point to the top element

	either null? memory/n-head [
		memory/n-head: frame				;-- first item in the list
		memory/n-tail: frame
		memory/n-active: frame
	][
		memory/n-tail/next: frame			;-- append new item at tail of the list
		frame/prev: memory/n-tail			;-- link back to previous tail
		memory/n-tail: frame				;-- now tail is the new item
	]

	format-node-stack frame					;-- prepare the node frame for use
	frame
]

;-------------------------------------------
;-- Release a node frame buffer
;-------------------------------------------
free-node-frame: func [
	frame [node-frame!]						;-- frame to release
][
	either null? frame/prev [				;-- if frame = head
		memory/n-head: frame/next			;-- head now points to next one
	][
		either null? frame/next [			;-- if frame = tail
			memory/n-tail: frame/prev		;-- tail is now at one position back
		][
			frame/prev/next: frame/next		;-- link preceding frame to next frame
			frame/next/prev: frame/prev		;-- link back next frame to preceding frame
		]
	]
	if memory/n-active = frame [
		memory/n-active: memory/n-tail		;-- reset active frame to last one @@
	]

	assert not all [						;-- ensure that list is not empty
		null? memory/n-head
		null? memory/n-tail
	]

	free-virtual as int-ptr! frame			;-- release the memory to the OS
]

;-------------------------------------------
;-- Obtain a free node from a node frame
;-------------------------------------------
alloc-node: func [
	return: [int-ptr!]						;-- return a free node pointer
	/local frame node
][
	frame: memory/n-active					;-- take node from active node frame
	node: as int-ptr! frame/top/value		;-- pop free node address from stack
	frame/top: frame/top - 1

	if frame/top = frame/bottom [
		; TBD: trigger a "light" GC pass from here and update memory/n-active
		frame: alloc-node-frame nodes-per-frame	;-- allocate a new frame
		memory/n-active: frame				;@@ to be removed once GC implemented
		node: as int-ptr! frame/top/value	;-- pop free node address from stack
		frame/top: frame/top - 1
	]
	node
]

;-------------------------------------------
;-- Release a used node
;-------------------------------------------
free-node: func [
	node [int-ptr!]							;-- node to release
	/local frame offset
][
	assert not null? node

	frame: memory/n-active
	offset: as-integer node - frame

	unless all [
		positive? offset					;-- check if node address is part of active frame
		offset < node-frame-size
	][										;@@ following code not be needed if freed only by the GC...
		frame: memory/n-head				;-- search for right frame from head of the list
		while [								; @@ could be optimized by searching backward/forward from active frame
			offset: as-integer node - frame
			not all [						;-- test if node address is part of that frame
				positive? offset
				offset < node-frame-size	; @@ check upper bound case
			]
		][
			frame: frame/next
			assert frame <> null			;-- should found the right one before the list end
		]
	]

	frame/top: frame/top + 1				;-- free node by pushing its address on stack
	frame/top/value: as-integer node

	assert frame/top < (frame/bottom + frame/nodes)	;-- top should not overflow
]

;-------------------------------------------
;-- Allocate a series frame buffer
;-------------------------------------------
alloc-series-frame: func [
	return:	[series-frame!]					;-- newly initialized frame
	/local size frame
][
	size: memory/s-size
	if size < memory/s-max [memory/s-size: size * 2]

	size: size + size? series-frame! 		;-- total required size for a series frame
	frame: as series-frame! allocate-virtual size no ;-- R/W only

	either null? memory/s-head [
		memory/s-head: frame				;-- first item in the list
		memory/s-tail: frame
		memory/s-active: frame
		frame/prev:  null
	][
		memory/s-tail/next: frame			;-- append new item at tail of the list
		frame/prev: memory/s-tail			;-- link back to previous tail
		memory/s-tail: frame				;-- now tail is the new item
	]

	frame/next: null
	frame/heap: as series-buffer! (as byte-ptr! frame) + size? series-frame!
	frame/tail: (as byte-ptr! frame) + size	;-- point to last byte in frame
	frame
]

;-------------------------------------------
;-- Release a series frame buffer
;-------------------------------------------
free-series-frame: func [
	frame [series-frame!]					;-- frame to release
][
	either null? frame/prev [				;-- if frame = head
		memory/s-head: frame/next			;-- head now points to next one
	][
		either null? frame/next [			;-- if frame = tail
			memory/s-tail: frame/prev		;-- tail is now at one position back
		][
			frame/prev/next: frame/next		;-- link preceding frame to next frame
			frame/next/prev: frame/prev		;-- link back next frame to preceding frame
		]
	]
	if memory/s-active = frame [
		memory/s-active: memory/s-tail		;-- reset active frame to last one @@
	]

	assert not all [						;-- ensure that list is not empty
		null? memory/s-head
		null? memory/s-tail
	]

	free-virtual as int-ptr! frame			;-- release the memory to the OS
]

;-------------------------------------------
;-- Update node back-reference from moved series buffers
;-------------------------------------------
update-series-nodes: func [
	series	[series-buffer!]				;-- start of series region with nodes to re-sync
][
	until [
		;-- update the node pointer to the new series address
		series/node/value: as-integer (as byte-ptr! series) + size? series-buffer!

		;-- advance to the next series buffer
		series: as series-buffer! (as byte-ptr! series) + (series/size and s-size-mask)

		;-- exit when a freed series is met (<=> end of region)
		zero? (series/size and series-in-use)
	]
]

;-------------------------------------------
;-- Compact a series frame by moving down in-use series buffer regions
;-------------------------------------------
#define SM1_INIT		1					;-- enter the state machine
#define SM1_HOLE		2					;-- begin of contiguous region of freed buffers (hole)
#define SM1_HOLE_END	3					;-- end of freed buffers region
#define SM1_USED		4					;-- begin of contiguous region of buffers in use
#define SM1_USED_END	5					;-- end of used buffers region

compact-series-frame: func [
	frame [series-frame!]					;-- series frame to compact
	/local heap series state
		free? [logic!] src [byte-ptr!] dst [byte-ptr!]
][
	series: as series-buffer! (as byte-ptr! frame) + size? series-frame! ;-- point to first series buffer
	heap: frame/heap

	src: null								;-- src will point to start of buffer region to move down
	dst: null								;-- dst will point to start of free region
	state: SM1_INIT

	until [
		free?: zero? (series/size and series-in-use)  ;-- true: series is not used

		if all [state = SM1_INIT free?][
			dst: as byte-ptr! series		 ;-- start of "hole" region
			state: SM1_HOLE
		]
		if all [state = SM1_HOLE not free?][ ;-- search for first used series (<=> end of hole)
			state: SM1_HOLE_END
		]
		if state = SM1_HOLE_END [
			src: as byte-ptr! series		 ;-- start of new "alive" region
			state: SM1_USED
		]
	 	;-- point to next series buffer
		series: as series-buffer! (as byte-ptr! series) + (series/size and s-size-mask)

		if all [state = SM1_USED any [free? series >= heap]][	;-- handle both normal and "exit" states
			state: SM1_USED_END
		]
		if state = SM1_USED_END [
			assert dst < src				 ;-- regions are moved down in memory
			assert src < as byte-ptr! series ;-- src should point at least at series - series/size

			copy-memory dst	src as-integer series - src
			update-series-nodes as series-buffer! dst
			dst: dst + (as-integer series - src) ;-- points after moved region (ready for next move)
			state: SM1_HOLE
		]
		series >= heap						;-- exit state machine
	]

	unless null? dst [						;-- no compaction occurred, all series were in use
		frame/heap: as series-buffer! dst	;-- set new heap after last moved region
	]
]

;-------------------------------------------
;-- Allocate a series from the active series frame, return the series
;-------------------------------------------
alloc-series-buffer: func [
	size	[integer!]						;-- size in bytes
	return: [series-buffer!]				;-- return the new series buffer
	/local series frame sz
][
	assert positive? size					;-- size is not zero or negative
	size: round-to size 16					;-- size is a multiple of 16 (one cell! size)

	frame: memory/s-active
	sz: size + size? series-buffer!			;-- add series header size

	;-- size should not be greater than the frame capacity
	assert sz < as-integer (frame/tail - ((as byte-ptr! frame) + size? series-frame!))

	series: frame/heap
	if ((as byte-ptr! series) + sz) >= frame/tail [
		; TBD: trigger a GC pass from here and update memory/s-active
		frame: alloc-series-frame
		memory/s-active: frame				;@@ to be removed once GC implemented
		series: frame/heap
	]

	assert sz < _16MB						;-- max series size allowed in a series frame

	frame/heap: as series-buffer! (as byte-ptr! frame/heap) + sz

	series/size: sz
		or series-in-use 					;-- mark series as in-use
		or flag-ins-both					;-- optimize for both head & tail insertions (default)
		and not flag-series-big				;-- set type bit to 0 (= series)

	series/head: size / 2					;-- position empty series at middle of buffer
	series/tail: series/head
	series
]

;-------------------------------------------
;-- Allocate a node and a series from the active series frame, return the node
;-------------------------------------------
alloc-series: func [
	size	[integer!]						;-- size in multiple of 16 bytes (cell! size)
	return: [int-ptr!]						;-- return a new node pointer (pointing to the newly allocated series buffer)
	/local series node
][
	series: alloc-series-buffer size
	node: alloc-node						;-- get a new node
	series/node: node						;-- link back series to node
	;-- make node points to first usable byte of series buffer
	node/value: as-integer (as byte-ptr! series) + size? series-buffer!
	node									;-- return the node pointer
]

;-------------------------------------------
;-- Release a series
;-------------------------------------------
free-series: func [
	frame	[series-frame!]					;-- frame containing the series (should be provided by the GC)
	node	[int-ptr!]						;-- series' node pointer
	/local series
][
	assert not null? frame
	assert not null? node

	series: as series-buffer! ((as byte-ptr! node/value) - size? series-buffer!) ;-- point back to series header

	assert not zero? (series/size and not series-in-use) ;-- ensure that 'used bit is set
	series/size: series/size xor series-in-use	;-- clear 'used bit (enough to free the series)

	if frame/heap = as series-buffer! (		;-- test if series is on top of heap
		(as byte-ptr! node/value) +  (series/size and s-size-mask)
	) [
		frame/heap = series					;-- cheap collecting of last allocated series
	]

	free-node node
]

;-------------------------------------------
;-- Expand a series to a new size
;-------------------------------------------
expand-series: func [
	series  [series-buffer!]				;-- series to expand
	new-sz	[integer!]						;-- new size
	return: [series-buffer!]				;-- return new series with new size
	/local new
][
	assert not null? series
	assert new-sz > (series/size and s-size-mask)  ;-- ensure requested size is bigger than current one

	new: alloc-series-buffer new-sz
	series/node/value: as-integer new		;-- link node to new series buffer

	;TBD: honor flag-ins-head and flag-ins-tail when copying!

	copy-memory 							;-- copy old series in new buffer (including header)
		as byte-ptr! new
		as byte-ptr! series
		series/size + size? series-buffer!

	assert not zero? (series/size and not series-in-use) ;-- ensure that 'used bit is set
	series/size: series/size xor series-in-use	;-- clear 'used bit (enough to free the series)
	new
]

;-------------------------------------------
;-- Shrink a series to a smaller size (not needed for now)
;-------------------------------------------
;shrink-series: func [
;	series  [series-buffer!]
;	return: [series-buffer!]
;][
;
;]

;-------------------------------------------
;-- Allocate a big series
;-------------------------------------------
alloc-big: func [
	size [integer!]							;-- buffer size to allocate (in bytes)
	return: [byte-ptr!]						;-- return allocated buffer pointer
	/local sz frame frm
][
	assert positive? size
	assert size >= _2MB						;-- should be bigger than a series frame

	sz: size + size? big-frame! 			;-- total required size for a big frame
	frame: as big-frame! allocate-virtual sz no ;-- R/W only

	frame/next: null
	frame/size: size

	either null? memory/b-head [
		memory/b-head: frame				;-- first item in the list
	][
		frm: memory/b-head					;-- search for tail of list (@@ might want to save it?)
		until [frm: frm/next null? frm/next]
		assert not null? frm

		frm/next: frame						;-- append new item at tail of the list
	]

	as byte-ptr! ((as byte-ptr! frame) + size? big-frame!)	;-- return a pointer to the requested buffer
]

;-------------------------------------------
;-- Release a big series
;-------------------------------------------
free-big: func [
	buffer	[byte-ptr!]						;-- big buffer to release
	/local frame frm
][
	assert not null? buffer

	frame: as big-frame! (buffer - size? big-frame!)  ;-- point to frame header

	either frame = memory/b-head [
		memory/b-head: null
	][
		frm: memory/b-head					;-- search for frame position in list
		while [frm/next <> frame][			;-- frm should point to one item behind frame on exit
			frm: frm/next
			assert not null? frm			;-- ensure tail of list is not passed
		]
		frm/next: frame/next				;-- remove frame from list
	]

	free-virtual as int-ptr! frame			;-- release the memory to the OS
]

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

#if debug? = yes [

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

			size: ((series/size and s-size-mask) - size? series-buffer!) / 16
			until [
				print block
				size: size - 1
				zero? size
			]

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

]


FIX: issue #757 (Red runtime lexer can't handle "^(xxxx)")

Red [
	Title:   "Red runtime lexer"
	Author:  "Nenad Rakocevic"
	File: 	 %lexer.red
	Tabs:	 4
	Rights:  "Copyright (C) 2014 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
	}
]

trans-integer: routine [
	start [string!]
	end	  [string!]
	/local
		c	 [integer!]
		n	 [integer!]
		m	 [integer!]
		len  [integer!]
		p	 [byte-ptr!]
		neg? [logic!]
][
	str:  GET_BUFFER(start)
	unit: GET_UNIT(str)
	p:	  string/rs-head start
	len:  end/head - start/head
	neg?: no

	c: string/get-char p unit
	if any [
		c = as-integer #"+"
		c = as-integer #"-"
	][
		neg?: c = as-integer #"-"
		p: p + unit
		len: len - 1
	]
	n: 0
	until [
		c: string/get-char p unit

		m: n * 10
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		m: n + c - #"0"
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		p: p + unit
		len: len - 1
		zero? len
	]
	integer/box either neg? [0 - n][n]
]

trans-hexa: routine [
	start	[string!]
	end		[string!]
	return: [integer!]
	/local
		s	  [series!]
		unit  [integer!]
		p	  [byte-ptr!]
		head  [byte-ptr!]
		p4	  [int-ptr!]
		n	  [integer!]
		power [integer!]
		cp	  [byte!]
][
	s: GET_BUFFER(start)
	unit: GET_UNIT(s)

	p: (string/rs-head end) - unit
	head: string/rs-head start

	n: 0
	power: 0
	while [p >= head][
		cp: switch unit [
			Latin1 [p/value]
			UCS-2  [as-byte ((as-integer p/2) << 8 + p/1)]
			UCS-4  [p4: as int-ptr! p as-byte p4/value]
		]
		if cp <> #"0" [
			case [
				all [#"0" <= cp cp <= #"9"][cp: cp - #"0"]
				all [#"A" <= cp cp <= #"F"][cp: cp - #"A" + 10]
				all [#"a" <= cp cp <= #"f"][cp: cp - #"a" + 10]
			]
			n: n + ((as-integer cp) << power)
		]
		power: power + 4
		p: p - unit
	]
	n
]

trans-char: routine [
	start	[string!]
	end		[string!]
	/local
		n	  [integer!]
		value [red-value!]
][
	n: trans-hexa start end
	value: as red-value! integer/box n
	set-type value TYPE_CHAR
]

trans-push-path: routine [
	stack [block!]
	type  [datatype!]
	/local
		path [red-path!]
][
	path: as red-path! block/make-at as red-block! ALLOC_TAIL(stack) 4
	path/header: switch type/value [
		TYPE_GET_WORD [TYPE_GET_PATH]
		TYPE_LIT_WORD [TYPE_LIT_PATH]
		default [TYPE_PATH]
	]
]

trans-set-path: routine [
	stack [block!]
	/local
		path [red-path!]
][
	path: as red-path! block/pick stack 1 null
	set-type as red-value! path TYPE_SET_PATH
]

trans-word: routine [
	stack [block!]
	src   [string!]
	type  [datatype!]
	/local
		value [red-value!]
][
	value: as red-value! word/push-in (symbol/make-alt src) stack
	set-type value type/value
]

trans-pop: function [stack [block!]][
	value: last stack
	remove back tail stack
	append/only last stack :value
]

transcode: function [
	src		[string!]
	dst		[block! none!]
	return: [block!]
	/local
		new s e c hex pos value cnt type process
		digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
		not-file-char not-str-char not-mstr-char caret-char
		non-printable-char integer-end ws-ASCII ws-U+2k control-char
][
	cs:		[- - - - - - - - - - - - - - - -]			;-- memoized bitsets
	stack:	clear []
	count?:	yes											;-- if TRUE, lines counter is enabled
	line: 	1

	append/only stack any [dst make block! 4]

	trans-string: [
		new: make type (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				escaped-char (append new value)
				| #"^^"									;-- trash single caret chars
				| set c skip (append new c)
			]
		]
		new
	]

	decode-hex: [
		set c [
			digit 			(value: c - #"0")
			| hexa-upper	(value: c - #"A" + 10)
			| hexa-lower	(value: c - #"a" + 10)
			| (print "*** Syntax Error: invalid file hexa encoding") ;@@ temporary hardcoded
		]
	]

	decode-2hex: [
		decode-hex (hex: value << 4)
		decode-hex (hex: hex + value)
	]

	trans-file: [
		new: make file! (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				#"%" decode-2hex (append new hex)
				| set c skip (append new c)
			]
		]
		new
	]

	if cs/1 = '- [
		cs/1:  charset "0123465798"						;-- digit
		cs/2:  charset "ABCDEF"							;-- hexa-upper
		cs/3:  charset "abcdef"							;-- hexa-lower
		cs/4:  union cs/1 cs/2							;-- hexa
		cs/5:  union cs/4 cs/3							;-- hexa-char
		cs/6:  charset {/\^^,[](){}"#%$@:;}				;-- not-word-char
		cs/7:  union union cs/6 cs/1 charset {'}		;-- not-word-1st
		cs/8:  charset {[](){}"%@:;}					;-- not-file-char
		cs/9:  #"^""									;-- not-str-char
		cs/10: #"}"										;-- not-mstr-char
		cs/11: charset [#"^(40)" - #"^(5F)"]			;-- caret-char
		cs/12: charset [#"^(00)" - #"^(1F)"]			;-- non-printable-char
		cs/13: charset {^{"[]);}						;-- integer-end
		cs/14: charset " ^-^M"							;-- ws-ASCII, ASCII common whitespaces
		cs/15: charset [#"^(80)" - #"^(8A)"]			;-- ws-U+2k, Unicode spaces in the U+2000-U+200A range
		cs/16: charset [#"^(00)" - #"^(1F)"] 			;-- ASCII control characters

	]
	set [
		digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
		not-file-char not-str-char not-mstr-char caret-char
		non-printable-char integer-end ws-ASCII ws-U+2k control-char
	] cs

	;-- Whitespaces list from: http://en.wikipedia.org/wiki/Whitespace_character
	ws: [
		pos: #"^/" (
			if count? [
				line: line + 1
				;append/only lines to block! stack/tail?
			]
		)
		| ws-ASCII										;-- only the common whitespaces are matched
		| #"^(0085)"									;-- U+0085 (Newline)
		| #"^(00A0)"									;-- U+00A0 (No-break space)
		| #"^(1680)"									;-- U+1680 (Ogham space mark)
		| #"^(180E)"									;-- U+180E (Mongolian vowel separator)
		| ws-U+2k										;-- U+2000-U+200A range
		| #"^(2028)"									;-- U+2028 (Line separator)
		| #"^(2029)"									;-- U+2029 (Paragraph separator)
		| #"^(202F)"									;-- U+202F (Narrow no-break space)
		| #"^(205F)"									;-- U+205F (Medium mathematical space)
		| #"^(3000)"									;-- U+3000 (Ideographic space)
	]

	newline-char: [
		#"^/"
		| #"^(0085)"									;-- U+0085 (Newline)
		| #"^(2028)"									;-- U+2028 (Line separator)
		| #"^(2029)"									;-- U+2029 (Paragraph separator)
	]

	counted-newline: [pos: #"^/" (line: line + 1)]

	ws-no-count: [(count?: no) ws (count?: yes)]

	escaped-char: [
		"^^(" [
			[										;-- special case first
				"null" 	 (value: #"^(00)")
				| "back" (value: #"^(08)")
				| "tab"  (value: #"^(09)")
				| "line" (value: #"^(0A)")
				| "page" (value: #"^(0C)")
				| "esc"  (value: #"^(1B)")
				| "del"	 (value: #"^(7F)")
			]
			| pos: [2 6 hexa-char] e: (				;-- Unicode values allowed up to 10FFFFh
				value: trans-char pos e
			)
		] #")"
		| #"^^" [
			[
				#"/" 	(value: #"^/")
				| #"-"	(value: #"^-")
				| #"?" 	(value: #"^(del)")			;@@FIXME
				| #"^^" (value: #"^^")				;-- caret escaping case
				| #"{"	(value: #"{")
				| #"}"	(value: #"}")
				| #"^""	(value: #"^"")
			]
			| pos: caret-char (value: pos/1 - 64)
		]
	]

	char-rule: [
		{#"} s: [
			 escaped-char
			| ahead [non-printable-char | not-str-char] break
			| skip (value: s/1)
		] {"}
	]

	line-string: [
		{"} s: any [
			{^^"}
			| ahead [#"^"" | newline-char] break
			| escaped-char
			| skip
		]
		e: {"}
	]

	nested-curly-braces: [
		(cnt: 1)
		any [
			counted-newline
			| "^^{"
			| "^^}"
			| #"{" 	  (cnt: cnt + 1)
			| e: #"}" if (zero? cnt: cnt - 1) break
			| escaped-char
			| skip
		]
	]

	multiline-string: [#"{" s: nested-curly-braces]

	string-rule: [(type: string!) line-string | multiline-string]

	file-rule: [
		#"%" [
			line-string (process: trans-string type: file!)
			| s: any [ahead [not-file-char | ws-no-count] break | skip] e:
			  (process: trans-file)
		]
	]

	symbol-rule: [
		some [ahead [not-word-char | ws-no-count | control-char] break | skip] e:
	]

	begin-symbol-rule: [								;-- 1st char in symbols is restricted
		[not ahead [not-word-1st | ws-no-count | control-char]]
		symbol-rule
	]

	path-rule: [
		ahead slash (									;-- path detection barrier
			trans-push-path stack type					;-- create empty path
			trans-word last stack copy/part s e type	;-- push 1st path element
		)
		some [
			slash
			s: [
				integer-number-rule			(append last stack trans-integer s e)
				| begin-symbol-rule			(trans-word last stack copy/part s e word!)
				| paren-rule
				| #":" s: begin-symbol-rule	(trans-word last stack copy/part s e get-word!)
				;@@ add more datatypes here
			]
			opt [#":" (trans-set-path back tail stack)]
		] (trans-pop stack)
	]

	word-rule: 	[
		s: begin-symbol-rule (type: word!) [
			path-rule 									;-- path matched
			| opt [#":" (type: set-word!)]
			  (trans-word last stack copy/part s e type) ;-- word or set-word matched
		]
	]

	get-word-rule: [
		#":" (type: get-word!) s: begin-symbol-rule [
			path-rule (type: get-path!)
			| (trans-word last stack copy/part s e type) ;-- get-word matched
		]
	]

	lit-word-rule: [
		#"'" (type: lit-word!) s: begin-symbol-rule [
			path-rule (type: lit-path!)					;-- path matched
			| (trans-word last stack copy/part s e type) ;-- lit-word matched
		]
	]

	issue-rule: [
		#"#" (type: issue!) s: symbol-rule
		(trans-word last stack copy/part s e type)
	]

	refinement-rule: [
		slash (type: refinement!) s: symbol-rule
		(trans-word last stack copy/part s e type)
	]

	slash-rule: [s: [slash opt slash] e:]

	hexa-rule: [2 8 hexa e: #"h"]

	integer-number-rule: [
		opt [#"-" | #"+"] digit any [digit | #"'" digit] e:
	]

	integer-rule: [
		integer-number-rule
		ahead [integer-end | ws-no-count | end]
	]

	block-rule: [
		#"[" (append/only stack make block! 4)
		any-value
		#"]" (trans-pop stack)
	]

	paren-rule: [
		#"(" (append/only stack make paren! 4)
		any-value
		#")" (trans-pop stack)
	]

	escaped-rule: [
		"#[" pos: any ws [
			  "true"  			(value: true)
			| "false" 			(value: false)
			| [
				"none!"			(value: none!)
				| "logic!"		(value: logic!)
				| "block!"		(value: block!)
				| "integer!"	(value: integer!)
				| "word!"		(value: word!)
				| "set-word!"	(value: set-word!)
				| "get-word!"	(value: get-word!)
				| "lit-word!"	(value: lit-word!)
				| "refinement!"	(value: refinement!)
				;| "binary!"	(value: binary!)
				| "string!"		(value: string!)
				| "char!"		(value: char!)
				| "bitset!"		(value: bitset!)
				| "path!"		(value: path!)
				| "set-path!"	(value: set-path!)
				| "lit-path!"	(value: lit-path!)
				| "get-path!"	(value: get-path!)
				| "native!"		(value: native!)
				| "action!"		(value: action!)
				| "op!"			(value: op!)
				| "issue!"		(value: issue!)
				| "paren!"		(value: paren!)
				| "function!"	(value: function!)
				| "routine!"	(value: routine!)
			]
			| "none" 			(value: none)
		] pos: any ws #"]"
	]

	comment-rule: [#";" [to lf | to end]]

	wrong-delimiters: [
		pos: [
			  #"]" (value: #"[") | #")" (value: #"(")
			| #"[" (value: #"]") | #"(" (value: #")")
		] :pos
		(print ["missing matching" value])
	]

	literal-value: [
		pos: (e: none) s: [
			comment-rule
			| escaped-rule		(append last stack value)
			| integer-rule		(append last stack trans-integer s e)
			| hexa-rule			(append last stack trans-hexa s e)
			| word-rule
			| lit-word-rule
			| get-word-rule
			| slash-rule		(trans-word last stack copy/part s e word!)
			| refinement-rule
			| file-rule			(append last stack do process)
			| char-rule			(append last stack value)
			| issue-rule
			| block-rule
			| paren-rule
			| string-rule		(append last stack do trans-string)
			;| binary-rule	  	(stack/push load-binary s e)
		]
	]

	any-value: [pos: any [literal-value | ws]]

	unless parse/case src [any-value opt wrong-delimiters][
		print ["*** Syntax Error: invalid Red value at:" copy/part pos 20]
	]
	stack/1
]

Red [
	Title:   "Red runtime lexer"
	Author:  "Nenad Rakocevic"
	File: 	 %lexer.red
	Tabs:	 4
	Rights:  "Copyright (C) 2014 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
	}
]

trans-integer: routine [
	start [string!]
	end	  [string!]
	/local
		c	 [integer!]
		n	 [integer!]
		m	 [integer!]
		len  [integer!]
		p	 [byte-ptr!]
		neg? [logic!]
][
	str:  GET_BUFFER(start)
	unit: GET_UNIT(str)
	p:	  string/rs-head start
	len:  end/head - start/head
	neg?: no

	c: string/get-char p unit
	if any [
		c = as-integer #"+"
		c = as-integer #"-"
	][
		neg?: c = as-integer #"-"
		p: p + unit
		len: len - 1
	]
	n: 0
	until [
		c: string/get-char p unit

		m: n * 10
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		m: n + c - #"0"
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		p: p + unit
		len: len - 1
		zero? len
	]
	integer/box either neg? [0 - n][n]
]

trans-hexa: routine [
	start	[string!]
	end		[string!]
	return: [integer!]
	/local
		s	  [series!]
		unit  [integer!]
		p	  [byte-ptr!]
		head  [byte-ptr!]
		p4	  [int-ptr!]
		n	  [integer!]
		power [integer!]
		cp	  [byte!]
][
	s: GET_BUFFER(start)
	unit: GET_UNIT(s)

	p: (string/rs-head end) - unit
	head: string/rs-head start

	n: 0
	power: 0
	while [p >= head][
		cp: switch unit [
			Latin1 [p/value]
			UCS-2  [as-byte ((as-integer p/2) << 8 + p/1)]
			UCS-4  [p4: as int-ptr! p as-byte p4/value]
		]
		if cp <> #"0" [
			case [
				all [#"0" <= cp cp <= #"9"][cp: cp - #"0"]
				all [#"A" <= cp cp <= #"F"][cp: cp - #"A" + 10]
				all [#"a" <= cp cp <= #"f"][cp: cp - #"a" + 10]
			]
			n: n + ((as-integer cp) << power)
		]
		power: power + 4
		p: p - unit
	]
	n
]

trans-push-path: routine [
	stack [block!]
	type  [datatype!]
	/local
		path [red-path!]
][
	path: as red-path! block/make-at as red-block! ALLOC_TAIL(stack) 4
	path/header: switch type/value [
		TYPE_GET_WORD [TYPE_GET_PATH]
		TYPE_LIT_WORD [TYPE_LIT_PATH]
		default [TYPE_PATH]
	]
]

trans-set-path: routine [
	stack [block!]
	/local
		path [red-path!]
][
	path: as red-path! block/pick stack 1 null
	set-type as red-value! path TYPE_SET_PATH
]

trans-word: routine [
	stack [block!]
	src   [string!]
	type  [datatype!]
	/local
		value [red-value!]
][
	value: as red-value! word/push-in (symbol/make-alt src) stack
	set-type value type/value
]

trans-pop: function [stack [block!]][
	value: last stack
	remove back tail stack
	append/only last stack :value
]

transcode: function [
	src		[string!]
	dst		[block! none!]
	return: [block!]
	/local
		new s e c hex pos value cnt type process
		digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
		not-file-char not-str-char not-mstr-char caret-char
		non-printable-char integer-end ws-ASCII ws-U+2k control-char
][
	cs:		[- - - - - - - - - - - - - - - -]			;-- memoized bitsets
	stack:	clear []
	count?:	yes											;-- if TRUE, lines counter is enabled
	line: 	1

	append/only stack any [dst make block! 4]

	trans-string: [
		new: make type (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				escaped-char (append new value)
				| #"^^"									;-- trash single caret chars
				| set c skip (append new c)
			]
		]
		new
	]

	decode-hex: [
		set c [
			digit 			(value: c - #"0")
			| hexa-upper	(value: c - #"A" + 10)
			| hexa-lower	(value: c - #"a" + 10)
			| (print "*** Syntax Error: invalid file hexa encoding") ;@@ temporary hardcoded
		]
	]

	decode-2hex: [
		decode-hex (hex: value << 4)
		decode-hex (hex: hex + value)
	]

	trans-file: [
		new: make file! (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				#"%" decode-2hex (append new hex)
				| set c skip (append new c)
			]
		]
		new
	]

	if cs/1 = '- [
		cs/1:  charset "0123465798"						;-- digit
		cs/2:  charset "ABCDEF"							;-- hexa-upper
		cs/3:  charset "abcdef"							;-- hexa-lower
		cs/4:  union cs/1 cs/2							;-- hexa
		cs/5:  union cs/4 cs/3							;-- hexa-char
		cs/6:  charset {/\^^,[](){}"#%$@:;}				;-- not-word-char
		cs/7:  union union cs/6 cs/1 charset {'}		;-- not-word-1st
		cs/8:  charset {[](){}"%@:;}					;-- not-file-char
		cs/9:  #"^""									;-- not-str-char
		cs/10: #"}"										;-- not-mstr-char
		cs/11: charset [#"^(40)" - #"^(5F)"]			;-- caret-char
		cs/12: charset [#"^(00)" - #"^(1F)"]			;-- non-printable-char
		cs/13: charset {^{"[]);}						;-- integer-end
		cs/14: charset " ^-^M"							;-- ws-ASCII, ASCII common whitespaces
		cs/15: charset [#"^(80)" - #"^(8A)"]			;-- ws-U+2k, Unicode spaces in the U+2000-U+200A range
		cs/16: charset [#"^(00)" - #"^(1F)"] 			;-- ASCII control characters

	]
	set [
		digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
		not-file-char not-str-char not-mstr-char caret-char
		non-printable-char integer-end ws-ASCII ws-U+2k control-char
	] cs

	;-- Whitespaces list from: http://en.wikipedia.org/wiki/Whitespace_character
	ws: [
		pos: #"^/" (
			if count? [
				line: line + 1
				;append/only lines to block! stack/tail?
			]
		)
		| ws-ASCII										;-- only the common whitespaces are matched
		| #"^(0085)"									;-- U+0085 (Newline)
		| #"^(00A0)"									;-- U+00A0 (No-break space)
		| #"^(1680)"									;-- U+1680 (Ogham space mark)
		| #"^(180E)"									;-- U+180E (Mongolian vowel separator)
		| ws-U+2k										;-- U+2000-U+200A range
		| #"^(2028)"									;-- U+2028 (Line separator)
		| #"^(2029)"									;-- U+2029 (Paragraph separator)
		| #"^(202F)"									;-- U+202F (Narrow no-break space)
		| #"^(205F)"									;-- U+205F (Medium mathematical space)
		| #"^(3000)"									;-- U+3000 (Ideographic space)
	]

	newline-char: [
		#"^/"
		| #"^(0085)"									;-- U+0085 (Newline)
		| #"^(2028)"									;-- U+2028 (Line separator)
		| #"^(2029)"									;-- U+2029 (Paragraph separator)
	]

	counted-newline: [pos: #"^/" (line: line + 1)]

	ws-no-count: [(count?: no) ws (count?: yes)]

	escaped-char: [
		"^^(" [
			[										;-- special case first
				"null" 	 (value: #"^(00)")
				| "back" (value: #"^(08)")
				| "tab"  (value: #"^(09)")
				| "line" (value: #"^(0A)")
				| "page" (value: #"^(0C)")
				| "esc"  (value: #"^(1B)")
				| "del"	 (value: #"^(7F)")
			]
			| pos: [2 6 hexa-char] e: (				;-- Unicode values allowed up to 10FFFFh
				value: encode-UTF8-char pos e
			)
		] #")"
		| #"^^" [
			[
				#"/" 	(value: #"^/")
				| #"-"	(value: #"^-")
				| #"?" 	(value: #"^(del)")			;@@FIXME
				| #"^^" (value: #"^^")				;-- caret escaping case
				| #"{"	(value: #"{")
				| #"}"	(value: #"}")
				| #"^""	(value: #"^"")
			]
			| pos: caret-char (value: pos/1 - 64)
		]
	]

	char-rule: [
		{#"} s: [
			 escaped-char
			| ahead [non-printable-char | not-str-char] break
			| skip (value: s/1)
		] {"}
	]

	line-string: [
		{"} s: any [
			{^^"}
			| ahead [#"^"" | newline-char] break
			| escaped-char
			| skip
		]
		e: {"}
	]

	nested-curly-braces: [
		(cnt: 1)
		any [
			counted-newline
			| "^^{"
			| "^^}"
			| #"{" 	  (cnt: cnt + 1)
			| e: #"}" if (zero? cnt: cnt - 1) break
			| escaped-char
			| skip
		]
	]

	multiline-string: [#"{" s: nested-curly-braces]

	string-rule: [(type: string!) line-string | multiline-string]

	file-rule: [
		#"%" [
			line-string (process: trans-string type: file!)
			| s: any [ahead [not-file-char | ws-no-count] break | skip] e:
			  (process: trans-file)
		]
	]

	symbol-rule: [
		some [ahead [not-word-char | ws-no-count | control-char] break | skip] e:
	]

	begin-symbol-rule: [								;-- 1st char in symbols is restricted
		[not ahead [not-word-1st | ws-no-count | control-char]]
		symbol-rule
	]

	path-rule: [
		ahead slash (									;-- path detection barrier
			trans-push-path stack type					;-- create empty path
			trans-word last stack copy/part s e type	;-- push 1st path element
		)
		some [
			slash
			s: [
				integer-number-rule			(append last stack trans-integer s e)
				| begin-symbol-rule			(trans-word last stack copy/part s e word!)
				| paren-rule
				| #":" s: begin-symbol-rule	(trans-word last stack copy/part s e get-word!)
				;@@ add more datatypes here
			]
			opt [#":" (trans-set-path back tail stack)]
		] (trans-pop stack)
	]

	word-rule: 	[
		s: begin-symbol-rule (type: word!) [
			path-rule 									;-- path matched
			| opt [#":" (type: set-word!)]
			  (trans-word last stack copy/part s e type) ;-- word or set-word matched
		]
	]

	get-word-rule: [
		#":" (type: get-word!) s: begin-symbol-rule [
			path-rule (type: get-path!)
			| (trans-word last stack copy/part s e type) ;-- get-word matched
		]
	]

	lit-word-rule: [
		#"'" (type: lit-word!) s: begin-symbol-rule [
			path-rule (type: lit-path!)					;-- path matched
			| (trans-word last stack copy/part s e type) ;-- lit-word matched
		]
	]

	issue-rule: [
		#"#" (type: issue!) s: symbol-rule
		(trans-word last stack copy/part s e type)
	]

	refinement-rule: [
		slash (type: refinement!) s: symbol-rule
		(trans-word last stack copy/part s e type)
	]

	slash-rule: [s: [slash opt slash] e:]

	hexa-rule: [2 8 hexa e: #"h"]

	integer-number-rule: [
		opt [#"-" | #"+"] digit any [digit | #"'" digit] e:
	]

	integer-rule: [
		integer-number-rule
		ahead [integer-end | ws-no-count | end]
	]

	block-rule: [
		#"[" (append/only stack make block! 4)
		any-value
		#"]" (trans-pop stack)
	]

	paren-rule: [
		#"(" (append/only stack make paren! 4)
		any-value
		#")" (trans-pop stack)
	]

	escaped-rule: [
		"#[" pos: any ws [
			  "true"  			(value: true)
			| "false" 			(value: false)
			| [
				"none!"			(value: none!)
				| "logic!"		(value: logic!)
				| "block!"		(value: block!)
				| "integer!"	(value: integer!)
				| "word!"		(value: word!)
				| "set-word!"	(value: set-word!)
				| "get-word!"	(value: get-word!)
				| "lit-word!"	(value: lit-word!)
				| "refinement!"	(value: refinement!)
				;| "binary!"	(value: binary!)
				| "string!"		(value: string!)
				| "char!"		(value: char!)
				| "bitset!"		(value: bitset!)
				| "path!"		(value: path!)
				| "set-path!"	(value: set-path!)
				| "lit-path!"	(value: lit-path!)
				| "get-path!"	(value: get-path!)
				| "native!"		(value: native!)
				| "action!"		(value: action!)
				| "op!"			(value: op!)
				| "issue!"		(value: issue!)
				| "paren!"		(value: paren!)
				| "function!"	(value: function!)
				| "routine!"	(value: routine!)
			]
			| "none" 			(value: none)
		] pos: any ws #"]"
	]

	comment-rule: [#";" [to lf | to end]]

	wrong-delimiters: [
		pos: [
			  #"]" (value: #"[") | #")" (value: #"(")
			| #"[" (value: #"]") | #"(" (value: #")")
		] :pos
		(print ["missing matching" value])
	]

	literal-value: [
		pos: (e: none) s: [
			comment-rule
			| escaped-rule		(append last stack value)
			| integer-rule		(append last stack trans-integer s e)
			| hexa-rule			(append last stack trans-hexa s e)
			| word-rule
			| lit-word-rule
			| get-word-rule
			| slash-rule		(trans-word last stack copy/part s e word!)
			| refinement-rule
			| file-rule			(append last stack do process)
			| char-rule			(append last stack value)
			| issue-rule
			| block-rule
			| paren-rule
			| string-rule		(append last stack do trans-string)
			;| binary-rule	  	(stack/push load-binary s e)
		]
	]

	any-value: [pos: any [literal-value | ws]]

	unless parse/case src [any-value opt wrong-delimiters][
		print ["*** Syntax Error: invalid Red value at:" copy/part pos 20]
	]
	stack/1
]