Fix funny comment.

Fix funny comment.

Approved by:	adrian (co-mentor) (implicit)

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

marker task-menusets.4th

variable menuset_use_name

create menuset_affixbuf	255 allot
create menuset_x        1   allot
create menuset_y        1   allot

: menuset-loadvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	s" set cmdbuf='set ${type}_${var}=\$'" evaluate
	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
	menuset_use_name @ true = if
		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}"
		( u1 -- u1 c-addr2 u2 )
	else
		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}"
		( u1 -- u1 c-addr2 u2 )
	then
	evaluate ( u1 c-addr2 u2 -- u1 )
	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
	rot 2 pick 2 pick over + -rot + tuck -
		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
		\ Generate a string representing rvalue inheritance var
	getenv dup -1 = if
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
		\ NOT set -- clean up the stack
		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
		2drop ( c-addr2 u2 -- )
	else
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
		evaluate ( c-addr2 u2 -- )
	then

	s" cmdbuf" unsetenv
;

: menuset-unloadvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	menuset_use_name @ true = if
		s" set buf=${affix}${type}_${var}"
	else
		s" set buf=${type}set${affix}_${var}"
	then
	evaluate
	s" buf" getenv unsetenv
	s" buf" unsetenv
;

: menuset-loadmenuvar ( -- )
	s" set type=menu" evaluate
	menuset-loadvar
;

: menuset-unloadmenuvar ( -- )
	s" set type=menu" evaluate
	menuset-unloadvar
;

: menuset-loadxvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	s" set cmdbuf='set ${type}_${var}[${x}]=\$'" evaluate
	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
	menuset_use_name @ true = if
		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}]"
		( u1 -- u1 c-addr2 u2 )
	else
		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}]"
		( u1 -- u1 c-addr2 u2 )
	then
	evaluate ( u1 c-addr2 u2 -- u1 )
	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
	rot 2 pick 2 pick over + -rot + tuck -
		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
		\ Generate a string representing rvalue inheritance var
	getenv dup -1 = if
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
		\ NOT set -- clean up the stack
		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
		2drop ( c-addr2 u2 -- )
	else
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
		evaluate ( c-addr2 u2 -- )
	then

	s" cmdbuf" unsetenv
;

: menuset-unloadxvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	menuset_use_name @ true = if
		s" set buf=${affix}${type}_${var}[${x}]"
	else
		s" set buf=${type}set${affix}_${var}[${x}]"
	then
	evaluate
	s" buf" getenv unsetenv
	s" buf" unsetenv
;

: menuset-loadansixvar ( -- )
	s" set type=ansi" evaluate
	menuset-loadxvar
;

: menuset-unloadansixvar ( -- )
	s" set type=ansi" evaluate
	menuset-unloadxvar
;

: menuset-loadmenuxvar ( -- )
	s" set type=menu" evaluate
	menuset-loadxvar
;

: menuset-unloadmenuxvar ( -- )
	s" set type=menu" evaluate
	menuset-unloadxvar
;

: menuset-loadtoggledxvar ( -- )
	s" set type=toggled" evaluate
	menuset-loadxvar
;

: menuset-unloadtoggledxvar ( -- )
	s" set type=toggled" evaluate
	menuset-unloadxvar
;

: menuset-loadxyvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $y is "0" through "9"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	s" set cmdbuf='set ${type}_${var}[${x}][${y}]=\$'" evaluate
	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
	menuset_use_name @ true = if
		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}][${y}]"
		( u1 -- u1 c-addr2 u2 )
	else
		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}][${y}]"
		( u1 -- u1 c-addr2 u2 )
	then
	evaluate ( u1 c-addr2 u2 -- u1 )
	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
	rot 2 pick 2 pick over + -rot + tuck -
		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
		\ Generate a string representing rvalue inheritance var
	getenv dup -1 = if
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
		\ NOT set -- clean up the stack
		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
		2drop ( c-addr2 u2 -- )
	else
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
		evaluate ( c-addr2 u2 -- )
	then

	s" cmdbuf" unsetenv
;

: menuset-unloadxyvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $y is "0" through "9"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	menuset_use_name @ true = if
		s" set buf=${affix}${type}_${var}[${x}][${y}]"
	else
		s" set buf=${type}set${affix}_${var}[${x}][${y}]"
	then
	evaluate
	s" buf" getenv unsetenv
	s" buf" unsetenv
;

: menuset-loadansixyvar ( -- )
	s" set type=ansi" evaluate
	menuset-loadxyvar
;

: menuset-unloadansixyvar ( -- )
	s" set type=ansi" evaluate
	menuset-unloadxyvar
;

: menuset-loadmenuxyvar ( -- )
	s" set type=menu" evaluate
	menuset-loadxyvar
;

: menuset-unloadmenuxyvar ( -- )
	s" set type=menu" evaluate
	menuset-unloadxyvar
;

: menuset-setnum-namevar ( N -- C-Addr/U )

	s" menuset_nameNNNNN" ( n -- n c-addr1 u1 )	\ variable basename
	drop 12 ( n c-addr1 u1 -- n c-addr1 12 )	\ remove "NNNNN"
	rot     ( n c-addr1 12 -- c-addr1 12 n )	\ move number on top

	\ convert to string
	s>d <# #s #> ( c-addr1 12 n -- c-addr1 12 c-addr2 u2 )

	\ Combine strings
	begin ( using u2 in c-addr2/u2 pair as countdown to zero )
		over	( c-addr1 u1 c-addr2 u2 -- continued below )
			( c-addr1 u1 c-addr2 u2 c-addr2 ) \ copy src-addr
		c@	( c-addr1 u1 c-addr2 u2 c-addr2 -- continued below )
			( c-addr1 u1 c-addr2 u2 c ) \ get next src-addr byte
		4 pick 4 pick
			( c-addr1 u1 c-addr2 u2 c -- continued below )
			( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
			\ get destination c-addr1/u1 pair
		+	( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- cont. below )
			( c-addr1 u1 c-addr2 u2 c c-addr3 )
			\ combine dest-c-addr to get dest-addr for byte
		c!	( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
			( c-addr1 u1 c-addr2 u2 )
			\ store the current src-addr byte into dest-addr

		2swap 1+ 2swap	\ increment u1 in destination c-addr1/u1 pair
		swap 1+ swap	\ increment c-addr2 in source c-addr2/u2 pair
		1-		\ decrement u2 in the source c-addr2/u2 pair

		dup 0= \ time to break?
	until

	2drop	( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 )
		\ drop temporary number-format conversion c-addr2/u2
;

: menuset-checksetnum ( N -- )

	\
	\ adjust input to be both positive and no-higher than 65535
	\
	abs dup 65535 > if drop 65535 then ( n -- n )

	\
	\ The next few blocks will determine if we should use the default
	\ methodology (referencing the original numeric stack-input), or if-
	\ instead $menuset_name{N} has been defined wherein we would then
	\ use the value thereof as the prefix to every menu variable.
	\

	false menuset_use_name ! \ assume name is not set

	menuset-setnum-namevar
	\
	\ We now have a string that is the assembled variable name to check
	\ for... $menuset_name{N}. Let's check for it.
	\
	2dup ( c-addr1 u1 -- c-addr1 u1 c-addr1 u1 ) \ save a copy
	getenv dup -1 <> if ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 c-addr2 u2 )
		\ The variable is set. Let's clean up the stack leaving only
		\ its value for later use.

		true menuset_use_name !
		2swap 2drop	( c-addr1 u1 c-addr2 u2 -- c-addr2 u2 )
				\ drop assembled variable name, leave the value
	else ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 -1 ) \ no such variable
		\ The variable is not set. Let's clean up the stack leaving the
		\ string [portion] representing the original numeric input.

		drop ( c-addr1 u1 -1 -- c-addr1 u1 ) \ drop -1 result
		12 - swap 12 + swap ( c-addr1 u1 -- c-addr2 u2 )
			\ truncate to original numeric stack-input
	then

	\
	\ Now, depending on whether $menuset_name{N} has been set, we have
	\ either the value thereof to be used as a prefix to all menu_*
	\ variables or we have a string representing the numeric stack-input
	\ to be used as a "set{N}" infix to the same menu_* variables.
	\
	\ For example, if the stack-input is 1 and menuset_name1 is NOT set
	\ the following variables will be referenced:
	\ 	ansiset1_caption[x]		-> ansi_caption[x]
	\ 	ansiset1_caption[x][y]		-> ansi_caption[x][y]
	\ 	menuset1_acpi			-> menu_acpi
	\ 	menuset1_caption[x]		-> menu_caption[x]
	\ 	menuset1_caption[x][y]		-> menu_caption[x][y]
	\ 	menuset1_command[x]		-> menu_command[x]
	\ 	menuset1_init			-> ``evaluated''
	\ 	menuset1_init[x]		-> menu_init[x]
	\ 	menuset1_keycode[x]		-> menu_keycode[x]
	\ 	menuset1_options		-> menu_options
	\ 	menuset1_optionstext		-> menu_optionstext
	\ 	menuset1_reboot			-> menu_reboot
	\ 	toggledset1_ansi[x]		-> toggled_ansi[x]
	\ 	toggledset1_text[x]		-> toggled_text[x]
	\ otherwise, the following variables are referenced (where {name}
	\ represents the value of $menuset_name1 (given 1 as stack-input):
	\ 	{name}ansi_caption[x]		-> ansi_caption[x]
	\ 	{name}ansi_caption[x][y]	-> ansi_caption[x][y]
	\ 	{name}menu_acpi			-> menu_acpi
	\ 	{name}menu_caption[x]		-> menu_caption[x]
	\ 	{name}menu_caption[x][y]	-> menu_caption[x][y]
	\ 	{name}menu_command[x]		-> menu_command[x]
	\ 	{name}menu_init			-> ``evaluated''
	\ 	{name}menu_init[x]		-> menu_init[x]
	\ 	{name}menu_keycode[x]		-> menu_keycode[x]
	\ 	{name}menu_options		-> menu_options
	\ 	{name}menu_optionstext		-> menu_optionstext
	\ 	{name}menu_reboot		-> menu_reboot
	\ 	{name}toggled_ansi[x]		-> toggled_ansi[x]
	\ 	{name}toggled_text[x]		-> toggled_text[x]
	\
	\ Note that menuset{N}_init and {name}menu_init are the initializers
	\ for the entire menu (for wholly dynamic menus) opposed to the per-
	\ menuitem initializers (with [x] afterward). The whole-menu init
	\ routine is evaluated and not passed down to $menu_init (which
	\ would result in double evaluation). By doing this, the initializer
	\ can initialize the menuset before we transfer it to active-duty.
	\

	\
	\ Copy our affixation (prefix or infix depending on menuset_use_name)
	\ to our buffer so that we can safely use the s-quote (s") buf again.
	\
	menuset_affixbuf 0 2swap ( c-addr2 u2 -- c-addr1 0 c-addr2 u2 )
	begin ( using u2 in c-addr2/u2 pair as countdown to zero )
		over ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c-addr2 )
		c@   ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c )
		4 pick 4 pick
		     ( c-addr1 u1 c-addr2 u2 c -- continued below )
		     ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
		+    ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- continued below )
		     ( c-addr1 u1 c-addr2 u2 c c-addr3 )
		c!   ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
		     ( c-addr1 u1 c-addr2 u2 )
		2swap 1+ 2swap	\ increment affixbuf byte position/count
		swap 1+ swap	\ increment strbuf pointer (source c-addr2)
		1-		\ decrement strbuf byte count (source u2)
		dup 0=          \ time to break?
	until
	2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 ) \ drop strbuf c-addr2/u2

	\
	\ Create a variable for referencing our affix data (prefix or infix
	\ depending on menuset_use_name as described above). This variable will
	\ be temporary and only used to simplify cmdbuf assembly.
	\
	s" affix" setenv ( c-addr1 u1 -- )
;

: menuset-cleanup ( -- )
	s" type"  unsetenv
	s" var"   unsetenv
	s" x"     unsetenv
	s" y"     unsetenv
	s" affix" unsetenv
;

