Deleted Added
sdiff udiff text old ( 65621 ) new ( 65630 )
full compact
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 $
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
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 )
180 0 1 unload drop
181
182 0= if ( interpreted ) get-arguments then
183 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
258;
259
260only forth also support-functions also builtins definitions
261
262: boot
263 load-conf
264 ?dup 0= if 0 1 boot then
265;
266
267: boot-conf
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