\ Copyright (c) 1999 Daniel C. Sobral \ 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 ; : set-tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) \ No options, set the default ones dup 0= if s" kernel_options" getenv dup -1 = if drop else s" temp_options" setenv then exit then \ Skip filename 2 pick c@ [char] - <> if swap >r swap >r 1 >r \ Filename present 1 - \ One less argument else 0 >r \ Filename not present then \ If no other arguments exist, use default options ?dup 0= if s" kernel_options" getenv dup -1 = if drop else s" temp_options" setenv then \ Put filename back on the stack, if necessary r> if r> r> 1 else 0 then exit then \ Concatenate remaining arguments into a single string >r strdup r> 1 ?do \ Allocate new buffer 2over nip over + 1+ allocate if out_of_memory throw then \ Copy old buffer over 0 2swap over >r strcat \ Free old buffer r> free if free_error throw then \ Copy a space s" " strcat \ Copy next string (do not free) 2swap strcat loop \ Set temp_options variable, free whatever memory that needs freeing over >r s" temp_options" setenv r> free if free_error throw then \ Put filename back on the stack, if necessary r> if r> r> 1 else 0 then ; : get-arguments ( -- addrN lenN ... addr1 len1 N ) 0 begin \ Get next word on the command line parse-word ?dup while 2>r ( push to the rstack, so we can retrieve in the correct order ) 1+ repeat drop ( empty string ) dup begin dup while 2r> rot >r rot r> 1 - repeat drop ; also builtins : load-kernel ( addr len -- addr len error? ) s" temp_options" getenv dup -1 = if drop 2dup 1 else 2over 2 then 1 load ; : load-conf ( args 1 | 0 "args" -- flag ) 0 1 unload drop 0= if ( interpreted ) get-arguments then set-tempoptions if ( there are arguments ) load-kernel if ( load command failed ) \ 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} ${temp_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} ${temp_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 \ Return 0 to indicate success 0 \ 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} ${temp_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 \ Return 0 to indicate success 0 ; only forth also support-functions also builtins definitions : boot load-conf ?dup 0= if 0 1 boot then ; : boot-conf load-conf ?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 ( | 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 ( -- ) 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 ( -- ) 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 ( -- ) 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 ( -- ) 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