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