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\
| 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/support.4th 50477 1999-08-28 01:08:13Z peter $
| 25\ $FreeBSD: head/sys/boot/forth/support.4th 53672 1999-11-24 17:56:40Z dcs $
|
26
27\ Loader.rc support functions:
28\
29\ initialize_support ( -- ) initialize global variables
30\ initialize ( addr len -- ) as above, plus load_conf_files
31\ load_conf ( addr len -- ) load conf file given
32\ include_conf_files ( -- ) load all conf files in load_conf_files
33\ print_syntax_error ( -- ) print line and marker of where a syntax
34\ error was detected
35\ print_line ( -- ) print last line processed
36\ load_kernel ( -- ) load kernel
37\ load_modules ( -- ) load modules flagged
38\
39\ Exported structures:
40\
41\ string counted string structure
42\ cell .addr string address
43\ cell .len string length
44\ module module loading information structure
45\ cell module.flag should we load it?
46\ string module.name module's name
47\ string module.loadname name to be used in loading the module
48\ string module.type module's type
49\ string module.args flags to be passed during load
50\ string module.beforeload command to be executed before load
51\ string module.afterload command to be executed after load
52\ string module.loaderror command to be executed if load fails
53\ cell module.next list chain
54\
55\ Exported global variables;
56\
57\ string conf_files configuration files to be loaded
| 26
27\ Loader.rc support functions:
28\
29\ initialize_support ( -- ) initialize global variables
30\ initialize ( addr len -- ) as above, plus load_conf_files
31\ load_conf ( addr len -- ) load conf file given
32\ include_conf_files ( -- ) load all conf files in load_conf_files
33\ print_syntax_error ( -- ) print line and marker of where a syntax
34\ error was detected
35\ print_line ( -- ) print last line processed
36\ load_kernel ( -- ) load kernel
37\ load_modules ( -- ) load modules flagged
38\
39\ Exported structures:
40\
41\ string counted string structure
42\ cell .addr string address
43\ cell .len string length
44\ module module loading information structure
45\ cell module.flag should we load it?
46\ string module.name module's name
47\ string module.loadname name to be used in loading the module
48\ string module.type module's type
49\ string module.args flags to be passed during load
50\ string module.beforeload command to be executed before load
51\ string module.afterload command to be executed after load
52\ string module.loaderror command to be executed if load fails
53\ cell module.next list chain
54\
55\ Exported global variables;
56\
57\ string conf_files configuration files to be loaded
|
| 58\ string password password
|
58\ cell modules_options pointer to first module information
59\ value verbose? indicates if user wants a verbose loading
60\ value any_conf_read? indicates if a conf file was succesfully read
61\
62\ Other exported words:
63\
64\ strdup ( addr len -- addr' len) similar to strdup(3)
65\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3)
66\ s' ( | string' -- addr len | ) similar to s"
67\ rudimentary structure support
68
69\ Exception values
70
711 constant syntax_error
722 constant out_of_memory
733 constant free_error
744 constant set_error
755 constant read_error
766 constant open_error
777 constant exec_error
788 constant before_load_error
799 constant after_load_error
80
81\ Crude structure support
82
83: structure: create here 0 , 0 does> create @ allot ;
84: member: create dup , over , + does> cell+ @ + ;
85: ;structure swap ! ;
86: sizeof ' >body @ state @ if postpone literal then ; immediate
87: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate
88: ptr 1 cells member: ;
89: int 1 cells member: ;
90
91\ String structure
92
93structure: string
94 ptr .addr
95 int .len
96;structure
97
98\ Module options linked list
99
100structure: module
101 int module.flag
102 sizeof string member: module.name
103 sizeof string member: module.loadname
104 sizeof string member: module.type
105 sizeof string member: module.args
106 sizeof string member: module.beforeload
107 sizeof string member: module.afterload
108 sizeof string member: module.loaderror
109 ptr module.next
110;structure
111
112\ Global variables
113
114string conf_files
| 59\ cell modules_options pointer to first module information
60\ value verbose? indicates if user wants a verbose loading
61\ value any_conf_read? indicates if a conf file was succesfully read
62\
63\ Other exported words:
64\
65\ strdup ( addr len -- addr' len) similar to strdup(3)
66\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3)
67\ s' ( | string' -- addr len | ) similar to s"
68\ rudimentary structure support
69
70\ Exception values
71
721 constant syntax_error
732 constant out_of_memory
743 constant free_error
754 constant set_error
765 constant read_error
776 constant open_error
787 constant exec_error
798 constant before_load_error
809 constant after_load_error
81
82\ Crude structure support
83
84: structure: create here 0 , 0 does> create @ allot ;
85: member: create dup , over , + does> cell+ @ + ;
86: ;structure swap ! ;
87: sizeof ' >body @ state @ if postpone literal then ; immediate
88: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate
89: ptr 1 cells member: ;
90: int 1 cells member: ;
91
92\ String structure
93
94structure: string
95 ptr .addr
96 int .len
97;structure
98
99\ Module options linked list
100
101structure: module
102 int module.flag
103 sizeof string member: module.name
104 sizeof string member: module.loadname
105 sizeof string member: module.type
106 sizeof string member: module.args
107 sizeof string member: module.beforeload
108 sizeof string member: module.afterload
109 sizeof string member: module.loaderror
110 ptr module.next
111;structure
112
113\ Global variables
114
115string conf_files
|
| 116string password
|
115create module_options sizeof module.next allot
116create last_module_option sizeof module.next allot
1170 value verbose?
118
119\ Support string functions
120
121: strdup ( addr len -- addr' len )
122 >r r@ allocate if out_of_memory throw then
123 tuck r@ move
124 r>
125;
126
127: strcat { addr len addr' len' -- addr len+len' }
128 addr' addr len + len' move
129 addr len len' +
130;
131
132: s'
133 [char] ' parse
134 state @ if
135 postpone sliteral
136 then
137; immediate
138
| 117create module_options sizeof module.next allot
118create last_module_option sizeof module.next allot
1190 value verbose?
120
121\ Support string functions
122
123: strdup ( addr len -- addr' len )
124 >r r@ allocate if out_of_memory throw then
125 tuck r@ move
126 r>
127;
128
129: strcat { addr len addr' len' -- addr len+len' }
130 addr' addr len + len' move
131 addr len len' +
132;
133
134: s'
135 [char] ' parse
136 state @ if
137 postpone sliteral
138 then
139; immediate
140
|
| 141\ How come ficl doesn't have again?
142
143: again false postpone literal postpone until ; immediate
144
|
139\ Private definitions
140
141vocabulary support-functions
142only forth also support-functions definitions
143
144\ Some control characters constants
145
| 145\ Private definitions
146
147vocabulary support-functions
148only forth also support-functions definitions
149
150\ Some control characters constants
151
|
| 1527 constant bell
1538 constant backspace
|
1469 constant tab
14710 constant lf
| 1549 constant tab
15510 constant lf
|
| 15613 constant <cr>
|
148
149\ Read buffer size
150
15180 constant read_buffer_size
152
153\ Standard suffixes
154
155: load_module_suffix s" _load" ;
156: module_loadname_suffix s" _name" ;
157: module_type_suffix s" _type" ;
158: module_args_suffix s" _flags" ;
159: module_beforeload_suffix s" _before" ;
160: module_afterload_suffix s" _after" ;
161: module_loaderror_suffix s" _error" ;
162
163\ Support operators
164
165: >= < 0= ;
166: <= > 0= ;
167
168\ Assorted support funcitons
169
170: free-memory free if free_error throw then ;
171
172\ Assignment data temporary storage
173
174string name_buffer
175string value_buffer
176
177\ File data temporary storage
178
179string line_buffer
180string read_buffer
1810 value read_buffer_ptr
182
183\ File's line reading function
184
1850 value end_of_file?
186variable fd
187
188: skip_newlines
189 begin
190 read_buffer .len @ read_buffer_ptr >
191 while
192 read_buffer .addr @ read_buffer_ptr + c@ lf = if
193 read_buffer_ptr char+ to read_buffer_ptr
194 else
195 exit
196 then
197 repeat
198;
199
200: scan_buffer ( -- addr len )
201 read_buffer_ptr >r
202 begin
203 read_buffer .len @ r@ >
204 while
205 read_buffer .addr @ r@ + c@ lf = if
206 read_buffer .addr @ read_buffer_ptr + ( -- addr )
207 r@ read_buffer_ptr - ( -- len )
208 r> to read_buffer_ptr
209 exit
210 then
211 r> char+ >r
212 repeat
213 read_buffer .addr @ read_buffer_ptr + ( -- addr )
214 r@ read_buffer_ptr - ( -- len )
215 r> to read_buffer_ptr
216;
217
218: line_buffer_resize ( len -- len )
219 >r
220 line_buffer .len @ if
221 line_buffer .addr @
222 line_buffer .len @ r@ +
223 resize if out_of_memory throw then
224 else
225 r@ allocate if out_of_memory throw then
226 then
227 line_buffer .addr !
228 r>
229;
230
231: append_to_line_buffer ( addr len -- )
232 line_buffer .addr @ line_buffer .len @
233 2swap strcat
234 line_buffer .len !
235 drop
236;
237
238: read_from_buffer
239 scan_buffer ( -- addr len )
240 line_buffer_resize ( len -- len )
241 append_to_line_buffer ( addr len -- )
242;
243
244: refill_required?
245 read_buffer .len @ read_buffer_ptr =
246 end_of_file? 0= and
247;
248
249: refill_buffer
250 0 to read_buffer_ptr
251 read_buffer .addr @ 0= if
252 read_buffer_size allocate if out_of_memory throw then
253 read_buffer .addr !
254 then
255 fd @ read_buffer .addr @ read_buffer_size fread
256 dup -1 = if read_error throw then
257 dup 0= if true to end_of_file? then
258 read_buffer .len !
259;
260
261: reset_line_buffer
262 0 line_buffer .addr !
263 0 line_buffer .len !
264;
265
266: read_line
267 reset_line_buffer
268 skip_newlines
269 begin
270 read_from_buffer
271 refill_required?
272 while
273 refill_buffer
274 repeat
275;
276
277\ Conf file line parser:
278\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
279\ <spaces>[<comment>]
280\ <name> ::= <letter>{<letter>|<digit>|'_'}
281\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name>
282\ <character_set> ::= ASCII 32 to 126, except '\' and '"'
283\ <comment> ::= '#'{<anything>}
284
2850 value parsing_function
286
2870 value end_of_line
2880 value line_pointer
289
290: end_of_line?
291 line_pointer end_of_line =
292;
293
294: letter?
295 line_pointer c@ >r
296 r@ [char] A >=
297 r@ [char] Z <= and
298 r@ [char] a >=
299 r> [char] z <= and
300 or
301;
302
303: digit?
304 line_pointer c@ >r
305 r@ [char] 0 >=
306 r> [char] 9 <= and
307;
308
309: quote?
310 line_pointer c@ [char] " =
311;
312
313: assignment_sign?
314 line_pointer c@ [char] = =
315;
316
317: comment?
318 line_pointer c@ [char] # =
319;
320
321: space?
322 line_pointer c@ bl =
323 line_pointer c@ tab = or
324;
325
326: backslash?
327 line_pointer c@ [char] \ =
328;
329
330: underscore?
331 line_pointer c@ [char] _ =
332;
333
334: dot?
335 line_pointer c@ [char] . =
336;
337
338: skip_character
339 line_pointer char+ to line_pointer
340;
341
342: skip_to_end_of_line
343 end_of_line to line_pointer
344;
345
346: eat_space
347 begin
348 space?
349 while
350 skip_character
351 end_of_line? if exit then
352 repeat
353;
354
355: parse_name ( -- addr len )
356 line_pointer
357 begin
358 letter? digit? underscore? dot? or or or
359 while
360 skip_character
361 end_of_line? if
362 line_pointer over -
363 strdup
364 exit
365 then
366 repeat
367 line_pointer over -
368 strdup
369;
370
371: remove_backslashes { addr len | addr' len' -- addr' len' }
372 len allocate if out_of_memory throw then
373 to addr'
374 addr >r
375 begin
376 addr c@ [char] \ <> if
377 addr c@ addr' len' + c!
378 len' char+ to len'
379 then
380 addr char+ to addr
381 r@ len + addr =
382 until
383 r> drop
384 addr' len'
385;
386
387: parse_quote ( -- addr len )
388 line_pointer
389 skip_character
390 end_of_line? if syntax_error throw then
391 begin
392 quote? 0=
393 while
394 backslash? if
395 skip_character
396 end_of_line? if syntax_error throw then
397 then
398 skip_character
399 end_of_line? if syntax_error throw then
400 repeat
401 skip_character
402 line_pointer over -
403 remove_backslashes
404;
405
406: read_name
407 parse_name ( -- addr len )
408 name_buffer .len !
409 name_buffer .addr !
410;
411
412: read_value
413 quote? if
414 parse_quote ( -- addr len )
415 else
416 parse_name ( -- addr len )
417 then
418 value_buffer .len !
419 value_buffer .addr !
420;
421
422: comment
423 skip_to_end_of_line
424;
425
426: white_space_4
427 eat_space
428 comment? if ['] comment to parsing_function exit then
429 end_of_line? 0= if syntax_error throw then
430;
431
432: variable_value
433 read_value
434 ['] white_space_4 to parsing_function
435;
436
437: white_space_3
438 eat_space
439 letter? digit? quote? or or if
440 ['] variable_value to parsing_function exit
441 then
442 syntax_error throw
443;
444
445: assignment_sign
446 skip_character
447 ['] white_space_3 to parsing_function
448;
449
450: white_space_2
451 eat_space
452 assignment_sign? if ['] assignment_sign to parsing_function exit then
453 syntax_error throw
454;
455
456: variable_name
457 read_name
458 ['] white_space_2 to parsing_function
459;
460
461: white_space_1
462 eat_space
463 letter? if ['] variable_name to parsing_function exit then
464 comment? if ['] comment to parsing_function exit then
465 end_of_line? 0= if syntax_error throw then
466;
467
468: get_assignment
469 line_buffer .addr @ line_buffer .len @ + to end_of_line
470 line_buffer .addr @ to line_pointer
471 ['] white_space_1 to parsing_function
472 begin
473 end_of_line? 0=
474 while
475 parsing_function execute
476 repeat
477 parsing_function ['] comment =
478 parsing_function ['] white_space_1 =
479 parsing_function ['] white_space_4 =
480 or or 0= if syntax_error throw then
481;
482
483\ Process line
484
485: assignment_type? ( addr len -- flag )
486 name_buffer .addr @ name_buffer .len @
487 compare 0=
488;
489
490: suffix_type? ( addr len -- flag )
491 name_buffer .len @ over <= if 2drop false exit then
492 name_buffer .len @ over - name_buffer .addr @ +
493 over compare 0=
494;
495
496: loader_conf_files?
497 s" loader_conf_files" assignment_type?
498;
499
500: verbose_flag?
501 s" verbose_loading" assignment_type?
502;
503
504: execute?
505 s" exec" assignment_type?
506;
507
| 157
158\ Read buffer size
159
16080 constant read_buffer_size
161
162\ Standard suffixes
163
164: load_module_suffix s" _load" ;
165: module_loadname_suffix s" _name" ;
166: module_type_suffix s" _type" ;
167: module_args_suffix s" _flags" ;
168: module_beforeload_suffix s" _before" ;
169: module_afterload_suffix s" _after" ;
170: module_loaderror_suffix s" _error" ;
171
172\ Support operators
173
174: >= < 0= ;
175: <= > 0= ;
176
177\ Assorted support funcitons
178
179: free-memory free if free_error throw then ;
180
181\ Assignment data temporary storage
182
183string name_buffer
184string value_buffer
185
186\ File data temporary storage
187
188string line_buffer
189string read_buffer
1900 value read_buffer_ptr
191
192\ File's line reading function
193
1940 value end_of_file?
195variable fd
196
197: skip_newlines
198 begin
199 read_buffer .len @ read_buffer_ptr >
200 while
201 read_buffer .addr @ read_buffer_ptr + c@ lf = if
202 read_buffer_ptr char+ to read_buffer_ptr
203 else
204 exit
205 then
206 repeat
207;
208
209: scan_buffer ( -- addr len )
210 read_buffer_ptr >r
211 begin
212 read_buffer .len @ r@ >
213 while
214 read_buffer .addr @ r@ + c@ lf = if
215 read_buffer .addr @ read_buffer_ptr + ( -- addr )
216 r@ read_buffer_ptr - ( -- len )
217 r> to read_buffer_ptr
218 exit
219 then
220 r> char+ >r
221 repeat
222 read_buffer .addr @ read_buffer_ptr + ( -- addr )
223 r@ read_buffer_ptr - ( -- len )
224 r> to read_buffer_ptr
225;
226
227: line_buffer_resize ( len -- len )
228 >r
229 line_buffer .len @ if
230 line_buffer .addr @
231 line_buffer .len @ r@ +
232 resize if out_of_memory throw then
233 else
234 r@ allocate if out_of_memory throw then
235 then
236 line_buffer .addr !
237 r>
238;
239
240: append_to_line_buffer ( addr len -- )
241 line_buffer .addr @ line_buffer .len @
242 2swap strcat
243 line_buffer .len !
244 drop
245;
246
247: read_from_buffer
248 scan_buffer ( -- addr len )
249 line_buffer_resize ( len -- len )
250 append_to_line_buffer ( addr len -- )
251;
252
253: refill_required?
254 read_buffer .len @ read_buffer_ptr =
255 end_of_file? 0= and
256;
257
258: refill_buffer
259 0 to read_buffer_ptr
260 read_buffer .addr @ 0= if
261 read_buffer_size allocate if out_of_memory throw then
262 read_buffer .addr !
263 then
264 fd @ read_buffer .addr @ read_buffer_size fread
265 dup -1 = if read_error throw then
266 dup 0= if true to end_of_file? then
267 read_buffer .len !
268;
269
270: reset_line_buffer
271 0 line_buffer .addr !
272 0 line_buffer .len !
273;
274
275: read_line
276 reset_line_buffer
277 skip_newlines
278 begin
279 read_from_buffer
280 refill_required?
281 while
282 refill_buffer
283 repeat
284;
285
286\ Conf file line parser:
287\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
288\ <spaces>[<comment>]
289\ <name> ::= <letter>{<letter>|<digit>|'_'}
290\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name>
291\ <character_set> ::= ASCII 32 to 126, except '\' and '"'
292\ <comment> ::= '#'{<anything>}
293
2940 value parsing_function
295
2960 value end_of_line
2970 value line_pointer
298
299: end_of_line?
300 line_pointer end_of_line =
301;
302
303: letter?
304 line_pointer c@ >r
305 r@ [char] A >=
306 r@ [char] Z <= and
307 r@ [char] a >=
308 r> [char] z <= and
309 or
310;
311
312: digit?
313 line_pointer c@ >r
314 r@ [char] 0 >=
315 r> [char] 9 <= and
316;
317
318: quote?
319 line_pointer c@ [char] " =
320;
321
322: assignment_sign?
323 line_pointer c@ [char] = =
324;
325
326: comment?
327 line_pointer c@ [char] # =
328;
329
330: space?
331 line_pointer c@ bl =
332 line_pointer c@ tab = or
333;
334
335: backslash?
336 line_pointer c@ [char] \ =
337;
338
339: underscore?
340 line_pointer c@ [char] _ =
341;
342
343: dot?
344 line_pointer c@ [char] . =
345;
346
347: skip_character
348 line_pointer char+ to line_pointer
349;
350
351: skip_to_end_of_line
352 end_of_line to line_pointer
353;
354
355: eat_space
356 begin
357 space?
358 while
359 skip_character
360 end_of_line? if exit then
361 repeat
362;
363
364: parse_name ( -- addr len )
365 line_pointer
366 begin
367 letter? digit? underscore? dot? or or or
368 while
369 skip_character
370 end_of_line? if
371 line_pointer over -
372 strdup
373 exit
374 then
375 repeat
376 line_pointer over -
377 strdup
378;
379
380: remove_backslashes { addr len | addr' len' -- addr' len' }
381 len allocate if out_of_memory throw then
382 to addr'
383 addr >r
384 begin
385 addr c@ [char] \ <> if
386 addr c@ addr' len' + c!
387 len' char+ to len'
388 then
389 addr char+ to addr
390 r@ len + addr =
391 until
392 r> drop
393 addr' len'
394;
395
396: parse_quote ( -- addr len )
397 line_pointer
398 skip_character
399 end_of_line? if syntax_error throw then
400 begin
401 quote? 0=
402 while
403 backslash? if
404 skip_character
405 end_of_line? if syntax_error throw then
406 then
407 skip_character
408 end_of_line? if syntax_error throw then
409 repeat
410 skip_character
411 line_pointer over -
412 remove_backslashes
413;
414
415: read_name
416 parse_name ( -- addr len )
417 name_buffer .len !
418 name_buffer .addr !
419;
420
421: read_value
422 quote? if
423 parse_quote ( -- addr len )
424 else
425 parse_name ( -- addr len )
426 then
427 value_buffer .len !
428 value_buffer .addr !
429;
430
431: comment
432 skip_to_end_of_line
433;
434
435: white_space_4
436 eat_space
437 comment? if ['] comment to parsing_function exit then
438 end_of_line? 0= if syntax_error throw then
439;
440
441: variable_value
442 read_value
443 ['] white_space_4 to parsing_function
444;
445
446: white_space_3
447 eat_space
448 letter? digit? quote? or or if
449 ['] variable_value to parsing_function exit
450 then
451 syntax_error throw
452;
453
454: assignment_sign
455 skip_character
456 ['] white_space_3 to parsing_function
457;
458
459: white_space_2
460 eat_space
461 assignment_sign? if ['] assignment_sign to parsing_function exit then
462 syntax_error throw
463;
464
465: variable_name
466 read_name
467 ['] white_space_2 to parsing_function
468;
469
470: white_space_1
471 eat_space
472 letter? if ['] variable_name to parsing_function exit then
473 comment? if ['] comment to parsing_function exit then
474 end_of_line? 0= if syntax_error throw then
475;
476
477: get_assignment
478 line_buffer .addr @ line_buffer .len @ + to end_of_line
479 line_buffer .addr @ to line_pointer
480 ['] white_space_1 to parsing_function
481 begin
482 end_of_line? 0=
483 while
484 parsing_function execute
485 repeat
486 parsing_function ['] comment =
487 parsing_function ['] white_space_1 =
488 parsing_function ['] white_space_4 =
489 or or 0= if syntax_error throw then
490;
491
492\ Process line
493
494: assignment_type? ( addr len -- flag )
495 name_buffer .addr @ name_buffer .len @
496 compare 0=
497;
498
499: suffix_type? ( addr len -- flag )
500 name_buffer .len @ over <= if 2drop false exit then
501 name_buffer .len @ over - name_buffer .addr @ +
502 over compare 0=
503;
504
505: loader_conf_files?
506 s" loader_conf_files" assignment_type?
507;
508
509: verbose_flag?
510 s" verbose_loading" assignment_type?
511;
512
513: execute?
514 s" exec" assignment_type?
515;
516
|
| 517: password?
518 s" password" assignment_type?
519;
520
|
508: module_load?
509 load_module_suffix suffix_type?
510;
511
512: module_loadname?
513 module_loadname_suffix suffix_type?
514;
515
516: module_type?
517 module_type_suffix suffix_type?
518;
519
520: module_args?
521 module_args_suffix suffix_type?
522;
523
524: module_beforeload?
525 module_beforeload_suffix suffix_type?
526;
527
528: module_afterload?
529 module_afterload_suffix suffix_type?
530;
531
532: module_loaderror?
533 module_loaderror_suffix suffix_type?
534;
535
536: set_conf_files
537 conf_files .addr @ ?dup if
538 free-memory
539 then
540 value_buffer .addr @ c@ [char] " = if
541 value_buffer .addr @ char+ value_buffer .len @ 2 chars -
542 else
543 value_buffer .addr @ value_buffer .len @
544 then
545 strdup
546 conf_files .len ! conf_files .addr !
547;
548
549: append_to_module_options_list ( addr -- )
550 module_options @ 0= if
551 dup module_options !
552 last_module_option !
553 else
554 dup last_module_option @ module.next !
555 last_module_option !
556 then
557;
558
559: set_module_name ( addr -- )
560 name_buffer .addr @ name_buffer .len @
561 strdup
562 >r over module.name .addr !
563 r> swap module.name .len !
564;
565
566: yes_value?
567 value_buffer .addr @ value_buffer .len @
568 2dup s' "YES"' compare >r
569 2dup s' "yes"' compare >r
570 2dup s" YES" compare >r
571 s" yes" compare r> r> r> and and and 0=
572;
573
574: find_module_option ( -- addr | 0 )
575 module_options @
576 begin
577 dup
578 while
579 dup module.name dup .addr @ swap .len @
580 name_buffer .addr @ name_buffer .len @
581 compare 0= if exit then
582 module.next @
583 repeat
584;
585
586: new_module_option ( -- addr )
587 sizeof module allocate if out_of_memory throw then
588 dup sizeof module erase
589 dup append_to_module_options_list
590 dup set_module_name
591;
592
593: get_module_option ( -- addr )
594 find_module_option
595 ?dup 0= if new_module_option then
596;
597
598: set_module_flag
599 name_buffer .len @ load_module_suffix nip - name_buffer .len !
600 yes_value? get_module_option module.flag !
601;
602
603: set_module_args
604 name_buffer .len @ module_args_suffix nip - name_buffer .len !
605 get_module_option module.args
606 dup .addr @ ?dup if free-memory then
607 value_buffer .addr @ value_buffer .len @
608 over c@ [char] " = if
609 2 chars - swap char+ swap
610 then
611 strdup
612 >r over .addr !
613 r> swap .len !
614;
615
616: set_module_loadname
617 name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
618 get_module_option module.loadname
619 dup .addr @ ?dup if free-memory then
620 value_buffer .addr @ value_buffer .len @
621 over c@ [char] " = if
622 2 chars - swap char+ swap
623 then
624 strdup
625 >r over .addr !
626 r> swap .len !
627;
628
629: set_module_type
630 name_buffer .len @ module_type_suffix nip - name_buffer .len !
631 get_module_option module.type
632 dup .addr @ ?dup if free-memory then
633 value_buffer .addr @ value_buffer .len @
634 over c@ [char] " = if
635 2 chars - swap char+ swap
636 then
637 strdup
638 >r over .addr !
639 r> swap .len !
640;
641
642: set_module_beforeload
643 name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
644 get_module_option module.beforeload
645 dup .addr @ ?dup if free-memory then
646 value_buffer .addr @ value_buffer .len @
647 over c@ [char] " = if
648 2 chars - swap char+ swap
649 then
650 strdup
651 >r over .addr !
652 r> swap .len !
653;
654
655: set_module_afterload
656 name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
657 get_module_option module.afterload
658 dup .addr @ ?dup if free-memory then
659 value_buffer .addr @ value_buffer .len @
660 over c@ [char] " = if
661 2 chars - swap char+ swap
662 then
663 strdup
664 >r over .addr !
665 r> swap .len !
666;
667
668: set_module_loaderror
669 name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
670 get_module_option module.loaderror
671 dup .addr @ ?dup if free-memory then
672 value_buffer .addr @ value_buffer .len @
673 over c@ [char] " = if
674 2 chars - swap char+ swap
675 then
676 strdup
677 >r over .addr !
678 r> swap .len !
679;
680
681: set_environment_variable
682 name_buffer .len @
683 value_buffer .len @ +
684 5 chars +
685 allocate if out_of_memory throw then
686 dup 0 ( addr -- addr addr len )
687 s" set " strcat
688 name_buffer .addr @ name_buffer .len @ strcat
689 s" =" strcat
690 value_buffer .addr @ value_buffer .len @ strcat
691 ['] evaluate catch if
692 2drop free drop
693 set_error throw
694 else
695 free-memory
696 then
697;
698
699: set_verbose
700 yes_value? to verbose?
701;
702
703: execute_command
704 value_buffer .addr @ value_buffer .len @
705 over c@ [char] " = if
| 521: module_load?
522 load_module_suffix suffix_type?
523;
524
525: module_loadname?
526 module_loadname_suffix suffix_type?
527;
528
529: module_type?
530 module_type_suffix suffix_type?
531;
532
533: module_args?
534 module_args_suffix suffix_type?
535;
536
537: module_beforeload?
538 module_beforeload_suffix suffix_type?
539;
540
541: module_afterload?
542 module_afterload_suffix suffix_type?
543;
544
545: module_loaderror?
546 module_loaderror_suffix suffix_type?
547;
548
549: set_conf_files
550 conf_files .addr @ ?dup if
551 free-memory
552 then
553 value_buffer .addr @ c@ [char] " = if
554 value_buffer .addr @ char+ value_buffer .len @ 2 chars -
555 else
556 value_buffer .addr @ value_buffer .len @
557 then
558 strdup
559 conf_files .len ! conf_files .addr !
560;
561
562: append_to_module_options_list ( addr -- )
563 module_options @ 0= if
564 dup module_options !
565 last_module_option !
566 else
567 dup last_module_option @ module.next !
568 last_module_option !
569 then
570;
571
572: set_module_name ( addr -- )
573 name_buffer .addr @ name_buffer .len @
574 strdup
575 >r over module.name .addr !
576 r> swap module.name .len !
577;
578
579: yes_value?
580 value_buffer .addr @ value_buffer .len @
581 2dup s' "YES"' compare >r
582 2dup s' "yes"' compare >r
583 2dup s" YES" compare >r
584 s" yes" compare r> r> r> and and and 0=
585;
586
587: find_module_option ( -- addr | 0 )
588 module_options @
589 begin
590 dup
591 while
592 dup module.name dup .addr @ swap .len @
593 name_buffer .addr @ name_buffer .len @
594 compare 0= if exit then
595 module.next @
596 repeat
597;
598
599: new_module_option ( -- addr )
600 sizeof module allocate if out_of_memory throw then
601 dup sizeof module erase
602 dup append_to_module_options_list
603 dup set_module_name
604;
605
606: get_module_option ( -- addr )
607 find_module_option
608 ?dup 0= if new_module_option then
609;
610
611: set_module_flag
612 name_buffer .len @ load_module_suffix nip - name_buffer .len !
613 yes_value? get_module_option module.flag !
614;
615
616: set_module_args
617 name_buffer .len @ module_args_suffix nip - name_buffer .len !
618 get_module_option module.args
619 dup .addr @ ?dup if free-memory then
620 value_buffer .addr @ value_buffer .len @
621 over c@ [char] " = if
622 2 chars - swap char+ swap
623 then
624 strdup
625 >r over .addr !
626 r> swap .len !
627;
628
629: set_module_loadname
630 name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
631 get_module_option module.loadname
632 dup .addr @ ?dup if free-memory then
633 value_buffer .addr @ value_buffer .len @
634 over c@ [char] " = if
635 2 chars - swap char+ swap
636 then
637 strdup
638 >r over .addr !
639 r> swap .len !
640;
641
642: set_module_type
643 name_buffer .len @ module_type_suffix nip - name_buffer .len !
644 get_module_option module.type
645 dup .addr @ ?dup if free-memory then
646 value_buffer .addr @ value_buffer .len @
647 over c@ [char] " = if
648 2 chars - swap char+ swap
649 then
650 strdup
651 >r over .addr !
652 r> swap .len !
653;
654
655: set_module_beforeload
656 name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
657 get_module_option module.beforeload
658 dup .addr @ ?dup if free-memory then
659 value_buffer .addr @ value_buffer .len @
660 over c@ [char] " = if
661 2 chars - swap char+ swap
662 then
663 strdup
664 >r over .addr !
665 r> swap .len !
666;
667
668: set_module_afterload
669 name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
670 get_module_option module.afterload
671 dup .addr @ ?dup if free-memory then
672 value_buffer .addr @ value_buffer .len @
673 over c@ [char] " = if
674 2 chars - swap char+ swap
675 then
676 strdup
677 >r over .addr !
678 r> swap .len !
679;
680
681: set_module_loaderror
682 name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
683 get_module_option module.loaderror
684 dup .addr @ ?dup if free-memory then
685 value_buffer .addr @ value_buffer .len @
686 over c@ [char] " = if
687 2 chars - swap char+ swap
688 then
689 strdup
690 >r over .addr !
691 r> swap .len !
692;
693
694: set_environment_variable
695 name_buffer .len @
696 value_buffer .len @ +
697 5 chars +
698 allocate if out_of_memory throw then
699 dup 0 ( addr -- addr addr len )
700 s" set " strcat
701 name_buffer .addr @ name_buffer .len @ strcat
702 s" =" strcat
703 value_buffer .addr @ value_buffer .len @ strcat
704 ['] evaluate catch if
705 2drop free drop
706 set_error throw
707 else
708 free-memory
709 then
710;
711
712: set_verbose
713 yes_value? to verbose?
714;
715
716: execute_command
717 value_buffer .addr @ value_buffer .len @
718 over c@ [char] " = if
|
706 2 chars - swap char+ swap
| 719 2 - swap char+ swap
|
707 then
708 ['] evaluate catch if exec_error throw then
709;
710
| 720 then
721 ['] evaluate catch if exec_error throw then
722;
723
|
| 724: set_password
725 password .addr @ ?dup if free if free_error throw then then
726 value_buffer .addr @ c@ [char] " = if
727 value_buffer .addr @ char+ value_buffer .len @ 2 - strdup
728 value_buffer .addr @ free if free_error throw then
729 else
730 value_buffer .addr @ value_buffer .len @
731 then
732 password .len ! password .addr !
733 0 value_buffer .addr !
734;
735
|
711: process_assignment
712 name_buffer .len @ 0= if exit then
713 loader_conf_files? if set_conf_files exit then
714 verbose_flag? if set_verbose exit then
715 execute? if execute_command exit then
| 736: process_assignment
737 name_buffer .len @ 0= if exit then
738 loader_conf_files? if set_conf_files exit then
739 verbose_flag? if set_verbose exit then
740 execute? if execute_command exit then
|
| 741 password? if set_password exit then
|
716 module_load? if set_module_flag exit then
717 module_loadname? if set_module_loadname exit then
718 module_type? if set_module_type exit then
719 module_args? if set_module_args exit then
720 module_beforeload? if set_module_beforeload exit then
721 module_afterload? if set_module_afterload exit then
722 module_loaderror? if set_module_loaderror exit then
723 set_environment_variable
724;
725
| 742 module_load? if set_module_flag exit then
743 module_loadname? if set_module_loadname exit then
744 module_type? if set_module_type exit then
745 module_args? if set_module_args exit then
746 module_beforeload? if set_module_beforeload exit then
747 module_afterload? if set_module_afterload exit then
748 module_loaderror? if set_module_loaderror exit then
749 set_environment_variable
750;
751
|
| 752\ free_buffer ( -- )
753\
754\ Free some pointers if needed. The code then tests for errors
755\ in freeing, and throws an exception if needed. If a pointer is
756\ not allocated, it's value (0) is used as flag.
757
|
726: free_buffers
727 line_buffer .addr @ dup if free then
728 name_buffer .addr @ dup if free then
729 value_buffer .addr @ dup if free then
730 or or if free_error throw then
731;
732
733: reset_assignment_buffers
734 0 name_buffer .addr !
735 0 name_buffer .len !
736 0 value_buffer .addr !
737 0 value_buffer .len !
738;
739
740\ Higher level file processing
741
742: process_conf
743 begin
744 end_of_file? 0=
745 while
746 reset_assignment_buffers
747 read_line
748 get_assignment
749 ['] process_assignment catch
750 ['] free_buffers catch
751 swap throw throw
752 repeat
753;
754
755: create_null_terminated_string { addr len -- addr' len }
756 len char+ allocate if out_of_memory throw then
757 >r
758 addr r@ len move
759 0 r@ len + c!
760 r> len
761;
762
763\ Interface to loading conf files
764
765: load_conf ( addr len -- )
766 0 to end_of_file?
767 0 to read_buffer_ptr
768 create_null_terminated_string
769 over >r
770 fopen fd !
771 r> free-memory
772 fd @ -1 = if open_error throw then
773 ['] process_conf catch
774 fd @ fclose
775 throw
776;
777
778: initialize_support
779 0 read_buffer .addr !
780 0 conf_files .addr !
| 758: free_buffers
759 line_buffer .addr @ dup if free then
760 name_buffer .addr @ dup if free then
761 value_buffer .addr @ dup if free then
762 or or if free_error throw then
763;
764
765: reset_assignment_buffers
766 0 name_buffer .addr !
767 0 name_buffer .len !
768 0 value_buffer .addr !
769 0 value_buffer .len !
770;
771
772\ Higher level file processing
773
774: process_conf
775 begin
776 end_of_file? 0=
777 while
778 reset_assignment_buffers
779 read_line
780 get_assignment
781 ['] process_assignment catch
782 ['] free_buffers catch
783 swap throw throw
784 repeat
785;
786
787: create_null_terminated_string { addr len -- addr' len }
788 len char+ allocate if out_of_memory throw then
789 >r
790 addr r@ len move
791 0 r@ len + c!
792 r> len
793;
794
795\ Interface to loading conf files
796
797: load_conf ( addr len -- )
798 0 to end_of_file?
799 0 to read_buffer_ptr
800 create_null_terminated_string
801 over >r
802 fopen fd !
803 r> free-memory
804 fd @ -1 = if open_error throw then
805 ['] process_conf catch
806 fd @ fclose
807 throw
808;
809
810: initialize_support
811 0 read_buffer .addr !
812 0 conf_files .addr !
|
| 813 0 password .addr !
|
781 0 module_options !
782 0 last_module_option !
783 0 to verbose?
784;
785
786: print_line
787 line_buffer .addr @ line_buffer .len @ type cr
788;
789
790: print_syntax_error
791 line_buffer .addr @ line_buffer .len @ type cr
792 line_buffer .addr @
793 begin
794 line_pointer over <>
795 while
796 bl emit
797 char+
798 repeat
799 drop
800 ." ^" cr
801;
802
803\ Depuration support functions
804
805only forth definitions also support-functions
806
807: test-file
808 ['] load_conf catch dup .
809 syntax_error = if cr print_syntax_error then
810;
811
812: show-module-options
813 module_options @
814 begin
815 ?dup
816 while
817 ." Name: " dup module.name dup .addr @ swap .len @ type cr
818 ." Path: " dup module.loadname dup .addr @ swap .len @ type cr
819 ." Type: " dup module.type dup .addr @ swap .len @ type cr
820 ." Flags: " dup module.args dup .addr @ swap .len @ type cr
821 ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr
822 ." After load: " dup module.afterload dup .addr @ swap .len @ type cr
823 ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr
824 ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr
825 module.next @
826 repeat
827;
828
829only forth also support-functions definitions
830
831\ Variables used for processing multiple conf files
832
833string current_file_name
834variable current_conf_files
835
836\ Indicates if any conf file was succesfully read
837
8380 value any_conf_read?
839
840\ loader_conf_files processing support functions
841
842: set_current_conf_files
843 conf_files .addr @ current_conf_files !
844;
845
846: get_conf_files
847 conf_files .addr @ conf_files .len @ strdup
848;
849
850: recurse_on_conf_files?
851 current_conf_files @ conf_files .addr @ <>
852;
853
| 814 0 module_options !
815 0 last_module_option !
816 0 to verbose?
817;
818
819: print_line
820 line_buffer .addr @ line_buffer .len @ type cr
821;
822
823: print_syntax_error
824 line_buffer .addr @ line_buffer .len @ type cr
825 line_buffer .addr @
826 begin
827 line_pointer over <>
828 while
829 bl emit
830 char+
831 repeat
832 drop
833 ." ^" cr
834;
835
836\ Depuration support functions
837
838only forth definitions also support-functions
839
840: test-file
841 ['] load_conf catch dup .
842 syntax_error = if cr print_syntax_error then
843;
844
845: show-module-options
846 module_options @
847 begin
848 ?dup
849 while
850 ." Name: " dup module.name dup .addr @ swap .len @ type cr
851 ." Path: " dup module.loadname dup .addr @ swap .len @ type cr
852 ." Type: " dup module.type dup .addr @ swap .len @ type cr
853 ." Flags: " dup module.args dup .addr @ swap .len @ type cr
854 ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr
855 ." After load: " dup module.afterload dup .addr @ swap .len @ type cr
856 ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr
857 ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr
858 module.next @
859 repeat
860;
861
862only forth also support-functions definitions
863
864\ Variables used for processing multiple conf files
865
866string current_file_name
867variable current_conf_files
868
869\ Indicates if any conf file was succesfully read
870
8710 value any_conf_read?
872
873\ loader_conf_files processing support functions
874
875: set_current_conf_files
876 conf_files .addr @ current_conf_files !
877;
878
879: get_conf_files
880 conf_files .addr @ conf_files .len @ strdup
881;
882
883: recurse_on_conf_files?
884 current_conf_files @ conf_files .addr @ <>
885;
886
|
854: skip_leading_spaces { addr len ptr -- addr len ptr' }
| 887: skip_leading_spaces { addr len pos -- addr len pos' }
|
855 begin
| 888 begin
|
856 ptr len = if addr len ptr exit then
857 addr ptr + c@ bl =
| 889 pos len = if addr len pos exit then
890 addr pos + c@ bl =
|
858 while
| 891 while
|
859 ptr char+ to ptr
| 892 pos char+ to pos
|
860 repeat
| 893 repeat
|
861 addr len ptr
| 894 addr len pos
|
862;
863
| 895;
896
|
864: get_file_name { addr len ptr -- addr len ptr' addr' len' || 0 }
865 ptr len = if
| 897: get_file_name { addr len pos -- addr len pos' addr' len' || 0 }
898 pos len = if
|
866 addr free abort" Fatal error freeing memory"
867 0 exit
868 then
| 899 addr free abort" Fatal error freeing memory"
900 0 exit
901 then
|
869 ptr >r
| 902 pos >r
|
870 begin
| 903 begin
|
871 addr ptr + c@ bl <>
| 904 addr pos + c@ bl <>
|
872 while
| 905 while
|
873 ptr char+ to ptr
874 ptr len = if
875 addr len ptr addr r@ + ptr r> - exit
| 906 pos char+ to pos
907 pos len = if
908 addr len pos addr r@ + pos r> - exit
|
876 then
877 repeat
| 909 then
910 repeat
|
878 addr len ptr addr r@ + ptr r> -
| 911 addr len pos addr r@ + pos r> -
|
879;
880
881: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 )
882 skip_leading_spaces
883 get_file_name
884;
885
886: set_current_file_name
887 over current_file_name .addr !
888 dup current_file_name .len !
889;
890
891: print_current_file
892 current_file_name .addr @ current_file_name .len @ type
893;
894
895: process_conf_errors
896 dup 0= if true to any_conf_read? drop exit then
897 >r 2drop r>
898 dup syntax_error = if
899 ." Warning: syntax error on file " print_current_file cr
900 print_syntax_error drop exit
901 then
902 dup set_error = if
903 ." Warning: bad definition on file " print_current_file cr
904 print_line drop exit
905 then
906 dup read_error = if
907 ." Warning: error reading file " print_current_file cr drop exit
908 then
909 dup open_error = if
910 verbose? if ." Warning: unable to open file " print_current_file cr then
911 drop exit
912 then
913 dup free_error = abort" Fatal error freeing memory"
914 dup out_of_memory = abort" Out of memory"
915 throw \ Unknown error -- pass ahead
916;
917
918\ Process loader_conf_files recursively
919\ Interface to loader_conf_files processing
920
921: include_conf_files
922 set_current_conf_files
923 get_conf_files 0
924 begin
925 get_next_file ?dup
926 while
927 set_current_file_name
928 ['] load_conf catch
929 process_conf_errors
930 recurse_on_conf_files? if recurse then
931 repeat
932;
933
934\ Module loading functions
935
936: load_module?
937 module.flag @
938;
939
940: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N )
941 dup >r
942 r@ module.args .addr @ r@ module.args .len @
943 r@ module.loadname .len @ if
944 r@ module.loadname .addr @ r@ module.loadname .len @
945 else
946 r@ module.name .addr @ r@ module.name .len @
947 then
948 r@ module.type .len @ if
949 r@ module.type .addr @ r@ module.type .len @
950 s" -t "
951 4 ( -t type name flags )
952 else
953 2 ( name flags )
954 then
955 r> drop
956;
957
958: before_load ( addr -- addr )
959 dup module.beforeload .len @ if
960 dup module.beforeload .addr @ over module.beforeload .len @
961 ['] evaluate catch if before_load_error throw then
962 then
963;
964
965: after_load ( addr -- addr )
966 dup module.afterload .len @ if
967 dup module.afterload .addr @ over module.afterload .len @
968 ['] evaluate catch if after_load_error throw then
969 then
970;
971
972: load_error ( addr -- addr )
973 dup module.loaderror .len @ if
974 dup module.loaderror .addr @ over module.loaderror .len @
975 evaluate \ This we do not intercept so it can throw errors
976 then
977;
978
979: pre_load_message ( addr -- addr )
980 verbose? if
981 dup module.name .addr @ over module.name .len @ type
982 ." ..."
983 then
984;
985
986: load_error_message verbose? if ." failed!" cr then ;
987
988: load_succesful_message verbose? if ." ok" cr then ;
989
990: load_module
991 load_parameters load
992;
993
994: process_module ( addr -- addr )
995 pre_load_message
996 before_load
997 begin
998 ['] load_module catch if
999 dup module.loaderror .len @ if
1000 load_error \ Command should return a flag!
1001 else
1002 load_error_message true \ Do not retry
1003 then
1004 else
1005 after_load
1006 load_succesful_message true \ Succesful, do not retry
1007 then
1008 until
1009;
1010
1011: process_module_errors ( addr ior -- )
1012 dup before_load_error = if
1013 drop
1014 ." Module "
1015 dup module.name .addr @ over module.name .len @ type
1016 dup module.loadname .len @ if
1017 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1018 then
1019 cr
1020 ." Error executing "
1021 dup module.beforeload .addr @ over module.afterload .len @ type cr
1022 abort
1023 then
1024
1025 dup after_load_error = if
1026 drop
1027 ." Module "
1028 dup module.name .addr @ over module.name .len @ type
1029 dup module.loadname .len @ if
1030 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1031 then
1032 cr
1033 ." Error executing "
1034 dup module.afterload .addr @ over module.afterload .len @ type cr
1035 abort
1036 then
1037
1038 throw \ Don't know what it is all about -- pass ahead
1039;
1040
1041\ Module loading interface
1042
1043: load_modules ( -- ) ( throws: abort & user-defined )
1044 module_options @
1045 begin
1046 ?dup
1047 while
1048 dup load_module? if
1049 ['] process_module catch
1050 process_module_errors
1051 then
1052 module.next @
1053 repeat
1054;
1055
1056\ Additional functions used in "start"
1057
1058: initialize ( addr len -- )
1059 initialize_support
1060 strdup conf_files .len ! conf_files .addr !
1061;
1062
1063: load_kernel ( -- ) ( throws: abort )
1064 s" load ${kernel} ${kernel_options}" ['] evaluate catch
1065 if s" echo Unable to load kernel: ${kernel_name}" evaluate abort then
1066;
1067
| 912;
913
914: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 )
915 skip_leading_spaces
916 get_file_name
917;
918
919: set_current_file_name
920 over current_file_name .addr !
921 dup current_file_name .len !
922;
923
924: print_current_file
925 current_file_name .addr @ current_file_name .len @ type
926;
927
928: process_conf_errors
929 dup 0= if true to any_conf_read? drop exit then
930 >r 2drop r>
931 dup syntax_error = if
932 ." Warning: syntax error on file " print_current_file cr
933 print_syntax_error drop exit
934 then
935 dup set_error = if
936 ." Warning: bad definition on file " print_current_file cr
937 print_line drop exit
938 then
939 dup read_error = if
940 ." Warning: error reading file " print_current_file cr drop exit
941 then
942 dup open_error = if
943 verbose? if ." Warning: unable to open file " print_current_file cr then
944 drop exit
945 then
946 dup free_error = abort" Fatal error freeing memory"
947 dup out_of_memory = abort" Out of memory"
948 throw \ Unknown error -- pass ahead
949;
950
951\ Process loader_conf_files recursively
952\ Interface to loader_conf_files processing
953
954: include_conf_files
955 set_current_conf_files
956 get_conf_files 0
957 begin
958 get_next_file ?dup
959 while
960 set_current_file_name
961 ['] load_conf catch
962 process_conf_errors
963 recurse_on_conf_files? if recurse then
964 repeat
965;
966
967\ Module loading functions
968
969: load_module?
970 module.flag @
971;
972
973: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N )
974 dup >r
975 r@ module.args .addr @ r@ module.args .len @
976 r@ module.loadname .len @ if
977 r@ module.loadname .addr @ r@ module.loadname .len @
978 else
979 r@ module.name .addr @ r@ module.name .len @
980 then
981 r@ module.type .len @ if
982 r@ module.type .addr @ r@ module.type .len @
983 s" -t "
984 4 ( -t type name flags )
985 else
986 2 ( name flags )
987 then
988 r> drop
989;
990
991: before_load ( addr -- addr )
992 dup module.beforeload .len @ if
993 dup module.beforeload .addr @ over module.beforeload .len @
994 ['] evaluate catch if before_load_error throw then
995 then
996;
997
998: after_load ( addr -- addr )
999 dup module.afterload .len @ if
1000 dup module.afterload .addr @ over module.afterload .len @
1001 ['] evaluate catch if after_load_error throw then
1002 then
1003;
1004
1005: load_error ( addr -- addr )
1006 dup module.loaderror .len @ if
1007 dup module.loaderror .addr @ over module.loaderror .len @
1008 evaluate \ This we do not intercept so it can throw errors
1009 then
1010;
1011
1012: pre_load_message ( addr -- addr )
1013 verbose? if
1014 dup module.name .addr @ over module.name .len @ type
1015 ." ..."
1016 then
1017;
1018
1019: load_error_message verbose? if ." failed!" cr then ;
1020
1021: load_succesful_message verbose? if ." ok" cr then ;
1022
1023: load_module
1024 load_parameters load
1025;
1026
1027: process_module ( addr -- addr )
1028 pre_load_message
1029 before_load
1030 begin
1031 ['] load_module catch if
1032 dup module.loaderror .len @ if
1033 load_error \ Command should return a flag!
1034 else
1035 load_error_message true \ Do not retry
1036 then
1037 else
1038 after_load
1039 load_succesful_message true \ Succesful, do not retry
1040 then
1041 until
1042;
1043
1044: process_module_errors ( addr ior -- )
1045 dup before_load_error = if
1046 drop
1047 ." Module "
1048 dup module.name .addr @ over module.name .len @ type
1049 dup module.loadname .len @ if
1050 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1051 then
1052 cr
1053 ." Error executing "
1054 dup module.beforeload .addr @ over module.afterload .len @ type cr
1055 abort
1056 then
1057
1058 dup after_load_error = if
1059 drop
1060 ." Module "
1061 dup module.name .addr @ over module.name .len @ type
1062 dup module.loadname .len @ if
1063 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1064 then
1065 cr
1066 ." Error executing "
1067 dup module.afterload .addr @ over module.afterload .len @ type cr
1068 abort
1069 then
1070
1071 throw \ Don't know what it is all about -- pass ahead
1072;
1073
1074\ Module loading interface
1075
1076: load_modules ( -- ) ( throws: abort & user-defined )
1077 module_options @
1078 begin
1079 ?dup
1080 while
1081 dup load_module? if
1082 ['] process_module catch
1083 process_module_errors
1084 then
1085 module.next @
1086 repeat
1087;
1088
1089\ Additional functions used in "start"
1090
1091: initialize ( addr len -- )
1092 initialize_support
1093 strdup conf_files .len ! conf_files .addr !
1094;
1095
1096: load_kernel ( -- ) ( throws: abort )
1097 s" load ${kernel} ${kernel_options}" ['] evaluate catch
1098 if s" echo Unable to load kernel: ${kernel_name}" evaluate abort then
1099;
1100
|
| 1101: read-password { size | buf len -- }
1102 size allocate if out_of_memory throw then
1103 to buf
1104 0 to len
1105 begin
1106 key
1107 dup backspace = if
1108 drop
1109 len if
1110 backspace emit bl emit backspace emit
1111 len 1 - to len
1112 else
1113 bell emit
1114 then
1115 else
1116 dup <cr> = if cr drop buf len exit then
1117 [char] * emit
1118 len size < if
1119 buf len chars + c!
1120 else
1121 drop
1122 then
1123 len 1+ to len
1124 then
1125 again
1126;
1127
|
1068\ Go back to straight forth vocabulary
1069
1070only forth also definitions
1071
| 1128\ Go back to straight forth vocabulary
1129
1130only forth also definitions
1131
|