sys/boot/forth/loader.4th

   1 \ Copyright (c) 1999 Daniel C. Sobral <dcs@freebsd.org>
   2 \ All rights reserved.
   3 \
   4 \ Redistribution and use in source and binary forms, with or without
   5 \ modification, are permitted provided that the following conditions
   6 \ are met:
   7 \ 1. Redistributions of source code must retain the above copyright
   8 \    notice, this list of conditions and the following disclaimer.
   9 \ 2. Redistributions in binary form must reproduce the above copyright
  10 \    notice, this list of conditions and the following disclaimer in the
  11 \    documentation and/or other materials provided with the distribution.
  12 \
  13 \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
  14 \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  15 \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  16 \ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
  17 \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  18 \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  19 \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  20 \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  21 \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  22 \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  23 \ SUCH DAMAGE.
  24 \
  25 \ $FreeBSD: src/sys/boot/forth/loader.4th,v 1.5.2.1 2000/07/07 00:14:34 obrien Exp $
  26 \ $DragonFly: src/sys/boot/forth/loader.4th,v 1.2 2003/06/17 04:28:18 dillon Exp $
  27
  28 s" arch-alpha" environment? [if] [if]
  29         s" loader_version" environment?  [if]
  30                 3 < [if]
  31                         .( Loader version 0.3+ required) cr
  32                         abort
  33                 [then]
  34         [else]
  35                 .( Could not get loader version!) cr
  36                 abort
  37         [then]
  38 [then] [then]
  39
  40 s" arch-i386" environment? [if] [if]
  41         s" loader_version" environment?  [if]
  42                 8 < [if]
  43                         .( Loader version 0.8+ required) cr
  44                         abort
  45                 [then]
  46         [else]
  47                 .( Could not get loader version!) cr
  48                 abort
  49         [then]
  50 [then] [then]
  51
  52 include /boot/support.4th
  53
  54 only forth definitions also support-functions
  55
  56 \ ***** boot-conf
  57 \
  58 \       Prepares to boot as specified by loaded configuration files.
  59
  60 also support-functions definitions
  61
  62 : bootpath s" /boot/" ;
  63 : modulepath s" module_path" ;
  64 : saveenv ( addr len | 0 -1 -- addr' len | 0 -1 )
  65   dup -1 = if exit then
  66   dup allocate abort" Out of memory"
  67   swap 2dup 2>r
  68   move
  69   2r>
  70 ;
  71 : freeenv ( addr len | 0 -1 )
  72   -1 = if drop else free abort" Freeing error" then
  73 ;
  74 : restoreenv  ( addr len | 0 -1 -- )
  75   dup -1 = if ( it wasn't set )
  76     2drop
  77     modulepath unsetenv
  78   else
  79     over >r
  80     modulepath setenv
  81     r> free abort" Freeing error"
  82   then
  83 ;
  84
  85 only forth also support-functions also builtins definitions
  86
  87 : boot-conf  ( args 1 | 0 "args" -- flag )
  88   0 1 unload drop
  89
  90   0= if ( interpreted )
  91     \ Get next word on the command line
  92     bl word count
  93     ?dup 0= if ( there wasn't anything )
  94       drop 0
  95     else ( put in the number of strings )
  96       1
  97     then
  98   then ( interpreted )
  99
 100   if ( there are arguments )
 101     \ Try to load the kernel
 102     s" kernel_options" getenv dup -1 = if drop 2dup 1 else 2over 2 then
 103
 104     1 load if ( load command failed )
 105       \ Remove garbage from the stack
 106
 107       \ Set the environment variable module_path, and try loading
 108       \ the kernel again.
 109
 110       \ First, save module_path value
 111       modulepath getenv saveenv dup -1 = if 0 swap then 2>r
 112
 113       \ Sets the new value
 114       2dup modulepath setenv
 115
 116       \ Try to load the kernel
 117       s" load ${kernel} ${kernel_options}" ['] evaluate catch
 118       if ( load failed yet again )
 119         \ Remove garbage from the stack
 120         2drop
 121
 122         \ Try prepending /boot/
 123         bootpath 2over nip over + allocate
 124         if ( out of memory )
 125           2drop 2drop
 126           2r> restoreenv
 127           100 exit
 128         then
 129
 130         0 2swap strcat 2swap strcat
 131         2dup modulepath setenv
 132
 133         drop free if ( freeing memory error )
 134           2drop
 135           2r> restoreenv
 136           100 exit
 137         then
 138
 139         \ Now, once more, try to load the kernel
 140         s" load ${kernel} ${kernel_options}" ['] evaluate catch
 141         if ( failed once more )
 142           2drop
 143           2r> restoreenv
 144           100 exit
 145         then
 146
 147       else ( we found the kernel on the path passed )
 148
 149         2drop ( discard command line arguments )
 150
 151       then ( could not load kernel from directory passed )
 152
 153       \ Load the remaining modules, if the kernel was loaded at all
 154       ['] load_modules catch if 2r> restoreenv 100 exit then
 155
 156       \ Call autoboot to perform the booting
 157       0 1 autoboot
 158
 159       \ Keep new module_path
 160       2r> freeenv
 161
 162       exit
 163     then ( could not load kernel with name passed )
 164
 165     2drop ( discard command line arguments )
 166
 167   else ( try just a straight-forward kernel load )
 168     s" load ${kernel} ${kernel_options}" ['] evaluate catch
 169     if ( kernel load failed ) 2drop 100 exit then
 170
 171   then ( there are command line arguments )
 172
 173   \ Load the remaining modules, if the kernel was loaded at all
 174   ['] load_modules catch if 100 exit then
 175
 176   \ Call autoboot to perform the booting
 177   0 1 autoboot
 178 ;
 179
 180 also forth definitions
 181 builtin: boot-conf
 182 only forth definitions also support-functions
 183
 184 \ ***** check-password
 185 \
 186 \       If a password was defined, execute autoboot and ask for
 187 \       password if autoboot returns.
 188
 189 : check-password
 190   password .addr @ if
 191     0 autoboot
 192     false >r
 193     begin
 194       bell emit bell emit
 195       ." Password: "
 196       password .len @ read-password
 197       dup password .len @ = if
 198         2dup password .addr @ password .len @
 199         compare 0= if r> drop true >r then
 200       then
 201       drop free drop
 202       r@
 203     until
 204     r> drop
 205   then
 206 ;
 207
 208 \ ***** start
 209 \
 210 \       Initializes support.4th global variables, sets loader_conf_files,
 211 \       process conf files, and, if any one such file was succesfully
 212 \       read to the end, load kernel and modules.
 213
 214 : start  ( -- ) ( throws: abort & user-defined )
 215   s" /boot/defaults/loader.conf" initialize
 216   include_conf_files
 217   \ Will *NOT* try to load kernel and modules if no configuration file
 218   \ was succesfully loaded!
 219   any_conf_read? if
 220     load_kernel
 221     load_modules
 222   then
 223 ;
 224
 225 \ ***** initialize
 226 \
 227 \       Overrides support.4th initialization word with one that does
 228 \       everything start one does, short of loading the kernel and
 229 \       modules. Returns a flag
 230
 231 : initialize ( -- flag )
 232   s" /boot/defaults/loader.conf" initialize
 233   include_conf_files
 234   any_conf_read?
 235 ;
 236
 237 \ ***** read-conf
 238 \
 239 \       Read a configuration file, whose name was specified on the command
 240 \       line, if interpreted, or given on the stack, if compiled in.
 241
 242 : (read-conf)  ( addr len -- )
 243   conf_files .addr @ ?dup if free abort" Fatal error freeing memory" then
 244   strdup conf_files .len ! conf_files .addr !
 245   include_conf_files \ Will recurse on new loader_conf_files definitions
 246 ;
 247
 248 : read-conf  ( <filename> | addr len -- ) ( throws: abort & user-defined )
 249   state @ if
 250     \ Compiling
 251     postpone (read-conf)
 252   else
 253     \ Interpreting
 254     bl parse (read-conf)
 255   then
 256 ; immediate
 257
 258 \ ***** enable-module
 259 \
 260 \       Turn a module loading on.
 261
 262 : enable-module ( <module> -- )
 263   bl parse module_options @ >r
 264   begin
 265     r@
 266   while
 267     2dup
 268     r@ module.name dup .addr @ swap .len @
 269     compare 0= if
 270       2drop
 271       r@ module.name dup .addr @ swap .len @ type
 272       true r> module.flag !
 273       ."  will be loaded." cr
 274       exit
 275     then
 276     r> module.next @ >r
 277   repeat
 278   r> drop
 279   type ."  wasn't found." cr
 280 ;
 281
 282 \ ***** disable-module
 283 \
 284 \       Turn a module loading off.
 285
 286 : disable-module ( <module> -- )
 287   bl parse module_options @ >r
 288   begin
 289     r@
 290   while
 291     2dup
 292     r@ module.name dup .addr @ swap .len @
 293     compare 0= if
 294       2drop
 295       r@ module.name dup .addr @ swap .len @ type
 296       false r> module.flag !
 297       ."  will not be loaded." cr
 298       exit
 299     then
 300     r> module.next @ >r
 301   repeat
 302   r> drop
 303   type ."  wasn't found." cr
 304 ;
 305
 306 \ ***** toggle-module
 307 \
 308 \       Turn a module loading on/off.
 309
 310 : toggle-module ( <module> -- )
 311   bl parse module_options @ >r
 312   begin
 313     r@
 314   while
 315     2dup
 316     r@ module.name dup .addr @ swap .len @
 317     compare 0= if
 318       2drop
 319       r@ module.name dup .addr @ swap .len @ type
 320       r@ module.flag @ 0= dup r> module.flag !
 321       if
 322         ."  will be loaded." cr
 323       else
 324         ."  will not be loaded." cr
 325       then
 326       exit
 327     then
 328     r> module.next @ >r
 329   repeat
 330   r> drop
 331   type ."  wasn't found." cr
 332 ;
 333
 334 \ ***** show-module
 335 \
 336 \       Show loading information about a module.
 337
 338 : show-module ( <module> -- )
 339   bl parse module_options @ >r
 340   begin
 341     r@
 342   while
 343     2dup
 344     r@ module.name dup .addr @ swap .len @
 345     compare 0= if
 346       2drop
 347       ." Name: " r@ module.name dup .addr @ swap .len @ type cr
 348       ." Path: " r@ module.loadname dup .addr @ swap .len @ type cr
 349       ." Type: " r@ module.type dup .addr @ swap .len @ type cr
 350       ." Flags: " r@ module.args dup .addr @ swap .len @ type cr
 351       ." Before load: " r@ module.beforeload dup .addr @ swap .len @ type cr
 352       ." After load: " r@ module.afterload dup .addr @ swap .len @ type cr
 353       ." Error: " r@ module.loaderror dup .addr @ swap .len @ type cr
 354       ." Status: " r> module.flag @ if ." Load" else ." Don't load" then cr
 355       exit
 356     then
 357     r> module.next @ >r
 358   repeat
 359   r> drop
 360   type ."  wasn't found." cr
 361 ;
 362
 363 \ Words to be used inside configuration files
 364
 365 : retry false ;         \ For use in load error commands
 366 : ignore true ;         \ For use in load error commands
 367
 368 \ Return to strict forth vocabulary
 369
 370 only forth also
 371