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