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 66349 2000-09-25 11:36:55Z dcs $
| 25\ $FreeBSD: head/sys/boot/forth/support.4th 87636 2001-12-11 00:49:34Z jhb $
|
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
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\ strlen ( addr -- len ) similar to strlen(3)
68\ s' ( | string' -- addr len | ) similar to s"
69\ rudimentary structure support
70
71\ Exception values
72
731 constant syntax_error
742 constant out_of_memory
753 constant free_error
764 constant set_error
775 constant read_error
786 constant open_error
797 constant exec_error
808 constant before_load_error
819 constant after_load_error
82
| 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
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\ strlen ( addr -- len ) similar to strlen(3)
68\ s' ( | string' -- addr len | ) similar to s"
69\ rudimentary structure support
70
71\ Exception values
72
731 constant syntax_error
742 constant out_of_memory
753 constant free_error
764 constant set_error
775 constant read_error
786 constant open_error
797 constant exec_error
808 constant before_load_error
819 constant after_load_error
82
|
| 83\ I/O constants
84
850 constant SEEK_SET
861 constant SEEK_CUR
872 constant SEEK_END
88
890 constant O_RDONLY
901 constant O_WRONLY
912 constant O_RDWR
92
|
83\ Crude structure support
84
85: structure:
86 create here 0 , ['] drop , 0
87 does> create here swap dup @ allot cell+ @ execute
88;
89: member: create dup , over , + does> cell+ @ + ;
90: ;structure swap ! ;
91: constructor! >body cell+ ! ;
92: constructor: over :noname ;
93: ;constructor postpone ; swap cell+ ! ; immediate
94: sizeof ' >body @ state @ if postpone literal then ; immediate
95: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate
96: ptr 1 cells member: ;
97: int 1 cells member: ;
98
99\ String structure
100
101structure: string
102 ptr .addr
103 int .len
104 constructor:
105 0 over .addr !
106 0 swap .len !
107 ;constructor
108;structure
109
110
111\ Module options linked list
112
113structure: module
114 int module.flag
115 sizeof string member: module.name
116 sizeof string member: module.loadname
117 sizeof string member: module.type
118 sizeof string member: module.args
119 sizeof string member: module.beforeload
120 sizeof string member: module.afterload
121 sizeof string member: module.loaderror
122 ptr module.next
123;structure
124
125\ Internal loader structures
126structure: preloaded_file
127 ptr pf.name
128 ptr pf.type
129 ptr pf.args
130 ptr pf.metadata \ file_metadata
131 int pf.loader
132 int pf.addr
133 int pf.size
134 ptr pf.modules \ kernel_module
135 ptr pf.next \ preloaded_file
136;structure
137
138structure: kernel_module
139 ptr km.name
140 \ ptr km.args
141 ptr km.fp \ preloaded_file
142 ptr km.next \ kernel_module
143;structure
144
145structure: file_metadata
146 int md.size
147 2 member: md.type \ this is not ANS Forth compatible (XXX)
148 ptr md.next \ file_metadata
149 0 member: md.data \ variable size
150;structure
151
152structure: config_resource
153 ptr cf.name
154 int cf.type
1550 constant RES_INT
1561 constant RES_STRING
1572 constant RES_LONG
158 2 cells member: u
159;structure
160
161structure: config_device
162 ptr cd.name
163 int cd.unit
164 int cd.resource_count
165 ptr cd.resources \ config_resource
166;structure
167
168structure: STAILQ_HEAD
169 ptr stqh_first \ type*
170 ptr stqh_last \ type**
171;structure
172
173structure: STAILQ_ENTRY
174 ptr stqe_next \ type*
175;structure
176
177structure: pnphandler
178 ptr pnph.name
179 ptr pnph.enumerate
180;structure
181
182structure: pnpident
183 ptr pnpid.ident \ char*
184 sizeof STAILQ_ENTRY cells member: pnpid.link \ pnpident
185;structure
186
187structure: pnpinfo
188 ptr pnpi.desc
189 int pnpi.revision
190 ptr pnpi.module \ (char*) module args
191 int pnpi.argc
192 ptr pnpi.argv
193 ptr pnpi.handler \ pnphandler
194 sizeof STAILQ_HEAD member: pnpi.ident \ pnpident
195 sizeof STAILQ_ENTRY member: pnpi.link \ pnpinfo
196;structure
197
198\ Global variables
199
200string conf_files
201string password
202create module_options sizeof module.next allot 0 module_options !
203create last_module_option sizeof module.next allot 0 last_module_option !
2040 value verbose?
205
206\ Support string functions
207
208: strdup ( addr len -- addr' len )
209 >r r@ allocate if out_of_memory throw then
210 tuck r@ move
211 r>
212;
213
214: strcat { addr len addr' len' -- addr len+len' }
215 addr' addr len + len' move
216 addr len len' +
217;
218
219: strlen ( addr -- len )
220 0 >r
221 begin
222 dup c@ while
223 1+ r> 1+ >r repeat
224 drop r>
225;
226
227: s'
228 [char] ' parse
229 state @ if
230 postpone sliteral
231 then
232; immediate
233
234: 2>r postpone >r postpone >r ; immediate
235: 2r> postpone r> postpone r> ; immediate
236: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate
237
238: getenv?
239 getenv
240 -1 = if false else drop true then
241;
242
243\ Private definitions
244
245vocabulary support-functions
246only forth also support-functions definitions
247
248\ Some control characters constants
249
2507 constant bell
2518 constant backspace
2529 constant tab
25310 constant lf
25413 constant <cr>
255
256\ Read buffer size
257
25880 constant read_buffer_size
259
260\ Standard suffixes
261
262: load_module_suffix s" _load" ;
263: module_loadname_suffix s" _name" ;
264: module_type_suffix s" _type" ;
265: module_args_suffix s" _flags" ;
266: module_beforeload_suffix s" _before" ;
267: module_afterload_suffix s" _after" ;
268: module_loaderror_suffix s" _error" ;
269
270\ Support operators
271
272: >= < 0= ;
273: <= > 0= ;
274
275\ Assorted support funcitons
276
277: free-memory free if free_error throw then ;
278
279\ Assignment data temporary storage
280
281string name_buffer
282string value_buffer
283
284\ Line by line file reading functions
285\
286\ exported:
287\ line_buffer
288\ end_of_file?
289\ fd
290\ read_line
291\ reset_line_reading
292
293vocabulary line-reading
294also line-reading definitions also
295
296\ File data temporary storage
297
298string read_buffer
2990 value read_buffer_ptr
300
301\ File's line reading function
302
303support-functions definitions
304
305string line_buffer
3060 value end_of_file?
307variable fd
308
309line-reading definitions
310
311: skip_newlines
312 begin
313 read_buffer .len @ read_buffer_ptr >
314 while
315 read_buffer .addr @ read_buffer_ptr + c@ lf = if
316 read_buffer_ptr char+ to read_buffer_ptr
317 else
318 exit
319 then
320 repeat
321;
322
323: scan_buffer ( -- addr len )
324 read_buffer_ptr >r
325 begin
326 read_buffer .len @ r@ >
327 while
328 read_buffer .addr @ r@ + c@ lf = if
329 read_buffer .addr @ read_buffer_ptr + ( -- addr )
330 r@ read_buffer_ptr - ( -- len )
331 r> to read_buffer_ptr
332 exit
333 then
334 r> char+ >r
335 repeat
336 read_buffer .addr @ read_buffer_ptr + ( -- addr )
337 r@ read_buffer_ptr - ( -- len )
338 r> to read_buffer_ptr
339;
340
341: line_buffer_resize ( len -- len )
342 >r
343 line_buffer .len @ if
344 line_buffer .addr @
345 line_buffer .len @ r@ +
346 resize if out_of_memory throw then
347 else
348 r@ allocate if out_of_memory throw then
349 then
350 line_buffer .addr !
351 r>
352;
353
354: append_to_line_buffer ( addr len -- )
355 line_buffer .addr @ line_buffer .len @
356 2swap strcat
357 line_buffer .len !
358 drop
359;
360
361: read_from_buffer
362 scan_buffer ( -- addr len )
363 line_buffer_resize ( len -- len )
364 append_to_line_buffer ( addr len -- )
365;
366
367: refill_required?
368 read_buffer .len @ read_buffer_ptr =
369 end_of_file? 0= and
370;
371
372: refill_buffer
373 0 to read_buffer_ptr
374 read_buffer .addr @ 0= if
375 read_buffer_size allocate if out_of_memory throw then
376 read_buffer .addr !
377 then
378 fd @ read_buffer .addr @ read_buffer_size fread
379 dup -1 = if read_error throw then
380 dup 0= if true to end_of_file? then
381 read_buffer .len !
382;
383
384: reset_line_buffer
385 line_buffer .addr @ ?dup if
386 free-memory
387 then
388 0 line_buffer .addr !
389 0 line_buffer .len !
390;
391
392support-functions definitions
393
394: reset_line_reading
395 0 to read_buffer_ptr
396;
397
398: read_line
399 reset_line_buffer
400 skip_newlines
401 begin
402 read_from_buffer
403 refill_required?
404 while
405 refill_buffer
406 repeat
407;
408
409only forth also support-functions definitions
410
411\ Conf file line parser:
412\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
413\ <spaces>[<comment>]
414\ <name> ::= <letter>{<letter>|<digit>|'_'}
415\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name>
416\ <character_set> ::= ASCII 32 to 126, except '\' and '"'
417\ <comment> ::= '#'{<anything>}
418\
419\ exported:
420\ line_pointer
421\ process_conf
422
4230 value line_pointer
424
425vocabulary file-processing
426also file-processing definitions
427
428\ parser functions
429\
430\ exported:
431\ get_assignment
432
433vocabulary parser
434also parser definitions also
435
4360 value parsing_function
4370 value end_of_line
438
439: end_of_line?
440 line_pointer end_of_line =
441;
442
443: letter?
444 line_pointer c@ >r
445 r@ [char] A >=
446 r@ [char] Z <= and
447 r@ [char] a >=
448 r> [char] z <= and
449 or
450;
451
452: digit?
453 line_pointer c@ >r
454 r@ [char] 0 >=
455 r> [char] 9 <= and
456;
457
458: quote?
459 line_pointer c@ [char] " =
460;
461
462: assignment_sign?
463 line_pointer c@ [char] = =
464;
465
466: comment?
467 line_pointer c@ [char] # =
468;
469
470: space?
471 line_pointer c@ bl =
472 line_pointer c@ tab = or
473;
474
475: backslash?
476 line_pointer c@ [char] \ =
477;
478
479: underscore?
480 line_pointer c@ [char] _ =
481;
482
483: dot?
484 line_pointer c@ [char] . =
485;
486
487: skip_character
488 line_pointer char+ to line_pointer
489;
490
491: skip_to_end_of_line
492 end_of_line to line_pointer
493;
494
495: eat_space
496 begin
497 space?
498 while
499 skip_character
500 end_of_line? if exit then
501 repeat
502;
503
504: parse_name ( -- addr len )
505 line_pointer
506 begin
507 letter? digit? underscore? dot? or or or
508 while
509 skip_character
510 end_of_line? if
511 line_pointer over -
512 strdup
513 exit
514 then
515 repeat
516 line_pointer over -
517 strdup
518;
519
520: remove_backslashes { addr len | addr' len' -- addr' len' }
521 len allocate if out_of_memory throw then
522 to addr'
523 addr >r
524 begin
525 addr c@ [char] \ <> if
526 addr c@ addr' len' + c!
527 len' char+ to len'
528 then
529 addr char+ to addr
530 r@ len + addr =
531 until
532 r> drop
533 addr' len'
534;
535
536: parse_quote ( -- addr len )
537 line_pointer
538 skip_character
539 end_of_line? if syntax_error throw then
540 begin
541 quote? 0=
542 while
543 backslash? if
544 skip_character
545 end_of_line? if syntax_error throw then
546 then
547 skip_character
548 end_of_line? if syntax_error throw then
549 repeat
550 skip_character
551 line_pointer over -
552 remove_backslashes
553;
554
555: read_name
556 parse_name ( -- addr len )
557 name_buffer .len !
558 name_buffer .addr !
559;
560
561: read_value
562 quote? if
563 parse_quote ( -- addr len )
564 else
565 parse_name ( -- addr len )
566 then
567 value_buffer .len !
568 value_buffer .addr !
569;
570
571: comment
572 skip_to_end_of_line
573;
574
575: white_space_4
576 eat_space
577 comment? if ['] comment to parsing_function exit then
578 end_of_line? 0= if syntax_error throw then
579;
580
581: variable_value
582 read_value
583 ['] white_space_4 to parsing_function
584;
585
586: white_space_3
587 eat_space
588 letter? digit? quote? or or if
589 ['] variable_value to parsing_function exit
590 then
591 syntax_error throw
592;
593
594: assignment_sign
595 skip_character
596 ['] white_space_3 to parsing_function
597;
598
599: white_space_2
600 eat_space
601 assignment_sign? if ['] assignment_sign to parsing_function exit then
602 syntax_error throw
603;
604
605: variable_name
606 read_name
607 ['] white_space_2 to parsing_function
608;
609
610: white_space_1
611 eat_space
612 letter? if ['] variable_name to parsing_function exit then
613 comment? if ['] comment to parsing_function exit then
614 end_of_line? 0= if syntax_error throw then
615;
616
617file-processing definitions
618
619: get_assignment
620 line_buffer .addr @ line_buffer .len @ + to end_of_line
621 line_buffer .addr @ to line_pointer
622 ['] white_space_1 to parsing_function
623 begin
624 end_of_line? 0=
625 while
626 parsing_function execute
627 repeat
628 parsing_function ['] comment =
629 parsing_function ['] white_space_1 =
630 parsing_function ['] white_space_4 =
631 or or 0= if syntax_error throw then
632;
633
634only forth also support-functions also file-processing definitions also
635
636\ Process line
637
638: assignment_type? ( addr len -- flag )
639 name_buffer .addr @ name_buffer .len @
640 compare 0=
641;
642
643: suffix_type? ( addr len -- flag )
644 name_buffer .len @ over <= if 2drop false exit then
645 name_buffer .len @ over - name_buffer .addr @ +
646 over compare 0=
647;
648
649: loader_conf_files?
650 s" loader_conf_files" assignment_type?
651;
652
653: verbose_flag?
654 s" verbose_loading" assignment_type?
655;
656
657: execute?
658 s" exec" assignment_type?
659;
660
661: password?
662 s" password" assignment_type?
663;
664
665: module_load?
666 load_module_suffix suffix_type?
667;
668
669: module_loadname?
670 module_loadname_suffix suffix_type?
671;
672
673: module_type?
674 module_type_suffix suffix_type?
675;
676
677: module_args?
678 module_args_suffix suffix_type?
679;
680
681: module_beforeload?
682 module_beforeload_suffix suffix_type?
683;
684
685: module_afterload?
686 module_afterload_suffix suffix_type?
687;
688
689: module_loaderror?
690 module_loaderror_suffix suffix_type?
691;
692
693: set_conf_files
694 conf_files .addr @ ?dup if
695 free-memory
696 then
697 value_buffer .addr @ c@ [char] " = if
698 value_buffer .addr @ char+ value_buffer .len @ 2 chars -
699 else
700 value_buffer .addr @ value_buffer .len @
701 then
702 strdup
703 conf_files .len ! conf_files .addr !
704;
705
706: append_to_module_options_list ( addr -- )
707 module_options @ 0= if
708 dup module_options !
709 last_module_option !
710 else
711 dup last_module_option @ module.next !
712 last_module_option !
713 then
714;
715
716: set_module_name ( addr -- )
717 name_buffer .addr @ name_buffer .len @
718 strdup
719 >r over module.name .addr !
720 r> swap module.name .len !
721;
722
723: yes_value?
724 value_buffer .addr @ value_buffer .len @
725 2dup s' "YES"' compare >r
726 2dup s' "yes"' compare >r
727 2dup s" YES" compare >r
728 s" yes" compare r> r> r> and and and 0=
729;
730
731: find_module_option ( -- addr | 0 )
732 module_options @
733 begin
734 dup
735 while
736 dup module.name dup .addr @ swap .len @
737 name_buffer .addr @ name_buffer .len @
738 compare 0= if exit then
739 module.next @
740 repeat
741;
742
743: new_module_option ( -- addr )
744 sizeof module allocate if out_of_memory throw then
745 dup sizeof module erase
746 dup append_to_module_options_list
747 dup set_module_name
748;
749
750: get_module_option ( -- addr )
751 find_module_option
752 ?dup 0= if new_module_option then
753;
754
755: set_module_flag
756 name_buffer .len @ load_module_suffix nip - name_buffer .len !
757 yes_value? get_module_option module.flag !
758;
759
760: set_module_args
761 name_buffer .len @ module_args_suffix nip - name_buffer .len !
762 get_module_option module.args
763 dup .addr @ ?dup if free-memory then
764 value_buffer .addr @ value_buffer .len @
765 over c@ [char] " = if
766 2 chars - swap char+ swap
767 then
768 strdup
769 >r over .addr !
770 r> swap .len !
771;
772
773: set_module_loadname
774 name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
775 get_module_option module.loadname
776 dup .addr @ ?dup if free-memory then
777 value_buffer .addr @ value_buffer .len @
778 over c@ [char] " = if
779 2 chars - swap char+ swap
780 then
781 strdup
782 >r over .addr !
783 r> swap .len !
784;
785
786: set_module_type
787 name_buffer .len @ module_type_suffix nip - name_buffer .len !
788 get_module_option module.type
789 dup .addr @ ?dup if free-memory then
790 value_buffer .addr @ value_buffer .len @
791 over c@ [char] " = if
792 2 chars - swap char+ swap
793 then
794 strdup
795 >r over .addr !
796 r> swap .len !
797;
798
799: set_module_beforeload
800 name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
801 get_module_option module.beforeload
802 dup .addr @ ?dup if free-memory then
803 value_buffer .addr @ value_buffer .len @
804 over c@ [char] " = if
805 2 chars - swap char+ swap
806 then
807 strdup
808 >r over .addr !
809 r> swap .len !
810;
811
812: set_module_afterload
813 name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
814 get_module_option module.afterload
815 dup .addr @ ?dup if free-memory then
816 value_buffer .addr @ value_buffer .len @
817 over c@ [char] " = if
818 2 chars - swap char+ swap
819 then
820 strdup
821 >r over .addr !
822 r> swap .len !
823;
824
825: set_module_loaderror
826 name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
827 get_module_option module.loaderror
828 dup .addr @ ?dup if free-memory then
829 value_buffer .addr @ value_buffer .len @
830 over c@ [char] " = if
831 2 chars - swap char+ swap
832 then
833 strdup
834 >r over .addr !
835 r> swap .len !
836;
837
838: set_environment_variable
839 name_buffer .len @
840 value_buffer .len @ +
841 5 chars +
842 allocate if out_of_memory throw then
843 dup 0 ( addr -- addr addr len )
844 s" set " strcat
845 name_buffer .addr @ name_buffer .len @ strcat
846 s" =" strcat
847 value_buffer .addr @ value_buffer .len @ strcat
848 ['] evaluate catch if
849 2drop free drop
850 set_error throw
851 else
852 free-memory
853 then
854;
855
856: set_verbose
857 yes_value? to verbose?
858;
859
860: execute_command
861 value_buffer .addr @ value_buffer .len @
862 over c@ [char] " = if
863 2 - swap char+ swap
864 then
865 ['] evaluate catch if exec_error throw then
866;
867
868: set_password
869 password .addr @ ?dup if free if free_error throw then then
870 value_buffer .addr @ c@ [char] " = if
871 value_buffer .addr @ char+ value_buffer .len @ 2 - strdup
872 value_buffer .addr @ free if free_error throw then
873 else
874 value_buffer .addr @ value_buffer .len @
875 then
876 password .len ! password .addr !
877 0 value_buffer .addr !
878;
879
880: process_assignment
881 name_buffer .len @ 0= if exit then
882 loader_conf_files? if set_conf_files exit then
883 verbose_flag? if set_verbose exit then
884 execute? if execute_command exit then
885 password? if set_password exit then
886 module_load? if set_module_flag exit then
887 module_loadname? if set_module_loadname exit then
888 module_type? if set_module_type exit then
889 module_args? if set_module_args exit then
890 module_beforeload? if set_module_beforeload exit then
891 module_afterload? if set_module_afterload exit then
892 module_loaderror? if set_module_loaderror exit then
893 set_environment_variable
894;
895
896\ free_buffer ( -- )
897\
898\ Free some pointers if needed. The code then tests for errors
899\ in freeing, and throws an exception if needed. If a pointer is
900\ not allocated, it's value (0) is used as flag.
901
902: free_buffers
903 name_buffer .addr @ dup if free then
904 value_buffer .addr @ dup if free then
905 or if free_error throw then
906;
907
908: reset_assignment_buffers
909 0 name_buffer .addr !
910 0 name_buffer .len !
911 0 value_buffer .addr !
912 0 value_buffer .len !
913;
914
915\ Higher level file processing
916
917support-functions definitions
918
919: process_conf
920 begin
921 end_of_file? 0=
922 while
923 reset_assignment_buffers
924 read_line
925 get_assignment
926 ['] process_assignment catch
927 ['] free_buffers catch
928 swap throw throw
929 repeat
930;
931
932only forth also support-functions definitions
933
| 93\ Crude structure support
94
95: structure:
96 create here 0 , ['] drop , 0
97 does> create here swap dup @ allot cell+ @ execute
98;
99: member: create dup , over , + does> cell+ @ + ;
100: ;structure swap ! ;
101: constructor! >body cell+ ! ;
102: constructor: over :noname ;
103: ;constructor postpone ; swap cell+ ! ; immediate
104: sizeof ' >body @ state @ if postpone literal then ; immediate
105: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate
106: ptr 1 cells member: ;
107: int 1 cells member: ;
108
109\ String structure
110
111structure: string
112 ptr .addr
113 int .len
114 constructor:
115 0 over .addr !
116 0 swap .len !
117 ;constructor
118;structure
119
120
121\ Module options linked list
122
123structure: module
124 int module.flag
125 sizeof string member: module.name
126 sizeof string member: module.loadname
127 sizeof string member: module.type
128 sizeof string member: module.args
129 sizeof string member: module.beforeload
130 sizeof string member: module.afterload
131 sizeof string member: module.loaderror
132 ptr module.next
133;structure
134
135\ Internal loader structures
136structure: preloaded_file
137 ptr pf.name
138 ptr pf.type
139 ptr pf.args
140 ptr pf.metadata \ file_metadata
141 int pf.loader
142 int pf.addr
143 int pf.size
144 ptr pf.modules \ kernel_module
145 ptr pf.next \ preloaded_file
146;structure
147
148structure: kernel_module
149 ptr km.name
150 \ ptr km.args
151 ptr km.fp \ preloaded_file
152 ptr km.next \ kernel_module
153;structure
154
155structure: file_metadata
156 int md.size
157 2 member: md.type \ this is not ANS Forth compatible (XXX)
158 ptr md.next \ file_metadata
159 0 member: md.data \ variable size
160;structure
161
162structure: config_resource
163 ptr cf.name
164 int cf.type
1650 constant RES_INT
1661 constant RES_STRING
1672 constant RES_LONG
168 2 cells member: u
169;structure
170
171structure: config_device
172 ptr cd.name
173 int cd.unit
174 int cd.resource_count
175 ptr cd.resources \ config_resource
176;structure
177
178structure: STAILQ_HEAD
179 ptr stqh_first \ type*
180 ptr stqh_last \ type**
181;structure
182
183structure: STAILQ_ENTRY
184 ptr stqe_next \ type*
185;structure
186
187structure: pnphandler
188 ptr pnph.name
189 ptr pnph.enumerate
190;structure
191
192structure: pnpident
193 ptr pnpid.ident \ char*
194 sizeof STAILQ_ENTRY cells member: pnpid.link \ pnpident
195;structure
196
197structure: pnpinfo
198 ptr pnpi.desc
199 int pnpi.revision
200 ptr pnpi.module \ (char*) module args
201 int pnpi.argc
202 ptr pnpi.argv
203 ptr pnpi.handler \ pnphandler
204 sizeof STAILQ_HEAD member: pnpi.ident \ pnpident
205 sizeof STAILQ_ENTRY member: pnpi.link \ pnpinfo
206;structure
207
208\ Global variables
209
210string conf_files
211string password
212create module_options sizeof module.next allot 0 module_options !
213create last_module_option sizeof module.next allot 0 last_module_option !
2140 value verbose?
215
216\ Support string functions
217
218: strdup ( addr len -- addr' len )
219 >r r@ allocate if out_of_memory throw then
220 tuck r@ move
221 r>
222;
223
224: strcat { addr len addr' len' -- addr len+len' }
225 addr' addr len + len' move
226 addr len len' +
227;
228
229: strlen ( addr -- len )
230 0 >r
231 begin
232 dup c@ while
233 1+ r> 1+ >r repeat
234 drop r>
235;
236
237: s'
238 [char] ' parse
239 state @ if
240 postpone sliteral
241 then
242; immediate
243
244: 2>r postpone >r postpone >r ; immediate
245: 2r> postpone r> postpone r> ; immediate
246: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate
247
248: getenv?
249 getenv
250 -1 = if false else drop true then
251;
252
253\ Private definitions
254
255vocabulary support-functions
256only forth also support-functions definitions
257
258\ Some control characters constants
259
2607 constant bell
2618 constant backspace
2629 constant tab
26310 constant lf
26413 constant <cr>
265
266\ Read buffer size
267
26880 constant read_buffer_size
269
270\ Standard suffixes
271
272: load_module_suffix s" _load" ;
273: module_loadname_suffix s" _name" ;
274: module_type_suffix s" _type" ;
275: module_args_suffix s" _flags" ;
276: module_beforeload_suffix s" _before" ;
277: module_afterload_suffix s" _after" ;
278: module_loaderror_suffix s" _error" ;
279
280\ Support operators
281
282: >= < 0= ;
283: <= > 0= ;
284
285\ Assorted support funcitons
286
287: free-memory free if free_error throw then ;
288
289\ Assignment data temporary storage
290
291string name_buffer
292string value_buffer
293
294\ Line by line file reading functions
295\
296\ exported:
297\ line_buffer
298\ end_of_file?
299\ fd
300\ read_line
301\ reset_line_reading
302
303vocabulary line-reading
304also line-reading definitions also
305
306\ File data temporary storage
307
308string read_buffer
3090 value read_buffer_ptr
310
311\ File's line reading function
312
313support-functions definitions
314
315string line_buffer
3160 value end_of_file?
317variable fd
318
319line-reading definitions
320
321: skip_newlines
322 begin
323 read_buffer .len @ read_buffer_ptr >
324 while
325 read_buffer .addr @ read_buffer_ptr + c@ lf = if
326 read_buffer_ptr char+ to read_buffer_ptr
327 else
328 exit
329 then
330 repeat
331;
332
333: scan_buffer ( -- addr len )
334 read_buffer_ptr >r
335 begin
336 read_buffer .len @ r@ >
337 while
338 read_buffer .addr @ r@ + c@ lf = if
339 read_buffer .addr @ read_buffer_ptr + ( -- addr )
340 r@ read_buffer_ptr - ( -- len )
341 r> to read_buffer_ptr
342 exit
343 then
344 r> char+ >r
345 repeat
346 read_buffer .addr @ read_buffer_ptr + ( -- addr )
347 r@ read_buffer_ptr - ( -- len )
348 r> to read_buffer_ptr
349;
350
351: line_buffer_resize ( len -- len )
352 >r
353 line_buffer .len @ if
354 line_buffer .addr @
355 line_buffer .len @ r@ +
356 resize if out_of_memory throw then
357 else
358 r@ allocate if out_of_memory throw then
359 then
360 line_buffer .addr !
361 r>
362;
363
364: append_to_line_buffer ( addr len -- )
365 line_buffer .addr @ line_buffer .len @
366 2swap strcat
367 line_buffer .len !
368 drop
369;
370
371: read_from_buffer
372 scan_buffer ( -- addr len )
373 line_buffer_resize ( len -- len )
374 append_to_line_buffer ( addr len -- )
375;
376
377: refill_required?
378 read_buffer .len @ read_buffer_ptr =
379 end_of_file? 0= and
380;
381
382: refill_buffer
383 0 to read_buffer_ptr
384 read_buffer .addr @ 0= if
385 read_buffer_size allocate if out_of_memory throw then
386 read_buffer .addr !
387 then
388 fd @ read_buffer .addr @ read_buffer_size fread
389 dup -1 = if read_error throw then
390 dup 0= if true to end_of_file? then
391 read_buffer .len !
392;
393
394: reset_line_buffer
395 line_buffer .addr @ ?dup if
396 free-memory
397 then
398 0 line_buffer .addr !
399 0 line_buffer .len !
400;
401
402support-functions definitions
403
404: reset_line_reading
405 0 to read_buffer_ptr
406;
407
408: read_line
409 reset_line_buffer
410 skip_newlines
411 begin
412 read_from_buffer
413 refill_required?
414 while
415 refill_buffer
416 repeat
417;
418
419only forth also support-functions definitions
420
421\ Conf file line parser:
422\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
423\ <spaces>[<comment>]
424\ <name> ::= <letter>{<letter>|<digit>|'_'}
425\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name>
426\ <character_set> ::= ASCII 32 to 126, except '\' and '"'
427\ <comment> ::= '#'{<anything>}
428\
429\ exported:
430\ line_pointer
431\ process_conf
432
4330 value line_pointer
434
435vocabulary file-processing
436also file-processing definitions
437
438\ parser functions
439\
440\ exported:
441\ get_assignment
442
443vocabulary parser
444also parser definitions also
445
4460 value parsing_function
4470 value end_of_line
448
449: end_of_line?
450 line_pointer end_of_line =
451;
452
453: letter?
454 line_pointer c@ >r
455 r@ [char] A >=
456 r@ [char] Z <= and
457 r@ [char] a >=
458 r> [char] z <= and
459 or
460;
461
462: digit?
463 line_pointer c@ >r
464 r@ [char] 0 >=
465 r> [char] 9 <= and
466;
467
468: quote?
469 line_pointer c@ [char] " =
470;
471
472: assignment_sign?
473 line_pointer c@ [char] = =
474;
475
476: comment?
477 line_pointer c@ [char] # =
478;
479
480: space?
481 line_pointer c@ bl =
482 line_pointer c@ tab = or
483;
484
485: backslash?
486 line_pointer c@ [char] \ =
487;
488
489: underscore?
490 line_pointer c@ [char] _ =
491;
492
493: dot?
494 line_pointer c@ [char] . =
495;
496
497: skip_character
498 line_pointer char+ to line_pointer
499;
500
501: skip_to_end_of_line
502 end_of_line to line_pointer
503;
504
505: eat_space
506 begin
507 space?
508 while
509 skip_character
510 end_of_line? if exit then
511 repeat
512;
513
514: parse_name ( -- addr len )
515 line_pointer
516 begin
517 letter? digit? underscore? dot? or or or
518 while
519 skip_character
520 end_of_line? if
521 line_pointer over -
522 strdup
523 exit
524 then
525 repeat
526 line_pointer over -
527 strdup
528;
529
530: remove_backslashes { addr len | addr' len' -- addr' len' }
531 len allocate if out_of_memory throw then
532 to addr'
533 addr >r
534 begin
535 addr c@ [char] \ <> if
536 addr c@ addr' len' + c!
537 len' char+ to len'
538 then
539 addr char+ to addr
540 r@ len + addr =
541 until
542 r> drop
543 addr' len'
544;
545
546: parse_quote ( -- addr len )
547 line_pointer
548 skip_character
549 end_of_line? if syntax_error throw then
550 begin
551 quote? 0=
552 while
553 backslash? if
554 skip_character
555 end_of_line? if syntax_error throw then
556 then
557 skip_character
558 end_of_line? if syntax_error throw then
559 repeat
560 skip_character
561 line_pointer over -
562 remove_backslashes
563;
564
565: read_name
566 parse_name ( -- addr len )
567 name_buffer .len !
568 name_buffer .addr !
569;
570
571: read_value
572 quote? if
573 parse_quote ( -- addr len )
574 else
575 parse_name ( -- addr len )
576 then
577 value_buffer .len !
578 value_buffer .addr !
579;
580
581: comment
582 skip_to_end_of_line
583;
584
585: white_space_4
586 eat_space
587 comment? if ['] comment to parsing_function exit then
588 end_of_line? 0= if syntax_error throw then
589;
590
591: variable_value
592 read_value
593 ['] white_space_4 to parsing_function
594;
595
596: white_space_3
597 eat_space
598 letter? digit? quote? or or if
599 ['] variable_value to parsing_function exit
600 then
601 syntax_error throw
602;
603
604: assignment_sign
605 skip_character
606 ['] white_space_3 to parsing_function
607;
608
609: white_space_2
610 eat_space
611 assignment_sign? if ['] assignment_sign to parsing_function exit then
612 syntax_error throw
613;
614
615: variable_name
616 read_name
617 ['] white_space_2 to parsing_function
618;
619
620: white_space_1
621 eat_space
622 letter? if ['] variable_name to parsing_function exit then
623 comment? if ['] comment to parsing_function exit then
624 end_of_line? 0= if syntax_error throw then
625;
626
627file-processing definitions
628
629: get_assignment
630 line_buffer .addr @ line_buffer .len @ + to end_of_line
631 line_buffer .addr @ to line_pointer
632 ['] white_space_1 to parsing_function
633 begin
634 end_of_line? 0=
635 while
636 parsing_function execute
637 repeat
638 parsing_function ['] comment =
639 parsing_function ['] white_space_1 =
640 parsing_function ['] white_space_4 =
641 or or 0= if syntax_error throw then
642;
643
644only forth also support-functions also file-processing definitions also
645
646\ Process line
647
648: assignment_type? ( addr len -- flag )
649 name_buffer .addr @ name_buffer .len @
650 compare 0=
651;
652
653: suffix_type? ( addr len -- flag )
654 name_buffer .len @ over <= if 2drop false exit then
655 name_buffer .len @ over - name_buffer .addr @ +
656 over compare 0=
657;
658
659: loader_conf_files?
660 s" loader_conf_files" assignment_type?
661;
662
663: verbose_flag?
664 s" verbose_loading" assignment_type?
665;
666
667: execute?
668 s" exec" assignment_type?
669;
670
671: password?
672 s" password" assignment_type?
673;
674
675: module_load?
676 load_module_suffix suffix_type?
677;
678
679: module_loadname?
680 module_loadname_suffix suffix_type?
681;
682
683: module_type?
684 module_type_suffix suffix_type?
685;
686
687: module_args?
688 module_args_suffix suffix_type?
689;
690
691: module_beforeload?
692 module_beforeload_suffix suffix_type?
693;
694
695: module_afterload?
696 module_afterload_suffix suffix_type?
697;
698
699: module_loaderror?
700 module_loaderror_suffix suffix_type?
701;
702
703: set_conf_files
704 conf_files .addr @ ?dup if
705 free-memory
706 then
707 value_buffer .addr @ c@ [char] " = if
708 value_buffer .addr @ char+ value_buffer .len @ 2 chars -
709 else
710 value_buffer .addr @ value_buffer .len @
711 then
712 strdup
713 conf_files .len ! conf_files .addr !
714;
715
716: append_to_module_options_list ( addr -- )
717 module_options @ 0= if
718 dup module_options !
719 last_module_option !
720 else
721 dup last_module_option @ module.next !
722 last_module_option !
723 then
724;
725
726: set_module_name ( addr -- )
727 name_buffer .addr @ name_buffer .len @
728 strdup
729 >r over module.name .addr !
730 r> swap module.name .len !
731;
732
733: yes_value?
734 value_buffer .addr @ value_buffer .len @
735 2dup s' "YES"' compare >r
736 2dup s' "yes"' compare >r
737 2dup s" YES" compare >r
738 s" yes" compare r> r> r> and and and 0=
739;
740
741: find_module_option ( -- addr | 0 )
742 module_options @
743 begin
744 dup
745 while
746 dup module.name dup .addr @ swap .len @
747 name_buffer .addr @ name_buffer .len @
748 compare 0= if exit then
749 module.next @
750 repeat
751;
752
753: new_module_option ( -- addr )
754 sizeof module allocate if out_of_memory throw then
755 dup sizeof module erase
756 dup append_to_module_options_list
757 dup set_module_name
758;
759
760: get_module_option ( -- addr )
761 find_module_option
762 ?dup 0= if new_module_option then
763;
764
765: set_module_flag
766 name_buffer .len @ load_module_suffix nip - name_buffer .len !
767 yes_value? get_module_option module.flag !
768;
769
770: set_module_args
771 name_buffer .len @ module_args_suffix nip - name_buffer .len !
772 get_module_option module.args
773 dup .addr @ ?dup if free-memory then
774 value_buffer .addr @ value_buffer .len @
775 over c@ [char] " = if
776 2 chars - swap char+ swap
777 then
778 strdup
779 >r over .addr !
780 r> swap .len !
781;
782
783: set_module_loadname
784 name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
785 get_module_option module.loadname
786 dup .addr @ ?dup if free-memory then
787 value_buffer .addr @ value_buffer .len @
788 over c@ [char] " = if
789 2 chars - swap char+ swap
790 then
791 strdup
792 >r over .addr !
793 r> swap .len !
794;
795
796: set_module_type
797 name_buffer .len @ module_type_suffix nip - name_buffer .len !
798 get_module_option module.type
799 dup .addr @ ?dup if free-memory then
800 value_buffer .addr @ value_buffer .len @
801 over c@ [char] " = if
802 2 chars - swap char+ swap
803 then
804 strdup
805 >r over .addr !
806 r> swap .len !
807;
808
809: set_module_beforeload
810 name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
811 get_module_option module.beforeload
812 dup .addr @ ?dup if free-memory then
813 value_buffer .addr @ value_buffer .len @
814 over c@ [char] " = if
815 2 chars - swap char+ swap
816 then
817 strdup
818 >r over .addr !
819 r> swap .len !
820;
821
822: set_module_afterload
823 name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
824 get_module_option module.afterload
825 dup .addr @ ?dup if free-memory then
826 value_buffer .addr @ value_buffer .len @
827 over c@ [char] " = if
828 2 chars - swap char+ swap
829 then
830 strdup
831 >r over .addr !
832 r> swap .len !
833;
834
835: set_module_loaderror
836 name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
837 get_module_option module.loaderror
838 dup .addr @ ?dup if free-memory then
839 value_buffer .addr @ value_buffer .len @
840 over c@ [char] " = if
841 2 chars - swap char+ swap
842 then
843 strdup
844 >r over .addr !
845 r> swap .len !
846;
847
848: set_environment_variable
849 name_buffer .len @
850 value_buffer .len @ +
851 5 chars +
852 allocate if out_of_memory throw then
853 dup 0 ( addr -- addr addr len )
854 s" set " strcat
855 name_buffer .addr @ name_buffer .len @ strcat
856 s" =" strcat
857 value_buffer .addr @ value_buffer .len @ strcat
858 ['] evaluate catch if
859 2drop free drop
860 set_error throw
861 else
862 free-memory
863 then
864;
865
866: set_verbose
867 yes_value? to verbose?
868;
869
870: execute_command
871 value_buffer .addr @ value_buffer .len @
872 over c@ [char] " = if
873 2 - swap char+ swap
874 then
875 ['] evaluate catch if exec_error throw then
876;
877
878: set_password
879 password .addr @ ?dup if free if free_error throw then then
880 value_buffer .addr @ c@ [char] " = if
881 value_buffer .addr @ char+ value_buffer .len @ 2 - strdup
882 value_buffer .addr @ free if free_error throw then
883 else
884 value_buffer .addr @ value_buffer .len @
885 then
886 password .len ! password .addr !
887 0 value_buffer .addr !
888;
889
890: process_assignment
891 name_buffer .len @ 0= if exit then
892 loader_conf_files? if set_conf_files exit then
893 verbose_flag? if set_verbose exit then
894 execute? if execute_command exit then
895 password? if set_password exit then
896 module_load? if set_module_flag exit then
897 module_loadname? if set_module_loadname exit then
898 module_type? if set_module_type exit then
899 module_args? if set_module_args exit then
900 module_beforeload? if set_module_beforeload exit then
901 module_afterload? if set_module_afterload exit then
902 module_loaderror? if set_module_loaderror exit then
903 set_environment_variable
904;
905
906\ free_buffer ( -- )
907\
908\ Free some pointers if needed. The code then tests for errors
909\ in freeing, and throws an exception if needed. If a pointer is
910\ not allocated, it's value (0) is used as flag.
911
912: free_buffers
913 name_buffer .addr @ dup if free then
914 value_buffer .addr @ dup if free then
915 or if free_error throw then
916;
917
918: reset_assignment_buffers
919 0 name_buffer .addr !
920 0 name_buffer .len !
921 0 value_buffer .addr !
922 0 value_buffer .len !
923;
924
925\ Higher level file processing
926
927support-functions definitions
928
929: process_conf
930 begin
931 end_of_file? 0=
932 while
933 reset_assignment_buffers
934 read_line
935 get_assignment
936 ['] process_assignment catch
937 ['] free_buffers catch
938 swap throw throw
939 repeat
940;
941
942only forth also support-functions definitions
943
|
934: create_null_terminated_string { addr len -- addr' len }
935 len char+ allocate if out_of_memory throw then
936 >r
937 addr r@ len move
938 0 r@ len + c!
939 r> len
940;
941
| |
942\ Interface to loading conf files
943
944: load_conf ( addr len -- )
945 0 to end_of_file?
946 reset_line_reading
| 944\ Interface to loading conf files
945
946: load_conf ( addr len -- )
947 0 to end_of_file?
948 reset_line_reading
|
947 create_null_terminated_string
948 over >r
949 fopen fd !
950 r> free-memory
| 949 O_RDONLY fopen fd !
|
951 fd @ -1 = if open_error throw then
952 ['] process_conf catch
953 fd @ fclose
954 throw
955;
956
957: print_line
958 line_buffer .addr @ line_buffer .len @ type cr
959;
960
961: print_syntax_error
962 line_buffer .addr @ line_buffer .len @ type cr
963 line_buffer .addr @
964 begin
965 line_pointer over <>
966 while
967 bl emit
968 char+
969 repeat
970 drop
971 ." ^" cr
972;
973
974\ Depuration support functions
975
976only forth definitions also support-functions
977
978: test-file
979 ['] load_conf catch dup .
980 syntax_error = if cr print_syntax_error then
981;
982
983: show-module-options
984 module_options @
985 begin
986 ?dup
987 while
988 ." Name: " dup module.name dup .addr @ swap .len @ type cr
989 ." Path: " dup module.loadname dup .addr @ swap .len @ type cr
990 ." Type: " dup module.type dup .addr @ swap .len @ type cr
991 ." Flags: " dup module.args dup .addr @ swap .len @ type cr
992 ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr
993 ." After load: " dup module.afterload dup .addr @ swap .len @ type cr
994 ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr
995 ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr
996 module.next @
997 repeat
998;
999
1000only forth also support-functions definitions
1001
1002\ Variables used for processing multiple conf files
1003
1004string current_file_name
1005variable current_conf_files
1006
1007\ Indicates if any conf file was succesfully read
1008
10090 value any_conf_read?
1010
1011\ loader_conf_files processing support functions
1012
1013: set_current_conf_files
1014 conf_files .addr @ current_conf_files !
1015;
1016
1017: get_conf_files
1018 conf_files .addr @ conf_files .len @ strdup
1019;
1020
1021: recurse_on_conf_files?
1022 current_conf_files @ conf_files .addr @ <>
1023;
1024
1025: skip_leading_spaces { addr len pos -- addr len pos' }
1026 begin
1027 pos len = if addr len pos exit then
1028 addr pos + c@ bl =
1029 while
1030 pos char+ to pos
1031 repeat
1032 addr len pos
1033;
1034
1035: get_file_name { addr len pos -- addr len pos' addr' len' || 0 }
1036 pos len = if
1037 addr free abort" Fatal error freeing memory"
1038 0 exit
1039 then
1040 pos >r
1041 begin
1042 addr pos + c@ bl <>
1043 while
1044 pos char+ to pos
1045 pos len = if
1046 addr len pos addr r@ + pos r> - exit
1047 then
1048 repeat
1049 addr len pos addr r@ + pos r> -
1050;
1051
1052: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 )
1053 skip_leading_spaces
1054 get_file_name
1055;
1056
1057: set_current_file_name
1058 over current_file_name .addr !
1059 dup current_file_name .len !
1060;
1061
1062: print_current_file
1063 current_file_name .addr @ current_file_name .len @ type
1064;
1065
1066: process_conf_errors
1067 dup 0= if true to any_conf_read? drop exit then
1068 >r 2drop r>
1069 dup syntax_error = if
1070 ." Warning: syntax error on file " print_current_file cr
1071 print_syntax_error drop exit
1072 then
1073 dup set_error = if
1074 ." Warning: bad definition on file " print_current_file cr
1075 print_line drop exit
1076 then
1077 dup read_error = if
1078 ." Warning: error reading file " print_current_file cr drop exit
1079 then
1080 dup open_error = if
1081 verbose? if ." Warning: unable to open file " print_current_file cr then
1082 drop exit
1083 then
1084 dup free_error = abort" Fatal error freeing memory"
1085 dup out_of_memory = abort" Out of memory"
1086 throw \ Unknown error -- pass ahead
1087;
1088
1089\ Process loader_conf_files recursively
1090\ Interface to loader_conf_files processing
1091
1092: include_conf_files
1093 set_current_conf_files
1094 get_conf_files 0
1095 begin
1096 get_next_file ?dup
1097 while
1098 set_current_file_name
1099 ['] load_conf catch
1100 process_conf_errors
1101 recurse_on_conf_files? if recurse then
1102 repeat
1103;
1104
1105\ Module loading functions
1106
1107: load_module?
1108 module.flag @
1109;
1110
1111: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N )
1112 dup >r
1113 r@ module.args .addr @ r@ module.args .len @
1114 r@ module.loadname .len @ if
1115 r@ module.loadname .addr @ r@ module.loadname .len @
1116 else
1117 r@ module.name .addr @ r@ module.name .len @
1118 then
1119 r@ module.type .len @ if
1120 r@ module.type .addr @ r@ module.type .len @
1121 s" -t "
1122 4 ( -t type name flags )
1123 else
1124 2 ( name flags )
1125 then
1126 r> drop
1127;
1128
1129: before_load ( addr -- addr )
1130 dup module.beforeload .len @ if
1131 dup module.beforeload .addr @ over module.beforeload .len @
1132 ['] evaluate catch if before_load_error throw then
1133 then
1134;
1135
1136: after_load ( addr -- addr )
1137 dup module.afterload .len @ if
1138 dup module.afterload .addr @ over module.afterload .len @
1139 ['] evaluate catch if after_load_error throw then
1140 then
1141;
1142
1143: load_error ( addr -- addr )
1144 dup module.loaderror .len @ if
1145 dup module.loaderror .addr @ over module.loaderror .len @
1146 evaluate \ This we do not intercept so it can throw errors
1147 then
1148;
1149
1150: pre_load_message ( addr -- addr )
1151 verbose? if
1152 dup module.name .addr @ over module.name .len @ type
1153 ." ..."
1154 then
1155;
1156
1157: load_error_message verbose? if ." failed!" cr then ;
1158
1159: load_succesful_message verbose? if ." ok" cr then ;
1160
1161: load_module
1162 load_parameters load
1163;
1164
1165: process_module ( addr -- addr )
1166 pre_load_message
1167 before_load
1168 begin
1169 ['] load_module catch if
1170 dup module.loaderror .len @ if
1171 load_error \ Command should return a flag!
1172 else
1173 load_error_message true \ Do not retry
1174 then
1175 else
1176 after_load
1177 load_succesful_message true \ Succesful, do not retry
1178 then
1179 until
1180;
1181
1182: process_module_errors ( addr ior -- )
1183 dup before_load_error = if
1184 drop
1185 ." Module "
1186 dup module.name .addr @ over module.name .len @ type
1187 dup module.loadname .len @ if
1188 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1189 then
1190 cr
1191 ." Error executing "
1192 dup module.beforeload .addr @ over module.afterload .len @ type cr
1193 abort
1194 then
1195
1196 dup after_load_error = if
1197 drop
1198 ." Module "
1199 dup module.name .addr @ over module.name .len @ type
1200 dup module.loadname .len @ if
1201 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1202 then
1203 cr
1204 ." Error executing "
1205 dup module.afterload .addr @ over module.afterload .len @ type cr
1206 abort
1207 then
1208
1209 throw \ Don't know what it is all about -- pass ahead
1210;
1211
1212\ Module loading interface
1213
1214: load_modules ( -- ) ( throws: abort & user-defined )
1215 module_options @
1216 begin
1217 ?dup
1218 while
1219 dup load_module? if
1220 ['] process_module catch
1221 process_module_errors
1222 then
1223 module.next @
1224 repeat
1225;
1226
1227\ h00h00 magic used to try loading either a kernel with a given name,
1228\ or a kernel with the default name in a directory of a given name
1229\ (the pain!)
1230
1231: bootpath s" /boot/" ;
1232: modulepath s" module_path" ;
1233
1234\ Functions used to save and restore module_path's value.
1235: saveenv ( addr len | -1 -- addr' len | 0 -1 )
1236 dup -1 = if 0 swap exit then
1237 strdup
1238;
1239: freeenv ( addr len | 0 -1 )
1240 -1 = if drop else free abort" Freeing error" then
1241;
1242: restoreenv ( addr len | 0 -1 -- )
1243 dup -1 = if ( it wasn't set )
1244 2drop
1245 modulepath unsetenv
1246 else
1247 over >r
1248 modulepath setenv
1249 r> free abort" Freeing error"
1250 then
1251;
1252
1253: clip_args \ Drop second string if only one argument is passed
1254 1 = if
1255 2swap 2drop
1256 1
1257 else
1258 2
1259 then
1260;
1261
1262also builtins
1263
1264\ Parse filename from a comma-separated list
1265
1266: parse-; ( addr len -- addr' len-x addr x )
1267 over 0 2swap
1268 begin
1269 dup 0 <>
1270 while
1271 over c@ [char] ; <>
1272 while
1273 1- swap 1+ swap
1274 2swap 1+ 2swap
1275 repeat then
1276 dup 0 <> if
1277 1- swap 1+ swap
1278 then
1279 2swap
1280;
1281
1282\ Try loading one of multiple kernels specified
1283
1284: try_multiple_kernels ( addr len addr' len' args -- flag )
1285 >r
1286 begin
1287 parse-; 2>r
1288 2over 2r>
1289 r@ clip_args
1290 s" DEBUG" getenv? if
1291 s" echo Module_path: ${module_path}" evaluate
1292 ." Kernel : " >r 2dup type r> cr
1293 dup 2 = if ." Flags : " >r 2over type r> cr then
1294 then
1295 1 load
1296 while
1297 dup 0=
1298 until
1299 1 >r \ Failure
1300 else
1301 0 >r \ Success
1302 then
1303 2drop 2drop
1304 r>
1305 r> drop
1306;
1307
1308\ Try to load a kernel; the kernel name is taken from one of
1309\ the following lists, as ordered:
1310\
1311\ 1. The "bootfile" environment variable
1312\ 2. The "kernel" environment variable
1313\
1314\ Flags are passed, if available. If not, dummy values must be given.
1315\
1316\ The kernel gets loaded from the current module_path.
1317
1318: load_a_kernel ( flags len 1 | x x 0 -- flag )
1319 local args
1320 2local flags
1321 0 0 2local kernel
1322 end-locals
1323
1324 \ Check if a default kernel name exists at all, exits if not
1325 s" bootfile" getenv dup -1 <> if
1326 to kernel
1327 flags kernel args 1+ try_multiple_kernels
1328 dup 0= if exit then
1329 then
1330 drop
1331
1332 s" kernel" getenv dup -1 <> if
1333 to kernel
1334 else
1335 drop
1336 1 exit \ Failure
1337 then
1338
1339 \ Try all default kernel names
1340 flags kernel args 1+ try_multiple_kernels
1341;
1342
1343\ Try to load a kernel; the kernel name is taken from one of
1344\ the following lists, as ordered:
1345\
1346\ 1. The "bootfile" environment variable
1347\ 2. The "kernel" environment variable
1348\
1349\ Flags are passed, if provided.
1350\
1351\ The kernel will be loaded from a directory computed from the
1352\ path given. Two directories will be tried in the following order:
1353\
1354\ 1. /boot/path
1355\ 2. path
1356\
1357\ The module_path variable is overridden if load is succesful, by
1358\ prepending the successful path.
1359
1360: load_from_directory ( path len 1 | flags len' path len 2 -- flag )
1361 local args
1362 2local path
1363 args 1 = if 0 0 then
1364 2local flags
1365 0 0 2local oldmodulepath
1366 0 0 2local newmodulepath
1367 end-locals
1368
1369 \ Set the environment variable module_path, and try loading
1370 \ the kernel again.
1371 modulepath getenv saveenv to oldmodulepath
1372
1373 \ Try prepending /boot/ first
1374 bootpath nip path nip +
1375 oldmodulepath nip dup -1 = if
1376 drop
1377 else
1378 1+ +
1379 then
1380 allocate
1381 if ( out of memory )
1382 1 exit
1383 then
1384
1385 0
1386 bootpath strcat
1387 path strcat
1388 2dup to newmodulepath
1389 modulepath setenv
1390
1391 \ Try all default kernel names
1392 flags args 1- load_a_kernel
1393 0= if ( success )
1394 oldmodulepath nip -1 <> if
1395 newmodulepath s" ;" strcat
1396 oldmodulepath strcat
1397 modulepath setenv
1398 newmodulepath drop free-memory
1399 oldmodulepath drop free-memory
1400 then
1401 0 exit
1402 then
1403
1404 \ Well, try without the prepended /boot/
1405 path newmodulepath drop swap move
1406 newmodulepath drop path nip
1407 2dup to newmodulepath
1408 modulepath setenv
1409
1410 \ Try all default kernel names
1411 flags args 1- load_a_kernel
1412 if ( failed once more )
1413 oldmodulepath restoreenv
1414 newmodulepath drop free-memory
1415 1
1416 else
1417 oldmodulepath nip -1 <> if
1418 newmodulepath s" ;" strcat
1419 oldmodulepath strcat
1420 modulepath setenv
1421 newmodulepath drop free-memory
1422 oldmodulepath drop free-memory
1423 then
1424 0
1425 then
1426;
1427
1428\ Try to load a kernel; the kernel name is taken from one of
1429\ the following lists, as ordered:
1430\
1431\ 1. The "bootfile" environment variable
1432\ 2. The "kernel" environment variable
1433\ 3. The "path" argument
1434\
1435\ Flags are passed, if provided.
1436\
1437\ The kernel will be loaded from a directory computed from the
1438\ path given. Two directories will be tried in the following order:
1439\
1440\ 1. /boot/path
1441\ 2. path
1442\
1443\ Unless "path" is meant to be kernel name itself. In that case, it
1444\ will first be tried as a full path, and, next, search on the
1445\ directories pointed by module_path.
1446\
1447\ The module_path variable is overridden if load is succesful, by
1448\ prepending the successful path.
1449
1450: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag )
1451 local args
1452 2local path
1453 args 1 = if 0 0 then
1454 2local flags
1455 end-locals
1456
1457 \ First, assume path is an absolute path to a directory
1458 flags path args clip_args load_from_directory
1459 dup 0= if exit else drop then
1460
1461 \ Next, assume path points to the kernel
1462 flags path args try_multiple_kernels
1463;
1464
1465: initialize ( addr len -- )
1466 strdup conf_files .len ! conf_files .addr !
1467;
1468
1469: kernel_options ( -- addr len 1 | 0 )
1470 s" kernel_options" getenv
1471 dup -1 = if drop 0 else 1 then
1472;
1473
1474: standard_kernel_search ( flags 1 | 0 -- flag )
1475 local args
1476 args 0= if 0 0 then
1477 2local flags
1478 s" kernel" getenv
1479 dup -1 = if 0 swap then
1480 2local path
1481 end-locals
1482
1483 path nip -1 = if ( there isn't a "kernel" environment variable )
1484 flags args load_a_kernel
1485 else
1486 flags path args 1+ clip_args load_directory_or_file
1487 then
1488;
1489
1490: load_kernel ( -- ) ( throws: abort )
1491 kernel_options standard_kernel_search
1492 abort" Unable to load a kernel!"
1493;
1494
1495: set_defaultoptions ( -- )
1496 s" kernel_options" getenv dup -1 = if
1497 drop
1498 else
1499 s" temp_options" setenv
1500 then
1501;
1502
1503: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
1504 2dup = if 0 0 exit then
1505 dup >r
1506 1+ 2* ( skip N and ui )
1507 pick
1508 r>
1509 1+ 2* ( skip N and ai )
1510 pick
1511;
1512
1513: drop_args ( aN uN ... a1 u1 N -- )
1514 0 ?do 2drop loop
1515;
1516
1517: argc
1518 dup
1519;
1520
1521: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 )
1522 >r
1523 over 2* 1+ -roll
1524 r>
1525 over 2* 1+ -roll
1526 1+
1527;
1528
1529: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 )
1530 1- -rot
1531;
1532
1533: strlen(argv)
1534 dup 0= if 0 exit then
1535 0 >r \ Size
1536 0 >r \ Index
1537 begin
1538 argc r@ <>
1539 while
1540 r@ argv[]
1541 nip
1542 r> r> rot + 1+
1543 >r 1+ >r
1544 repeat
1545 r> drop
1546 r>
1547;
1548
1549: concat_argv ( aN uN ... a1 u1 N -- a u )
1550 strlen(argv) allocate if out_of_memory throw then
1551 0 2>r
1552
1553 begin
1554 argc
1555 while
1556 unqueue_argv
1557 2r> 2swap
1558 strcat
1559 s" " strcat
1560 2>r
1561 repeat
1562 drop_args
1563 2r>
1564;
1565
1566: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
1567 \ Save the first argument, if it exists and is not a flag
1568 argc if
1569 0 argv[] drop c@ [char] - <> if
1570 unqueue_argv 2>r \ Filename
1571 1 >r \ Filename present
1572 else
1573 0 >r \ Filename not present
1574 then
1575 else
1576 0 >r \ Filename not present
1577 then
1578
1579 \ If there are other arguments, assume they are flags
1580 ?dup if
1581 concat_argv
1582 2dup s" temp_options" setenv
1583 drop free if free_error throw then
1584 else
1585 set_defaultoptions
1586 then
1587
1588 \ Bring back the filename, if one was provided
1589 r> if 2r> 1 else 0 then
1590;
1591
1592: get_arguments ( -- addrN lenN ... addr1 len1 N )
1593 0
1594 begin
1595 \ Get next word on the command line
1596 parse-word
1597 ?dup while
1598 queue_argv
1599 repeat
1600 drop ( empty string )
1601;
1602
1603: load_kernel_and_modules ( args -- flag )
1604 set_tempoptions
1605 argc >r
1606 s" temp_options" getenv dup -1 <> if
1607 queue_argv
1608 else
1609 drop
1610 then
1611 r> if ( a path was passed )
1612 load_directory_or_file
1613 else
1614 standard_kernel_search
1615 then
1616 ?dup 0= if ['] load_modules catch then
1617;
1618
1619: read-password { size | buf len -- }
1620 size allocate if out_of_memory throw then
1621 to buf
1622 0 to len
1623 begin
1624 key
1625 dup backspace = if
1626 drop
1627 len if
1628 backspace emit bl emit backspace emit
1629 len 1 - to len
1630 else
1631 bell emit
1632 then
1633 else
1634 dup <cr> = if cr drop buf len exit then
1635 [char] * emit
1636 len size < if
1637 buf len chars + c!
1638 else
1639 drop
1640 then
1641 len 1+ to len
1642 then
1643 again
1644;
1645
1646\ Go back to straight forth vocabulary
1647
1648only forth also definitions
1649
| 950 fd @ -1 = if open_error throw then
951 ['] process_conf catch
952 fd @ fclose
953 throw
954;
955
956: print_line
957 line_buffer .addr @ line_buffer .len @ type cr
958;
959
960: print_syntax_error
961 line_buffer .addr @ line_buffer .len @ type cr
962 line_buffer .addr @
963 begin
964 line_pointer over <>
965 while
966 bl emit
967 char+
968 repeat
969 drop
970 ." ^" cr
971;
972
973\ Depuration support functions
974
975only forth definitions also support-functions
976
977: test-file
978 ['] load_conf catch dup .
979 syntax_error = if cr print_syntax_error then
980;
981
982: show-module-options
983 module_options @
984 begin
985 ?dup
986 while
987 ." Name: " dup module.name dup .addr @ swap .len @ type cr
988 ." Path: " dup module.loadname dup .addr @ swap .len @ type cr
989 ." Type: " dup module.type dup .addr @ swap .len @ type cr
990 ." Flags: " dup module.args dup .addr @ swap .len @ type cr
991 ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr
992 ." After load: " dup module.afterload dup .addr @ swap .len @ type cr
993 ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr
994 ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr
995 module.next @
996 repeat
997;
998
999only forth also support-functions definitions
1000
1001\ Variables used for processing multiple conf files
1002
1003string current_file_name
1004variable current_conf_files
1005
1006\ Indicates if any conf file was succesfully read
1007
10080 value any_conf_read?
1009
1010\ loader_conf_files processing support functions
1011
1012: set_current_conf_files
1013 conf_files .addr @ current_conf_files !
1014;
1015
1016: get_conf_files
1017 conf_files .addr @ conf_files .len @ strdup
1018;
1019
1020: recurse_on_conf_files?
1021 current_conf_files @ conf_files .addr @ <>
1022;
1023
1024: skip_leading_spaces { addr len pos -- addr len pos' }
1025 begin
1026 pos len = if addr len pos exit then
1027 addr pos + c@ bl =
1028 while
1029 pos char+ to pos
1030 repeat
1031 addr len pos
1032;
1033
1034: get_file_name { addr len pos -- addr len pos' addr' len' || 0 }
1035 pos len = if
1036 addr free abort" Fatal error freeing memory"
1037 0 exit
1038 then
1039 pos >r
1040 begin
1041 addr pos + c@ bl <>
1042 while
1043 pos char+ to pos
1044 pos len = if
1045 addr len pos addr r@ + pos r> - exit
1046 then
1047 repeat
1048 addr len pos addr r@ + pos r> -
1049;
1050
1051: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 )
1052 skip_leading_spaces
1053 get_file_name
1054;
1055
1056: set_current_file_name
1057 over current_file_name .addr !
1058 dup current_file_name .len !
1059;
1060
1061: print_current_file
1062 current_file_name .addr @ current_file_name .len @ type
1063;
1064
1065: process_conf_errors
1066 dup 0= if true to any_conf_read? drop exit then
1067 >r 2drop r>
1068 dup syntax_error = if
1069 ." Warning: syntax error on file " print_current_file cr
1070 print_syntax_error drop exit
1071 then
1072 dup set_error = if
1073 ." Warning: bad definition on file " print_current_file cr
1074 print_line drop exit
1075 then
1076 dup read_error = if
1077 ." Warning: error reading file " print_current_file cr drop exit
1078 then
1079 dup open_error = if
1080 verbose? if ." Warning: unable to open file " print_current_file cr then
1081 drop exit
1082 then
1083 dup free_error = abort" Fatal error freeing memory"
1084 dup out_of_memory = abort" Out of memory"
1085 throw \ Unknown error -- pass ahead
1086;
1087
1088\ Process loader_conf_files recursively
1089\ Interface to loader_conf_files processing
1090
1091: include_conf_files
1092 set_current_conf_files
1093 get_conf_files 0
1094 begin
1095 get_next_file ?dup
1096 while
1097 set_current_file_name
1098 ['] load_conf catch
1099 process_conf_errors
1100 recurse_on_conf_files? if recurse then
1101 repeat
1102;
1103
1104\ Module loading functions
1105
1106: load_module?
1107 module.flag @
1108;
1109
1110: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N )
1111 dup >r
1112 r@ module.args .addr @ r@ module.args .len @
1113 r@ module.loadname .len @ if
1114 r@ module.loadname .addr @ r@ module.loadname .len @
1115 else
1116 r@ module.name .addr @ r@ module.name .len @
1117 then
1118 r@ module.type .len @ if
1119 r@ module.type .addr @ r@ module.type .len @
1120 s" -t "
1121 4 ( -t type name flags )
1122 else
1123 2 ( name flags )
1124 then
1125 r> drop
1126;
1127
1128: before_load ( addr -- addr )
1129 dup module.beforeload .len @ if
1130 dup module.beforeload .addr @ over module.beforeload .len @
1131 ['] evaluate catch if before_load_error throw then
1132 then
1133;
1134
1135: after_load ( addr -- addr )
1136 dup module.afterload .len @ if
1137 dup module.afterload .addr @ over module.afterload .len @
1138 ['] evaluate catch if after_load_error throw then
1139 then
1140;
1141
1142: load_error ( addr -- addr )
1143 dup module.loaderror .len @ if
1144 dup module.loaderror .addr @ over module.loaderror .len @
1145 evaluate \ This we do not intercept so it can throw errors
1146 then
1147;
1148
1149: pre_load_message ( addr -- addr )
1150 verbose? if
1151 dup module.name .addr @ over module.name .len @ type
1152 ." ..."
1153 then
1154;
1155
1156: load_error_message verbose? if ." failed!" cr then ;
1157
1158: load_succesful_message verbose? if ." ok" cr then ;
1159
1160: load_module
1161 load_parameters load
1162;
1163
1164: process_module ( addr -- addr )
1165 pre_load_message
1166 before_load
1167 begin
1168 ['] load_module catch if
1169 dup module.loaderror .len @ if
1170 load_error \ Command should return a flag!
1171 else
1172 load_error_message true \ Do not retry
1173 then
1174 else
1175 after_load
1176 load_succesful_message true \ Succesful, do not retry
1177 then
1178 until
1179;
1180
1181: process_module_errors ( addr ior -- )
1182 dup before_load_error = if
1183 drop
1184 ." Module "
1185 dup module.name .addr @ over module.name .len @ type
1186 dup module.loadname .len @ if
1187 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1188 then
1189 cr
1190 ." Error executing "
1191 dup module.beforeload .addr @ over module.afterload .len @ type cr
1192 abort
1193 then
1194
1195 dup after_load_error = if
1196 drop
1197 ." Module "
1198 dup module.name .addr @ over module.name .len @ type
1199 dup module.loadname .len @ if
1200 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1201 then
1202 cr
1203 ." Error executing "
1204 dup module.afterload .addr @ over module.afterload .len @ type cr
1205 abort
1206 then
1207
1208 throw \ Don't know what it is all about -- pass ahead
1209;
1210
1211\ Module loading interface
1212
1213: load_modules ( -- ) ( throws: abort & user-defined )
1214 module_options @
1215 begin
1216 ?dup
1217 while
1218 dup load_module? if
1219 ['] process_module catch
1220 process_module_errors
1221 then
1222 module.next @
1223 repeat
1224;
1225
1226\ h00h00 magic used to try loading either a kernel with a given name,
1227\ or a kernel with the default name in a directory of a given name
1228\ (the pain!)
1229
1230: bootpath s" /boot/" ;
1231: modulepath s" module_path" ;
1232
1233\ Functions used to save and restore module_path's value.
1234: saveenv ( addr len | -1 -- addr' len | 0 -1 )
1235 dup -1 = if 0 swap exit then
1236 strdup
1237;
1238: freeenv ( addr len | 0 -1 )
1239 -1 = if drop else free abort" Freeing error" then
1240;
1241: restoreenv ( addr len | 0 -1 -- )
1242 dup -1 = if ( it wasn't set )
1243 2drop
1244 modulepath unsetenv
1245 else
1246 over >r
1247 modulepath setenv
1248 r> free abort" Freeing error"
1249 then
1250;
1251
1252: clip_args \ Drop second string if only one argument is passed
1253 1 = if
1254 2swap 2drop
1255 1
1256 else
1257 2
1258 then
1259;
1260
1261also builtins
1262
1263\ Parse filename from a comma-separated list
1264
1265: parse-; ( addr len -- addr' len-x addr x )
1266 over 0 2swap
1267 begin
1268 dup 0 <>
1269 while
1270 over c@ [char] ; <>
1271 while
1272 1- swap 1+ swap
1273 2swap 1+ 2swap
1274 repeat then
1275 dup 0 <> if
1276 1- swap 1+ swap
1277 then
1278 2swap
1279;
1280
1281\ Try loading one of multiple kernels specified
1282
1283: try_multiple_kernels ( addr len addr' len' args -- flag )
1284 >r
1285 begin
1286 parse-; 2>r
1287 2over 2r>
1288 r@ clip_args
1289 s" DEBUG" getenv? if
1290 s" echo Module_path: ${module_path}" evaluate
1291 ." Kernel : " >r 2dup type r> cr
1292 dup 2 = if ." Flags : " >r 2over type r> cr then
1293 then
1294 1 load
1295 while
1296 dup 0=
1297 until
1298 1 >r \ Failure
1299 else
1300 0 >r \ Success
1301 then
1302 2drop 2drop
1303 r>
1304 r> drop
1305;
1306
1307\ Try to load a kernel; the kernel name is taken from one of
1308\ the following lists, as ordered:
1309\
1310\ 1. The "bootfile" environment variable
1311\ 2. The "kernel" environment variable
1312\
1313\ Flags are passed, if available. If not, dummy values must be given.
1314\
1315\ The kernel gets loaded from the current module_path.
1316
1317: load_a_kernel ( flags len 1 | x x 0 -- flag )
1318 local args
1319 2local flags
1320 0 0 2local kernel
1321 end-locals
1322
1323 \ Check if a default kernel name exists at all, exits if not
1324 s" bootfile" getenv dup -1 <> if
1325 to kernel
1326 flags kernel args 1+ try_multiple_kernels
1327 dup 0= if exit then
1328 then
1329 drop
1330
1331 s" kernel" getenv dup -1 <> if
1332 to kernel
1333 else
1334 drop
1335 1 exit \ Failure
1336 then
1337
1338 \ Try all default kernel names
1339 flags kernel args 1+ try_multiple_kernels
1340;
1341
1342\ Try to load a kernel; the kernel name is taken from one of
1343\ the following lists, as ordered:
1344\
1345\ 1. The "bootfile" environment variable
1346\ 2. The "kernel" environment variable
1347\
1348\ Flags are passed, if provided.
1349\
1350\ The kernel will be loaded from a directory computed from the
1351\ path given. Two directories will be tried in the following order:
1352\
1353\ 1. /boot/path
1354\ 2. path
1355\
1356\ The module_path variable is overridden if load is succesful, by
1357\ prepending the successful path.
1358
1359: load_from_directory ( path len 1 | flags len' path len 2 -- flag )
1360 local args
1361 2local path
1362 args 1 = if 0 0 then
1363 2local flags
1364 0 0 2local oldmodulepath
1365 0 0 2local newmodulepath
1366 end-locals
1367
1368 \ Set the environment variable module_path, and try loading
1369 \ the kernel again.
1370 modulepath getenv saveenv to oldmodulepath
1371
1372 \ Try prepending /boot/ first
1373 bootpath nip path nip +
1374 oldmodulepath nip dup -1 = if
1375 drop
1376 else
1377 1+ +
1378 then
1379 allocate
1380 if ( out of memory )
1381 1 exit
1382 then
1383
1384 0
1385 bootpath strcat
1386 path strcat
1387 2dup to newmodulepath
1388 modulepath setenv
1389
1390 \ Try all default kernel names
1391 flags args 1- load_a_kernel
1392 0= if ( success )
1393 oldmodulepath nip -1 <> if
1394 newmodulepath s" ;" strcat
1395 oldmodulepath strcat
1396 modulepath setenv
1397 newmodulepath drop free-memory
1398 oldmodulepath drop free-memory
1399 then
1400 0 exit
1401 then
1402
1403 \ Well, try without the prepended /boot/
1404 path newmodulepath drop swap move
1405 newmodulepath drop path nip
1406 2dup to newmodulepath
1407 modulepath setenv
1408
1409 \ Try all default kernel names
1410 flags args 1- load_a_kernel
1411 if ( failed once more )
1412 oldmodulepath restoreenv
1413 newmodulepath drop free-memory
1414 1
1415 else
1416 oldmodulepath nip -1 <> if
1417 newmodulepath s" ;" strcat
1418 oldmodulepath strcat
1419 modulepath setenv
1420 newmodulepath drop free-memory
1421 oldmodulepath drop free-memory
1422 then
1423 0
1424 then
1425;
1426
1427\ Try to load a kernel; the kernel name is taken from one of
1428\ the following lists, as ordered:
1429\
1430\ 1. The "bootfile" environment variable
1431\ 2. The "kernel" environment variable
1432\ 3. The "path" argument
1433\
1434\ Flags are passed, if provided.
1435\
1436\ The kernel will be loaded from a directory computed from the
1437\ path given. Two directories will be tried in the following order:
1438\
1439\ 1. /boot/path
1440\ 2. path
1441\
1442\ Unless "path" is meant to be kernel name itself. In that case, it
1443\ will first be tried as a full path, and, next, search on the
1444\ directories pointed by module_path.
1445\
1446\ The module_path variable is overridden if load is succesful, by
1447\ prepending the successful path.
1448
1449: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag )
1450 local args
1451 2local path
1452 args 1 = if 0 0 then
1453 2local flags
1454 end-locals
1455
1456 \ First, assume path is an absolute path to a directory
1457 flags path args clip_args load_from_directory
1458 dup 0= if exit else drop then
1459
1460 \ Next, assume path points to the kernel
1461 flags path args try_multiple_kernels
1462;
1463
1464: initialize ( addr len -- )
1465 strdup conf_files .len ! conf_files .addr !
1466;
1467
1468: kernel_options ( -- addr len 1 | 0 )
1469 s" kernel_options" getenv
1470 dup -1 = if drop 0 else 1 then
1471;
1472
1473: standard_kernel_search ( flags 1 | 0 -- flag )
1474 local args
1475 args 0= if 0 0 then
1476 2local flags
1477 s" kernel" getenv
1478 dup -1 = if 0 swap then
1479 2local path
1480 end-locals
1481
1482 path nip -1 = if ( there isn't a "kernel" environment variable )
1483 flags args load_a_kernel
1484 else
1485 flags path args 1+ clip_args load_directory_or_file
1486 then
1487;
1488
1489: load_kernel ( -- ) ( throws: abort )
1490 kernel_options standard_kernel_search
1491 abort" Unable to load a kernel!"
1492;
1493
1494: set_defaultoptions ( -- )
1495 s" kernel_options" getenv dup -1 = if
1496 drop
1497 else
1498 s" temp_options" setenv
1499 then
1500;
1501
1502: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
1503 2dup = if 0 0 exit then
1504 dup >r
1505 1+ 2* ( skip N and ui )
1506 pick
1507 r>
1508 1+ 2* ( skip N and ai )
1509 pick
1510;
1511
1512: drop_args ( aN uN ... a1 u1 N -- )
1513 0 ?do 2drop loop
1514;
1515
1516: argc
1517 dup
1518;
1519
1520: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 )
1521 >r
1522 over 2* 1+ -roll
1523 r>
1524 over 2* 1+ -roll
1525 1+
1526;
1527
1528: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 )
1529 1- -rot
1530;
1531
1532: strlen(argv)
1533 dup 0= if 0 exit then
1534 0 >r \ Size
1535 0 >r \ Index
1536 begin
1537 argc r@ <>
1538 while
1539 r@ argv[]
1540 nip
1541 r> r> rot + 1+
1542 >r 1+ >r
1543 repeat
1544 r> drop
1545 r>
1546;
1547
1548: concat_argv ( aN uN ... a1 u1 N -- a u )
1549 strlen(argv) allocate if out_of_memory throw then
1550 0 2>r
1551
1552 begin
1553 argc
1554 while
1555 unqueue_argv
1556 2r> 2swap
1557 strcat
1558 s" " strcat
1559 2>r
1560 repeat
1561 drop_args
1562 2r>
1563;
1564
1565: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
1566 \ Save the first argument, if it exists and is not a flag
1567 argc if
1568 0 argv[] drop c@ [char] - <> if
1569 unqueue_argv 2>r \ Filename
1570 1 >r \ Filename present
1571 else
1572 0 >r \ Filename not present
1573 then
1574 else
1575 0 >r \ Filename not present
1576 then
1577
1578 \ If there are other arguments, assume they are flags
1579 ?dup if
1580 concat_argv
1581 2dup s" temp_options" setenv
1582 drop free if free_error throw then
1583 else
1584 set_defaultoptions
1585 then
1586
1587 \ Bring back the filename, if one was provided
1588 r> if 2r> 1 else 0 then
1589;
1590
1591: get_arguments ( -- addrN lenN ... addr1 len1 N )
1592 0
1593 begin
1594 \ Get next word on the command line
1595 parse-word
1596 ?dup while
1597 queue_argv
1598 repeat
1599 drop ( empty string )
1600;
1601
1602: load_kernel_and_modules ( args -- flag )
1603 set_tempoptions
1604 argc >r
1605 s" temp_options" getenv dup -1 <> if
1606 queue_argv
1607 else
1608 drop
1609 then
1610 r> if ( a path was passed )
1611 load_directory_or_file
1612 else
1613 standard_kernel_search
1614 then
1615 ?dup 0= if ['] load_modules catch then
1616;
1617
1618: read-password { size | buf len -- }
1619 size allocate if out_of_memory throw then
1620 to buf
1621 0 to len
1622 begin
1623 key
1624 dup backspace = if
1625 drop
1626 len if
1627 backspace emit bl emit backspace emit
1628 len 1 - to len
1629 else
1630 bell emit
1631 then
1632 else
1633 dup <cr> = if cr drop buf len exit then
1634 [char] * emit
1635 len size < if
1636 buf len chars + c!
1637 else
1638 drop
1639 then
1640 len 1+ to len
1641 then
1642 again
1643;
1644
1645\ Go back to straight forth vocabulary
1646
1647only forth also definitions
1648
|