The forth code is a real mess, things are repeated all over the place.
[dragonfly.git] / sys / boot / forth / loader.4th
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: src/sys/boot/forth/loader.4th,v 1.24 2002/05/24 02:28:58 gordon Exp $
26 \ $DragonFly: src/sys/boot/forth/loader.4th,v 1.7 2004/10/14 18:36:00 dillon Exp $
27
28 s" arch-alpha" environment? [if] [if]
29         s" loader_version" environment?  [if]
30                 12 < [if]
31                         .( Loader version 1.2+ required) cr
32                         abort
33                 [then]
34         [else]
35                 .( Could not get loader version!) cr
36                 abort
37         [then]
38 [then] [then]
39
40 s" arch-i386" environment? [if] [if]
41         s" loader_version" environment?  [if]
42                 11 < [if]
43                         .( Loader version 1.1+ required) cr
44                         abort
45                 [then]
46         [else]
47                 .( Could not get loader version!) cr
48                 abort
49         [then]
50 [then] [then]
51
52 256 dictthreshold !  \ 256 cells minimum free space
53 2048 dictincrease !  \ 2048 additional cells each time
54
55 include /boot/support.4th
56
57 \ ***** boot-conf
58 \
59 \       Prepares to boot as specified by loaded configuration files.
60
61 only forth also support-functions also builtins definitions
62
63 : boot
64   0= if ( interpreted ) get_arguments then
65
66   \ Unload only if a path was passed
67   dup if
68     >r over r> swap
69     c@ [char] - <> if
70       0 1 unload drop
71     else
72       s" kernelname" getenv? if ( a kernel has been loaded )
73         1 boot exit
74       then
75       load_kernel_and_modules
76       ?dup if exit then
77       0 1 boot exit
78     then
79   else
80     s" kernelname" getenv? if ( a kernel has been loaded )
81       1 boot exit
82     then
83     load_kernel_and_modules
84     ?dup if exit then
85     0 1 boot exit
86   then
87   load_kernel_and_modules
88   ?dup 0= if 0 1 boot then
89 ;
90
91 : boot-conf
92   0= if ( interpreted ) get_arguments then
93   0 1 unload drop
94   load_kernel_and_modules
95   ?dup 0= if 0 1 autoboot then
96 ;
97
98 also forth definitions also builtins
99
100 builtin: boot
101 builtin: boot-conf
102
103 only forth definitions also support-functions
104
105 \ ***** check-password
106 \
107 \       If a password was defined, execute autoboot and ask for
108 \       password if autoboot returns.
109
110 : check-password
111   password .addr @ if
112     0 autoboot
113     false >r
114     begin
115       bell emit bell emit
116       ." Password: "
117       password .len @ read-password
118       dup password .len @ = if
119         2dup password .addr @ password .len @
120         compare 0= if r> drop true >r then
121       then
122       drop free drop
123       r@
124     until
125     r> drop
126   then
127 ;
128
129 \ ***** start
130 \
131 \       Initializes support.4th global variables, sets loader_conf_files,
132 \       process conf files, and, if any one such file was succesfully
133 \       read to the end, load kernel and modules.
134
135 : start  ( -- ) ( throws: abort & user-defined )
136   s" boot.nfsroot.path" getenv? if
137     s" /boot/defaults/loader-bootp.conf" initialize
138   else
139     s" /boot/defaults/loader.conf" initialize
140   then
141   include_conf_files
142   include_nextboot_file
143   \ Will *NOT* try to load kernel and modules if no configuration file
144   \ was succesfully loaded!
145   any_conf_read? if
146     load_kernel
147     load_modules
148   then
149 ;
150
151 \ ***** initialize
152 \
153 \       Overrides support.4th initialization word with one that does
154 \       everything start one does, short of loading the kernel and
155 \       modules. Returns a flag
156
157 : initialize ( -- flag )
158   s" boot.nfsroot.path" getenv? if
159     s" /boot/defaults/loader-bootp.conf" initialize
160   else
161     s" /boot/defaults/loader.conf" initialize
162   then
163   include_conf_files
164   include_nextboot_file
165   any_conf_read?
166 ;
167
168 \ ***** read-conf
169 \
170 \       Read a configuration file, whose name was specified on the command
171 \       line, if interpreted, or given on the stack, if compiled in.
172
173 : (read-conf)  ( addr len -- )
174   conf_files .addr @ ?dup if free abort" Fatal error freeing memory" then
175   strdup conf_files .len ! conf_files .addr !
176   include_conf_files \ Will recurse on new loader_conf_files definitions
177 ;
178
179 : read-conf  ( <filename> | addr len -- ) ( throws: abort & user-defined )
180   state @ if
181     \ Compiling
182     postpone (read-conf)
183   else
184     \ Interpreting
185     bl parse (read-conf)
186   then
187 ; immediate
188
189 \ ***** enable-module
190 \
191 \       Turn a module loading on.
192
193 : enable-module ( <module> -- )
194   bl parse module_options @ >r
195   begin
196     r@
197   while
198     2dup
199     r@ module.name dup .addr @ swap .len @
200     compare 0= if
201       2drop
202       r@ module.name dup .addr @ swap .len @ type
203       true r> module.flag !
204       ."  will be loaded." cr
205       exit
206     then
207     r> module.next @ >r
208   repeat
209   r> drop
210   type ."  wasn't found." cr
211 ;
212
213 \ ***** disable-module
214 \
215 \       Turn a module loading off.
216
217 : disable-module ( <module> -- )
218   bl parse module_options @ >r
219   begin
220     r@
221   while
222     2dup
223     r@ module.name dup .addr @ swap .len @
224     compare 0= if
225       2drop
226       r@ module.name dup .addr @ swap .len @ type
227       false r> module.flag !
228       ."  will not be loaded." cr
229       exit
230     then
231     r> module.next @ >r
232   repeat
233   r> drop
234   type ."  wasn't found." cr
235 ;
236
237 \ ***** toggle-module
238 \
239 \       Turn a module loading on/off.
240
241 : toggle-module ( <module> -- )
242   bl parse module_options @ >r
243   begin
244     r@
245   while
246     2dup
247     r@ module.name dup .addr @ swap .len @
248     compare 0= if
249       2drop
250       r@ module.name dup .addr @ swap .len @ type
251       r@ module.flag @ 0= dup r> module.flag !
252       if
253         ."  will be loaded." cr
254       else
255         ."  will not be loaded." cr
256       then
257       exit
258     then
259     r> module.next @ >r
260   repeat
261   r> drop
262   type ."  wasn't found." cr
263 ;
264
265 \ ***** show-module
266 \
267 \       Show loading information about a module.
268
269 : show-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       ." Name: " r@ module.name dup .addr @ swap .len @ type cr
279       ." Path: " r@ module.loadname dup .addr @ swap .len @ type cr
280       ." Type: " r@ module.type dup .addr @ swap .len @ type cr
281       ." Flags: " r@ module.args dup .addr @ swap .len @ type cr
282       ." Before load: " r@ module.beforeload dup .addr @ swap .len @ type cr
283       ." After load: " r@ module.afterload dup .addr @ swap .len @ type cr
284       ." Error: " r@ module.loaderror dup .addr @ swap .len @ type cr
285       ." Status: " r> module.flag @ if ." Load" else ." Don't load" then cr
286       exit
287     then
288     r> module.next @ >r
289   repeat
290   r> drop
291   type ."  wasn't found." cr
292 ;
293
294 \ Words to be used inside configuration files
295
296 : retry false ;         \ For use in load error commands
297 : ignore true ;         \ For use in load error commands
298
299 \ Return to strict forth vocabulary
300
301 : #type
302   over - >r
303   type
304   r> spaces
305 ;
306
307 : .? 2 spaces 2swap 15 #type 2 spaces type cr ;
308
309 : ?
310   ['] ? execute
311   s" boot-conf" s" load kernel and modules, then autoboot" .?
312   s" read-conf" s" read a configuration file" .?
313   s" enable-module" s" enable loading of a module" .?
314   s" disable-module" s" disable loading of a module" .?
315   s" toggle-module" s" toggle loading of a module" .?
316   s" show-module" s" show module load data" .?
317 ;
318
319 only forth also
320