: menuset-loadsetnum ( N -- )

	menuset-checksetnum ( n -- )

	\
	\ From here out, we use temporary environment variables to make
	\ dealing with variable-length strings easier.
	\
	\ menuset_use_name is true or false
	\ $affix should be used appropriately w/respect to menuset_use_name
	\

	\ ... menu_init ...
	s" set var=init" evaluate
	menuset-loadmenuvar

	\ If menu_init was set by the above, evaluate it here-and-now
	\ so that the remaining variables are influenced by its actions
	s" menu_init" 2dup getenv dup -1 <> if
		2swap unsetenv \ don't want later menu-create to re-call this
		evaluate
	else
		drop 2drop ( n c-addr u -1 -- n )
	then

	[char] 1 ( -- x ) \ Loop range ASCII '1' (49) to '8' (56)
	begin
		dup menuset_x tuck c! 1 s" x" setenv \ set loop iterator and $x

		s" set var=caption" evaluate

		\ ... menu_caption[x] ...
		menuset-loadmenuxvar

		\ ... ansi_caption[x] ...
		menuset-loadansixvar

		[char] 0 ( x -- x y ) \ Inner Loop ASCII '1' (48) to '9' (57)
		begin
			dup menuset_y tuck c! 1 s" y" setenv
				\ set inner loop iterator and $y

			\ ... menu_caption[x][y] ...
			menuset-loadmenuxyvar

			\ ... ansi_caption[x][y] ...
			menuset-loadansixyvar

			1+ dup 57 > ( x y -- y' 0|-1 ) \ increment and test
		until
		drop ( x y -- x )

		\ ... menu_command[x] ...
		s" set var=command" evaluate
		menuset-loadmenuxvar

		\ ... menu_init[x] ...
		s" set var=init" evaluate
		menuset-loadmenuxvar

		\ ... menu_keycode[x] ...
		s" set var=keycode" evaluate
		menuset-loadmenuxvar

		\ ... toggled_text[x] ...
		s" set var=text" evaluate
		menuset-loadtoggledxvar

		\ ... toggled_ansi[x] ...
		s" set var=ansi" evaluate
		menuset-loadtoggledxvar

		1+ dup 56 > ( x -- x' 0|-1 ) \ increment iterator
		                             \ continue if less than 57
	until
	drop ( x -- ) \ loop iterator

	\ ... menu_reboot ...
	s" set var=reboot" evaluate
	menuset-loadmenuvar

	\ ... menu_acpi ...
	s" set var=acpi" evaluate
	menuset-loadmenuvar

	\ ... menu_options ...
	s" set var=options" evaluate
	menuset-loadmenuvar

	\ ... menu_optionstext ...
	s" set var=optionstext" evaluate
	menuset-loadmenuvar

	menuset-cleanup
;

: menuset-loadinitial ( -- )
	s" menuset_initial" getenv dup -1 <> if
		?number 0<> if
			menuset-loadsetnum
		then
	else
		drop \ cruft
	then
;

: menusets-unset ( -- )

	s" menuset_initial" unsetenv

	1 begin
		dup menuset-checksetnum ( n n -- n )

		dup menuset-setnum-namevar ( n n -- n )
		unsetenv

		\ If the current menuset does not populate the first menuitem,
		\ we stop completely.

		menuset_use_name @ true = if
			s" set buf=${affix}menu_caption[1]"
		else
			s" set buf=menuset${affix}_caption[1]"
		then
		evaluate s" buf" getenv getenv -1 = if
			drop ( n -- )
			s" buf" unsetenv
			menuset-cleanup
			exit
		else
			drop ( n c-addr2 -- n ) \ unused
		then

		[char] 1 ( n -- n x ) \ Loop range ASCII '1' (49) to '8' (56)
		begin
			dup menuset_x tuck c! 1 s" x" setenv \ set $x to x

			s" set var=caption" evaluate
			menuset-unloadmenuxvar
			menuset-unloadmenuxvar
			menuset-unloadansixvar
			[char] 0 ( n x -- n x y ) \ Inner loop '0' to '9'
			begin
				dup menuset_y tuck c! 1 s" y" setenv
					\ sets $y to y
				menuset-unloadmenuxyvar
				menuset-unloadansixyvar
				1+ dup 57 > ( n x y -- n x y' 0|-1 )
			until
			drop ( n x y -- n x )
			s" set var=command" evaluate menuset-unloadmenuxvar
			s" set var=init"    evaluate menuset-unloadmenuxvar
			s" set var=keycode" evaluate menuset-unloadmenuxvar
			s" set var=text"    evaluate menuset-unloadtoggledxvar
			s" set var=ansi"    evaluate menuset-unloadtoggledxvar

			1+ dup 56 > ( x -- x' 0|-1 ) \ increment and test
		until
		drop ( n x -- n ) \ loop iterator

		s" set var=acpi"        evaluate menuset-unloadmenuvar
		s" set var=init"        evaluate menuset-unloadmenuvar
		s" set var=options"     evaluate menuset-unloadmenuvar
		s" set var=optionstext" evaluate menuset-unloadmenuvar
		s" set var=reboot"      evaluate menuset-unloadmenuvar

		1+ dup 65535 > ( n -- n' 0|-1 ) \ increment and test
	until
	drop ( n' -- ) \ loop iterator

	s" buf" unsetenv
	menuset-cleanup
;

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

marker task-menusets.4th

variable menuset_use_name

create menuset_affixbuf	255 allot
create menuset_x        1   allot
create menuset_y        1   allot

: menuset-loadvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	s" set cmdbuf='set ${type}_${var}=\$'" evaluate
	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
	menuset_use_name @ true = if
		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}"
		( u1 -- u1 c-addr2 u2 )
	else
		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}"
		( u1 -- u1 c-addr2 u2 )
	then
	evaluate ( u1 c-addr2 u2 -- u1 )
	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
	rot 2 pick 2 pick over + -rot + tuck -
		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
		\ Generate a string representing rvalue inheritance var
	getenv dup -1 = if
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
		\ NOT set -- clean up the stack
		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
		2drop ( c-addr2 u2 -- )
	else
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
		evaluate ( c-addr2 u2 -- )
	then

	s" cmdbuf" unsetenv
;

: menuset-unloadvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	menuset_use_name @ true = if
		s" set buf=${affix}${type}_${var}"
	else
		s" set buf=${type}set${affix}_${var}"
	then
	evaluate
	s" buf" getenv unsetenv
	s" buf" unsetenv
;

: menuset-loadmenuvar ( -- )
	s" set type=menu" evaluate
	menuset-loadvar
;

: menuset-unloadmenuvar ( -- )
	s" set type=menu" evaluate
	menuset-unloadvar
;

: menuset-loadxvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	s" set cmdbuf='set ${type}_${var}[${x}]=\$'" evaluate
	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
	menuset_use_name @ true = if
		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}]"
		( u1 -- u1 c-addr2 u2 )
	else
		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}]"
		( u1 -- u1 c-addr2 u2 )
	then
	evaluate ( u1 c-addr2 u2 -- u1 )
	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
	rot 2 pick 2 pick over + -rot + tuck -
		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
		\ Generate a string representing rvalue inheritance var
	getenv dup -1 = if
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
		\ NOT set -- clean up the stack
		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
		2drop ( c-addr2 u2 -- )
	else
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
		evaluate ( c-addr2 u2 -- )
	then

	s" cmdbuf" unsetenv
;

: menuset-unloadxvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	menuset_use_name @ true = if
		s" set buf=${affix}${type}_${var}[${x}]"
	else
		s" set buf=${type}set${affix}_${var}[${x}]"
	then
	evaluate
	s" buf" getenv unsetenv
	s" buf" unsetenv
;

: menuset-loadansixvar ( -- )
	s" set type=ansi" evaluate
	menuset-loadxvar
;

: menuset-unloadansixvar ( -- )
	s" set type=ansi" evaluate
	menuset-unloadxvar
;

: menuset-loadmenuxvar ( -- )
	s" set type=menu" evaluate
	menuset-loadxvar
;

: menuset-unloadmenuxvar ( -- )
	s" set type=menu" evaluate
	menuset-unloadxvar
;

: menuset-loadtoggledxvar ( -- )
	s" set type=toggled" evaluate
	menuset-loadxvar
;

: menuset-unloadtoggledxvar ( -- )
	s" set type=toggled" evaluate
	menuset-unloadxvar
;

: menuset-loadxyvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $y is "0" through "9"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	s" set cmdbuf='set ${type}_${var}[${x}][${y}]=\$'" evaluate
	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
	menuset_use_name @ true = if
		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}][${y}]"
		( u1 -- u1 c-addr2 u2 )
	else
		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}][${y}]"
		( u1 -- u1 c-addr2 u2 )
	then
	evaluate ( u1 c-addr2 u2 -- u1 )
	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
	rot 2 pick 2 pick over + -rot + tuck -
		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
		\ Generate a string representing rvalue inheritance var
	getenv dup -1 = if
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
		\ NOT set -- clean up the stack
		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
		2drop ( c-addr2 u2 -- )
	else
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
		evaluate ( c-addr2 u2 -- )
	then

	s" cmdbuf" unsetenv
;

: menuset-unloadxyvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $y is "0" through "9"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	menuset_use_name @ true = if
		s" set buf=${affix}${type}_${var}[${x}][${y}]"
	else
		s" set buf=${type}set${affix}_${var}[${x}][${y}]"
	then
	evaluate
	s" buf" getenv unsetenv
	s" buf" unsetenv
;

: menuset-loadansixyvar ( -- )
	s" set type=ansi" evaluate
	menuset-loadxyvar
;

: menuset-unloadansixyvar ( -- )
	s" set type=ansi" evaluate
	menuset-unloadxyvar
;

: menuset-loadmenuxyvar ( -- )
	s" set type=menu" evaluate
	menuset-loadxyvar
;

: menuset-unloadmenuxyvar ( -- )
	s" set type=menu" evaluate
	menuset-unloadxyvar
;

