use -1 for TRUE

use -1 for TRUE

( Implementations of builtins.
  These functions are provided for the host in the msp430.asm.forth module. The
  implementations here are for the target.

  vi:ft=forth
)

( ----- low level supporting functions ----- )

CODE LIT
    ." \t decd TOS         ; prepare push on stack \n "
    ." \t mov @IP+, 0(TOS) ; copy value from thread to stack \n "
    NEXT
END-CODE

CODE BRANCH
    ." \t add @IP+, IP \n "
    ." \t decd IP \n "
    NEXT
END-CODE-INTERNAL

CODE BRANCH0
    ." \t mov @IP+, W ; get offset \n "
    ." \t tst 0(TOS)  ; check TOS \n "
    ." \t jnz .Lnjmp  ; skip next if non zero \n "
    ." \t decd IP     ; offset is relative to position of offset, correct \n "
    ." \t add W, IP   ; adjust IP \n "
." .Lnjmp: "
    DROP-ASM
    NEXT
END-CODE-INTERNAL

( ----- Stack ops ----- )

CODE DROP
    ." \t incd TOS " NL
    NEXT
END-CODE-INTERNAL

CODE DUP
    ." \t decd TOS " NL
    ." \t mov 2(TOS), 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

CODE OVER
    ." \t decd TOS " NL
    ." \t mov 4(TOS), 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

