FIX: Printed output of SOURCE for non-function! types

Will now print actual type instead of "word" for non-functions

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

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

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

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other useful functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
    about - display version number and build date
    q or quit - leave the Red console
}
		]
		all [word? word datatype? get :word] [						;-- HELP <datatype!>
			type: get :word
			foreach w system/words [
				if type = type? get w [
					case [
						any [function? get w native? get w action? get w op? get w][
							prin [tab w]
							spec: spec-of get w

							either any [
								string? desc: spec/1
								string? desc: spec/2					;-- attributes block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
		]
		string? word [
			foreach w system/words [
				if any [function? get w native? get w action? get w op? get w][
					spec: spec-of get w
					if any [find form w word find form spec word] [
						prin [tab w]

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

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

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

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

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

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

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

?: :help

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

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

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

about: function [
	"Print Red version information"
][
	print ["Red" system/version]
]

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

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

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

    help insert
    ? insert

To see all words of a specific datatype:

    ? native!
    ? function!
    ? datatype!

Other useful functions:

    ?? - display a variable and its value
    probe - print a value (molded)
    source func - show source code of func
    what - show a list of known functions
    about - display version number and build date
    q or quit - leave the Red console
}
		]
		all [word? word datatype? get :word] [						;-- HELP <datatype!>
			type: get :word
			foreach w system/words [
				if type = type? get w [
					case [
						any [function? get w native? get w action? get w op? get w][
							prin [tab w]
							spec: spec-of get w

							either any [
								string? desc: spec/1
								string? desc: spec/2					;-- attributes block case
							][
								print ["^-=> " desc]
							][
								prin lf
							]
						]
						datatype? get w [
							print [tab :w]
						]
						'else [
							print [tab :w "^-: " mold get w]
						]
					]
				]
			]
		]
		string? word [
			foreach w system/words [
				if any [function? get w native? get w action? get w op? get w][
					spec: spec-of get w
					if any [find form w word find form spec word] [
						prin [tab w]

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

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

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

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

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

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

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

?: :help

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

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

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

about: function [
	"Print Red version information"
][
	print ["Red" system/version]
]


FIX: many fixes for on %help.red

FIX: many fixes for on %help.red

Changes:
- replaced spaces by tabs
- changed the coding style on [] positioning
- improved HELP output by adding tabulations
- added description string to WHAT output
- fixed crashing SOURCE function.
- SOURCE now prints the name and the whole function constructor
.
TBD:
- align all printed text
- improve the code quality/elegancy of HELP
- add support to HELP for searching string patterns
- add support for any-type!, so that HELP can be invoked with no arguments

Red [
	Title:	"Console help functions"
	Author:	["Ingo Hohmann" "Nenad Rakocevic"]
	File:	%help.red
	Tabs:	4
	Rights:	"Copyright (C) 2014 Ingo Hohmann, Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

help: func [
	"Get help for functions"
	'func-name "Word you are looking for"
	/local tab tab4 tab8 type start attributs info fun w ref block
][
	tab: tab4: "    "
	tab8: "        "

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

	either all [
		word? func-name
		fun: get func-name
		any [action? :fun function? :fun native? :fun]
	][
;		print ["^/" func-name "is of type" type? :fun newline]
		prin ["^/USAGE:^/" tab func-name]

		parse spec-of :fun [
			start: any [								;-- 1st pass
				/local to end
				| set w word! (prin [" " w])
				| set w [lit-word! | refinement!] (prin [" " mold w])
				| skip
			]

			:start										;-- 2nd pass
			opt [set attributs block! (prin ["^/^/ATTRIBUTS:^/" tab mold attributs])]
			opt [set info string! (print ["^/^/DESCRIPTION:^/" tab append form info dot])]

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

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

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

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

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

Red [
   Title: "Help function for Red"
   Author: "Ingo Hohmann"
]

help: function [
   "Get help for functions"
   'func-name "Word you are looking for"
][
   argument-rule: [
      [set word word! (pre: "") | set word lit-word! (pre: "'") | set word get-word! (pre: ":")]
      opt [ set annotation block! (prin [ " " mold annotation])]
      opt [ set info string! (prin [ " =>" info])]
      (print [ ])
   ]
   either all [ word? func-name any [ action? get func-name function? get func-name native? get func-name]][
;      print ["^/" func-name "is of type" type? get :func-name newline]

      prin ["^/USAGE:^/" func-name ]
      parse spec-of get func-name [ any [ /local to end | set w word! (prin[" " w]) | set w [ lit-word! | refinement! ] (prin [" " mold w]) | skip ]]
      parse spec-of get func-name [
	 opt [set annotation block! (prin ["^/^/ANNOTATIONS:^/" mold annotation])]
	 opt [set info string! (print ["^/^/DESCRIPTION:^/" info])]
	 (print "^/ARGUMENTS:")
	 any [
	    argument-rule
	    (print "")
	 ]
	 (print "^/REFINEMENTS:")
	 any [
	    [/local [ to set-word! | to end ] ]
	    |
	    [
	       set ref refinement! (prin mold ref)
	       opt [ set info string! (prin [ " =>" info])]
	       (print "")
	       any [argument-rule (print "")]
	    ]
	 ]
	 opt [
	    set-word! set block block!
	    (print ["^/RETURN:^/" mold block])
	 ]
      ]
   ][
      print [func-name "is of type" either word? func-name [type? get func-name][type? func-name] "."]
      print "No more help available."
   ]
   exit
]

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

source: function [
   "print the source of a function"
   func-name [lit-word!] "The name of the function as lit-word!"
][
   either function? get func-name [
      print mold body-of :func-name
   ][
      print ["Sorry," func-name "is a" type? :func-name "so no source is available"]
   ]
]


Removed unneeded parens

Removed unneeded parens

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
]

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
]


Removes redlang

Removes redlang

Red [
	Title:   "Interandroid Fictional Language"
	Author:  "Olivier Huin"
	File: 	 %language.red
	Tabs:	 4
	Version: 1.0.0.0
	Rights:  "Copyright (C) 2017 Olivier Huin. All rights reserved."
	License: {
		Distributed under the MIT License.
		See https://opensource.org/licenses/MIT
	}
]

rlang:  charset "Rr"
tlang:  charset "Tt"
nlang:  charset "Nn"
slang:  charset "Ss"
llang:  charset "Ll"
klang:  charset "CcKk"
dlang:  charset "Dd"
plang:  charset "Pp"
glang:  charset "Gg"
blang:  charset "Bb"
flang:  charset "Ff"
ylang:  charset "Yy"
wlang:  charset "Ww("
vlang:  charset "Vv)"
spaceLang:  charset " Zz"
xlang:  charset "Xx?"

ten: charset "RrTtNnSsLlCcKkDdPpGgBb"
extra: charset "FfYy"
begin: union spaceLang wlang xlang
finish: union spaceLang vlang
twelve: charset "RrTtNnSsLlCcKkDdPpGgBbFfYy"
category: [ten twelve]
; sets
oneType: rlang ; one and onl yone
manyType: tlang ; some or a subset
noneType: nlang; or complement
everyType: slang
mostType: llang
verbType: klang
adjectiveType: dlang
articleType: plang
pronounType: glang
adverbType: blang

nounType: union oneType manyType noneType everyType mostType
noun: [begin nounType category 3 twelve finish]
verb: [begin verbType category 3 twelve finish]
adjective: [adjectiveType category 3 twelve]
adverb: [begin adverbType category 3 twelve finish]

language: function [prog [string!]][
        size: 30000
        parse prog ["dtt" (prin "A")]
    ]

    ; This code will print a Hello World! message
language { dttnnn }


FIX: bad new buffer handling for string! to UTF-8 conversion.

Buffer size allocation now bigger to avoid overflows. Still the most accurate way is precalculating the size of the UTF-8 output like done by Oldes in the `float` branch.

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

#enum encoding! [
	UTF-16LE:	-1
	UTF-8:		 0
	Latin1:		 1
	UCS-2:		 2
	UCS-4:		 4
]

unicode: context [
	verbose: 0

	#define U_REPLACEMENT 	FFFDh
	;	choose one of the following options
	;	FFFDh			; U+FFFD = replacement character
	;	1Ah				; U+001A = control SUB (substitute)
	;	241Ah			; U+241A = symbol for substitute
	;	2426h			; U+2426 = symbol for substitute form two
	;	3Fh				; U+003F = question mark
	;	BFh				; U+00BF = inverted question mark
	;	DC00h + b1		; U+DCxx where xx = b1 (never a Unicode codepoint)

	utf8-char-size?: func [
		byte-1st	[integer!]
		return:		[integer!]
	][
		;@@ In function unicode/decode-utf8-char
		;@@ just support up to four bytes in a UTF-8 sequence
		;if byte-1st and FCh = FCh [return 6]
		;if byte-1st and F8h = F8h [return 5]
		if byte-1st and F0h = F0h [return 4]
		if byte-1st and E0h = E0h [return 3]
		if byte-1st and C0h = C0h [return 2]
		0
	]

	to-utf8: func [
		str		[red-string!]
		return: [c-string!]
		/local
			s	 [series!]
			node [node!]
			buf	 [byte-ptr!]
			p	 [byte-ptr!]
			p4	 [int-ptr!]
			tail [byte-ptr!]
			unit [integer!]
			cp	 [integer!]
	][
		s:	  GET_BUFFER(str)
		unit: GET_UNIT(s)

		node: alloc-bytes unit << 1 * (1 + string/rs-length? str)	;@@ TBD: mark this buffer as protected!
		s: 	  as series! node/value
		buf:  as byte-ptr! s/offset

		p:	  string/rs-head str
		tail: string/rs-tail str

		while [p < tail][
			cp: switch unit [
				Latin1 [as-integer p/value]
				UCS-2  [(as-integer p/2) << 8 + p/1]
				UCS-4  [p4: as int-ptr! p p4/value]
			]
			case [
				cp <= 7Fh [
					buf/1: as-byte cp
					buf: buf + 1
				]
				cp <= 07FFh [
					buf/1: as-byte cp >> 6 or C0h
					buf/2: as-byte cp and 3Fh or 80h
					buf: buf + 2
				]
				cp < 0000FFFFh [
					buf/1: as-byte cp >> 12 or E0h
					buf/2: as-byte cp >> 6 and 3Fh or 80h
					buf/3: as-byte cp	   and 3Fh or 80h
					buf: buf + 3
				]
				cp < 0010FFFFh [
					buf/1: as-byte cp >> 18 or F0h
					buf/2: as-byte cp >> 12 and 3Fh or 80h
					buf/3: as-byte cp >> 6  and 3Fh or 80h
					buf/4: as-byte cp 		and 3Fh or 80h
					buf: buf + 4
				]
				true [
					print "*** Error: to-utf8 codepoint overflow"
					halt
				]
			]
			p: p + unit
		]
		buf/1: null-byte

		as-c-string s/offset
	]

	Latin1-to-UCS2: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/Latin1-to-UCS2"]]

		used: as-integer s/tail - s/offset
		if used * 2 >= s/size [							;-- ensure we have enough space
			s: expand-series s (used + 1) * 2			;-- reserve one more for edge cases
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  (as byte-ptr! s/offset) + (used * 2)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 1
			dst: dst - 2
			dst/1: src/1
			dst/2: null-byte
		]
		s/flags: s/flags and flag-unit-mask or UCS-2	;-- s/unit: UCS-2
		s
	]

	Latin1-to-UCS4: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/Latin1-to-UCS4"]]

		used: as-integer s/tail - s/offset
		if used * 4 >= s/size [							;-- ensure we have enough space
			s: expand-series s (used + 1) * 4			;-- reserve one more for edge cases
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  as int-ptr! (as byte-ptr! s/offset) + (used * 4)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 1
			dst: dst - 1
			dst/value: as-integer src/1
		]
		s/flags: s/flags and flag-unit-mask or UCS-4	;-- s/unit: UCS-4
		s
	]

	UCS2-to-UCS4: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/UCS2-to-UCS4"]]

		used: as-integer s/tail - s/offset
		if used * 2 >= s/size [							;-- ensure we have enough space
			s: expand-series s used * 2 + 1
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  as int-ptr! (as byte-ptr! s/offset) + (used * 2)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 2
			dst: dst - 1
			dst/value: (as-integer src/2) << 8 + src/1
		]
		s/flags: s/flags and flag-unit-mask or UCS-4	;-- s/unit: UCS-4
		s
	]

	decode-utf8-char: func [
		src		[c-string!]
		cnt		[int-ptr!]								;-- pointer to size of next char in bytes
		return: [integer!]
		/local
			b1  [integer!]								;-- up to four bytes in a UTF-8 sequence
			b2  [integer!]								;-- for computing purposes they are of integer! type
			b3  [integer!]
			b4  [integer!]
			cp  [integer!]								; computed codepoint
	][
		b1: as-integer src/1

		either b1 < 80h	[								; single byte (ASCII)
			cp: b1										; and we are done
			cnt/value: 1
		][
			cp: U_REPLACEMENT
			; assume error by default - this simplifies code greatly
			; cp is now only set if a correct sequence has been decoded

			unless b1 < C0h [							; 80h - BFh may not start a sequence
				case  [
					b1 < E0h [							; start of two-byte sequence
						if cnt/value < 2 [return -1]
						b2: as-integer src/2
						if all [
							b2 >= 80h b2 < C0h
						][
							cp:	(b1 - C0h << 6) or
								(b2 - 80h)
;							if any [
;								cp > 7Fh				; optional test for overlong
;								cp = 0					; even so, must allow U+0000
;							][
								cnt/value: 2
;							]
						]
					]
					b1 < F0h [							; start of three-byte sequence
						if cnt/value < 3 [return -1]
						b2: as-integer src/2
						b3: as-integer src/3
						if all [
							b2 >= 80h b2 < C0h
							b3 >= 80h b3 < C0h
						][
							cp:	(b1 - E0h << 12) or
								(b2 - 80h <<  6) or
								(b3 - 80h)
							if all [
								any [cp < DC00h cp > DCFFh]
;								cp > 7FFh				; optional test for overlong
							][
								cnt/value: 3
							]
						]
					]
					b1 < F8h [							; start of four-byte sequence
						if cnt/value < 4 [return -1]
						b2: as-integer src/2
						b3: as-integer src/3
						b4: as-integer src/4
						if all [
							b2 >= 80h b2 < C0h
							b3 >= 80h b3 < C0h
							b4 >= 80h b4 < C0h
						][
							cp:	(b1 - F0h << 18) or
								(b2 - 80h << 12) or
								(b3 - 80h <<  6) or
								(b4 - 80h)
							if all [
								cp <= 0010FFFFh
;								cp > FFFFh				; optional test for overlong
							][
								cnt/value: 4
							]
						]
					]
;					true [
;						error case						;@@ throw an error! value
;					]
				]
			]
		]
		cp
	]

	load-utf8-buffer: func [
		src		   [c-string!]							;-- UTF-8 input buffer (zero-terminated)
		size	   [integer!]							;-- size of src in bytes (including terminal NUL)
		dst		   [series!]							;-- optional output string! series
		remain	   [int-ptr!]							;-- number of undecoded bytes at end of buffer
		return:	   [node!]
		/local
			node   [node!]
			s 	   [series!]
			buf1   [byte-ptr!]
			buf4   [int-ptr!]
			end    [byte-ptr!]
			unit   [integer!]
			cp	   [integer!]							;-- computed codepoint
			count  [integer!]
			used   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/load-utf8-buffer"]]

		assert positive? size

		either null? dst [								;-- test if output buffer is provided
			node: alloc-series size 1 0
			s: as series! node/value
			unit:  Latin1								;-- start with 1 byte/codepoint
		][
			node: dst/node
			s: dst
			unit: GET_UNIT(s)
			if s/size / unit < size [
				s: expand-series s size * unit
			]
		]

		buf1:  as byte-ptr! s/offset
		buf4:  null
		end:   buf1 + s/size
		count: size

		if size = 1 [return node]						;-- terminal NUL accounted
		;assert not zero? as-integer src/1				;@@ ensure input string not empty

		;-- the first part of loop is Rudolf's code with very minor modifications
		;-- (res/value replaced by cp, 'u renamed to 'src)
		;-- original source code: https://gist.github.com/1325840

		until [
			; cycling through res is done at the end; likewise for src
			; to account for this, as soon as a multiple byte sequence is consumed
			; the pointer in src is moved one less than the number of bytes consumed

			used: count									;-- pass number of remaining bytes in input stream
			cp: decode-utf8-char src :used
			if cp = -1 [								;-- premature exit if buffer incomplete
				s/tail: as cell! either unit = UCS-4 [buf4][buf1]	;-- position s/tail at end of loaded characters (no NUL terminator)
				remain/value: count						;-- return the number of unprocessed bytes
				return node
			]

			switch unit [
				Latin1 [
					case [
						cp <= FFh [
							buf1/value: as-byte cp
							buf1: buf1 + 1
							assert buf1 <= end			;-- should not happen if we're good
						]
						cp <= FFFFh [
							s/tail: as cell! buf1
							unit: UCS-2
							s:    Latin1-to-UCS2 s		;-- upgrade to UCS-2
							buf1: as byte-ptr! s/tail
							end:  (as byte-ptr! s/offset) + s/size

							buf1/1: as-byte cp and FFh
							buf1/2: as-byte cp >> 8
							buf1: buf1 + 2
						]
						true [
							s/tail: as cell! buf1
							unit: UCS-4
							s:    Latin1-to-UCS4 s		;-- upgrade to UCS-4
							buf4: as int-ptr! s/tail
							end:  (as byte-ptr! s/offset) + s/size

							buf4/value: cp
							buf4: buf4 + 1
						]
					]
				]
				UCS-2 [
					either cp > FFFFh [
						s/tail: as cell! buf1
						unit: UCS-4
						s:    UCS2-to-UCS4 s			;-- upgrade to UCS-4
						buf4: as int-ptr! s/tail
						end:  (as byte-ptr! s/offset) + s/size

						buf4/value: cp
						buf4: buf4 + 1
					][
						if buf1 >= end [
							s/tail: as cell! buf1
							s: expand-series s s/size + (size >> 2)	;-- increase size by 50%
							buf1: as byte-ptr! s/tail
							end: (as byte-ptr! s/offset) + s/size
						]
						buf1/1: as-byte cp and FFh
						buf1/2: as-byte cp >> 8
						buf1: buf1 + 2
					]
				]
				UCS-4 [
					if buf4 >= (as int-ptr! end) [
						s/tail: as cell! buf4
						s: expand-series s s/size + size ;-- increase size by 100%
						buf4: as int-ptr! s/tail
						end: (as byte-ptr! s/offset) + s/size
					]
					buf4/value: cp
					buf4: buf4 + 1
				]
			]

			count: count - used
			src: src + used
			zero? count
		] 												;-- end until

		s/tail: as cell! switch unit [					;-- position s/tail just before the NUL character
			Latin1 [buf1 - 1]
			UCS-2  [buf1 - 2]
			UCS-4  [buf4 - 1]
		]
		assert s/size - GET_UNIT(s) >= as-integer (s/tail - s/offset) ;-- tail points before NUL

		node
	]

	load-utf8-stream: func [
		src		   [c-string!]							;-- UTF-8 input buffer (not NUL-terminated)
		size	   [integer!]							;-- size of src buffer in bytes (excluding NUL if any)
		output	   [red-string!]						;-- output buffer to append new chars to
		remain	   [int-ptr!]							;-- number of undecoded bytes at end of input buffer
		return:	   [node!]
	][
		load-utf8-buffer src size GET_BUFFER(output) remain
	]

	load-utf8: func [
		src		   [c-string!]							;-- UTF-8 input buffer (zero-terminated)
		size	   [integer!]							;-- size of src in bytes (including terminal NUL)
		return:	   [node!]
	][
		load-utf8-buffer src size null null
	]

	scan-utf16: func [									;-- detect codepoint max storage size
		src		[c-string!]
		size	[integer!]
		return: [integer!]								;-- 1, 2 or 4 (bytes per codepoint)
		/local
			unit [integer!]
			c	 [byte!]
	][
		unit: 1
		src: src + 1
		while [size > 0][
			c: src/1
			if all [#"^(D8)" <= c c <= #"^(DF)"][return 4]	;-- max
			if c <> null-byte [unit: 2]
			src: src + 2
			size: size - 1
		]
		unit
	]

	load-utf16: func [
		src		[c-string!]							;-- UTF-16LE input buffer (zero-terminated)
		size	[integer!]							;-- size of src in codepoints (including terminal NUL)
		return:	[node!]
		/local
			unit [encoding!]
			node [node!]
			s	 [series!]
			p	 [byte-ptr!]
			p4	 [int-ptr!]
			cnt  [integer!]
			c	 [integer!]
			cp	 [integer!]
	][
		unit: scan-utf16 src size
		node: alloc-series size unit 0
		s:	  as series! node/value
		p:	  as byte-ptr! s/offset
		cnt:  size

		switch unit [
			Latin1 [
				while [cnt > 0][
					p/value: src/1
					p: p + 1
					src: src + 2
					cnt: cnt - 1
				]
			]
			UCS-2 [
				copy-memory p as byte-ptr! src size * 2
			]
			UCS-4 [
				p4: as int-ptr! p
				while [cnt > 0][
					c: as-integer src/2
					either all [D8h <= c c <= DBh][
						cp: c << 8 + src/1 and 03FFh << 10	;-- lead surrogate deocoding

						src: src + 2
						cnt: cnt - 1
						c: as-integer src/2
						if any [
							cnt < 0
							not any [DCh <= c c <= DFh]
						][
							print "*** Input Error: invalid UTF-16LE codepoint"
							halt
						]
						p4/value: c << 8 + src/1 and 03FFh or cp  ;-- trail surrogate deocoding
					][
						p4/value: c << 8 + src/1
					]
					p4: p4 + 1
					src: src + 2
					cnt: cnt - 1
				]
			]
		]
		s/tail: as cell! (as byte-ptr! s/offset) + (size - 1 * unit)
		node
	]
]

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

#enum encoding! [
	UTF-16LE:	-1
	UTF-8:		 0
	Latin1:		 1
	UCS-2:		 2
	UCS-4:		 4
]

unicode: context [
	verbose: 0

	#define U_REPLACEMENT 	FFFDh
	;	choose one of the following options
	;	FFFDh			; U+FFFD = replacement character
	;	1Ah				; U+001A = control SUB (substitute)
	;	241Ah			; U+241A = symbol for substitute
	;	2426h			; U+2426 = symbol for substitute form two
	;	3Fh				; U+003F = question mark
	;	BFh				; U+00BF = inverted question mark
	;	DC00h + b1		; U+DCxx where xx = b1 (never a Unicode codepoint)

	utf8-char-size?: func [
		byte-1st	[integer!]
		return:		[integer!]
	][
		;@@ In function unicode/decode-utf8-char
		;@@ just support up to four bytes in a UTF-8 sequence
		;if byte-1st and FCh = FCh [return 6]
		;if byte-1st and F8h = F8h [return 5]
		if byte-1st and F0h = F0h [return 4]
		if byte-1st and E0h = E0h [return 3]
		if byte-1st and C0h = C0h [return 2]
		0
	]

	to-utf8: func [
		str		[red-string!]
		return: [c-string!]
		/local
			s	 [series!]
			node [node!]
			buf	 [byte-ptr!]
			p	 [byte-ptr!]
			p4	 [int-ptr!]
			tail [byte-ptr!]
			unit [integer!]
			cp	 [integer!]
	][
		s:	  GET_BUFFER(str)
		unit: GET_UNIT(s)
		node: alloc-bytes unit * (1 + string/rs-length? str)	;@@ TBD: mark this buffer as protected!
		s: 	  as series! node/value
		buf:  as byte-ptr! s/offset

		p:	  string/rs-head str
		tail: string/rs-tail str

		while [p < tail][
			cp: switch unit [
				Latin1 [as-integer p/value]
				UCS-2  [(as-integer p/2) << 8 + p/1]
				UCS-4  [p4: as int-ptr! p p4/value]
			]
			case [
				cp <= 7Fh [
					buf/1: as-byte cp
					buf: buf + 1
				]
				cp <= 07FFh [
					buf/1: as-byte cp >> 6 or C0h
					buf/2: as-byte cp and 3Fh or 80h
					buf: buf + 2
				]
				cp < 0000FFFFh [
					buf/1: as-byte cp >> 12 or E0h
					buf/2: as-byte cp >> 6 and 3Fh or 80h
					buf/3: as-byte cp	   and 3Fh or 80h
					buf: buf + 3
				]
				cp < 0010FFFFh [
					buf/1: as-byte cp >> 18 or F0h
					buf/2: as-byte cp >> 12 and 3Fh or 80h
					buf/3: as-byte cp >> 6  and 3Fh or 80h
					buf/4: as-byte cp 		and 3Fh or 80h
					buf: buf + 4
				]
				true [
					print "*** Error: to-utf8 codepoint overflow"
					halt
				]
			]
			p: p + unit
		]
		string/add-terminal-NUL p unit
		as-c-string s/offset
	]

	Latin1-to-UCS2: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/Latin1-to-UCS2"]]

		used: as-integer s/tail - s/offset
		if used * 2 >= s/size [							;-- ensure we have enough space
			s: expand-series s (used + 1) * 2			;-- reserve one more for edge cases
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  (as byte-ptr! s/offset) + (used * 2)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 1
			dst: dst - 2
			dst/1: src/1
			dst/2: null-byte
		]
		s/flags: s/flags and flag-unit-mask or UCS-2	;-- s/unit: UCS-2
		s
	]

	Latin1-to-UCS4: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/Latin1-to-UCS4"]]

		used: as-integer s/tail - s/offset
		if used * 4 >= s/size [							;-- ensure we have enough space
			s: expand-series s (used + 1) * 4			;-- reserve one more for edge cases
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  as int-ptr! (as byte-ptr! s/offset) + (used * 4)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 1
			dst: dst - 1
			dst/value: as-integer src/1
		]
		s/flags: s/flags and flag-unit-mask or UCS-4	;-- s/unit: UCS-4
		s
	]

	UCS2-to-UCS4: func [
		s		 [series!]
		return:	 [series!]
		/local
			used [integer!]
			base [byte-ptr!]
			src  [byte-ptr!]
			dst  [int-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/UCS2-to-UCS4"]]

		used: as-integer s/tail - s/offset
		if used * 2 >= s/size [							;-- ensure we have enough space
			s: expand-series s used * 2 + 1
		]
		base: as byte-ptr! s/offset
		src:  as byte-ptr! s/tail						;-- start from end
		dst:  as int-ptr! (as byte-ptr! s/offset) + (used * 2)
		s/tail: as cell! dst							;-- adjust to new tail

		while [src > base][								;-- in-place conversion
			src: src - 2
			dst: dst - 1
			dst/value: (as-integer src/2) << 8 + src/1
		]
		s/flags: s/flags and flag-unit-mask or UCS-4	;-- s/unit: UCS-4
		s
	]

	decode-utf8-char: func [
		src		[c-string!]
		cnt		[int-ptr!]								;-- pointer to size of next char in bytes
		return: [integer!]
		/local
			b1  [integer!]								;-- up to four bytes in a UTF-8 sequence
			b2  [integer!]								;-- for computing purposes they are of integer! type
			b3  [integer!]
			b4  [integer!]
			cp  [integer!]								; computed codepoint
	][
		b1: as-integer src/1

		either b1 < 80h	[								; single byte (ASCII)
			cp: b1										; and we are done
			cnt/value: 1
		][
			cp: U_REPLACEMENT
			; assume error by default - this simplifies code greatly
			; cp is now only set if a correct sequence has been decoded

			unless b1 < C0h [							; 80h - BFh may not start a sequence
				case  [
					b1 < E0h [							; start of two-byte sequence
						if cnt/value < 2 [return -1]
						b2: as-integer src/2
						if all [
							b2 >= 80h b2 < C0h
						][
							cp:	(b1 - C0h << 6) or
								(b2 - 80h)
;							if any [
;								cp > 7Fh				; optional test for overlong
;								cp = 0					; even so, must allow U+0000
;							][
								cnt/value: 2
;							]
						]
					]
					b1 < F0h [							; start of three-byte sequence
						if cnt/value < 3 [return -1]
						b2: as-integer src/2
						b3: as-integer src/3
						if all [
							b2 >= 80h b2 < C0h
							b3 >= 80h b3 < C0h
						][
							cp:	(b1 - E0h << 12) or
								(b2 - 80h <<  6) or
								(b3 - 80h)
							if all [
								any [cp < DC00h cp > DCFFh]
;								cp > 7FFh				; optional test for overlong
							][
								cnt/value: 3
							]
						]
					]
					b1 < F8h [							; start of four-byte sequence
						if cnt/value < 4 [return -1]
						b2: as-integer src/2
						b3: as-integer src/3
						b4: as-integer src/4
						if all [
							b2 >= 80h b2 < C0h
							b3 >= 80h b3 < C0h
							b4 >= 80h b4 < C0h
						][
							cp:	(b1 - F0h << 18) or
								(b2 - 80h << 12) or
								(b3 - 80h <<  6) or
								(b4 - 80h)
							if all [
								cp <= 0010FFFFh
;								cp > FFFFh				; optional test for overlong
							][
								cnt/value: 4
							]
						]
					]
;					true [
;						error case						;@@ throw an error! value
;					]
				]
			]
		]
		cp
	]

	load-utf8-buffer: func [
		src		   [c-string!]							;-- UTF-8 input buffer (zero-terminated)
		size	   [integer!]							;-- size of src in bytes (including terminal NUL)
		dst		   [series!]							;-- optional output string! series
		remain	   [int-ptr!]							;-- number of undecoded bytes at end of buffer
		return:	   [node!]
		/local
			node   [node!]
			s 	   [series!]
			buf1   [byte-ptr!]
			buf4   [int-ptr!]
			end    [byte-ptr!]
			unit   [integer!]
			cp	   [integer!]							;-- computed codepoint
			count  [integer!]
			used   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "unicode/load-utf8-buffer"]]

		assert positive? size

		either null? dst [								;-- test if output buffer is provided
			node: alloc-series size 1 0
			s: as series! node/value
			unit:  Latin1								;-- start with 1 byte/codepoint
		][
			node: dst/node
			s: dst
			unit: GET_UNIT(s)
			if s/size / unit < size [
				s: expand-series s size * unit
			]
		]

		buf1:  as byte-ptr! s/offset
		buf4:  null
		end:   buf1 + s/size
		count: size

		if size = 1 [return node]						;-- terminal NUL accounted
		;assert not zero? as-integer src/1				;@@ ensure input string not empty

		;-- the first part of loop is Rudolf's code with very minor modifications
		;-- (res/value replaced by cp, 'u renamed to 'src)
		;-- original source code: https://gist.github.com/1325840

		until [
			; cycling through res is done at the end; likewise for src
			; to account for this, as soon as a multiple byte sequence is consumed
			; the pointer in src is moved one less than the number of bytes consumed

			used: count									;-- pass number of remaining bytes in input stream
			cp: decode-utf8-char src :used
			if cp = -1 [								;-- premature exit if buffer incomplete
				s/tail: as cell! either unit = UCS-4 [buf4][buf1]	;-- position s/tail at end of loaded characters (no NUL terminator)
				remain/value: count						;-- return the number of unprocessed bytes
				return node
			]

			switch unit [
				Latin1 [
					case [
						cp <= FFh [
							buf1/value: as-byte cp
							buf1: buf1 + 1
							assert buf1 <= end			;-- should not happen if we're good
						]
						cp <= FFFFh [
							s/tail: as cell! buf1
							unit: UCS-2
							s:    Latin1-to-UCS2 s		;-- upgrade to UCS-2
							buf1: as byte-ptr! s/tail
							end:  (as byte-ptr! s/offset) + s/size

							buf1/1: as-byte cp and FFh
							buf1/2: as-byte cp >> 8
							buf1: buf1 + 2
						]
						true [
							s/tail: as cell! buf1
							unit: UCS-4
							s:    Latin1-to-UCS4 s		;-- upgrade to UCS-4
							buf4: as int-ptr! s/tail
							end:  (as byte-ptr! s/offset) + s/size

							buf4/value: cp
							buf4: buf4 + 1
						]
					]
				]
				UCS-2 [
					either cp > FFFFh [
						s/tail: as cell! buf1
						unit: UCS-4
						s:    UCS2-to-UCS4 s			;-- upgrade to UCS-4
						buf4: as int-ptr! s/tail
						end:  (as byte-ptr! s/offset) + s/size

						buf4/value: cp
						buf4: buf4 + 1
					][
						if buf1 >= end [
							s/tail: as cell! buf1
							s: expand-series s s/size + (size >> 2)	;-- increase size by 50%
							buf1: as byte-ptr! s/tail
							end: (as byte-ptr! s/offset) + s/size
						]
						buf1/1: as-byte cp and FFh
						buf1/2: as-byte cp >> 8
						buf1: buf1 + 2
					]
				]
				UCS-4 [
					if buf4 >= (as int-ptr! end) [
						s/tail: as cell! buf4
						s: expand-series s s/size + size ;-- increase size by 100%
						buf4: as int-ptr! s/tail
						end: (as byte-ptr! s/offset) + s/size
					]
					buf4/value: cp
					buf4: buf4 + 1
				]
			]

			count: count - used
			src: src + used
			zero? count
		] 												;-- end until

		s/tail: as cell! switch unit [					;-- position s/tail just before the NUL character
			Latin1 [buf1 - 1]
			UCS-2  [buf1 - 2]
			UCS-4  [buf4 - 1]
		]
		assert s/size - GET_UNIT(s) >= as-integer (s/tail - s/offset) ;-- tail points before NUL

		node
	]

	load-utf8-stream: func [
		src		   [c-string!]							;-- UTF-8 input buffer (not NUL-terminated)
		size	   [integer!]							;-- size of src buffer in bytes (excluding NUL if any)
		output	   [red-string!]						;-- output buffer to append new chars to
		remain	   [int-ptr!]							;-- number of undecoded bytes at end of input buffer
		return:	   [node!]
	][
		load-utf8-buffer src size GET_BUFFER(output) remain
	]

	load-utf8: func [
		src		   [c-string!]							;-- UTF-8 input buffer (zero-terminated)
		size	   [integer!]							;-- size of src in bytes (including terminal NUL)
		return:	   [node!]
	][
		load-utf8-buffer src size null null
	]

	scan-utf16: func [									;-- detect codepoint max storage size
		src		[c-string!]
		size	[integer!]
		return: [integer!]								;-- 1, 2 or 4 (bytes per codepoint)
		/local
			unit [integer!]
			c	 [byte!]
	][
		unit: 1
		src: src + 1
		while [size > 0][
			c: src/1
			if all [#"^(D8)" <= c c <= #"^(DF)"][return 4]	;-- max
			if c <> null-byte [unit: 2]
			src: src + 2
			size: size - 1
		]
		unit
	]

	load-utf16: func [
		src		[c-string!]							;-- UTF-16LE input buffer (zero-terminated)
		size	[integer!]							;-- size of src in codepoints (including terminal NUL)
		return:	[node!]
		/local
			unit [encoding!]
			node [node!]
			s	 [series!]
			p	 [byte-ptr!]
			p4	 [int-ptr!]
			cnt  [integer!]
			c	 [integer!]
			cp	 [integer!]
	][
		unit: scan-utf16 src size
		node: alloc-series size unit 0
		s:	  as series! node/value
		p:	  as byte-ptr! s/offset
		cnt:  size

		switch unit [
			Latin1 [
				while [cnt > 0][
					p/value: src/1
					p: p + 1
					src: src + 2
					cnt: cnt - 1
				]
			]
			UCS-2 [
				copy-memory p as byte-ptr! src size * 2
			]
			UCS-4 [
				p4: as int-ptr! p
				while [cnt > 0][
					c: as-integer src/2
					either all [D8h <= c c <= DBh][
						cp: c << 8 + src/1 and 03FFh << 10	;-- lead surrogate deocoding

						src: src + 2
						cnt: cnt - 1
						c: as-integer src/2
						if any [
							cnt < 0
							not any [DCh <= c c <= DFh]
						][
							print "*** Input Error: invalid UTF-16LE codepoint"
							halt
						]
						p4/value: c << 8 + src/1 and 03FFh or cp  ;-- trail surrogate deocoding
					][
						p4/value: c << 8 + src/1
					]
					p4: p4 + 1
					src: src + 2
					cnt: cnt - 1
				]
			]
		]
		s/tail: as cell! (as byte-ptr! s/offset) + (size - 1 * unit)
		node
	]
]


zigzag

zigzag

Red []

zigzag: function [a] [
  m: n: 0

  forall a [
    if a/3 [
      either ((a/2 > a/1) and (a/2 > a/3))
          or ((a/2 < a/1) and (a/2 < a/3)) [
        n: n + 1
      ] [
        m: max m n
        n: 0
      ]
    ]
  ]

  last-eq?: either a/3 [a/2 = a/3] [a/1 = a/2]
  head a
  first-eq?: a/1 = a/2
  either all [m = 0 n = 0 first-eq? last-eq?] [
    1
  ] [
    (max m n) + 2
  ]
]

print zigzag [4 4]
;= 1
print zigzag [4 5]
;= 2
print zigzag [4 5 6]
;= 2
print zigzag [4 5 3]
;= 3
print zigzag [9 8 8 5 3 5 3 2 8 6]
;= 4
print zigzag [2 1 4 4 1 4 4 1 2 0 1 0 0 3 1 3 4 1 3 4]
;= 6


FIX: some typos in POSIX.reds

FIX: some typos in POSIX.reds

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

#define __LC_CTYPE 0
#define __LC_ALL   6

#import [
	LIBC-file cdecl [
		wprintf: "wprintf" [
			[variadic]
			return: 	[integer!]
		]
		setlocale: "setlocale" [
			category	[integer!]
			locale		[c-string!]
			return:		[c-string!]
		]
	]
]

;-------------------------------------------
;-- Print a UCS-4 string to console
;-------------------------------------------
print-UCS4: func [
	str 	[int-ptr!]									;-- zero-terminated UCS-4 string
	size	[integer!]
	/local
		cp [integer!]
][
	assert str <> null

	while [not zero? size][
		cp: str/value
		case [
			cp <= 7Fh [
				putchar as-byte cp
			]
			cp <= 07FFh [
				putchar as-byte cp >> 6 or C0h
				putchar as-byte cp and 3Fh or 80h
			]
			cp <= FFFFh [
				putchar as-byte cp >> 12 or E0h
				putchar as-byte cp >> 6 and 3Fh or 80h
				putchar as-byte cp and 3Fh or 80h
			]
			cp <= 001FFFFFh [
				putchar as-byte cp >> 18 or F0h
				putchar as-byte cp >> 12 and 3Fh or 80h
				putchar as-byte cp >>  6 and 3Fh or 80h
				putchar as-byte cp and 3Fh or 80h
			]
			true [
				print-line "Error in print-UCS4: codepoint > 1FFFFFh"
			]
		]
		size: size - 4
		str: str + 1
	]
]

;-------------------------------------------
;-- Print a UCS-4 string to console
;-------------------------------------------
print-line-UCS4: func [
	str    [int-ptr!]									;-- UCS-4 string
	size   [integer!]
	/local
		cp [integer!]									;-- codepoint
][
	assert str <> null

	print-UCS4 str size									;@@ throw an error on failure
	putchar as-byte 10									;-- newline
]

;-------------------------------------------
;-- Print a UCS-2 string to console
;-------------------------------------------
print-UCS2: func [
	str 	[byte-ptr!]									;-- UCS-2 string
	size	[integer!]
	/local
		cp [integer!]
][
	assert str <> null

	while [not zero? size][
		cp: as-integer str/2
		cp: cp << 8 + str/1
		case [
			cp <= 7Fh [
				putchar as-byte cp
			]
			cp <= 07FFh [
				putchar as-byte cp >> 6 or C0h
				putchar as-byte cp and 3Fh or 80h
			]
			true [
				putchar as-byte cp >> 12 or E0h
				putchar as-byte cp >> 6 and 3Fh or 80h
				putchar as-byte cp and 3Fh or 80h
			]
		]
		size: size - 2
		str: str + 2
	]
]

;-------------------------------------------
;-- Print a UCS-2 string with newline to console
;-------------------------------------------
print-line-UCS2: func [
	str 	[byte-ptr!]									;-- UCS-2 string
	size	[integer!]
][
	assert str <> null
	print-UCS2 str size
	putchar as-byte 10									;-- newline
]

;-------------------------------------------
;-- Print a Latin-1 string to console
;-------------------------------------------
print-Latin1: func [
	str 	[c-string!]									;-- Latin-1 string
	size	[integer!]
	/local
		cp [integer!]
][
	assert str <> null

	while [not zero? size][
		cp: as-integer str/1
		either cp <= 7Fh [
			putchar as-byte cp
		][
			putchar as-byte cp >> 6 or C0h
			putchar as-byte cp and 3Fh or 80h
		]
		size: size - 1
		str: str + 1
	]
]

;-------------------------------------------
;-- Print a Latin-1 string with newline to console
;-------------------------------------------
print-line-Latin1: func [
	str  [c-string!]									;-- Latin-1 string
	size [integer!]
][
	assert str <> null
	print-Latin1 str size
	putchar as-byte 10									;-- newline
]

;-------------------------------------------
;-- Red/System Unicode replacement printing functions
;-------------------------------------------

prin*: func [
	s		[c-string!]
	return: [c-string!]
	/local
		p  [c-string!]
		cp [integer!]
][
	p: s
	while [cp: as-integer p/1 cp <> 0][
		either cp <= 7Fh [
			putchar as-byte cp
		][
			putchar as-byte cp >> 6 or C0h
			putchar as-byte cp and 3Fh or 80h
		]
		p: p + 1
	]
	s
]

prin-int*: func [i [integer!] return: [integer!]][
	printf ["%i" i]									;-- UTF-8 literal string
	i
]

prin-hex*: func [i [integer!] return: [integer!]][
	printf ["%08X" i]									;-- UTF-8 literal string
	i
]

prin-float*: func [f [float!] return: [float!]][
	printf ["%.16g" f]									;-- UTF-8 literal string
	f
]

prin-float32*: func [f [float32!] return: [float32!]][
	printf ["%.7g" as-float f]							;-- UTF-8 literal string
	f
]

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

#define __LC_CTYPE 0
#define __LC_ALL   6

#import [
	LIBC-file cdecl [
		wprintf: "wprintf" [
			[variadic]
			return: 	[integer!]
		]
		setlocale: "setlocale" [
			category	[integer!]
			locale		[c-string!]
			return:		[c-string!]
		]
	]
]

;-------------------------------------------
;-- Print a UCS-4 string to console
;-------------------------------------------
print-UCS4: func [
	str 	[int-ptr!]									;-- zero-terminated UCS-4 string
	size	[integer!]
	/local
		cp [integer!]
][
	assert str <> null

	while [not zero? zero][
		cp: str/value
		case [
			cp <= 7Fh [
				putchar as-byte cp
			]
			cp <= 07FFh [
				putchar as-byte cp >> 6 or C0h
				putchar as-byte cp and 3Fh or 80h
			]
			cp <= FFFFh [
				putchar as-byte cp >> 12 or E0h
				putchar as-byte cp >> 6 and 3Fh or 80h
				putchar as-byte cp and 3Fh or 80h
			]
			cp <= 001FFFFFh [
				putchar as-byte cp >> 18 or F0h
				putchar as-byte cp >> 12 and 3Fh or 80h
				putchar as-byte cp >>  6 and 3Fh or 80h
				putchar as-byte cp and 3Fh or 80h
			]
			true [
				print-line "Error in print-UCS4: codepoint > 1FFFFFh"
			]
		]
		size: size - 4
		str: str + 1
	]
]

;-------------------------------------------
;-- Print a UCS-4 string to console
;-------------------------------------------
print-line-UCS4: func [
	str    [int-ptr!]									;-- UCS-4 string
	size   [integer!]
	/local
		cp [integer!]									;-- codepoint
][
	assert str <> null

	print-UCS4 str size									;@@ throw an error on failure
	putchar as-byte 10									;-- newline
]

;-------------------------------------------
;-- Print a UCS-2 string to console
;-------------------------------------------
print-UCS2: func [
	str 	[byte-ptr!]									;-- UCS-2 string
	size	[integer!]
	/local
		cp [integer!]
][
	assert str <> null

	while [not zero? size][
		cp: as-integer str/2
		cp: cp << 8 + str/1
		case [
			cp <= 7Fh [
				putchar as-byte cp
			]
			cp <= 07FFh [
				putchar as-byte cp >> 6 or C0h
				putchar as-byte cp and 3Fh or 80h
			]
			true [
				putchar as-byte cp >> 12 or E0h
				putchar as-byte cp >> 6 and 3Fh or 80h
				putchar as-byte cp and 3Fh or 80h
			]
		]
		size: size - 2
		str: str + 2
	]
]

;-------------------------------------------
;-- Print a UCS-2 string with newline to console
;-------------------------------------------
print-line-UCS2: func [
	str 	[byte-ptr!]									;-- UCS-2 string
	size	[integer!]
][
	assert str <> null
	print-UCS2 str size
	putchar as-byte 10									;-- newline
]

;-------------------------------------------
;-- Print a Latin-1 string to console
;-------------------------------------------
print-Latin1: func [
	str 	[c-string!]									;-- Latin-1 string
	size	[integer!]
	/local
		p  [c-string!]
		cp [integer!]
][
	assert str <> null

	p: s
	while [not zero? size][
		cp: as-integer p/1
		either cp <= 7Fh [
			putchar as-byte cp
		][
			putchar as-byte cp >> 6 or C0h
			putchar as-byte cp and 3Fh or 80h
		]
		size: size - 1
		p: p + 1
	]
	s
]

;-------------------------------------------
;-- Print a Latin-1 string with newline to console
;-------------------------------------------
print-line-Latin1: func [
	str  [c-string!]									;-- Latin-1 string
	size [integer!]
][
	assert str <> null
	print-Latin1 str size
	putchar as-byte 10									;-- newline
]

;-------------------------------------------
;-- Red/System Unicode replacement printing functions
;-------------------------------------------

prin*: func [
	s		[c-string!]
	return: [c-string!]
	/local
		p  [c-string!]
		cp [integer!]
][
	p: s
	while [cp: as-integer p/1 cp <> 0][
		either cp <= 7Fh [
			putchar as-byte cp
		][
			putchar as-byte cp >> 6 or C0h
			putchar as-byte cp and 3Fh or 80h
		]
		p: p + 1
	]
	s
]

prin-int*: func [i [integer!] return: [integer!]][
	printf ["%i" i]									;-- UTF-8 literal string
	i
]

prin-hex*: func [i [integer!] return: [integer!]][
	printf ["%08X" i]									;-- UTF-8 literal string
	i
]

prin-float*: func [f [float!] return: [float!]][
	printf ["%.16g" f]									;-- UTF-8 literal string
	f
]

prin-float32*: func [f [float32!] return: [float32!]][
	printf ["%.7g" as-float f]							;-- UTF-8 literal string
	f
]