loader.4th revision 65621 
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
465