: menuset-setnum-namevar ( N -- C-Addr/U )

	s" menuset_nameNNNNN" ( n -- n c-addr1 u1 )	\ variable basename
	drop 12 ( n c-addr1 u1 -- n c-addr1 12 )	\ remove "NNNNN"
	rot     ( n c-addr1 12 -- c-addr1 12 n )	\ move number on top

	\ convert to string
	s>d <# #s #> ( c-addr1 12 n -- c-addr1 12 c-addr2 u2 )

	\ Combine strings
	begin ( using u2 in c-addr2/u2 pair as countdown to zero )
		over	( c-addr1 u1 c-addr2 u2 -- continued below )
			( c-addr1 u1 c-addr2 u2 c-addr2 ) \ copy src-addr
		c@	( c-addr1 u1 c-addr2 u2 c-addr2 -- continued below )
			( c-addr1 u1 c-addr2 u2 c ) \ get next src-addr byte
		4 pick 4 pick
			( c-addr1 u1 c-addr2 u2 c -- continued below )
			( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
			\ get destination c-addr1/u1 pair
		+	( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- cont. below )
			( c-addr1 u1 c-addr2 u2 c c-addr3 )
			\ combine dest-c-addr to get dest-addr for byte
		c!	( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
			( c-addr1 u1 c-addr2 u2 )
			\ store the current src-addr byte into dest-addr

		2swap 1+ 2swap	\ increment u1 in destination c-addr1/u1 pair
		swap 1+ swap	\ increment c-addr2 in source c-addr2/u2 pair
		1-		\ decrement u2 in the source c-addr2/u2 pair

		dup 0= \ time to break?
	until

	2drop	( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 )
		\ drop temporary number-format conversion c-addr2/u2
;

: menuset-checksetnum ( N -- )

	\
	\ adjust input to be both positive and no-higher than 65535
	\
	abs dup 65535 > if drop 65535 then ( n -- n )

	\
	\ The next few blocks will determine if we should use the default
	\ methodology (referencing the original numeric stack-input), or if-
	\ instead $menuset_name{N} has been defined wherein we would then
	\ use the value thereof as the prefix to every menu variable.
	\

	false menuset_use_name ! \ assume name is not set

	menuset-setnum-namevar
	\
	\ We now have a string that is the assembled variable name to check
	\ for... $menuset_name{N}. Let's check for it.
	\
	2dup ( c-addr1 u1 -- c-addr1 u1 c-addr1 u1 ) \ save a copy
	getenv dup -1 <> if ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 c-addr2 u2 )
		\ The variable is set. Let's clean up the stack leaving only
		\ its value for later use.

		true menuset_use_name !
		2swap 2drop	( c-addr1 u1 c-addr2 u2 -- c-addr2 u2 )
				\ drop assembled variable name, leave the value
	else ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 -1 ) \ no such variable
		\ The variable is not set. Let's clean up the stack leaving the
		\ string [portion] representing the original numeric input.

		drop ( c-addr1 u1 -1 -- c-addr1 u1 ) \ drop -1 result
		12 - swap 12 + swap ( c-addr1 u1 -- c-addr2 u2 )
			\ truncate to original numeric stack-input
	then

	\
	\ Now, depending on whether $menuset_name{N} has been set, we have
	\ either the value thereof to be used as a prefix to all menu_*
	\ variables or we have a string representing the numeric stack-input
	\ to be used as a "set{N}" infix to the same menu_* variables.
	\
	\ For example, if the stack-input is 1 and menuset_name1 is NOT set
	\ the following variables will be referenced:
	\ 	ansiset1_caption[x]		-> ansi_caption[x]
	\ 	ansiset1_caption[x][y]		-> ansi_caption[x][y]
	\ 	menuset1_acpi			-> menu_acpi
	\ 	menuset1_caption[x]		-> menu_caption[x]
	\ 	menuset1_caption[x][y]		-> menu_caption[x][y]
	\ 	menuset1_command[x]		-> menu_command[x]
	\ 	menuset1_init			-> ``evaluated''
	\ 	menuset1_init[x]		-> menu_init[x]
	\ 	menuset1_keycode[x]		-> menu_keycode[x]
	\ 	menuset1_options		-> menu_options
	\ 	menuset1_optionstext		-> menu_optionstext
	\ 	menuset1_reboot			-> menu_reboot
	\ 	toggledset1_ansi[x]		-> toggled_ansi[x]
	\ 	toggledset1_text[x]		-> toggled_text[x]
	\ otherwise, the following variables are referenced (where {name}
	\ represents the value of $menuset_name1 (given 1 as stack-input):
	\ 	{name}ansi_caption[x]		-> ansi_caption[x]
	\ 	{name}ansi_caption[x][y]	-> ansi_caption[x][y]
	\ 	{name}menu_acpi			-> menu_acpi
	\ 	{name}menu_caption[x]		-> menu_caption[x]
	\ 	{name}menu_caption[x][y]	-> menu_caption[x][y]
	\ 	{name}menu_command[x]		-> menu_command[x]
	\ 	{name}menu_init			-> ``evaluated''
	\ 	{name}menu_init[x]		-> menu_init[x]
	\ 	{name}menu_keycode[x]		-> menu_keycode[x]
	\ 	{name}menu_options		-> menu_options
	\ 	{name}menu_optionstext		-> menu_optionstext
	\ 	{name}menu_reboot		-> menu_reboot
	\ 	{name}toggled_ansi[x]		-> toggled_ansi[x]
	\ 	{name}toggled_text[x]		-> toggled_text[x]
	\
	\ Note that menuset{N}_init and {name}menu_init are the initializers
	\ for the entire menu (for wholly dynamic menus) opposed to the per-
	\ menuitem initializers (with [x] afterward). The whole-menu init
	\ routine is evaluated and not passed down to $menu_init (which
	\ would result in double evaluation). By doing this, the initializer
	\ can initialize the menuset before we transfer it to active-duty.
	\

	\
	\ Copy our affixation (prefix or infix depending on menuset_use_name)
	\ to our buffer so that we can safely use the s-quote (s") buf again.
	\
	menuset_affixbuf 0 2swap ( c-addr2 u2 -- c-addr1 0 c-addr2 u2 )
	begin ( using u2 in c-addr2/u2 pair as countdown to zero )
		over ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c-addr2 )
		c@   ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c )
		4 pick 4 pick
		     ( c-addr1 u1 c-addr2 u2 c -- continued below )
		     ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
		+    ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- continued below )
		     ( c-addr1 u1 c-addr2 u2 c c-addr3 )
		c!   ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
		     ( c-addr1 u1 c-addr2 u2 )
		2swap 1+ 2swap	\ increment affixbuf byte position/count
		swap 1+ swap	\ increment strbuf pointer (source c-addr2)
		1-		\ decrement strbuf byte count (source u2)
		dup 0=          \ time to break?
	until
	2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 ) \ drop strbuf c-addr2/u2

	\
	\ Create a variable for referencing our affix data (prefix or infix
	\ depending on menuset_use_name as described above). This variable will
	\ be temporary and only used to simplify cmdbuf assembly.
	\
	s" affix" setenv ( c-addr1 u1 -- )
;

: menuset-cleanup ( -- )
	s" type"  unsetenv
	s" var"   unsetenv
	s" x"     unsetenv
	s" y"     unsetenv
	s" affix" unsetenv
;