( Push a copy of the N'th element )
CODE PICK ( n - n )
    TOS->R15                    ( get element number from stack )
    ." \t rla R15 " NL          ( multiply by 2 -> 2 byte / cells )
    ." \t add TOS, R15 " NL     ( calculate address on stack )
    ." \t decd TOS " NL         ( push copy )
    ." \t mov 0(R15), 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

CODE SWAP ( y x - x y )
    ." \t mov 2(TOS), W " NL
    ." \t mov 0(TOS), 2(TOS) " NL
    ." \t mov W, 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

( ----- MATH ----- )

CODE +
    ." \t add 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE -
    ." \t sub 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

( ----- bit - ops ----- )
CODE &
    ." \t and 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE |
    ." \t bis 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE ^
    ." \t xor 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE ~
    ." \t inv 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

( ----- Logic ops ----- )
( include normalize to boolean )

CODE NOT
    ." \t tst 0(TOS) " NL
    ." \t jnz .not0 " NL
    ." \t mov \x23 -1, 0(TOS) " NL       ( replace TOS w/ result )
    ." \t jmp .not2 " NL
    ." .not0: " NL
    ." \t mov \x23 0, 0(TOS) " NL       ( replace TOS w/ result )
    ." .not2: " NL
    NEXT
END-CODE-INTERNAL

( ---------------------------------------------------
    "MIN" """Leave the smaller of two values on the stack"""
    "MAX" """Leave the larger of two values on the stack"""
    "*"
    "/"
    "NEG"
    "<<"
    ">>"
    "NOT"
    "AND"
    "OR"
)
( ----- Compare ----- )
CODE cmp_set_true   ( n - n )
    ." \t mov \x23 -1, 0(TOS) " NL   ( replace argument w/ result )
    NEXT
END-CODE

CODE cmp_set_false
    ." \t mov \x23 0, 0(TOS) " NL   ( replace argument w/ result )
    NEXT
END-CODE

CODE cmp_true
    DROP-ASM                        ( remove 1nd argument )
    ." \t mov \x23 -1, 0(TOS) " NL   ( replace 2nd argument w/ result )
    NEXT
END-CODE

CODE cmp_false
    DROP-ASM                        ( remove 1nd argument )
    ." \t mov \x23 0, 0(TOS) " NL   ( replace 2nd argument w/ result )
    NEXT
END-CODE

CODE <
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jl  cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

CODE >
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jl  cmp_false " NL
    ." \t jmp cmp_true " NL
END-CODE-INTERNAL

CODE <=
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jge cmp_false " NL
    ." \t jmp cmp_true " NL
END-CODE-INTERNAL

CODE >=
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jge cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

CODE ==
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jeq cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

( XXX alias for == )
CODE ==
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jeq cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

CODE !=
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jne cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

CODE 0=
    DEPENDS-ON cmp_set_true
    DEPENDS-ON cmp_set_false
    ." \t tst 0(TOS) " NL
    ." \t jz  cmp_set_true " NL
    ." \t jmp cmp_set_false " NL
END-CODE-INTERNAL

CODE 0>
    DEPENDS-ON cmp_set_true
    DEPENDS-ON cmp_set_false
    ." \t tst 0(TOS) " NL
    ." \t jn  cmp_set_false " NL
    ." \t jmp cmp_set_true " NL
END-CODE-INTERNAL

( Implementations of builtins.
  These functions are provided for the host in the msp430.asm.forth module. The
  implementations here are for the target.

  vi:ft=forth
)

( ----- low level supporting functions ----- )

CODE LIT
    ." \t decd TOS         ; prepare push on stack \n "
    ." \t mov @IP+, 0(TOS) ; copy value from thread to stack \n "
    NEXT
END-CODE

CODE BRANCH
    ." \t add @IP+, IP \n "
    ." \t decd IP \n "
    NEXT
END-CODE-INTERNAL

CODE BRANCH0
    ." \t mov @IP+, W ; get offset \n "
    ." \t tst 0(TOS)  ; check TOS \n "
    ." \t jnz .Lnjmp  ; skip next if non zero \n "
    ." \t decd IP     ; offset is relative to position of offset, correct \n "
    ." \t add W, IP   ; adjust IP \n "
." .Lnjmp: "
    DROP-ASM
    NEXT
END-CODE-INTERNAL

( ----- Stack ops ----- )

CODE DROP
    ." \t incd TOS " NL
    NEXT
END-CODE-INTERNAL

CODE DUP
    ." \t decd TOS " NL
    ." \t mov 2(TOS), 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

CODE OVER
    ." \t decd TOS " NL
    ." \t mov 4(TOS), 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

( Push a copy of the N'th element )
CODE PICK ( n - n )
    TOS->R15                    ( get element number from stack )
    ." \t rla R15 " NL          ( multiply by 2 -> 2 byte / cells )
    ." \t add TOS, R15 " NL     ( calculate address on stack )
    ." \t decd TOS " NL         ( push copy )
    ." \t mov 0(R15), 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

CODE SWAP ( y x - x y )
    ." \t mov 2(TOS), W " NL
    ." \t mov 0(TOS), 2(TOS) " NL
    ." \t mov W, 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

( ----- MATH ----- )

CODE +
    ." \t add 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE -
    ." \t sub 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

( ----- bit - ops ----- )
CODE &
    ." \t and 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE |
    ." \t bis 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE ^
    ." \t xor 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE ~
    ." \t inv 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

( ----- Logic ops ----- )
( include normalize to boolean )

CODE NOT
    ." \t tst 0(TOS) " NL
    ." \t jnz .not0 " NL
    ." \t mov \x23 1, 0(TOS) " NL       ( replace TOS w/ result )
    ." \t jmp .not2 " NL
    ." .not0: " NL
    ." \t mov \x23 0, 0(TOS) " NL       ( replace TOS w/ result )
    ." .not2: " NL
    NEXT
END-CODE-INTERNAL

( ---------------------------------------------------
    "MIN" """Leave the smaller of two values on the stack"""
    "MAX" """Leave the larger of two values on the stack"""
    "*"
    "/"
    "NEG"
    "<<"
    ">>"
    "NOT"
    "AND"
    "OR"
)
( ----- Compare ----- )
CODE cmp_set_true   ( n - n )
    ." \t mov \x23 1, 0(TOS) " NL   ( replace argument w/ result )
    NEXT
END-CODE

CODE cmp_set_false
    ." \t mov \x23 0, 0(TOS) " NL   ( replace argument w/ result )
    NEXT
END-CODE

CODE cmp_true
    DROP-ASM                        ( remove 1nd argument )
    ." \t mov \x23 1, 0(TOS) " NL   ( replace 2nd argument w/ result )
    NEXT
END-CODE

CODE cmp_false
    DROP-ASM                        ( remove 1nd argument )
    ." \t mov \x23 0, 0(TOS) " NL   ( replace 2nd argument w/ result )
    NEXT
END-CODE

CODE <
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jl  cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

CODE >
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jl  cmp_false " NL
    ." \t jmp cmp_true " NL
END-CODE-INTERNAL

CODE <=
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jge cmp_false " NL
    ." \t jmp cmp_true " NL
END-CODE-INTERNAL

CODE >=
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jge cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

CODE ==
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jeq cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

( XXX alias for == )
CODE ==
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jeq cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

CODE !=
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jne cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

CODE 0=
    DEPENDS-ON cmp_set_true
    DEPENDS-ON cmp_set_false
    ." \t tst 0(TOS) " NL
    ." \t jz  cmp_set_true " NL
    ." \t jmp cmp_set_false " NL
END-CODE-INTERNAL

CODE 0>
    DEPENDS-ON cmp_set_true
    DEPENDS-ON cmp_set_false
    ." \t tst 0(TOS) " NL
    ." \t jn  cmp_set_false " NL
    ." \t jmp cmp_set_true " NL
END-CODE-INTERNAL


PC98 uses the different frame code.

PC98 uses the different frame code.

\ Words implementing frame drawing
\ XXX Filled boxes are left as an exercise for the reader... ;-/
\ $FreeBSD$

marker task-frames.4th

variable h_el
variable v_el
variable lt_el
variable lb_el
variable rt_el
variable rb_el
variable fill

s" arch-pc98" environment? [if]
	\ Single frames
	149 constant sh_el
	150 constant sv_el
	152 constant slt_el
	154 constant slb_el
	153 constant srt_el
	155 constant srb_el
	\ Double frames
	149 constant dh_el
	150 constant dv_el
	152 constant dlt_el
	154 constant dlb_el
	153 constant drt_el
	155 constant drb_el
	\ Fillings
	0 constant fill_none
	32 constant fill_blank
	135 constant fill_dark
	135 constant fill_med
	135 constant fill_bright
[else]
	\ Single frames
	196 constant sh_el
	179 constant sv_el
	218 constant slt_el
	192 constant slb_el
	191 constant srt_el
	217 constant srb_el
	\ Double frames
	205 constant dh_el
	186 constant dv_el
	201 constant dlt_el
	200 constant dlb_el
	187 constant drt_el
	188 constant drb_el
	\ Fillings
	0 constant fill_none
	32 constant fill_blank
	176 constant fill_dark
	177 constant fill_med
	178 constant fill_bright
[then]

: hline	( len x y -- )	\ Draw horizontal single line
	at-xy		\ move cursor
	0 do
		h_el @ emit
	loop
;

: f_single	( -- )	\ set frames to single
	sh_el h_el !
	sv_el v_el !
	slt_el lt_el !
	slb_el lb_el !
	srt_el rt_el !
	srb_el rb_el !
;

: f_double	( -- )	\ set frames to double
	dh_el h_el !
	dv_el v_el !
	dlt_el lt_el !
	dlb_el lb_el !
	drt_el rt_el !
	drb_el rb_el !
;

: vline	( len x y -- )	\ Draw vertical single line
	2dup 4 pick
	0 do
		at-xy
		v_el @ emit
		1+
		2dup
	loop
	2drop 2drop drop
;

: box	( w h x y -- )	\ Draw a box
	2dup 1+ 4 pick 1- -rot
	vline		\ Draw left vert line
	2dup 1+ swap 5 pick + swap 4 pick 1- -rot
	vline		\ Draw right vert line
	2dup swap 1+ swap 5 pick 1- -rot
	hline		\ Draw top horiz line
	2dup swap 1+ swap 4 pick + 5 pick 1- -rot
	hline		\ Draw bottom horiz line
	2dup at-xy lt_el @ emit	\ Draw left-top corner
	2dup 4 pick + at-xy lb_el @ emit	\ Draw left bottom corner
	2dup swap 5 pick + swap at-xy rt_el @ emit	\ Draw right top corner
	2 pick + swap 3 pick + swap at-xy rb_el @ emit
	2drop
;

f_single
fill_none fill !

\ Words implementing frame drawing
\ XXX Filled boxes are left as an exercise for the reader... ;-/
\ $FreeBSD$

marker task-frames.4th

variable h_el
variable v_el
variable lt_el
variable lb_el
variable rt_el
variable rb_el
variable fill

\ Single frames
196 constant sh_el
179 constant sv_el
218 constant slt_el
192 constant slb_el
191 constant srt_el
217 constant srb_el
\ Double frames
205 constant dh_el
186 constant dv_el
201 constant dlt_el
200 constant dlb_el
187 constant drt_el
188 constant drb_el
\ Fillings
0 constant fill_none
32 constant fill_blank
176 constant fill_dark
177 constant fill_med
178 constant fill_bright

: hline	( len x y -- )	\ Draw horizontal single line
	at-xy		\ move cursor
	0 do
		h_el @ emit
	loop
;

: f_single	( -- )	\ set frames to single
	sh_el h_el !
	sv_el v_el !
	slt_el lt_el !
	slb_el lb_el !
	srt_el rt_el !
	srb_el rb_el !
;

: f_double	( -- )	\ set frames to double
	dh_el h_el !
	dv_el v_el !
	dlt_el lt_el !
	dlb_el lb_el !
	drt_el rt_el !
	drb_el rb_el !
;

: vline	( len x y -- )	\ Draw vertical single line
	2dup 4 pick
	0 do
		at-xy
		v_el @ emit
		1+
		2dup
	loop
	2drop 2drop drop
;

: box	( w h x y -- )	\ Draw a box
	2dup 1+ 4 pick 1- -rot
	vline		\ Draw left vert line
	2dup 1+ swap 5 pick + swap 4 pick 1- -rot
	vline		\ Draw right vert line
	2dup swap 1+ swap 5 pick 1- -rot
	hline		\ Draw top horiz line
	2dup swap 1+ swap 4 pick + 5 pick 1- -rot
	hline		\ Draw bottom horiz line
	2dup at-xy lt_el @ emit	\ Draw left-top corner
	2dup 4 pick + at-xy lb_el @ emit	\ Draw left bottom corner
	2dup swap 5 pick + swap at-xy rt_el @ emit	\ Draw right top corner
	2 pick + swap 3 pick + swap at-xy rb_el @ emit
	2drop
;

f_single
fill_none fill !


The word environment? returns a flag indicating whether the variable was found or not. Fix it's usage. Alas, it caused no problem before, besides leaving garbage in the stack, because refill, used by [if] [else] [then], was broken.

\ Copyright (c) 1999 Daniel C. Sobral <dcs@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$

s" arch-alpha" environment? [if] [if]
	s" loader_version" environment?  [if]
		3 < [if]
			.( Loader version 0.3+ required) cr
			abort
		[then]
	[else]
		.( Could not get loader version!) cr
		abort
	[then]
[then] [then]

s" arch-i386" environment? [if] [if]
	s" loader_version" environment?  [if]
		8 < [if]
			.( Loader version 0.8+ required) cr
			abort
		[then]
	[else]
		.( Could not get loader version!) cr
		abort
	[then]
[then] [then]

include /boot/support.4th

only forth definitions also support-functions

\ ***** boot-conf
\
\	Prepares to boot as specified by loaded configuration files.

also support-functions definitions

: bootpath s" /boot/" ;
: modulepath s" module_path" ;
: saveenv ( addr len | 0 -1 -- addr' len | 0 -1 )
  dup -1 = if exit then
  dup allocate abort" Out of memory"
  swap 2dup 2>r
  move
  2r>
;
: freeenv ( addr len | 0 -1 )
  -1 = if drop else free abort" Freeing error" then
;
: restoreenv  ( addr len | 0 -1 -- )
  dup -1 = if ( it wasn't set )
    2drop
    modulepath unsetenv
  else
    over >r
    modulepath setenv
    r> free abort" Freeing error"
  then
;

only forth also support-functions also builtins definitions

: boot-conf  ( args 1 | 0 "args" -- flag )
  0 1 unload drop

  0= if ( interpreted )
    \ Get next word on the command line
    bl word count
    ?dup 0= if ( there wasn't anything )
      drop 0
    else ( put in the number of strings )
      1
    then
  then ( interpreted )

  if ( there are arguments )
    \ Try to load the kernel
    s" kernel_options" getenv dup -1 = if drop 2dup 1 else 2over 2 then

    1 load if ( load command failed )
      \ Remove garbage from the stack

      \ Set the environment variable module_path, and try loading
      \ the kernel again.

      \ First, save module_path value
      modulepath getenv saveenv dup -1 = if 0 swap then 2>r

      \ Sets the new value
      2dup modulepath setenv

      \ Try to load the kernel
      s" load ${kernel} ${kernel_options}" ['] evaluate catch
      if ( load failed yet again )
	\ Remove garbage from the stack
	2drop

	\ Try prepending /boot/
	bootpath 2over nip over + allocate
	if ( out of memory )
	  2drop 2drop
	  2r> restoreenv
	  100 exit
	then

	0 2swap strcat 2swap strcat
	2dup modulepath setenv

	drop free if ( freeing memory error )
	  2drop
	  2r> restoreenv
	  100 exit
	then

	\ Now, once more, try to load the kernel
	s" load ${kernel} ${kernel_options}" ['] evaluate catch
	if ( failed once more )
	  2drop
	  2r> restoreenv
	  100 exit
	then

      else ( we found the kernel on the path passed )

	2drop ( discard command line arguments )

      then ( could not load kernel from directory passed )

      \ Load the remaining modules, if the kernel was loaded at all
      ['] load_modules catch if 2r> restoreenv 100 exit then

      \ Call autoboot to perform the booting
      0 1 autoboot

      \ Keep new module_path
      2r> freeenv

      exit
    then ( could not load kernel with name passed )

    2drop ( discard command line arguments )

  else ( try just a straight-forward kernel load )
    s" load ${kernel} ${kernel_options}" ['] evaluate catch
    if ( kernel load failed ) 2drop 100 exit then

  then ( there are command line arguments )

  \ Load the remaining modules, if the kernel was loaded at all
  ['] load_modules catch if 100 exit then

  \ Call autoboot to perform the booting
  0 1 autoboot
;

also forth definitions
builtin: boot-conf
only forth definitions also support-functions

\ ***** check-password
\
\	If a password was defined, execute autoboot and ask for
\	password if autoboot returns.

: check-password
  password .addr @ if
    0 autoboot
    false >r
    begin
      bell emit bell emit
      ." Password: "
      password .len @ read-password
      dup password .len @ = if
        2dup password .addr @ password .len @
        compare 0= if r> drop true >r then
      then
      drop free drop
      r@
    until
    r> drop
  then
;

\ ***** start
\
\       Initializes support.4th global variables, sets loader_conf_files,
\       process conf files, and, if any one such file was succesfully
\       read to the end, load kernel and modules.

: start  ( -- ) ( throws: abort & user-defined )
  s" /boot/defaults/loader.conf" initialize
  include_conf_files
  \ Will *NOT* try to load kernel and modules if no configuration file
  \ was succesfully loaded!
  any_conf_read? if
    load_kernel
    load_modules
  then
;

\ ***** initialize
\
\	Overrides support.4th initialization word with one that does
\	everything start one does, short of loading the kernel and
\	modules. Returns a flag

: initialize ( -- flag )
  s" /boot/defaults/loader.conf" initialize
  include_conf_files
  any_conf_read?
;

\ ***** read-conf
\
\	Read a configuration file, whose name was specified on the command
\	line, if interpreted, or given on the stack, if compiled in.

: (read-conf)  ( addr len -- )
  conf_files .addr @ ?dup if free abort" Fatal error freeing memory" then
  strdup conf_files .len ! conf_files .addr !
  include_conf_files \ Will recurse on new loader_conf_files definitions
;

: read-conf  ( <filename> | addr len -- ) ( throws: abort & user-defined )
  state @ if
    \ Compiling
    postpone (read-conf)
  else
    \ Interpreting
    bl parse (read-conf)
  then
; immediate

\ ***** enable-module
\
\       Turn a module loading on.

: enable-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      true r> module.flag !
      ."  will be loaded." cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** disable-module
\
\       Turn a module loading off.

: disable-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      false r> module.flag !
      ."  will not be loaded." cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** toggle-module
\
\       Turn a module loading on/off.

: toggle-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      r@ module.flag @ 0= dup r> module.flag !
      if
        ."  will be loaded." cr
      else
        ."  will not be loaded." cr
      then
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** show-module
\
\	Show loading information about a module.

: show-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      ." Name: " r@ module.name dup .addr @ swap .len @ type cr
      ." Path: " r@ module.loadname dup .addr @ swap .len @ type cr
      ." Type: " r@ module.type dup .addr @ swap .len @ type cr
      ." Flags: " r@ module.args dup .addr @ swap .len @ type cr
      ." Before load: " r@ module.beforeload dup .addr @ swap .len @ type cr
      ." After load: " r@ module.afterload dup .addr @ swap .len @ type cr
      ." Error: " r@ module.loaderror dup .addr @ swap .len @ type cr
      ." Status: " r> module.flag @ if ." Load" else ." Don't load" then cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ Words to be used inside configuration files

: retry false ;         \ For use in load error commands
: ignore true ;         \ For use in load error commands

\ Return to strict forth vocabulary

only forth also

\ Copyright (c) 1999 Daniel C. Sobral <dcs@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$

s" arch-alpha" environment? [if]
s" loader_version" environment? 3 < abort" Loader version 0.3+ required"
[then]

s" arch-i386" environment? [if]
s" loader_version" environment? 8 < abort" Loader version 0.8+ required"
[then]

include /boot/support.4th

only forth definitions also support-functions

\ ***** boot-conf
\
\	Prepares to boot as specified by loaded configuration files.

also support-functions definitions

: bootpath s" /boot/" ;
: modulepath s" module_path" ;
: saveenv ( addr len | 0 -1 -- addr' len | 0 -1 )
  dup -1 = if exit then
  dup allocate abort" Out of memory"
  swap 2dup 2>r
  move
  2r>
;
: freeenv ( addr len | 0 -1 )
  -1 = if drop else free abort" Freeing error" then
;
: restoreenv  ( addr len | 0 -1 -- )
  dup -1 = if ( it wasn't set )
    2drop
    modulepath unsetenv
  else
    over >r
    modulepath setenv
    r> free abort" Freeing error"
  then
;

only forth also support-functions also builtins definitions

: boot-conf  ( args 1 | 0 "args" -- flag )
  0 1 unload drop

  0= if ( interpreted )
    \ Get next word on the command line
    bl word count
    ?dup 0= if ( there wasn't anything )
      drop 0
    else ( put in the number of strings )
      1
    then
  then ( interpreted )

  if ( there are arguments )
    \ Try to load the kernel
    s" kernel_options" getenv dup -1 = if drop 2dup 1 else 2over 2 then

    1 load if ( load command failed )
      \ Remove garbage from the stack

      \ Set the environment variable module_path, and try loading
      \ the kernel again.

      \ First, save module_path value
      modulepath getenv saveenv dup -1 = if 0 swap then 2>r

      \ Sets the new value
      2dup modulepath setenv

      \ Try to load the kernel
      s" load ${kernel} ${kernel_options}" ['] evaluate catch
      if ( load failed yet again )
	\ Remove garbage from the stack
	2drop

	\ Try prepending /boot/
	bootpath 2over nip over + allocate
	if ( out of memory )
	  2drop 2drop
	  2r> restoreenv
	  100 exit
	then

	0 2swap strcat 2swap strcat
	2dup modulepath setenv

	drop free if ( freeing memory error )
	  2drop
	  2r> restoreenv
	  100 exit
	then

	\ Now, once more, try to load the kernel
	s" load ${kernel} ${kernel_options}" ['] evaluate catch
	if ( failed once more )
	  2drop
	  2r> restoreenv
	  100 exit
	then

      else ( we found the kernel on the path passed )

	2drop ( discard command line arguments )

      then ( could not load kernel from directory passed )

      \ Load the remaining modules, if the kernel was loaded at all
      ['] load_modules catch if 2r> restoreenv 100 exit then

      \ Call autoboot to perform the booting
      0 1 autoboot

      \ Keep new module_path
      2r> freeenv

      exit
    then ( could not load kernel with name passed )

    2drop ( discard command line arguments )

  else ( try just a straight-forward kernel load )
    s" load ${kernel} ${kernel_options}" ['] evaluate catch
    if ( kernel load failed ) 2drop 100 exit then

  then ( there are command line arguments )

  \ Load the remaining modules, if the kernel was loaded at all
  ['] load_modules catch if 100 exit then

  \ Call autoboot to perform the booting
  0 1 autoboot
;

also forth definitions
builtin: boot-conf
only forth definitions also support-functions

\ ***** check-password
\
\	If a password was defined, execute autoboot and ask for
\	password if autoboot returns.

: check-password
  password .addr @ if
    0 autoboot
    false >r
    begin
      bell emit bell emit
      ." Password: "
      password .len @ read-password
      dup password .len @ = if
        2dup password .addr @ password .len @
        compare 0= if r> drop true >r then
      then
      drop free drop
      r@
    until
    r> drop
  then
;

\ ***** start
\
\       Initializes support.4th global variables, sets loader_conf_files,
\       process conf files, and, if any one such file was succesfully
\       read to the end, load kernel and modules.

: start  ( -- ) ( throws: abort & user-defined )
  s" /boot/defaults/loader.conf" initialize
  include_conf_files
  \ Will *NOT* try to load kernel and modules if no configuration file
  \ was succesfully loaded!
  any_conf_read? if
    load_kernel
    load_modules
  then
;

\ ***** initialize
\
\	Overrides support.4th initialization word with one that does
\	everything start one does, short of loading the kernel and
\	modules. Returns a flag

: initialize ( -- flag )
  s" /boot/defaults/loader.conf" initialize
  include_conf_files
  any_conf_read?
;

\ ***** read-conf
\
\	Read a configuration file, whose name was specified on the command
\	line, if interpreted, or given on the stack, if compiled in.

: (read-conf)  ( addr len -- )
  conf_files .addr @ ?dup if free abort" Fatal error freeing memory" then
  strdup conf_files .len ! conf_files .addr !
  include_conf_files \ Will recurse on new loader_conf_files definitions
;

: read-conf  ( <filename> | addr len -- ) ( throws: abort & user-defined )
  state @ if
    \ Compiling
    postpone (read-conf)
  else
    \ Interpreting
    bl parse (read-conf)
  then
; immediate

\ ***** enable-module
\
\       Turn a module loading on.

: enable-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      true r> module.flag !
      ."  will be loaded." cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** disable-module
\
\       Turn a module loading off.

: disable-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      false r> module.flag !
      ."  will not be loaded." cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** toggle-module
\
\       Turn a module loading on/off.

: toggle-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      r@ module.flag @ 0= dup r> module.flag !
      if
        ."  will be loaded." cr
      else
        ."  will not be loaded." cr
      then
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** show-module
\
\	Show loading information about a module.

: show-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      ." Name: " r@ module.name dup .addr @ swap .len @ type cr
      ." Path: " r@ module.loadname dup .addr @ swap .len @ type cr
      ." Type: " r@ module.type dup .addr @ swap .len @ type cr
      ." Flags: " r@ module.args dup .addr @ swap .len @ type cr
      ." Before load: " r@ module.beforeload dup .addr @ swap .len @ type cr
      ." After load: " r@ module.afterload dup .addr @ swap .len @ type cr
      ." Error: " r@ module.loaderror dup .addr @ swap .len @ type cr
      ." Status: " r> module.flag @ if ." Load" else ." Don't load" then cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ Words to be used inside configuration files

: retry false ;         \ For use in load error commands
: ignore true ;         \ For use in load error commands

\ Return to strict forth vocabulary

only forth also


What could possibly have possessed me to forget the "0 (arguments)"
in two of the three boot words in the "boot" redefinition, I have no
clue. Fix it.

Noticed by: bp
Noticed by: adrian

\ Copyright (c) 1999 Daniel C. Sobral <dcs@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$

s" arch-alpha" environment? [if] [if]
	s" loader_version" environment?  [if]
		11 < [if]
			.( Loader version 1.1+ required) cr
			abort
		[then]
	[else]
		.( Could not get loader version!) cr
		abort
	[then]
[then] [then]

s" arch-i386" environment? [if] [if]
	s" loader_version" environment?  [if]
		10 < [if]
			.( Loader version 1.0+ required) cr
			abort
		[then]
	[else]
		.( Could not get loader version!) cr
		abort
	[then]
[then] [then]

include /boot/support.4th

\ ***** boot-conf
\
\	Prepares to boot as specified by loaded configuration files.

only forth also support-functions also builtins definitions

: boot
  0= if ( interpreted ) get_arguments then

  \ Unload only if a path was passed
  dup if
    >r over r> swap
    c@ [char] - <> if
      0 1 unload drop
    else
      s" kernelname" getenv? 0= if ( no kernel has been loaded )
	load_kernel_and_modules
	?dup if exit then
      then
      0 1 boot exit
    then
  else
    s" kernelname" getenv? 0= if ( no kernel has been loaded )
      load_kernel_and_modules
      ?dup if exit then
    then
    0 1 boot exit
  then
  load_kernel_and_modules
  ?dup 0= if 0 1 boot then
;

: boot-conf
  0= if ( interpreted ) get_arguments then
  0 1 unload drop
  load_kernel_and_modules
  ?dup 0= if 0 1 autoboot then
;

also forth definitions also builtins

builtin: boot
builtin: boot-conf

only forth definitions also support-functions

\ ***** check-password
\
\	If a password was defined, execute autoboot and ask for
\	password if autoboot returns.

: check-password
  password .addr @ if
    0 autoboot
    false >r
    begin
      bell emit bell emit
      ." Password: "
      password .len @ read-password
      dup password .len @ = if
        2dup password .addr @ password .len @
        compare 0= if r> drop true >r then
      then
      drop free drop
      r@
    until
    r> drop
  then
;

\ ***** start
\
\       Initializes support.4th global variables, sets loader_conf_files,
\       process conf files, and, if any one such file was succesfully
\       read to the end, load kernel and modules.

: start  ( -- ) ( throws: abort & user-defined )
  s" /boot/defaults/loader.conf" initialize
  include_conf_files
  \ Will *NOT* try to load kernel and modules if no configuration file
  \ was succesfully loaded!
  any_conf_read? if
    load_kernel
    load_modules
  then
;

\ ***** initialize
\
\	Overrides support.4th initialization word with one that does
\	everything start one does, short of loading the kernel and
\	modules. Returns a flag

: initialize ( -- flag )
  s" /boot/defaults/loader.conf" initialize
  include_conf_files
  any_conf_read?
;

\ ***** read-conf
\
\	Read a configuration file, whose name was specified on the command
\	line, if interpreted, or given on the stack, if compiled in.

: (read-conf)  ( addr len -- )
  conf_files .addr @ ?dup if free abort" Fatal error freeing memory" then
  strdup conf_files .len ! conf_files .addr !
  include_conf_files \ Will recurse on new loader_conf_files definitions
;

: read-conf  ( <filename> | addr len -- ) ( throws: abort & user-defined )
  state @ if
    \ Compiling
    postpone (read-conf)
  else
    \ Interpreting
    bl parse (read-conf)
  then
; immediate

\ ***** enable-module
\
\       Turn a module loading on.

: enable-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      true r> module.flag !
      ."  will be loaded." cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** disable-module
\
\       Turn a module loading off.

: disable-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      false r> module.flag !
      ."  will not be loaded." cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** toggle-module
\
\       Turn a module loading on/off.

: toggle-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      r@ module.flag @ 0= dup r> module.flag !
      if
        ."  will be loaded." cr
      else
        ."  will not be loaded." cr
      then
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** show-module
\
\	Show loading information about a module.

: show-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      ." Name: " r@ module.name dup .addr @ swap .len @ type cr
      ." Path: " r@ module.loadname dup .addr @ swap .len @ type cr
      ." Type: " r@ module.type dup .addr @ swap .len @ type cr
      ." Flags: " r@ module.args dup .addr @ swap .len @ type cr
      ." Before load: " r@ module.beforeload dup .addr @ swap .len @ type cr
      ." After load: " r@ module.afterload dup .addr @ swap .len @ type cr
      ." Error: " r@ module.loaderror dup .addr @ swap .len @ type cr
      ." Status: " r> module.flag @ if ." Load" else ." Don't load" then cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ Words to be used inside configuration files

: retry false ;         \ For use in load error commands
: ignore true ;         \ For use in load error commands

\ Return to strict forth vocabulary

: #type
  over - >r
  type
  r> spaces
;

: .? 2 spaces 2swap 15 #type 2 spaces type cr ;

: ?
  ['] ? execute
  s" boot-conf" s" load kernel and modules, then autoboot" .?
  s" read-conf" s" read a configuration file" .?
  s" enable-module" s" enable loading of a module" .?
  s" disable-module" s" disable loading of a module" .?
  s" toggle-module" s" toggle loading of a module" .?
  s" show-module" s" show module load data" .?
;

only forth also

\ Copyright (c) 1999 Daniel C. Sobral <dcs@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$

s" arch-alpha" environment? [if] [if]
	s" loader_version" environment?  [if]
		11 < [if]
			.( Loader version 1.1+ required) cr
			abort
		[then]
	[else]
		.( Could not get loader version!) cr
		abort
	[then]
[then] [then]

s" arch-i386" environment? [if] [if]
	s" loader_version" environment?  [if]
		10 < [if]
			.( Loader version 1.0+ required) cr
			abort
		[then]
	[else]
		.( Could not get loader version!) cr
		abort
	[then]
[then] [then]

include /boot/support.4th

\ ***** boot-conf
\
\	Prepares to boot as specified by loaded configuration files.

only forth also support-functions also builtins definitions

: boot
  0= if ( interpreted ) get_arguments then

  \ Unload only if a path was passed
  dup if
    >r over r> swap
    c@ [char] - <> if
      0 1 unload drop
    else
      s" kernelname" getenv? 0= if ( no kernel has been loaded )
	load_kernel_and_modules
	?dup if exit then
      then
      1 boot exit
    then
  else
    s" kernelname" getenv? 0= if ( no kernel has been loaded )
      load_kernel_and_modules
      ?dup if exit then
    then
    1 boot exit
  then
  load_kernel_and_modules
  ?dup 0= if 0 1 boot then
;

: boot-conf
  0= if ( interpreted ) get_arguments then
  0 1 unload drop
  load_kernel_and_modules
  ?dup 0= if 0 1 autoboot then
;

also forth definitions also builtins

builtin: boot
builtin: boot-conf

only forth definitions also support-functions

\ ***** check-password
\
\	If a password was defined, execute autoboot and ask for
\	password if autoboot returns.

: check-password
  password .addr @ if
    0 autoboot
    false >r
    begin
      bell emit bell emit
      ." Password: "
      password .len @ read-password
      dup password .len @ = if
        2dup password .addr @ password .len @
        compare 0= if r> drop true >r then
      then
      drop free drop
      r@
    until
    r> drop
  then
;

\ ***** start
\
\       Initializes support.4th global variables, sets loader_conf_files,
\       process conf files, and, if any one such file was succesfully
\       read to the end, load kernel and modules.

: start  ( -- ) ( throws: abort & user-defined )
  s" /boot/defaults/loader.conf" initialize
  include_conf_files
  \ Will *NOT* try to load kernel and modules if no configuration file
  \ was succesfully loaded!
  any_conf_read? if
    load_kernel
    load_modules
  then
;

\ ***** initialize
\
\	Overrides support.4th initialization word with one that does
\	everything start one does, short of loading the kernel and
\	modules. Returns a flag

: initialize ( -- flag )
  s" /boot/defaults/loader.conf" initialize
  include_conf_files
  any_conf_read?
;

\ ***** read-conf
\
\	Read a configuration file, whose name was specified on the command
\	line, if interpreted, or given on the stack, if compiled in.

: (read-conf)  ( addr len -- )
  conf_files .addr @ ?dup if free abort" Fatal error freeing memory" then
  strdup conf_files .len ! conf_files .addr !
  include_conf_files \ Will recurse on new loader_conf_files definitions
;

: read-conf  ( <filename> | addr len -- ) ( throws: abort & user-defined )
  state @ if
    \ Compiling
    postpone (read-conf)
  else
    \ Interpreting
    bl parse (read-conf)
  then
; immediate

\ ***** enable-module
\
\       Turn a module loading on.

: enable-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      true r> module.flag !
      ."  will be loaded." cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** disable-module
\
\       Turn a module loading off.

: disable-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      false r> module.flag !
      ."  will not be loaded." cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** toggle-module
\
\       Turn a module loading on/off.

: toggle-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      r@ module.flag @ 0= dup r> module.flag !
      if
        ."  will be loaded." cr
      else
        ."  will not be loaded." cr
      then
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** show-module
\
\	Show loading information about a module.

: show-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      ." Name: " r@ module.name dup .addr @ swap .len @ type cr
      ." Path: " r@ module.loadname dup .addr @ swap .len @ type cr
      ." Type: " r@ module.type dup .addr @ swap .len @ type cr
      ." Flags: " r@ module.args dup .addr @ swap .len @ type cr
      ." Before load: " r@ module.beforeload dup .addr @ swap .len @ type cr
      ." After load: " r@ module.afterload dup .addr @ swap .len @ type cr
      ." Error: " r@ module.loaderror dup .addr @ swap .len @ type cr
      ." Status: " r> module.flag @ if ." Load" else ." Don't load" then cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ Words to be used inside configuration files

: retry false ;         \ For use in load error commands
: ignore true ;         \ For use in load error commands

\ Return to strict forth vocabulary

: #type
  over - >r
  type
  r> spaces
;

: .? 2 spaces 2swap 15 #type 2 spaces type cr ;

: ?
  ['] ? execute
  s" boot-conf" s" load kernel and modules, then autoboot" .?
  s" read-conf" s" read a configuration file" .?
  s" enable-module" s" enable loading of a module" .?
  s" disable-module" s" disable loading of a module" .?
  s" toggle-module" s" toggle loading of a module" .?
  s" show-module" s" show module load data" .?
;

only forth also


Get rid of a spurious warning on the console when booting the kernel
from the interactive loader(8) prompt and beastie_disable="YES" is set
in loader.conf(5). In this case menu.rc is not evaluated and consequently
menu-unset does not have a body yet. This results in the ficl warning
"menu-unset not found" when try-menu-unset invokes menu-unset.

Check for beastie_disable="YES" explicitly, so that the try-menu-unset
word will not attempt to invoke menu-unset because the menu will have
never been configured. [1]
Use the sfind primitive as a last resort as an additional safer approach
conjuring a foreign word safely. [2]

PR:		kern/163938
Submitted by:	Devin Teske [1]
Reviewed by:	Devin Teske [2]
Reported and tested by:	dim
MFC after:	1 week
X-MFC with:	r228985