loader.4th revision 65630 
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 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
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
143: load-conf  ( args 1 | 0 "args" -- flag )
144  0= if ( interpreted ) get-arguments then
145  set-tempoptions
146  s" temp_options" getenv -1 <> if 2swap 2 else 1 then
147  load_kernel_and_modules
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
164  load-conf
165  ?dup 0= if 0 1 boot then
166;
167
168: boot-conf
169  0 1 unload drop
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
367