: menuset-loadsetnum ( N -- )

	menuset-checksetnum ( n -- )

	\
	\ From here out, we use temporary environment variables to make
	\ dealing with variable-length strings easier.
	\
	\ menuset_use_name is true or false
	\ $affix should be use appropriated w/respect to menuset_use_name
	\

	\ ... menu_init ...
	s" set var=init" evaluate
	menuset-loadmenuvar

	\ If menu_init was set by the above, evaluate it here-and-now
	\ so that the remaining variables are influenced by its actions
	s" menu_init" 2dup getenv dup -1 <> if
		2swap unsetenv \ don't want later menu-create to re-call this
		evaluate
	else
		drop 2drop ( n c-addr u -1 -- n )
	then

	[char] 1 ( -- x ) \ Loop range ASCII '1' (49) to '8' (56)
	begin
		dup menuset_x tuck c! 1 s" x" setenv \ set loop iterator and $x

		s" set var=caption" evaluate

		\ ... menu_caption[x] ...
		menuset-loadmenuxvar

		\ ... ansi_caption[x] ...
		menuset-loadansixvar

		[char] 0 ( x -- x y ) \ Inner Loop ASCII '1' (48) to '9' (57)
		begin
			dup menuset_y tuck c! 1 s" y" setenv
				\ set inner loop iterator and $y

			\ ... menu_caption[x][y] ...
			menuset-loadmenuxyvar

			\ ... ansi_caption[x][y] ...
			menuset-loadansixyvar

			1+ dup 57 > ( x y -- y' 0|-1 ) \ increment and test
		until
		drop ( x y -- x )

		\ ... menu_command[x] ...
		s" set var=command" evaluate
		menuset-loadmenuxvar

		\ ... menu_init[x] ...
		s" set var=init" evaluate
		menuset-loadmenuxvar

		\ ... menu_keycode[x] ...
		s" set var=keycode" evaluate
		menuset-loadmenuxvar

		\ ... toggled_text[x] ...
		s" set var=text" evaluate
		menuset-loadtoggledxvar

		\ ... toggled_ansi[x] ...
		s" set var=ansi" evaluate
		menuset-loadtoggledxvar

		1+ dup 56 > ( x -- x' 0|-1 ) \ increment iterator
		                             \ continue if less than 57
	until
	drop ( x -- ) \ loop iterator

	\ ... menu_reboot ...
	s" set var=reboot" evaluate
	menuset-loadmenuvar

	\ ... menu_acpi ...
	s" set var=acpi" evaluate
	menuset-loadmenuvar

	\ ... menu_options ...
	s" set var=options" evaluate
	menuset-loadmenuvar

	\ ... menu_optionstext ...
	s" set var=optionstext" evaluate
	menuset-loadmenuvar

	menuset-cleanup
;

: menuset-loadinitial ( -- )
	s" menuset_initial" getenv dup -1 <> if
		?number 0<> if
			menuset-loadsetnum
		then
	else
		drop \ cruft
	then
;

: menusets-unset ( -- )

	s" menuset_initial" unsetenv

	1 begin
		dup menuset-checksetnum ( n n -- n )

		dup menuset-setnum-namevar ( n n -- n )
		unsetenv

		\ If the current menuset does not populate the first menuitem,
		\ we stop completely.

		menuset_use_name @ true = if
			s" set buf=${affix}menu_caption[1]"
		else
			s" set buf=menuset${affix}_caption[1]"
		then
		evaluate s" buf" getenv getenv -1 = if
			drop ( n -- )
			s" buf" unsetenv
			menuset-cleanup
			exit
		else
			drop ( n c-addr2 -- n ) \ unused
		then

		[char] 1 ( n -- n x ) \ Loop range ASCII '1' (49) to '8' (56)
		begin
			dup menuset_x tuck c! 1 s" x" setenv \ set $x to x

			s" set var=caption" evaluate
			menuset-unloadmenuxvar
			menuset-unloadmenuxvar
			menuset-unloadansixvar
			[char] 0 ( n x -- n x y ) \ Inner loop '0' to '9'
			begin
				dup menuset_y tuck c! 1 s" y" setenv
					\ sets $y to y
				menuset-unloadmenuxyvar
				menuset-unloadansixyvar
				1+ dup 57 > ( n x y -- n x y' 0|-1 )
			until
			drop ( n x y -- n x )
			s" set var=command" evaluate menuset-unloadmenuxvar
			s" set var=init"    evaluate menuset-unloadmenuxvar
			s" set var=keycode" evaluate menuset-unloadmenuxvar
			s" set var=text"    evaluate menuset-unloadtoggledxvar
			s" set var=ansi"    evaluate menuset-unloadtoggledxvar

			1+ dup 56 > ( x -- x' 0|-1 ) \ increment and test
		until
		drop ( n x -- n ) \ loop iterator

		s" set var=acpi"        evaluate menuset-unloadmenuvar
		s" set var=init"        evaluate menuset-unloadmenuvar
		s" set var=options"     evaluate menuset-unloadmenuvar
		s" set var=optionstext" evaluate menuset-unloadmenuvar
		s" set var=reboot"      evaluate menuset-unloadmenuvar

		1+ dup 65535 > ( n -- n' 0|-1 ) \ increment and test
	until
	drop ( n' -- ) \ loop iterator

	s" buf" unsetenv
	menuset-cleanup
;


Unnecessary COMMA in compile

Unnecessary COMMA in compile

: (   41 parse 2drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note: default decimal numeric input mode. )

: \ ( <line> -- , comment out the rest of line)
   13 parse 2drop ; immediate

\ 1 echo !   \ Uncomment this line to echo Forth code while compiling.

\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ BYOK (portmanteau of BYE & OK) is a BYO kernel which happens to
\ implement a forth machine on i686 bare metal.
\
\ Substantial portions of this file were lifted straight from pForth
\ (http://pforth.googlecode.com/svn/trunk/fth/system.fth)
\ *********************************************************************
: CELL 1 ;
: BL 32 ;

: SPACE  ( -- )  bl emit ;
: CR  ( -- , cause output to appear at the beginning of the next line )  10 emit ;

: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1 + swap c@ ;

\ Miscellaneous support words
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

: CELL+  ( n -- n+cell )  cell + ;
: CELL-  ( n -- n-cell )  cell - ;
: CELL*  ( n -- n*cell )  cells ;

: CHAR+  ( n -- n+size_of_char ) 1+
\ : CHARS  ( n -- n*size_of_char, don't do anything ) ; immediate

\ useful stack manipulation words
: -ROT ( a b c -- c a b ) rot rot ;
: 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;

\ ------------------------------------------------------------------
: ID.  ( nfa -- ) count 31 and type ;

: BINARY    2 base ! ;
: OCTAL     8 base ! ;
: DECIMAL  10 base ! ;
: HEX      16 base ! ;

: PAD ( -- addr ) here 128 + ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;

: [  ( -- , enter interpreter mode )  0 state ! ; immediate
: ]  ( -- , enter compile mode )      1 state ! ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ cell 1- ] literal +
    [ cell 1- invert ] literal and ;
: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
\ : ALLOT  ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;
\ : C,  ( c -- ) here c! 1 chars dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

\ Compiler support -------------------------------------------------
: COMPILE,   ( xt -- , compile call to xt ) , ;
: [COMPILE]  ( <name> -- , compile now even if immediate ) ' compile, ; immediate
: (COMPILE)  ( xt -- , postpone compilation of token )
    [compile] literal ( compile a call to literal )
    ( store xt of word to be compiled )

    [ ' compile, ] literal \ compile call to compile,
    compile, ;

: COMPILE  ( <name> --, save xt and compile later ) ' (compile) ; immediate

: :NONAME  ( -- xt , begin compilation of headerless secondary ) align here ] ;

\ Error codes defined in ANSI Exception word set -------------------
: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

: ABORT ( i*x -- ) err_abort throw ;

\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION  ( f -- )  conditional_key - err_pairs ?error ;
: >MARK       ( -- addr )   here 0 , ;
: >RESOLVE    ( addr -- )   here over - swap ! ;
: <MARK       ( -- addr )   here ;
: <RESOLVE    ( addr -- )   here - , ;

: ?COMP  ( -- , error if not compiling ) state @ 0= err_executing ?error ;
: ?PAIRS ( n m -- ) - err_pairs ?error ;

\ Conditional primitives -------------------------------------------
: IF     ( -- f orig )  ?comp compile 0branch conditional_key >mark ; immediate
: THEN   ( f orig -- )  swap ?condition >resolve ; immediate
: BEGIN  ( -- f dest )  ?comp conditional_key <mark ; immediate
: AGAIN  ( f dest -- )  compile branch swap ?condition <resolve ; immediate
: UNTIL  ( f dest -- )  compile 0branch swap ?condition <resolve ; immediate
: AHEAD  ( -- f orig )  compile branch conditional_key >mark ; immediate

\ Conditionals built from primitives -------------------------------
: ELSE   ( f orig1 -- f orig2 )  [compile] ahead 2swap [compile] then ; immediate
: WHILE  ( f dest -- f origi f dest ) [compile] if 2swap ; immediate
: REPEAT  ( -- f orig f dest ) [compile] again [compile] then ; immediate

: [']  ( <name> -- xt , define compile time tick )
    ?comp ' [compile] literal
; immediate

: RECURSE  ( ? -- ? , call the word currently being defined )
    latest compile,
; immediate

: 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;

: /STRING  ( addr len n -- addr' len' ) over min rot over  + -rot - ;
: PLACE    ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ;

: ASCII ( <char> -- char, state smart )
    bl parse drop c@
    state @
    IF [compile] literal
    THEN
; immediate

: CHAR    ( <char> -- char , interpret mode ) bl parse drop c@ ;
: [CHAR]  ( <char> -- char , for compile mode )
    char [compile] literal
; immediate

: 'word  ( -- addr )  here ;

: (C")  ( -- $addr ) r> dup count + aligned >r ;
: (S")  ( -- c-addr cnt ) r> count 2dup + aligned >r ;
: (.")  ( -- , type following string ) r> count 2dup + aligned r> type ;
: ",    ( addr len -- , place string into dict ) tuck 'word place 1+ allot align ;
: ,"    ( -- ) [char] " parse ", ;

: .(  ( <string> --, type string delimited by parens )
    [char] ) parse type
; immediate

: ."  ( <string> -- , type string )
    state @
    IF compile (.")  ,"
    ELSE [char] " parse type
    THEN
; immediate

: (   41 parse 2drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note: default decimal numeric input mode. )

: \ ( <line> -- , comment out the rest of line)
   13 parse 2drop ; immediate

\ 1 echo !   \ Uncomment this line to echo Forth code while compiling.

\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ BYOK (portmanteau of BYE & OK) is a BYO kernel which happens to
\ implement a forth machine on i686 bare metal.
\
\ Substantial portions of this file were lifted straight from pForth
\ (http://pforth.googlecode.com/svn/trunk/fth/system.fth)
\ *********************************************************************
: CELL 1 ;
: BL 32 ;

: SPACE  ( -- )  bl emit ;
: CR  ( -- , cause output to appear at the beginning of the next line )  10 emit ;

: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1 + swap c@ ;

\ Miscellaneous support words
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

: CELL+  ( n -- n+cell )  cell + ;
: CELL-  ( n -- n-cell )  cell - ;
: CELL*  ( n -- n*cell )  cells ;

: CHAR+  ( n -- n+size_of_char ) 1+
\ : CHARS  ( n -- n*size_of_char, don't do anything ) ; immediate

\ useful stack manipulation words
: -ROT ( a b c -- c a b ) rot rot ;
: 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;

\ ------------------------------------------------------------------
: ID.  ( nfa -- ) count 31 and type ;

: BINARY    2 base ! ;
: OCTAL     8 base ! ;
: DECIMAL  10 base ! ;
: HEX      16 base ! ;

: PAD ( -- addr ) here 128 + ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;

: [  ( -- , enter interpreter mode )  0 state ! ; immediate
: ]  ( -- , enter compile mode )      1 state ! ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ cell 1- ] literal +
    [ cell 1- invert ] literal and ;
: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
\ : ALLOT  ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;
\ : C,  ( c -- ) here c! 1 chars dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

\ Compiler support -------------------------------------------------
: COMPILE,   ( xt -- , compile call to xt ) , ;
: [COMPILE]  ( <name> -- , compile now even if immediate ) ' compile, ; immediate
: (COMPILE)  ( xt -- , postpone compilation of token )
    [compile] literal ( compile a call to literal )
    , ( store xt of word to be compiled )

    [ ' compile, ] literal \ compile call to compile,
    compile, ;

: COMPILE  ( <name> --, save xt and compile later ) ' (compile) ; immediate

: :NONAME  ( -- xt , begin compilation of headerless secondary ) align here ] ;

\ Error codes defined in ANSI Exception word set -------------------
: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

: ABORT ( i*x -- ) err_abort throw ;

\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION  ( f -- )  conditional_key - err_pairs ?error ;
: >MARK       ( -- addr )   here 0 , ;
: >RESOLVE    ( addr -- )   here over - swap ! ;
: <MARK       ( -- addr )   here ;
: <RESOLVE    ( addr -- )   here - , ;

: ?COMP  ( -- , error if not compiling ) state @ 0= err_executing ?error ;
: ?PAIRS ( n m -- ) - err_pairs ?error ;

\ Conditional primitives -------------------------------------------
: IF     ( -- f orig )  ?comp compile 0branch conditional_key >mark ; immediate
: THEN   ( f orig -- )  swap ?condition >resolve ; immediate
: BEGIN  ( -- f dest )  ?comp conditional_key <mark ; immediate
: AGAIN  ( f dest -- )  compile branch swap ?condition <resolve ; immediate
: UNTIL  ( f dest -- )  compile 0branch swap ?condition <resolve ; immediate
: AHEAD  ( -- f orig )  compile branch conditional_key >mark ; immediate

\ Conditionals built from primitives -------------------------------
: ELSE   ( f orig1 -- f orig2 )  [compile] ahead 2swap [compile] then ; immediate
: WHILE  ( f dest -- f origi f dest ) [compile] if 2swap ; immediate
: REPEAT  ( -- f orig f dest ) [compile] again [compile] then ; immediate

: [']  ( <name> -- xt , define compile time tick )
    ?comp ' [compile] literal
; immediate

: RECURSE  ( ? -- ? , call the word currently being defined )
    latest compile,
; immediate

: 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;

: /STRING  ( addr len n -- addr' len' ) over min rot over  + -rot - ;
: PLACE    ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ;

: ASCII ( <char> -- char, state smart )
    bl parse drop c@
    state @
    IF [compile] literal
    THEN
; immediate

: CHAR    ( <char> -- char , interpret mode ) bl parse drop c@ ;
: [CHAR]  ( <char> -- char , for compile mode )
    char [compile] literal
; immediate

: 'word  ( -- addr )  here ;

: (C")  ( -- $addr ) r> dup count + aligned >r ;
: (S")  ( -- c-addr cnt ) r> count 2dup + aligned >r ;
: (.")  ( -- , type following string ) r> count 2dup + aligned r> type ;
: ",    ( addr len -- , place string into dict ) tuck 'word place 1+ allot align ;
: ,"    ( -- ) [char] " parse ", ;

: .(  ( <string> --, type string delimited by parens )
    [char] ) parse type
; immediate

: ."  ( <string> -- , type string )
    state @
    IF compile (.")  ,"
    ELSE [char] " parse type
    THEN
; immediate


Fixed bug in (.") which pushed erroneously on the data stack

: (   41 parse 2drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note: default decimal numeric input mode. )

: \ ( <line> -- , comment out the rest of line)
   13 parse 2drop ; immediate

\ 1 echo !   \ Uncomment this line to echo Forth code while compiling.

\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ BYOK (portmanteau of BYE & OK) is a BYO kernel which happens to
\ implement a forth machine on i686 bare metal.
\
\ Substantial portions of this file were lifted straight from pForth
\ (http://pforth.googlecode.com/svn/trunk/fth/system.fth)
\ *********************************************************************
: BL 32 ;

: SPACE  ( -- )  bl emit ;
: CR  ( -- , cause output to appear at the beginning of the next line )  10 emit ;

: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1+ swap c@ ;

\ Miscellaneous support words
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

: CELL+  ( n -- n+cell )  cell + ;
: CELL-  ( n -- n-cell )  cell - ;
: CELL*  ( n -- n*cell )  cells ;

: CHAR+  ( n -- n+size_of_char ) 1+
\ : CHARS  ( n -- n*size_of_char, don't do anything ) ; immediate

\ useful stack manipulation words
: -ROT ( a b c -- c a b ) rot rot ;
: 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;

\ ------------------------------------------------------------------
: ID.  ( nfa -- ) count 31 and type ;

: BINARY    2 base ! ;
: OCTAL     8 base ! ;
: DECIMAL  10 base ! ;
: HEX      16 base ! ;

: PAD ( -- addr ) here 128 + ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;

: [  ( -- , enter interpreter mode )  0 state ! ; immediate
: ]  ( -- , enter compile mode )      1 state ! ;

: ?  ( <name> -- )  @ . ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ ' (lit) , cell 1- , ]  +
    [ ' (lit) , cell 1- invert , ]  and ;

: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
: ALLOT  ( nbytes -- , allot space in dictionary ) dp +! align ;

: C,  ( c -- ) here c! 1 dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

\ Compiler support -------------------------------------------------
: COMPILE,   ( xt -- , compile call to xt ) , ;
: [COMPILE]  ( <name> -- , compile now even if immediate ) ' compile, ; immediate
: (COMPILE)  ( xt -- , postpone compilation of token )
    [compile] literal ( compile a call to literal )
    ( store xt of word to be compiled )

    [ ' compile, ] literal \ compile call to compile,
    compile, ;

: COMPILE  ( <name> --, save xt and compile later ) ' (compile) ; immediate

: :NONAME  ( -- xt , begin compilation of headerless secondary ) align here ] ;

\ Error codes defined in ANSI Exception word set -------------------
: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

: ABORT ( i*x -- ) err_abort throw ;

\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION  ( f -- )  conditional_key - err_pairs ?error ;
: >MARK       ( -- addr )   here 0 , ;
: >RESOLVE    ( addr -- )   here over - swap ! ;
: <MARK       ( -- addr )   here ;
: <RESOLVE    ( addr -- )   here - , ;

: ?COMP  ( -- , error if not compiling ) state @ 0= err_executing ?error ;
: ?PAIRS ( n m -- ) - err_pairs ?error ;

\ Conditional primitives -------------------------------------------
: IF     ( -- f orig )  ?comp compile 0branch conditional_key >mark ; immediate
: THEN   ( f orig -- )  swap ?condition >resolve ; immediate
: BEGIN  ( -- f dest )  ?comp conditional_key <mark ; immediate
: AGAIN  ( f dest -- )  compile branch swap ?condition <resolve ; immediate
: UNTIL  ( f dest -- )  compile 0branch swap ?condition <resolve ; immediate
: AHEAD  ( -- f orig )  compile branch conditional_key >mark ; immediate

\ Conditionals built from primitives -------------------------------
: ELSE   ( f orig1 -- f orig2 )  [compile] ahead 2swap [compile] then ; immediate
: WHILE  ( f dest -- f origi f dest ) [compile] if 2swap ; immediate
: REPEAT  ( -- f orig f dest ) [compile] again [compile] then ; immediate

: [']  ( <name> -- xt , define compile time tick )
    ?comp ' [compile] literal
; immediate

: RECURSE  ( ? -- ? , call the word currently being defined )
    latest compile,
; immediate

: 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;

: /STRING  ( addr len n -- addr' len' ) over min rot over  + -rot - ;
: PLACE    ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ;

: ASCII ( <char> -- char, state smart )
    bl parse drop c@
    state @ 1 =
    IF [compile] literal
    ELSE
    THEN
; immediate

: CHAR    ( <char> -- char , interpret mode ) bl parse drop c@ ;
: [CHAR]  ( <char> -- char , for compile mode )
    char [compile] literal
; immediate

: 'word  ( -- addr )  here ;

: (C")  ( -- $addr ) r> dup count + aligned >r ;
: (S")  ( -- c-addr cnt ) r> count 2dup + aligned >r ;
: (.")  ( -- , type following string ) r> count 2dup + aligned >r type ;
: ",    ( addr len -- , place string into dict ) tuck 'word place 1+ allot align ;
: ,"    ( -- ) 34 parse ", ;

: .(  ( <string> --, type string delimited by parens )
    41 parse type
; immediate

: ."  ( <string> -- , type string )
    state @ 1 =
    IF compile (.")  ,"
    ELSE 34 parse type
    THEN
; immediate

: SEE ( <name> -- )
    ' dup
    16 + @  \ offset in execution token for alloc size
    cells swap >body
    disassemble ;

: (   41 parse 2drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note: default decimal numeric input mode. )

: \ ( <line> -- , comment out the rest of line)
   13 parse 2drop ; immediate

\ 1 echo !   \ Uncomment this line to echo Forth code while compiling.

\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ BYOK (portmanteau of BYE & OK) is a BYO kernel which happens to
\ implement a forth machine on i686 bare metal.
\
\ Substantial portions of this file were lifted straight from pForth
\ (http://pforth.googlecode.com/svn/trunk/fth/system.fth)
\ *********************************************************************
: BL 32 ;

: SPACE  ( -- )  bl emit ;
: CR  ( -- , cause output to appear at the beginning of the next line )  10 emit ;

: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1+ swap c@ ;

\ Miscellaneous support words
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

: CELL+  ( n -- n+cell )  cell + ;
: CELL-  ( n -- n-cell )  cell - ;
: CELL*  ( n -- n*cell )  cells ;

: CHAR+  ( n -- n+size_of_char ) 1+
\ : CHARS  ( n -- n*size_of_char, don't do anything ) ; immediate

\ useful stack manipulation words
: -ROT ( a b c -- c a b ) rot rot ;
: 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;

\ ------------------------------------------------------------------
: ID.  ( nfa -- ) count 31 and type ;

: BINARY    2 base ! ;
: OCTAL     8 base ! ;
: DECIMAL  10 base ! ;
: HEX      16 base ! ;

: PAD ( -- addr ) here 128 + ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;

: [  ( -- , enter interpreter mode )  0 state ! ; immediate
: ]  ( -- , enter compile mode )      1 state ! ;

: ?  ( <name> -- )  @ . ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ ' (lit) , cell 1- , ]  +
    [ ' (lit) , cell 1- invert , ]  and ;

: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
: ALLOT  ( nbytes -- , allot space in dictionary ) dp +! align ;

: C,  ( c -- ) here c! 1 dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

\ Compiler support -------------------------------------------------
: COMPILE,   ( xt -- , compile call to xt ) , ;
: [COMPILE]  ( <name> -- , compile now even if immediate ) ' compile, ; immediate
: (COMPILE)  ( xt -- , postpone compilation of token )
    [compile] literal ( compile a call to literal )
    ( store xt of word to be compiled )

    [ ' compile, ] literal \ compile call to compile,
    compile, ;

: COMPILE  ( <name> --, save xt and compile later ) ' (compile) ; immediate

: :NONAME  ( -- xt , begin compilation of headerless secondary ) align here ] ;

\ Error codes defined in ANSI Exception word set -------------------
: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

: ABORT ( i*x -- ) err_abort throw ;

\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION  ( f -- )  conditional_key - err_pairs ?error ;
: >MARK       ( -- addr )   here 0 , ;
: >RESOLVE    ( addr -- )   here over - swap ! ;
: <MARK       ( -- addr )   here ;
: <RESOLVE    ( addr -- )   here - , ;

: ?COMP  ( -- , error if not compiling ) state @ 0= err_executing ?error ;
: ?PAIRS ( n m -- ) - err_pairs ?error ;

\ Conditional primitives -------------------------------------------
: IF     ( -- f orig )  ?comp compile 0branch conditional_key >mark ; immediate
: THEN   ( f orig -- )  swap ?condition >resolve ; immediate
: BEGIN  ( -- f dest )  ?comp conditional_key <mark ; immediate
: AGAIN  ( f dest -- )  compile branch swap ?condition <resolve ; immediate
: UNTIL  ( f dest -- )  compile 0branch swap ?condition <resolve ; immediate
: AHEAD  ( -- f orig )  compile branch conditional_key >mark ; immediate

\ Conditionals built from primitives -------------------------------
: ELSE   ( f orig1 -- f orig2 )  [compile] ahead 2swap [compile] then ; immediate
: WHILE  ( f dest -- f origi f dest ) [compile] if 2swap ; immediate
: REPEAT  ( -- f orig f dest ) [compile] again [compile] then ; immediate

: [']  ( <name> -- xt , define compile time tick )
    ?comp ' [compile] literal
; immediate

: RECURSE  ( ? -- ? , call the word currently being defined )
    latest compile,
; immediate

: 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;

: /STRING  ( addr len n -- addr' len' ) over min rot over  + -rot - ;
: PLACE    ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ;

: ASCII ( <char> -- char, state smart )
    bl parse drop c@
    state @ 1 =
    IF [compile] literal
    ELSE
    THEN
; immediate

: CHAR    ( <char> -- char , interpret mode ) bl parse drop c@ ;
: [CHAR]  ( <char> -- char , for compile mode )
    char [compile] literal
; immediate

: 'word  ( -- addr )  here ;

: (C")  ( -- $addr ) r> dup count + aligned >r ;
: (S")  ( -- c-addr cnt ) r> count 2dup + aligned >r ;
: (.")  ( -- , type following string ) r> count 2dup + aligned r> type ;
: ",    ( addr len -- , place string into dict ) tuck 'word place 1+ allot align ;
: ,"    ( -- ) 34 parse ", ;

: .(  ( <string> --, type string delimited by parens )
    41 parse type
; immediate

: ."  ( <string> -- , type string )
    state @ 1 =
    IF compile (.")  ,"
    ELSE 34 parse type
    THEN
; immediate

: SEE ( <name> -- )
    ' dup
    16 + @  \ offset in execution token for alloc size
    cells swap >body
    disassemble ;


Converted eforth.forth to lowercase

Converted eforth.forth to lowercase

The vm needs forth source in lowercase. The original uppercase eforth.forth was converted to lowercase  with:
  tr '[:upper:]' '[:lower:]' < eforth.forth.original > eforth.forth

: + um+  drop   ;
: cells  dup +  ;
: cell+  2   +  ;
: cell- -2   +  ;
: cell   2      ;
: boot     0 cells ;
: forth    4 cells ;
: dpl      5 cells ;
: sp0      6 cells ;
: rp0      7 cells ;
: '?key    8 cells ;
: 'emit    9 cells ;
: 'expect 10 cells ;
: 'tap    11 cells ;
: 'echo   12 cells ;
: 'prompt 13 cells ;
: base    14 cells ;
: tmp     15 cells ;
: span    16 cells ;
: >in     17 cells ;
: #tibb   18 cells ;
: tibb    19 cells ;
: csp     20 cells ;
: 'eval   21 cells ;
: 'number 22 cells ;
: hld     23 cells ;
: handler 24 cells ;
: context 25 cells ;
: current 27 cells ;
: cp      29 cells ;
: np      30 cells ;
: last    31 cells ;
: state   32 cells ;
: spp     33 cells ;
: rpp     34 cells ;
: true -1 ;
: false 0 ;
: bl 32 ;
: bs 8 ;
: =immed    3 ;
: =wordlist 2 ;
: immediate =immed last @ cell- ! ;
: here cp @ ;
: allot cp @ + cp ! ;
: , here cell allot ! ;
: c, here 1 allot c! ;
: +! swap over @ + swap ! ;
: compile r> dup @ , cell+ >r ;
: state? state @ ;
: literal compile lit , ; immediate
: [ false state ! ; immediate
: ] true state ! ; immediate
: if compile 0branch here 0 , ; immediate
: then here swap ! ; immediate
: for compile >r here ; immediate
: next compile next , ; immediate
: begin here ; immediate
: again compile branch , ; immediate
: until compile 0branch , ; immediate
: ahead compile branch here 0 , ; immediate
: repeat compile branch , here swap ! ; immediate
: aft drop compile branch here 0 ,  here swap ; immediate
: else compile branch here 0 ,  swap here swap !  ; immediate
: while compile 0branch here 0 , swap ; immediate
: execute >r ;
: @execute @ dup if execute then ;
: r@ r> r> dup >r swap >r ;
: #tib #tibb @ ;
: tib tibb @ ;
: \ #tib @ >in ! ; immediate
: rot >r swap r> swap ;
: -rot swap >r swap r> ;
: nip swap drop ;
: tuck swap over ;
: 2>r swap r> swap >r swap >r >r ;
: 2r> r> r> swap r> swap >r swap ;
: 2r@ r> r> r@ swap >r swap r@ swap >r ;
: 2drop drop drop ;
: 2dup over over ;
: 2swap rot >r rot r> ;
: 2over >r >r 2dup r> r> 2swap ;
: 2rot 2>r 2swap 2r> 2swap ;
: -2rot 2rot 2rot ;
: 2nip 2swap 2drop ;
: 2tuck 2swap 2over ;
: not dup nand ;
: and nand not ;
: or not swap not nand ;
: nor or not ;
: xor 2dup and -rot nor nor ;
: xnor xor not ;
: negate not 1 + ;
: - negate + ;
: 1+ 1 + ;
: 1- 1 - ;
: 2+ 2 + ;
: 2- 2 - ;
: d+ >r swap >r um+ r> r> + + ;
: dnegate not >r not 1 um+ r> + ;
: d- dnegate d+ ;
: 2! swap over ! cell+ ! ;
: 2@ dup cell+ @ swap @ ;
: ?dup dup if dup then ;
: s>d dup 0< ;
: abs dup 0< if negate then ;
: dabs dup 0< if dnegate then ;
: u< 2dup xor 0< if swap drop 0< exit then - 0< ;
: u> swap u< ;
: = xor if false exit then true ;
: < 2dup xor 0< if drop 0< exit then - 0< ;
: > swap < ;
: 0> negate 0< ;
: 0<> if true exit then false ;
: 0= 0 = ;
: <> = 0= ;
: d0< swap drop 0< ;
: d0> dnegate d0< ;
: d0= or 0= ;
: d= d- d0= ;
: d< rot 2dup xor if swap 2swap 2drop < ;
: du< rot 2dup xor if swap 2swap then then 2drop u< ;
: dmin 2over 2over 2swap d< if 2swap then 2drop ;
: dmax 2over 2over d< if 2swap then 2drop ;
: m+ s>d d+ ;
: m- s>d d- ;
: min 2dup swap < if swap then drop ;
: max 2dup < if swap then drop ;
: umin 2dup swap u< if swap then drop ;
: umax 2dup u< if swap then drop ;
: within over - >r - r> u< ;
: um/mod
    2dup u<
    if negate
        15 for
            >r dup um+
                >r >r dup um+
                r> + dup r> r@ swap
            >r um+
            r> or
                if >r drop 1+ r>
                else drop
            then r>
        next drop swap exit
    then drop 2drop -1 dup ;
: m/mod
    dup 0< dup >r
        if negate >r
            dnegate r>
        then >r dup 0<
        if r@ +
        then r> um/mod
    r>
    if swap negate swap then ;
: /mod over 0< swap m/mod ;
: mod /mod drop ;
: / /mod nip ;
: um*
    0 swap
    15 for
        dup um+ >r >r
        dup um+
        r> +
        r>
        if >r over um+
            r> +
        then
    next
    rot drop ;
: * um* drop ;
: m*
    2dup xor 0< >r
    abs swap abs um*
    r> if dnegate then ;
: */mod >r m* r> m/mod ;
: */ */mod swap drop ;
: 2* 2 * ;
: 2/ 2 / ;
: mu/mod >r 0 r@ um/mod r> swap >r um/mod r> ;
: d2* 2dup d+ ;
: du2/ 2 mu/mod rot drop ;
: d2/ dup >r 1 and du2/ r> 2/ or ;
: aligned dup 0 2 um/mod drop dup if 2 swap - then + ;
: parse
    tmp ! over >r dup
    if
        1- tmp @ bl =
        if
            for bl over c@ - 0< not
            while 1+
                next r> drop 0 dup exit
            then r>
        then
            over swap
        for tmp @ over c@ - tmp @ bl =
            if 0< then
        while 1+
        next dup >r
        else r> drop dup 1+ >r
        then over - r> r> - exit
    then over r> - ;
: parse >r tib >in @ + #tib c@ >in @ - r> parse >in +! ;
: char bl parse drop c@ ;
: tx! 1 putc ;
: emit 'emit @execute ;
: type for aft dup c@ emit 1+ then next drop ;
: ?rx 0 getc ;
: ?key '?key @execute ;
: key begin ?key until ;
: count dup 1+ swap c@ ;
: cmove
    for
        aft
            >r dup c@ r@ c! 1+ r> 1+
        then
    next 2drop ;
: fill
    swap
    for swap
        aft 2dup c! 1+ then
    next 2drop ;
: -trailing
    for
        aft
        bl over r@ + c@ <
        if
            r> 1+ exit
        then
    then
    next 0 ;
: pack$
    dup >r
        2dup c! 1+ 2dup + 0 swap ! swap cmove
    r> ;
: word parse here pack$ ;
: token bl parse 31 min np @ over - 1- pack$ ;
: link> 3 cells - ;
: code> 2 cells - ;
: type> 1 cells - ;
: data> cell+ ;
: same?
    for aft
        over r@ cells + @
        over r@ cells + @
        - ?dup
        if r> drop exit then
    then
    next 0 ;
: find
    @ begin dup while
        2dup c@ swap c@ = if
        2dup 1+ swap count aligned cell / >r swap r>
        same? 0= if
            2drop swap drop dup code> @ swap -1 exit
        then 2drop then
    link> @ repeat ;
: ' token context @ find if drop else swap drop 0 then ;
: ! ! ;
' tx! 'emit !
' ?rx '?key !
: ['] compile ' ; immediate
: postpone ' , ; immediate
: [char] char postpone literal ; immediate
: ( [char] ) parse 2drop ; immediate
: :noname here postpone ] ;
: overt last @ current @ ! ;
: $,n
    dup last ! cell-
    dup =wordlist
    swap !
    cell- dup here
    swap !
    cell- dup current @ @
    swap !
    cell- np ! ;
: : token $,n postpone ] ;
: ; compile exit postpone [ overt ; immediate
: recurse last @ code> @ , ; immediate
: dovar r> ;
: create token $,n compile dovar overt ;
: does last @ code> @ r> swap ! ;
: does> compile does compile r> ; immediate
: constant create , does> @ ;
: variable create 0 , ;
: 2literal swap postpone literal
    postpone literal ; immediate
: 2constant create , , does> 2@ ;
: 2variable create 2 cells allot ;
: space bl emit ;
: spaces 0 max for space next ;
: pad here 80 + ;
: decimal 10 base ! ;
: hex 16 base ! ;
: binary 2 base ! ;
: octal 8 base ! ;
decimal
: char- 1- ;
: char+ 1+ ;
: chars ;
: >char 127 and dup 127 bl within if drop 95 then ;
: digit 9 over < 7 and + [char] 0 + ;
: <# pad hld ! ;
: hold hld @ char- dup hld ! c! ;
: # 0 base @ um/mod >r base @ um/mod swap digit hold r> ;
: #s begin # 2dup or 0= until ;
: sign 0< if [char] - hold then ;
: #> 2drop hld @ pad over - ;
: s.r over - spaces type ;
: d.r >r dup >r dabs <# #s r> sign #> r> s.r ;
: u.r 0 swap d.r ;
: .r >r s>d r> d.r ;
: d. 0 d.r space ;
: u. 0 d. ;
: . base @ 10 xor if u. exit then s>d d. ;
: ? @ . ;
: du.r >r <# #s #> r> s.r ;
: du. du.r space ;
: do$ r> r@ r> count + aligned >r swap >r ;
: ."| do$ count type ;
: $," [char] " word count + aligned cp ! ;
: ." compile ."| $," ; immediate
: .( [char] ) parse type ; immediate
: $"| do$ ;
: $" compile $"| $," ; immediate
: s" [char] " parse here pack$ ;
: cr 10 emit ;
: tap over c! 1+ ;
: ktap
    10 xor
    if
        bl tap exit
    then
    nip dup ;
: accept
    over + over
    begin
        2dup xor
    while
        key
        dup bl - 95 u<
        if tap else ktap then
    repeat drop over - ;
: expect accept span ! drop ;
: query tib 80 accept #tib c! drop 0 >in ! ;
: digit?
    >r [char] 0 -
    9 over <
    if 7 - dup 10 < or then
    dup r> u< ;
: /string dup >r - swap r> + swap ;
: >number
    begin dup
    while >r dup >r c@ base @ digit?
    while swap base @ um* drop rot
    base @ um* d+ r> char+ r> 1 -
    repeat drop r> r> then ;
: number?
    over c@ [char] - = dup >r if 1 /string then
    >r >r 0 dup r> r> -1 dpl !
    begin >number dup
    while over c@ [char] . xor
        if rot drop rot r> 2drop false exit
    then 1 - dpl ! char+ dpl @
    repeat 2drop r> if dnegate then true ;
' number? 'number !
: $interpret
    context @ find
    if drop execute exit then
    count 'number @execute if
        dpl @ 0< if drop then exit then ." ?" type ;
: $compile
    context @ find
    if cell- @ =immed =
        if execute else , then exit
    then count 'number @execute
    if
        dpl @ 0<
        if drop postpone literal
        else postpone 2literal
        then exit
    then ." ?" type ;
: eval state? if $compile else $interpret then ;
' eval 'eval !
: eval
    begin token dup c@ while
        'eval @execute
    repeat drop ;
: ok cr ." ok." space ;
' ok 'prompt !
: quit
    begin 'prompt @execute query
    eval again ;
: bye ." good bye " cr halt ;
' quit boot !
: sp@ spp @ ;
: depth sp@ sp0 @ - cell / ;
: pick cells sp@ swap - 2 cells - @ ;
: .s cr depth for aft r@ pick . then next space ." <sp " cr ;
: words
    context @ @ begin dup while dup count type link>
    @ space repeat drop cr ;

variable file
: open f_open file ! ;
: close file @ f_close ;
: fput file @ putc ;
: fget file @ getc ;
: fputs count for aft dup c@ fput 1+ then next drop ;

: savevm $" eforth.img" $" wb" open 0
    16384 for aft dup c@ fput 1+ then next close drop ;

savevm

: + UM+  DROP   ;
: CELLS  DUP +  ;
: CELL+  2   +  ;
: CELL- -2   +  ;
: CELL   2      ;
: BOOT     0 CELLS ;
: FORTH    4 CELLS ;
: DPL      5 CELLS ;
: SP0      6 CELLS ;
: RP0      7 CELLS ;
: '?KEY    8 CELLS ;
: 'EMIT    9 CELLS ;
: 'EXPECT 10 CELLS ;
: 'TAP    11 CELLS ;
: 'ECHO   12 CELLS ;
: 'PROMPT 13 CELLS ;
: BASE    14 CELLS ;
: tmp     15 CELLS ;
: SPAN    16 CELLS ;
: >IN     17 CELLS ;
: #TIBB   18 CELLS ;
: TIBB    19 CELLS ;
: CSP     20 CELLS ;
: 'EVAL   21 CELLS ;
: 'NUMBER 22 CELLS ;
: HLD     23 CELLS ;
: HANDLER 24 CELLS ;
: CONTEXT 25 CELLS ;
: CURRENT 27 CELLS ;
: CP      29 CELLS ;
: NP      30 CELLS ;
: LAST    31 CELLS ;
: STATE   32 CELLS ;
: SPP     33 CELLS ;
: RPP     34 CELLS ;
: TRUE -1 ;
: FALSE 0 ;
: BL 32 ;
: BS 8 ;
: =IMMED    3 ;
: =WORDLIST 2 ;
: IMMEDIATE =IMMED LAST @ CELL- ! ;
: HERE CP @ ;
: ALLOT CP @ + CP ! ;
: , HERE CELL ALLOT ! ;
: C, HERE 1 ALLOT C! ;
: +! SWAP OVER @ + SWAP ! ;
: COMPILE R> DUP @ , CELL+ >R ;
: STATE? STATE @ ;
: LITERAL COMPILE LIT , ; IMMEDIATE
: [ FALSE STATE ! ; IMMEDIATE
: ] TRUE STATE ! ; IMMEDIATE
: IF COMPILE 0BRANCH HERE 0 , ; IMMEDIATE
: THEN HERE SWAP ! ; IMMEDIATE
: FOR COMPILE >R HERE ; IMMEDIATE
: NEXT COMPILE next , ; IMMEDIATE
: BEGIN HERE ; IMMEDIATE
: AGAIN COMPILE BRANCH , ; IMMEDIATE
: UNTIL COMPILE 0BRANCH , ; IMMEDIATE
: AHEAD COMPILE BRANCH HERE 0 , ; IMMEDIATE
: REPEAT COMPILE BRANCH , HERE SWAP ! ; IMMEDIATE
: AFT DROP COMPILE BRANCH HERE 0 ,  HERE SWAP ; IMMEDIATE
: ELSE COMPILE BRANCH HERE 0 ,  SWAP HERE SWAP !  ; IMMEDIATE
: WHILE COMPILE 0BRANCH HERE 0 , SWAP ; IMMEDIATE
: EXECUTE >R ;
: @EXECUTE @ DUP IF EXECUTE THEN ;
: R@ R> R> DUP >R SWAP >R ;
: #TIB #TIBB @ ;
: TIB TIBB @ ;
: \ #TIB @ >IN ! ; IMMEDIATE
: ROT >R SWAP R> SWAP ;
: -ROT SWAP >R SWAP R> ;
: NIP SWAP DROP ;
: TUCK SWAP OVER ;
: 2>R SWAP R> SWAP >R SWAP >R >R ;
: 2R> R> R> SWAP R> SWAP >R SWAP ;
: 2R@ R> R> R@ SWAP >R SWAP R@ SWAP >R ;
: 2DROP DROP DROP ;
: 2DUP OVER OVER ;
: 2SWAP ROT >R ROT R> ;
: 2OVER >R >R 2DUP R> R> 2SWAP ;
: 2ROT 2>R 2SWAP 2R> 2SWAP ;
: -2ROT 2ROT 2ROT ;
: 2NIP 2SWAP 2DROP ;
: 2TUCK 2SWAP 2OVER ;
: NOT DUP NAND ;
: AND NAND NOT ;
: OR NOT SWAP NOT NAND ;
: NOR OR NOT ;
: XOR 2DUP AND -ROT NOR NOR ;
: XNOR XOR NOT ;
: NEGATE NOT 1 + ;
: - NEGATE + ;
: 1+ 1 + ;
: 1- 1 - ;
: 2+ 2 + ;
: 2- 2 - ;
: D+ >R SWAP >R UM+ R> R> + + ;
: DNEGATE NOT >R NOT 1 UM+ R> + ;
: D- DNEGATE D+ ;
: 2! SWAP OVER ! CELL+ ! ;
: 2@ DUP CELL+ @ SWAP @ ;
: ?DUP DUP IF DUP THEN ;
: S>D DUP 0< ;
: ABS DUP 0< IF NEGATE THEN ;
: DABS DUP 0< IF DNEGATE THEN ;
: U< 2DUP XOR 0< IF SWAP DROP 0< EXIT THEN - 0< ;
: U> SWAP U< ;
: = XOR IF FALSE EXIT THEN TRUE ;
: < 2DUP XOR 0< IF DROP 0< EXIT THEN - 0< ;
: > SWAP < ;
: 0> NEGATE 0< ;
: 0<> IF TRUE EXIT THEN FALSE ;
: 0= 0 = ;
: <> = 0= ;
: D0< SWAP DROP 0< ;
: D0> DNEGATE D0< ;
: D0= OR 0= ;
: D= D- D0= ;
: D< ROT 2DUP XOR IF SWAP 2SWAP 2DROP < ;
: DU< ROT 2DUP XOR IF SWAP 2SWAP THEN THEN 2DROP U< ;
: DMIN 2OVER 2OVER 2SWAP D< IF 2SWAP THEN 2DROP ;
: DMAX 2OVER 2OVER D< IF 2SWAP THEN 2DROP ;
: M+ S>D D+ ;
: M- S>D D- ;
: MIN 2DUP SWAP < IF SWAP THEN DROP ;
: MAX 2DUP < IF SWAP THEN DROP ;
: UMIN 2DUP SWAP U< IF SWAP THEN DROP ;
: UMAX 2DUP U< IF SWAP THEN DROP ;
: WITHIN OVER - >R - R> U< ;
: UM/MOD
    2DUP U<
    IF NEGATE
        15 FOR
            >R DUP UM+
                >R >R DUP UM+
                R> + DUP R> R@ SWAP
            >R UM+
            R> OR
                IF >R DROP 1+ R>
                ELSE DROP
            THEN R>
        NEXT DROP SWAP EXIT
    THEN DROP 2DROP -1 DUP ;
: M/MOD
    DUP 0< DUP >R
        IF NEGATE >R
            DNEGATE R>
        THEN >R DUP 0<
        IF R@ +
        THEN R> UM/MOD
    R>
    IF SWAP NEGATE SWAP THEN ;
: /MOD OVER 0< SWAP M/MOD ;
: MOD /MOD DROP ;
: / /MOD NIP ;
: UM*
    0 SWAP
    15 FOR
        DUP UM+ >R >R
        DUP UM+
        R> +
        R>
        IF >R OVER UM+
            R> +
        THEN
    NEXT
    ROT DROP ;
: * UM* DROP ;
: M*
    2DUP XOR 0< >R
    ABS SWAP ABS UM*
    R> IF DNEGATE THEN ;
: */MOD >R M* R> M/MOD ;
: */ */MOD SWAP DROP ;
: 2* 2 * ;
: 2/ 2 / ;
: MU/MOD >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ;
: D2* 2DUP D+ ;
: DU2/ 2 MU/MOD ROT DROP ;
: D2/ DUP >R 1 AND DU2/ R> 2/ OR ;
: ALIGNED DUP 0 2 UM/MOD DROP DUP IF 2 SWAP - THEN + ;
: parse
    tmp ! OVER >R DUP
    IF
        1- tmp @ BL =
        IF
            FOR BL OVER C@ - 0< NOT
            WHILE 1+
                NEXT R> DROP 0 DUP EXIT
            THEN R>
        THEN
            OVER SWAP
        FOR tmp @ OVER C@ - tmp @ BL =
            IF 0< THEN
        WHILE 1+
        NEXT DUP >R
        ELSE R> DROP DUP 1+ >R
        THEN OVER - R> R> - EXIT
    THEN OVER R> - ;
: PARSE >R TIB >IN @ + #TIB C@ >IN @ - R> parse >IN +! ;
: CHAR BL PARSE DROP C@ ;
: TX! 1 PUTC ;
: EMIT 'EMIT @EXECUTE ;
: TYPE FOR AFT DUP C@ EMIT 1+ THEN NEXT DROP ;
: ?RX 0 GETC ;
: ?KEY '?KEY @EXECUTE ;
: KEY BEGIN ?KEY UNTIL ;
: COUNT DUP 1+ SWAP C@ ;
: CMOVE
    FOR
        AFT
            >R DUP C@ R@ C! 1+ R> 1+
        THEN
    NEXT 2DROP ;
: FILL
    SWAP
    FOR SWAP
        AFT 2DUP C! 1+ THEN
    NEXT 2DROP ;
: -TRAILING
    FOR
        AFT
        BL OVER R@ + C@ <
        IF
            R> 1+ EXIT
        THEN
    THEN
    NEXT 0 ;
: PACK$
    DUP >R
        2DUP C! 1+ 2DUP + 0 SWAP ! SWAP CMOVE
    R> ;
: WORD PARSE HERE PACK$ ;
: TOKEN BL PARSE 31 MIN NP @ OVER - 1- PACK$ ;
: LINK> 3 CELLS - ;
: CODE> 2 CELLS - ;
: TYPE> 1 CELLS - ;
: DATA> CELL+ ;
: SAME?
    FOR AFT
        OVER R@ CELLS + @
        OVER R@ CELLS + @
        - ?DUP
        IF R> DROP EXIT THEN
    THEN
    NEXT 0 ;
: find
    @ BEGIN DUP WHILE
        2DUP C@ SWAP C@ = IF
        2DUP 1+ SWAP COUNT ALIGNED CELL / >R SWAP R>
        SAME? 0= IF
            2DROP SWAP DROP DUP CODE> @ SWAP -1 EXIT
        THEN 2DROP THEN
    LINK> @ REPEAT ;
: ' TOKEN CONTEXT @ find IF DROP ELSE SWAP DROP 0 THEN ;
: ! ! ;
' TX! 'EMIT !
' ?RX '?KEY !
: ['] COMPILE ' ; IMMEDIATE
: POSTPONE ' , ; IMMEDIATE
: [CHAR] CHAR POSTPONE LITERAL ; IMMEDIATE
: ( [CHAR] ) PARSE 2DROP ; IMMEDIATE
: :NONAME HERE POSTPONE ] ;
: OVERT LAST @ CURRENT @ ! ;
: $,n
    DUP LAST ! CELL-
    DUP =WORDLIST
    SWAP !
    CELL- DUP HERE
    SWAP !
    CELL- DUP CURRENT @ @
    SWAP !
    CELL- NP ! ;
: : TOKEN $,n POSTPONE ] ;
: ; COMPILE EXIT POSTPONE [ OVERT ; IMMEDIATE
: RECURSE LAST @ code> @ , ; IMMEDIATE
: doVAR R> ;
: CREATE TOKEN $,n COMPILE doVAR OVERT ;
: DOES LAST @ CODE> @ R> SWAP ! ;
: DOES> COMPILE DOES COMPILE R> ; IMMEDIATE
: CONSTANT CREATE , DOES> @ ;
: VARIABLE CREATE 0 , ;
: 2LITERAL SWAP POSTPONE LITERAL
    POSTPONE LITERAL ; IMMEDIATE
: 2CONSTANT CREATE , , DOES> 2@ ;
: 2VARIABLE CREATE 2 CELLS ALLOT ;
: SPACE BL EMIT ;
: SPACES 0 MAX FOR SPACE NEXT ;
: PAD HERE 80 + ;
: DECIMAL 10 BASE ! ;
: HEX 16 BASE ! ;
: BINARY 2 BASE ! ;
: OCTAL 8 BASE ! ;
DECIMAL
: CHAR- 1- ;
: CHAR+ 1+ ;
: CHARS ;
: >CHAR 127 AND DUP 127 BL WITHIN IF DROP 95 THEN ;
: DIGIT 9 OVER < 7 AND + [CHAR] 0 + ;
: <# PAD HLD ! ;
: HOLD HLD @ CHAR- DUP HLD ! C! ;
: # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP DIGIT HOLD R> ;
: #S BEGIN # 2DUP OR 0= UNTIL ;
: SIGN 0< IF [CHAR] - HOLD THEN ;
: #> 2DROP HLD @ PAD OVER - ;
: S.R OVER - SPACES TYPE ;
: D.R >R DUP >R DABS <# #S R> SIGN #> R> S.R ;
: U.R 0 SWAP D.R ;
: .R >R S>D R> D.R ;
: D. 0 D.R SPACE ;
: U. 0 D. ;
: . BASE @ 10 XOR IF U. EXIT THEN S>D D. ;
: ? @ . ;
: DU.R >R <# #S #> R> S.R ;
: DU. DU.R SPACE ;
: do$ R> R@ R> COUNT + ALIGNED >R SWAP >R ;
: ."| do$ COUNT TYPE ;
: $," [CHAR] " WORD COUNT + ALIGNED CP ! ;
: ." COMPILE ."| $," ; IMMEDIATE
: .( [CHAR] ) PARSE TYPE ; IMMEDIATE
: $"| do$ ;
: $" COMPILE $"| $," ; IMMEDIATE
: s" [CHAR] " PARSE HERE PACK$ ;
: CR 10 EMIT ;
: TAP OVER C! 1+ ;
: KTAP
    10 XOR
    IF
        BL TAP EXIT
    THEN
    NIP DUP ;
: ACCEPT
    OVER + OVER
    BEGIN
        2DUP XOR
    WHILE
        KEY
        DUP BL - 95 U<
        IF TAP ELSE KTAP THEN
    REPEAT DROP OVER - ;
: EXPECT ACCEPT SPAN ! DROP ;
: QUERY TIB 80 ACCEPT #TIB C! DROP 0 >IN ! ;
: DIGIT?
    >R [CHAR] 0 -
    9 OVER <
    IF 7 - DUP 10 < OR THEN
    DUP R> U< ;
: /STRING DUP >R - SWAP R> + SWAP ;
: >NUMBER
    BEGIN DUP
    WHILE >R DUP >R C@ BASE @ DIGIT?
    WHILE SWAP BASE @ UM* DROP ROT
    BASE @ UM* D+ R> CHAR+ R> 1 -
    REPEAT DROP R> R> THEN ;
: NUMBER?
    OVER C@ [CHAR] - = DUP >R IF 1 /STRING THEN
    >R >R 0 DUP R> R> -1 DPL !
    BEGIN >NUMBER DUP
    WHILE OVER C@ [CHAR] . XOR
        IF ROT DROP ROT R> 2DROP FALSE EXIT
    THEN 1 - DPL ! CHAR+ DPL @
    REPEAT 2DROP R> IF DNEGATE THEN TRUE ;
' NUMBER? 'NUMBER !
: $INTERPRET
    CONTEXT @ find
    IF DROP EXECUTE EXIT THEN
    COUNT 'NUMBER @EXECUTE IF
        DPL @ 0< IF DROP THEN EXIT THEN ." ?" TYPE ;
: $COMPILE
    CONTEXT @ find
    IF CELL- @ =IMMED =
        IF EXECUTE ELSE , THEN EXIT
    THEN COUNT 'NUMBER @EXECUTE
    IF
        DPL @ 0<
        IF DROP POSTPONE LITERAL
        ELSE POSTPONE 2LITERAL
        THEN EXIT
    THEN ." ?" TYPE ;
: eval STATE? IF $COMPILE ELSE $INTERPRET THEN ;
' eval 'EVAL !
: EVAL
    BEGIN TOKEN DUP C@ WHILE
        'EVAL @EXECUTE
    REPEAT DROP ;
: OK CR ." OK." SPACE ;
' OK 'PROMPT !
: QUIT
    BEGIN 'PROMPT @EXECUTE QUERY
    EVAL AGAIN ;
: BYE ." Good Bye " CR HALT ;
' QUIT BOOT !
: SP@ SPP @ ;
: DEPTH SP@ SP0 @ - CELL / ;
: PICK CELLS SP@ SWAP - 2 CELLS - @ ;
: .S CR DEPTH FOR AFT R@ PICK . THEN NEXT SPACE ." <SP " CR ;
: WORDS
    CONTEXT @ @ BEGIN DUP WHILE DUP COUNT TYPE LINK>
    @ SPACE REPEAT DROP CR ;

VARIABLE FILE
: OPEN F_OPEN FILE ! ;
: CLOSE FILE @ F_CLOSE ;
: FPUT FILE @ PUTC ;
: FGET FILE @ GETC ;
: FPUTS COUNT FOR AFT DUP C@ FPUT 1+ THEN NEXT DROP ;

: SAVEVM $" eforth.img" $" wb" OPEN 0
    16384 FOR AFT DUP C@ FPUT 1+ THEN NEXT CLOSE DROP ;

SAVEVM


Disable the APIC when selecting the 'Safe Mode' option of the loader.  This will disable both APIC interrupt routing and SMP.

\ Copyright (c) 2003 Scott Long <scottl@freebsd.org>
\ Copyright (c) 2003 Aleksander Fafula <alex@fafula.com>
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions
\ are met:
\ 1. Redistributions of source code must retain the above copyright
\    notice, this list of conditions and the following disclaimer.
\ 2. Redistributions in binary form must reproduce the above copyright
\    notice, this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
\ SUCH DAMAGE.
\
\ $FreeBSD$

marker task-beastie.4th

include /boot/screen.4th
include /boot/frames.4th

hide

variable menuidx
variable menubllt
variable menuX
variable menuY
variable promptwidth

variable bootkey
variable bootacpikey
variable bootsafekey
variable bootverbosekey
variable bootsinglekey
variable escapekey
variable rebootkey

46 constant dot

\ The BSD Daemon.  He is 19 rows high and 34 columns wide
: technicolor-beastie ( x y -- )
2dup at-xy ."               ,        ," 1+
2dup at-xy ."              /(        )`" 1+
2dup at-xy ."              \ \___   / |" 1+
2dup at-xy ."              /- _  `-/  '" 1+
2dup at-xy ."             (/\/ \ \   /\" 1+
2dup at-xy ."             / /   | `    \" 1+
2dup at-xy ."             O O   ) /    |" 1+
2dup at-xy ."             `-^--'`<     '" 1+
2dup at-xy ."            (_.)  _  )   /" 1+
2dup at-xy ."             `.___/`    /       " 1+
2dup at-xy ."               `-----' /" 1+
2dup at-xy ."  <----.     __ / __   \" 1+
2dup at-xy ."  <----|====O)))==) \) /====|" 1+
2dup at-xy ."  <----'    `--' `.__,' \" 1+
2dup at-xy ."               |        |" 1+
2dup at-xy ."                \       /       /\" 1+
2dup at-xy ."           ______( (_  / \______/" 1+
2dup at-xy ."         ,'  ,-----'   |" 1+
at-xy ."         `--{__________) " 1+
;

: boring-beastie ( x y -- )
	2dup at-xy ."              ,        ," 1+
	2dup at-xy ."             /(        )`" 1+
	2dup at-xy ."             \ \___   / |" 1+
	2dup at-xy ."             /- _  `-/  '" 1+
	2dup at-xy ."            (/\/ \ \   /\" 1+
	2dup at-xy ."            / /   | `    \" 1+
	2dup at-xy ."            O O   ) /    |" 1+
	2dup at-xy ."            `-^--'`<     '" 1+
	2dup at-xy ."           (_.)  _  )   /" 1+
	2dup at-xy ."            `.___/`    /" 1+
	2dup at-xy ."              `-----' /" 1+
	2dup at-xy ." <----.     __ / __   \" 1+
	2dup at-xy ." <----|====O)))==) \) /====" 1+
	2dup at-xy ." <----'    `--' `.__,' \" 1+
	2dup at-xy ."              |        |" 1+
	2dup at-xy ."               \       /       /\" 1+
	2dup at-xy ."          ______( (_  / \______/" 1+
	2dup at-xy ."        ,'  ,-----'   |" 1+
	     at-xy ."        `--{__________)"
;

: print-beastie ( x y -- )
	s" loader_color" getenv
	dup -1 = if
		drop
		boring-beastie
		exit
	then
	s" YES" compare-insensitive 0<> if
		boring-beastie
		exit
	then
	technicolor-beastie
;

: acpienabled? ( -- flag )
	s" acpi_load" getenv
	dup -1 = if
		drop false exit
	then
	s" YES" compare-insensitive 0<> if
		false exit
	then
	s" hint.acpi.0.disabled" getenv
	dup -1 <> if
		s" 0" compare 0<> if
			false exit
		then
	then
	true
;

: printmenuitem ( -- n )
	menuidx @
	1+ dup
	menuidx !
	menuY @ + dup menuX @ swap at-xy
	menuidx @ .
	menuX @ 1+ swap at-xy
	menubllt @ emit
	menuidx @ 48 +
;

: beastie-menu ( -- )
	0 menuidx !
	dot menubllt !
	8 menuY !
	5 menuX !
	clear
	46 4 print-beastie
	42 20 2 2 box
	13 6 at-xy ." Welcome to FreeBSD!"
	printmenuitem ."  Boot FreeBSD [default]" bootkey !
	s" arch-i386" environment? if
		printmenuitem ."  Boot FreeBSD with ACPI " bootacpikey !
		acpienabled? if
			." disabled"
		else
			." enabled"
		then
	else
		-2 bootacpikey !
	then
	printmenuitem ."  Boot FreeBSD in Safe Mode" bootsafekey !
	printmenuitem ."  Boot FreeBSD in single user mode" bootsinglekey !
	printmenuitem ."  Boot FreeBSD with verbose logging" bootverbosekey !
	printmenuitem ."  Escape to loader prompt" escapekey !
	printmenuitem ."  Reboot" rebootkey !
	menuX @ 20 at-xy
	." Select option, [Enter] for default"
	menuX @ 21 at-xy
	s" or [Space] to pause timer    " dup 2 - promptwidth !
	type
;

: tkey
	dup
	seconds +
	begin 1 while
		over 0<> if
			dup seconds u< if
				drop
				-1
				exit
			then
			menuX @ promptwidth @ + 21 at-xy dup seconds - .
		then
		key? if
			drop
			key
			exit
		then
	50 ms
	repeat
;

set-current

: beastie-start
	s" beastie_disable" getenv
	dup -1 <> if
		s" YES" compare-insensitive 0= if
			exit
		then
	then
	beastie-menu
	s" autoboot_delay" getenv
	dup -1 = if
		drop
		10
	else
		0 0 2swap >number drop drop drop
	then
	begin true while
		dup tkey
		0 25 at-xy
		dup 32 = if nip 0 swap then
		dup -1 = if 0 boot then
		dup 13 = if 0 boot then
		dup bootkey @ = if 0 boot then
		dup bootacpikey @ = if
			acpienabled? if
				s" acpi_load" unsetenv
				s" 1" s" hint.acpi.0.disabled" setenv
				s" 1" s" loader.acpi_disabled_by_user" setenv
			else
				s" YES" s" acpi_load" setenv
				s" 0" s" hint.acpi.0.disabled" setenv
			then
			0 boot
		then
		dup bootsafekey @ = if
			s" arch-i386" environment? if
				s" acpi_load" unsetenv
				s" 1" s" hint.acpi.0.disabled" setenv
				s" 1" s" loader.acpi_disabled_by_user" setenv
				s" 1" s" hint.apic.0.disabled" setenv
			then
			s" 0" s" hw.ata.ata_dma" setenv
			s" 0" s" hw.ata.atapi_dma" setenv
			s" 0" s" hw.ata.wc" setenv
			s" 0" s" hw.eisa_slots" setenv
			0 boot
		then
		dup bootverbosekey @ = if
			s" YES" s" boot_verbose" setenv
			0 boot
		then
		dup bootsinglekey @ = if
			s" YES" s" boot_single" setenv
			0 boot
		then
		dup escapekey @ = if
			2drop
			s" NO" s" autoboot_delay" setenv
			exit
		then
		rebootkey @ = if 0 reboot then
	repeat
;

previous

\ Copyright (c) 2003 Scott Long <scottl@freebsd.org>
\ Copyright (c) 2003 Aleksander Fafula <alex@fafula.com>
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions
\ are met:
\ 1. Redistributions of source code must retain the above copyright
\    notice, this list of conditions and the following disclaimer.
\ 2. Redistributions in binary form must reproduce the above copyright
\    notice, this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
\ SUCH DAMAGE.
\
\ $FreeBSD$

marker task-beastie.4th

include /boot/screen.4th
include /boot/frames.4th

hide

variable menuidx
variable menubllt
variable menuX
variable menuY
variable promptwidth

variable bootkey
variable bootacpikey
variable bootsafekey
variable bootverbosekey
variable bootsinglekey
variable escapekey
variable rebootkey

46 constant dot

\ The BSD Daemon.  He is 19 rows high and 34 columns wide
: technicolor-beastie ( x y -- )
2dup at-xy ."               ,        ," 1+
2dup at-xy ."              /(        )`" 1+
2dup at-xy ."              \ \___   / |" 1+
2dup at-xy ."              /- _  `-/  '" 1+
2dup at-xy ."             (/\/ \ \   /\" 1+
2dup at-xy ."             / /   | `    \" 1+
2dup at-xy ."             O O   ) /    |" 1+
2dup at-xy ."             `-^--'`<     '" 1+
2dup at-xy ."            (_.)  _  )   /" 1+
2dup at-xy ."             `.___/`    /       " 1+
2dup at-xy ."               `-----' /" 1+
2dup at-xy ."  <----.     __ / __   \" 1+
2dup at-xy ."  <----|====O)))==) \) /====|" 1+
2dup at-xy ."  <----'    `--' `.__,' \" 1+
2dup at-xy ."               |        |" 1+
2dup at-xy ."                \       /       /\" 1+
2dup at-xy ."           ______( (_  / \______/" 1+
2dup at-xy ."         ,'  ,-----'   |" 1+
at-xy ."         `--{__________) " 1+
;

: boring-beastie ( x y -- )
	2dup at-xy ."              ,        ," 1+
	2dup at-xy ."             /(        )`" 1+
	2dup at-xy ."             \ \___   / |" 1+
	2dup at-xy ."             /- _  `-/  '" 1+
	2dup at-xy ."            (/\/ \ \   /\" 1+
	2dup at-xy ."            / /   | `    \" 1+
	2dup at-xy ."            O O   ) /    |" 1+
	2dup at-xy ."            `-^--'`<     '" 1+
	2dup at-xy ."           (_.)  _  )   /" 1+
	2dup at-xy ."            `.___/`    /" 1+
	2dup at-xy ."              `-----' /" 1+
	2dup at-xy ." <----.     __ / __   \" 1+
	2dup at-xy ." <----|====O)))==) \) /====" 1+
	2dup at-xy ." <----'    `--' `.__,' \" 1+
	2dup at-xy ."              |        |" 1+
	2dup at-xy ."               \       /       /\" 1+
	2dup at-xy ."          ______( (_  / \______/" 1+
	2dup at-xy ."        ,'  ,-----'   |" 1+
	     at-xy ."        `--{__________)"
;

: print-beastie ( x y -- )
	s" loader_color" getenv
	dup -1 = if
		drop
		boring-beastie
		exit
	then
	s" YES" compare-insensitive 0<> if
		boring-beastie
		exit
	then
	technicolor-beastie
;

: acpienabled? ( -- flag )
	s" acpi_load" getenv
	dup -1 = if
		drop false exit
	then
	s" YES" compare-insensitive 0<> if
		false exit
	then
	s" hint.acpi.0.disabled" getenv
	dup -1 <> if
		s" 0" compare 0<> if
			false exit
		then
	then
	true
;

: printmenuitem ( -- n )
	menuidx @
	1+ dup
	menuidx !
	menuY @ + dup menuX @ swap at-xy
	menuidx @ .
	menuX @ 1+ swap at-xy
	menubllt @ emit
	menuidx @ 48 +
;

: beastie-menu ( -- )
	0 menuidx !
	dot menubllt !
	8 menuY !
	5 menuX !
	clear
	46 4 print-beastie
	42 20 2 2 box
	13 6 at-xy ." Welcome to FreeBSD!"
	printmenuitem ."  Boot FreeBSD [default]" bootkey !
	s" arch-i386" environment? if
		printmenuitem ."  Boot FreeBSD with ACPI " bootacpikey !
		acpienabled? if
			." disabled"
		else
			." enabled"
		then
	else
		-2 bootacpikey !
	then
	printmenuitem ."  Boot FreeBSD in Safe Mode" bootsafekey !
	printmenuitem ."  Boot FreeBSD in single user mode" bootsinglekey !
	printmenuitem ."  Boot FreeBSD with verbose logging" bootverbosekey !
	printmenuitem ."  Escape to loader prompt" escapekey !
	printmenuitem ."  Reboot" rebootkey !
	menuX @ 20 at-xy
	." Select option, [Enter] for default"
	menuX @ 21 at-xy
	s" or [Space] to pause timer    " dup 2 - promptwidth !
	type
;

: tkey
	dup
	seconds +
	begin 1 while
		over 0<> if
			dup seconds u< if
				drop
				-1
				exit
			then
			menuX @ promptwidth @ + 21 at-xy dup seconds - .
		then
		key? if
			drop
			key
			exit
		then
	50 ms
	repeat
;

set-current

: beastie-start
	s" beastie_disable" getenv
	dup -1 <> if
		s" YES" compare-insensitive 0= if
			exit
		then
	then
	beastie-menu
	s" autoboot_delay" getenv
	dup -1 = if
		drop
		10
	else
		0 0 2swap >number drop drop drop
	then
	begin true while
		dup tkey
		0 25 at-xy
		dup 32 = if nip 0 swap then
		dup -1 = if 0 boot then
		dup 13 = if 0 boot then
		dup bootkey @ = if 0 boot then
		dup bootacpikey @ = if
			acpienabled? if
				s" acpi_load" unsetenv
				s" 1" s" hint.acpi.0.disabled" setenv
				s" 1" s" loader.acpi_disabled_by_user" setenv
			else
				s" YES" s" acpi_load" setenv
				s" 0" s" hint.acpi.0.disabled" setenv
			then
			0 boot
		then
		dup bootsafekey @ = if
			s" arch-i386" environment? if
				s" acpi_load" unsetenv
				s" 1" s" hint.acpi.0.disabled" setenv
				s" 1" s" loader.acpi_disabled_by_user" setenv
			then
			s" 0" s" hw.ata.ata_dma" setenv
			s" 0" s" hw.ata.atapi_dma" setenv
			s" 0" s" hw.ata.wc" setenv
			s" 0" s" hw.eisa_slots" setenv
			0 boot
		then
		dup bootverbosekey @ = if
			s" YES" s" boot_verbose" setenv
			0 boot
		then
		dup bootsinglekey @ = if
			s" YES" s" boot_single" setenv
			0 boot
		then
		dup escapekey @ = if
			2drop
			s" NO" s" autoboot_delay" setenv
			exit
		then
		rebootkey @ = if 0 reboot then
	repeat
;

previous