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\
| 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: head/sys/boot/forth/loader.4th 65621 2000-09-08 21:11:57Z dcs $
| 25\ $FreeBSD: head/sys/boot/forth/loader.4th 65630 2000-09-09 04:52:34Z dcs $
|
26
27s" arch-alpha" environment? [if] [if]
28 s" loader_version" environment? [if]
29 3 < [if]
30 .( Loader version 0.3+ required) cr
31 abort
32 [then]
33 [else]
34 .( Could not get loader version!) cr
35 abort
36 [then]
37[then] [then]
38
39s" arch-i386" environment? [if] [if]
40 s" loader_version" environment? [if]
41 8 < [if]
42 .( Loader version 0.8+ required) cr
43 abort
44 [then]
45 [else]
46 .( Could not get loader version!) cr
47 abort
48 [then]
49[then] [then]
50
51include /boot/support.4th
52
53only forth definitions also support-functions
54
55\ ***** boot-conf
56\
57\ Prepares to boot as specified by loaded configuration files.
58
59also support-functions definitions
60
| 26
27s" arch-alpha" environment? [if] [if]
28 s" loader_version" environment? [if]
29 3 < [if]
30 .( Loader version 0.3+ required) cr
31 abort
32 [then]
33 [else]
34 .( Could not get loader version!) cr
35 abort
36 [then]
37[then] [then]
38
39s" arch-i386" environment? [if] [if]
40 s" loader_version" environment? [if]
41 8 < [if]
42 .( Loader version 0.8+ required) cr
43 abort
44 [then]
45 [else]
46 .( Could not get loader version!) cr
47 abort
48 [then]
49[then] [then]
50
51include /boot/support.4th
52
53only forth definitions also support-functions
54
55\ ***** boot-conf
56\
57\ Prepares to boot as specified by loaded configuration files.
58
59also support-functions definitions
60
|
61: bootpath s" /boot/" ;
62: modulepath s" module_path" ;
63
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
72: freeenv ( addr len | 0 -1 )
73 -1 = if drop else free abort" Freeing error" then
74;
75
76: restoreenv ( addr len | 0 -1 -- )
77 dup -1 = if ( it wasn't set )
78 2drop
79 modulepath unsetenv
80 else
81 over >r
82 modulepath setenv
83 r> free abort" Freeing error"
84 then
85;
86
| |
87: set-tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
88 \ No options, set the default ones
89 dup 0= if
90 s" kernel_options" getenv dup -1 = if
91 drop
92 else
93 s" temp_options" setenv
94 then
95 exit
96 then
97
98 \ Skip filename
99 2 pick
100 c@
101 [char] - <> if
102 swap >r swap >r
103 1 >r \ Filename present
104 1 - \ One less argument
105 else
106 0 >r \ Filename not present
107 then
108
109 \ If no other arguments exist, use default options
110 ?dup 0= if
111 s" kernel_options" getenv dup -1 = if
112 drop
113 else
114 s" temp_options" setenv
115 then
116 \ Put filename back on the stack, if necessary
117 r> if r> r> 1 else 0 then
118 exit
119 then
120
121 \ Concatenate remaining arguments into a single string
122 >r strdup r>
123 1 ?do
124 \ Allocate new buffer
125 2over nip over + 1+
126 allocate if out_of_memory throw then
127 \ Copy old buffer over
128 0 2swap over >r strcat
129 \ Free old buffer
130 r> free if free_error throw then
131 \ Copy a space
132 s" " strcat
133 \ Copy next string (do not free)
134 2swap strcat
135 loop
136
137 \ Set temp_options variable, free whatever memory that needs freeing
138 over >r
139 s" temp_options" setenv
140 r> free if free_error throw then
141
142 \ Put filename back on the stack, if necessary
143 r> if r> r> 1 else 0 then
144;
145
146: get-arguments ( -- addrN lenN ... addr1 len1 N )
147 0
148 begin
149 \ Get next word on the command line
150 parse-word
151 ?dup while
152 2>r ( push to the rstack, so we can retrieve in the correct order )
153 1+
154 repeat
155 drop ( empty string )
156 dup
157 begin
158 dup
159 while
160 2r> rot
161 >r rot r>
162 1 -
163 repeat
164 drop
165;
166
167also builtins
168
| 61: set-tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
62 \ No options, set the default ones
63 dup 0= if
64 s" kernel_options" getenv dup -1 = if
65 drop
66 else
67 s" temp_options" setenv
68 then
69 exit
70 then
71
72 \ Skip filename
73 2 pick
74 c@
75 [char] - <> if
76 swap >r swap >r
77 1 >r \ Filename present
78 1 - \ One less argument
79 else
80 0 >r \ Filename not present
81 then
82
83 \ If no other arguments exist, use default options
84 ?dup 0= if
85 s" kernel_options" getenv dup -1 = if
86 drop
87 else
88 s" temp_options" setenv
89 then
90 \ Put filename back on the stack, if necessary
91 r> if r> r> 1 else 0 then
92 exit
93 then
94
95 \ Concatenate remaining arguments into a single string
96 >r strdup r>
97 1 ?do
98 \ Allocate new buffer
99 2over nip over + 1+
100 allocate if out_of_memory throw then
101 \ Copy old buffer over
102 0 2swap over >r strcat
103 \ Free old buffer
104 r> free if free_error throw then
105 \ Copy a space
106 s" " strcat
107 \ Copy next string (do not free)
108 2swap strcat
109 loop
110
111 \ Set temp_options variable, free whatever memory that needs freeing
112 over >r
113 s" temp_options" setenv
114 r> free if free_error throw then
115
116 \ Put filename back on the stack, if necessary
117 r> if r> r> 1 else 0 then
118;
119
120: get-arguments ( -- addrN lenN ... addr1 len1 N )
121 0
122 begin
123 \ Get next word on the command line
124 parse-word
125 ?dup while
126 2>r ( push to the rstack, so we can retrieve in the correct order )
127 1+
128 repeat
129 drop ( empty string )
130 dup
131 begin
132 dup
133 while
134 2r> rot
135 >r rot r>
136 1 -
137 repeat
138 drop
139;
140
141also builtins
142
|
169: load-kernel ( addr len -- addr len error? )
170 s" temp_options" getenv dup -1 = if
171 drop 2dup 1
172 else
173 2over 2
174 then
175
176 1 load
177;
178
| |
179: load-conf ( args 1 | 0 "args" -- flag )
| 143: load-conf ( args 1 | 0 "args" -- flag )
|
180 0 1 unload drop
181
| |
182 0= if ( interpreted ) get-arguments then
183 set-tempoptions
| 144 0= if ( interpreted ) get-arguments then
145 set-tempoptions
|
184
185 if ( there are arguments )
186 load-kernel if ( load command failed )
187 \ Set the environment variable module_path, and try loading
188 \ the kernel again.
189
190 \ First, save module_path value
191 modulepath getenv saveenv dup -1 = if 0 swap then 2>r
192
193 \ Sets the new value
194 2dup modulepath setenv
195
196 \ Try to load the kernel
197 s" load ${kernel} ${temp_options}" ['] evaluate catch
198 if ( load failed yet again )
199 \ Remove garbage from the stack
200 2drop
201
202 \ Try prepending /boot/
203 bootpath 2over nip over + allocate
204 if ( out of memory )
205 2drop 2drop
206 2r> restoreenv
207 100 exit
208 then
209
210 0 2swap strcat 2swap strcat
211 2dup modulepath setenv
212
213 drop free if ( freeing memory error )
214 2drop
215 2r> restoreenv
216 100 exit
217 then
218
219 \ Now, once more, try to load the kernel
220 s" load ${kernel} ${temp_options}" ['] evaluate catch
221 if ( failed once more )
222 2drop
223 2r> restoreenv
224 100 exit
225 then
226
227 else ( we found the kernel on the path passed )
228
229 2drop ( discard command line arguments )
230
231 then ( could not load kernel from directory passed )
232
233 \ Load the remaining modules, if the kernel was loaded at all
234 ['] load_modules catch if 2r> restoreenv 100 exit then
235
236 \ Return 0 to indicate success
237 0
238
239 \ Keep new module_path
240 2r> freeenv
241
242 exit
243 then ( could not load kernel with name passed )
244
245 2drop ( discard command line arguments )
246
247 else ( try just a straight-forward kernel load )
248 s" load ${kernel} ${temp_options}" ['] evaluate catch
249 if ( kernel load failed ) 2drop 100 exit then
250
251 then ( there are command line arguments )
252
253 \ Load the remaining modules, if the kernel was loaded at all
254 ['] load_modules catch if 100 exit then
255
256 \ Return 0 to indicate success
257 0
| 146 s" temp_options" getenv -1 <> if 2swap 2 else 1 then
147 load_kernel_and_modules
|
258;
259
260only forth also support-functions also builtins definitions
261
262: boot
| 148;
149
150only forth also support-functions also builtins definitions
151
152: boot
|
| 153 \ Unload only if a path was passed
154 >in @ parse-word rot >in !
155 if
156 c@ [char] - <> if
157 0 1 unload drop
158 else
159 get-arguments 1 boot exit
160 then
161 else
162 0 1 boot exit
163 then
|
263 load-conf
264 ?dup 0= if 0 1 boot then
265;
266
267: boot-conf
| 164 load-conf
165 ?dup 0= if 0 1 boot then
166;
167
168: boot-conf
|
| 169 0 1 unload drop
|
268 load-conf
269 ?dup 0= if 0 1 autoboot then
270;
271
272also forth definitions also builtins
273builtin: boot
274builtin: boot-conf
275only forth definitions also support-functions
276
277\ ***** check-password
278\
279\ If a password was defined, execute autoboot and ask for
280\ password if autoboot returns.
281
282: check-password
283 password .addr @ if
284 0 autoboot
285 false >r
286 begin
287 bell emit bell emit
288 ." Password: "
289 password .len @ read-password
290 dup password .len @ = if
291 2dup password .addr @ password .len @
292 compare 0= if r> drop true >r then
293 then
294 drop free drop
295 r@
296 until
297 r> drop
298 then
299;
300
301\ ***** start
302\
303\ Initializes support.4th global variables, sets loader_conf_files,
304\ process conf files, and, if any one such file was succesfully
305\ read to the end, load kernel and modules.
306
307: start ( -- ) ( throws: abort & user-defined )
308 s" /boot/defaults/loader.conf" initialize
309 include_conf_files
310 \ Will *NOT* try to load kernel and modules if no configuration file
311 \ was succesfully loaded!
312 any_conf_read? if
313 load_kernel
314 load_modules
315 then
316;
317
318\ ***** initialize
319\
320\ Overrides support.4th initialization word with one that does
321\ everything start one does, short of loading the kernel and
322\ modules. Returns a flag
323
324: initialize ( -- flag )
325 s" /boot/defaults/loader.conf" initialize
326 include_conf_files
327 any_conf_read?
328;
329
330\ ***** read-conf
331\
332\ Read a configuration file, whose name was specified on the command
333\ line, if interpreted, or given on the stack, if compiled in.
334
335: (read-conf) ( addr len -- )
336 conf_files .addr @ ?dup if free abort" Fatal error freeing memory" then
337 strdup conf_files .len ! conf_files .addr !
338 include_conf_files \ Will recurse on new loader_conf_files definitions
339;
340
341: read-conf ( <filename> | addr len -- ) ( throws: abort & user-defined )
342 state @ if
343 \ Compiling
344 postpone (read-conf)
345 else
346 \ Interpreting
347 bl parse (read-conf)
348 then
349; immediate
350
351\ ***** enable-module
352\
353\ Turn a module loading on.
354
355: enable-module ( <module> -- )
356 bl parse module_options @ >r
357 begin
358 r@
359 while
360 2dup
361 r@ module.name dup .addr @ swap .len @
362 compare 0= if
363 2drop
364 r@ module.name dup .addr @ swap .len @ type
365 true r> module.flag !
366 ." will be loaded." cr
367 exit
368 then
369 r> module.next @ >r
370 repeat
371 r> drop
372 type ." wasn't found." cr
373;
374
375\ ***** disable-module
376\
377\ Turn a module loading off.
378
379: disable-module ( <module> -- )
380 bl parse module_options @ >r
381 begin
382 r@
383 while
384 2dup
385 r@ module.name dup .addr @ swap .len @
386 compare 0= if
387 2drop
388 r@ module.name dup .addr @ swap .len @ type
389 false r> module.flag !
390 ." will not be loaded." cr
391 exit
392 then
393 r> module.next @ >r
394 repeat
395 r> drop
396 type ." wasn't found." cr
397;
398
399\ ***** toggle-module
400\
401\ Turn a module loading on/off.
402
403: toggle-module ( <module> -- )
404 bl parse module_options @ >r
405 begin
406 r@
407 while
408 2dup
409 r@ module.name dup .addr @ swap .len @
410 compare 0= if
411 2drop
412 r@ module.name dup .addr @ swap .len @ type
413 r@ module.flag @ 0= dup r> module.flag !
414 if
415 ." will be loaded." cr
416 else
417 ." will not be loaded." cr
418 then
419 exit
420 then
421 r> module.next @ >r
422 repeat
423 r> drop
424 type ." wasn't found." cr
425;
426
427\ ***** show-module
428\
429\ Show loading information about a module.
430
431: show-module ( <module> -- )
432 bl parse module_options @ >r
433 begin
434 r@
435 while
436 2dup
437 r@ module.name dup .addr @ swap .len @
438 compare 0= if
439 2drop
440 ." Name: " r@ module.name dup .addr @ swap .len @ type cr
441 ." Path: " r@ module.loadname dup .addr @ swap .len @ type cr
442 ." Type: " r@ module.type dup .addr @ swap .len @ type cr
443 ." Flags: " r@ module.args dup .addr @ swap .len @ type cr
444 ." Before load: " r@ module.beforeload dup .addr @ swap .len @ type cr
445 ." After load: " r@ module.afterload dup .addr @ swap .len @ type cr
446 ." Error: " r@ module.loaderror dup .addr @ swap .len @ type cr
447 ." Status: " r> module.flag @ if ." Load" else ." Don't load" then cr
448 exit
449 then
450 r> module.next @ >r
451 repeat
452 r> drop
453 type ." wasn't found." cr
454;
455
456\ Words to be used inside configuration files
457
458: retry false ; \ For use in load error commands
459: ignore true ; \ For use in load error commands
460
461\ Return to strict forth vocabulary
462
463only forth also
464
| 170 load-conf
171 ?dup 0= if 0 1 autoboot then
172;
173
174also forth definitions also builtins
175builtin: boot
176builtin: boot-conf
177only forth definitions also support-functions
178
179\ ***** check-password
180\
181\ If a password was defined, execute autoboot and ask for
182\ password if autoboot returns.
183
184: check-password
185 password .addr @ if
186 0 autoboot
187 false >r
188 begin
189 bell emit bell emit
190 ." Password: "
191 password .len @ read-password
192 dup password .len @ = if
193 2dup password .addr @ password .len @
194 compare 0= if r> drop true >r then
195 then
196 drop free drop
197 r@
198 until
199 r> drop
200 then
201;
202
203\ ***** start
204\
205\ Initializes support.4th global variables, sets loader_conf_files,
206\ process conf files, and, if any one such file was succesfully
207\ read to the end, load kernel and modules.
208
209: start ( -- ) ( throws: abort & user-defined )
210 s" /boot/defaults/loader.conf" initialize
211 include_conf_files
212 \ Will *NOT* try to load kernel and modules if no configuration file
213 \ was succesfully loaded!
214 any_conf_read? if
215 load_kernel
216 load_modules
217 then
218;
219
220\ ***** initialize
221\
222\ Overrides support.4th initialization word with one that does
223\ everything start one does, short of loading the kernel and
224\ modules. Returns a flag
225
226: initialize ( -- flag )
227 s" /boot/defaults/loader.conf" initialize
228 include_conf_files
229 any_conf_read?
230;
231
232\ ***** read-conf
233\
234\ Read a configuration file, whose name was specified on the command
235\ line, if interpreted, or given on the stack, if compiled in.
236
237: (read-conf) ( addr len -- )
238 conf_files .addr @ ?dup if free abort" Fatal error freeing memory" then
239 strdup conf_files .len ! conf_files .addr !
240 include_conf_files \ Will recurse on new loader_conf_files definitions
241;
242
243: read-conf ( <filename> | addr len -- ) ( throws: abort & user-defined )
244 state @ if
245 \ Compiling
246 postpone (read-conf)
247 else
248 \ Interpreting
249 bl parse (read-conf)
250 then
251; immediate
252
253\ ***** enable-module
254\
255\ Turn a module loading on.
256
257: enable-module ( <module> -- )
258 bl parse module_options @ >r
259 begin
260 r@
261 while
262 2dup
263 r@ module.name dup .addr @ swap .len @
264 compare 0= if
265 2drop
266 r@ module.name dup .addr @ swap .len @ type
267 true r> module.flag !
268 ." will be loaded." cr
269 exit
270 then
271 r> module.next @ >r
272 repeat
273 r> drop
274 type ." wasn't found." cr
275;
276
277\ ***** disable-module
278\
279\ Turn a module loading off.
280
281: disable-module ( <module> -- )
282 bl parse module_options @ >r
283 begin
284 r@
285 while
286 2dup
287 r@ module.name dup .addr @ swap .len @
288 compare 0= if
289 2drop
290 r@ module.name dup .addr @ swap .len @ type
291 false r> module.flag !
292 ." will not be loaded." cr
293 exit
294 then
295 r> module.next @ >r
296 repeat
297 r> drop
298 type ." wasn't found." cr
299;
300
301\ ***** toggle-module
302\
303\ Turn a module loading on/off.
304
305: toggle-module ( <module> -- )
306 bl parse module_options @ >r
307 begin
308 r@
309 while
310 2dup
311 r@ module.name dup .addr @ swap .len @
312 compare 0= if
313 2drop
314 r@ module.name dup .addr @ swap .len @ type
315 r@ module.flag @ 0= dup r> module.flag !
316 if
317 ." will be loaded." cr
318 else
319 ." will not be loaded." cr
320 then
321 exit
322 then
323 r> module.next @ >r
324 repeat
325 r> drop
326 type ." wasn't found." cr
327;
328
329\ ***** show-module
330\
331\ Show loading information about a module.
332
333: show-module ( <module> -- )
334 bl parse module_options @ >r
335 begin
336 r@
337 while
338 2dup
339 r@ module.name dup .addr @ swap .len @
340 compare 0= if
341 2drop
342 ." Name: " r@ module.name dup .addr @ swap .len @ type cr
343 ." Path: " r@ module.loadname dup .addr @ swap .len @ type cr
344 ." Type: " r@ module.type dup .addr @ swap .len @ type cr
345 ." Flags: " r@ module.args dup .addr @ swap .len @ type cr
346 ." Before load: " r@ module.beforeload dup .addr @ swap .len @ type cr
347 ." After load: " r@ module.afterload dup .addr @ swap .len @ type cr
348 ." Error: " r@ module.loaderror dup .addr @ swap .len @ type cr
349 ." Status: " r> module.flag @ if ." Load" else ." Don't load" then cr
350 exit
351 then
352 r> module.next @ >r
353 repeat
354 r> drop
355 type ." wasn't found." cr
356;
357
358\ Words to be used inside configuration files
359
360: retry false ; \ For use in load error commands
361: ignore true ; \ For use in load error commands
362
363\ Return to strict forth vocabulary
364
365only forth also
366
|