loader.4th revision 61694 
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 61694 2000-06-14 19:39:31Z 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: saveenv ( addr len | 0 -1 -- addr' len | 0 -1 )
64  dup -1 = if exit then
65  dup allocate abort" Out of memory"
66  swap 2dup 2>r
67  move
68  2r>
69;
70: freeenv ( addr len | 0 -1 )
71  -1 = if drop else free abort" Freeing error" then
72;
73: restoreenv  ( addr len | 0 -1 -- )
74  dup -1 = if ( it wasn't set )
75    2drop
76    modulepath unsetenv
77  else
78    over >r
79    modulepath setenv
80    r> free abort" Freeing error"
81  then
82;
83
84only forth also support-functions also builtins definitions
85
86: boot-conf  ( args 1 | 0 "args" -- flag )
87  0 1 unload drop
88
89  0= if ( interpreted )
90    \ Get next word on the command line
91    bl word count
92    ?dup 0= if ( there wasn't anything )
93      drop 0
94    else ( put in the number of strings )
95      1
96    then
97  then ( interpreted )
98
99  if ( there are arguments )
100    \ Try to load the kernel
101    s" kernel_options" getenv dup -1 = if drop 2dup 1 else 2over 2 then
102
103    1 load if ( load command failed )
104      \ Remove garbage from the stack
105
106      \ Set the environment variable module_path, and try loading
107      \ the kernel again.
108
109      \ First, save module_path value
110      modulepath getenv saveenv dup -1 = if 0 swap then 2>r
111
112      \ Sets the new value
113      2dup modulepath setenv
114
115      \ Try to load the kernel
116      s" load ${kernel} ${kernel_options}" ['] evaluate catch
117      if ( load failed yet again )
118	\ Remove garbage from the stack
119	2drop
120
121	\ Try prepending /boot/
122	bootpath 2over nip over + allocate
123	if ( out of memory )
124	  2drop 2drop
125	  2r> restoreenv
126	  100 exit
127	then
128
129	0 2swap strcat 2swap strcat
130	2dup modulepath setenv
131
132	drop free if ( freeing memory error )
133	  2drop
134	  2r> restoreenv
135	  100 exit
136	then
137 
138	\ Now, once more, try to load the kernel
139	s" load ${kernel} ${kernel_options}" ['] evaluate catch
140	if ( failed once more )
141	  2drop
142	  2r> restoreenv
143	  100 exit
144	then
145
146      else ( we found the kernel on the path passed )
147
148	2drop ( discard command line arguments )
149
150      then ( could not load kernel from directory passed )
151
152      \ Load the remaining modules, if the kernel was loaded at all
153      ['] load_modules catch if 2r> restoreenv 100 exit then
154
155      \ Call autoboot to perform the booting
156      0 1 autoboot
157
158      \ Keep new module_path
159      2r> freeenv
160
161      exit
162    then ( could not load kernel with name passed )
163
164    2drop ( discard command line arguments )
165
166  else ( try just a straight-forward kernel load )
167    s" load ${kernel} ${kernel_options}" ['] evaluate catch
168    if ( kernel load failed ) 2drop 100 exit then
169
170  then ( there are command line arguments )
171
172  \ Load the remaining modules, if the kernel was loaded at all
173  ['] load_modules catch if 100 exit then
174
175  \ Call autoboot to perform the booting
176  0 1 autoboot
177;
178
179also forth definitions
180builtin: boot-conf
181only forth definitions also support-functions
182
183\ ***** check-password
184\
185\	If a password was defined, execute autoboot and ask for
186\	password if autoboot returns.
187
188: check-password
189  password .addr @ if
190    0 autoboot
191    false >r
192    begin
193      bell emit bell emit
194      ." Password: "
195      password .len @ read-password
196      dup password .len @ = if
197        2dup password .addr @ password .len @
198        compare 0= if r> drop true >r then
199      then
200      drop free drop
201      r@
202    until
203    r> drop
204  then
205;
206
207\ ***** start
208\
209\       Initializes support.4th global variables, sets loader_conf_files,
210\       process conf files, and, if any one such file was succesfully
211\       read to the end, load kernel and modules.
212
213: start  ( -- ) ( throws: abort & user-defined )
214  s" /boot/defaults/loader.conf" initialize
215  include_conf_files
216  \ Will *NOT* try to load kernel and modules if no configuration file
217  \ was succesfully loaded!
218  any_conf_read? if
219    load_kernel
220    load_modules
221  then
222;
223
224\ ***** initialize
225\
226\	Overrides support.4th initialization word with one that does
227\	everything start one does, short of loading the kernel and
228\	modules. Returns a flag
229
230: initialize ( -- flag )
231  s" /boot/defaults/loader.conf" initialize
232  include_conf_files
233  any_conf_read?
234;
235
236\ ***** read-conf
237\
238\	Read a configuration file, whose name was specified on the command
239\	line, if interpreted, or given on the stack, if compiled in.
240
241: (read-conf)  ( addr len -- )
242  conf_files .addr @ ?dup if free abort" Fatal error freeing memory" then
243  strdup conf_files .len ! conf_files .addr !
244  include_conf_files \ Will recurse on new loader_conf_files definitions
245;
246
247: read-conf  ( <filename> | addr len -- ) ( throws: abort & user-defined )
248  state @ if
249    \ Compiling
250    postpone (read-conf)
251  else
252    \ Interpreting
253    bl parse (read-conf)
254  then
255; immediate
256
257\ ***** enable-module
258\
259\       Turn a module loading on.
260
261: enable-module ( <module> -- )
262  bl parse module_options @ >r
263  begin
264    r@
265  while
266    2dup
267    r@ module.name dup .addr @ swap .len @
268    compare 0= if
269      2drop
270      r@ module.name dup .addr @ swap .len @ type
271      true r> module.flag !
272      ."  will be loaded." cr
273      exit
274    then
275    r> module.next @ >r
276  repeat
277  r> drop
278  type ."  wasn't found." cr
279;
280
281\ ***** disable-module
282\
283\       Turn a module loading off.
284
285: disable-module ( <module> -- )
286  bl parse module_options @ >r
287  begin
288    r@
289  while
290    2dup
291    r@ module.name dup .addr @ swap .len @
292    compare 0= if
293      2drop
294      r@ module.name dup .addr @ swap .len @ type
295      false r> module.flag !
296      ."  will not be loaded." cr
297      exit
298    then
299    r> module.next @ >r
300  repeat
301  r> drop
302  type ."  wasn't found." cr
303;
304
305\ ***** toggle-module
306\
307\       Turn a module loading on/off.
308
309: toggle-module ( <module> -- )
310  bl parse module_options @ >r
311  begin
312    r@
313  while
314    2dup
315    r@ module.name dup .addr @ swap .len @
316    compare 0= if
317      2drop
318      r@ module.name dup .addr @ swap .len @ type
319      r@ module.flag @ 0= dup r> module.flag !
320      if
321        ."  will be loaded." cr
322      else
323        ."  will not be loaded." cr
324      then
325      exit
326    then
327    r> module.next @ >r
328  repeat
329  r> drop
330  type ."  wasn't found." cr
331;
332
333\ ***** show-module
334\
335\	Show loading information about a module.
336
337: show-module ( <module> -- )
338  bl parse module_options @ >r
339  begin
340    r@
341  while
342    2dup
343    r@ module.name dup .addr @ swap .len @
344    compare 0= if
345      2drop
346      ." Name: " r@ module.name dup .addr @ swap .len @ type cr
347      ." Path: " r@ module.loadname dup .addr @ swap .len @ type cr
348      ." Type: " r@ module.type dup .addr @ swap .len @ type cr
349      ." Flags: " r@ module.args dup .addr @ swap .len @ type cr
350      ." Before load: " r@ module.beforeload dup .addr @ swap .len @ type cr
351      ." After load: " r@ module.afterload dup .addr @ swap .len @ type cr
352      ." Error: " r@ module.loaderror dup .addr @ swap .len @ type cr
353      ." Status: " r> module.flag @ if ." Load" else ." Don't load" then cr
354      exit
355    then
356    r> module.next @ >r
357  repeat
358  r> drop
359  type ."  wasn't found." cr
360;
361
362\ Words to be used inside configuration files
363
364: retry false ;         \ For use in load error commands
365: ignore true ;         \ For use in load error commands
366
367\ Return to strict forth vocabulary
368
369only forth also
370
371