1 \ Copyright (c) 1999 Daniel C. Sobral <dcs@FreeBSD.org>
4 \ Redistribution and use in source and binary forms, with or without
5 \ modification, are permitted provided that the following conditions
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.
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
27 \ Loader.rc support functions:
29 \ initialize ( addr len -- ) as above, plus load_conf_files
30 \ load_conf ( addr len -- ) load conf file given
31 \ include_bootenv ( -- ) load bootenv.rc
32 \ include_conf_files ( -- ) load all conf files in load_conf_files
33 \ print_syntax_error ( -- ) print line and marker of where a syntax
35 \ print_line ( -- ) print last line processed
36 \ load_kernel ( -- ) load kernel
37 \ load_modules ( -- ) load modules flagged
39 \ Exported structures:
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 (file | hash | rootfs)
49 \ string module.hash module's sha1 hash
50 \ string module.args flags to be passed during load
51 \ string module.largs internal argument list
52 \ string module.beforeload command to be executed before load
53 \ string module.afterload command to be executed after load
54 \ string module.loaderror command to be executed if load fails
55 \ cell module.next list chain
57 \ Exported global variables;
59 \ string conf_files configuration files to be loaded
60 \ cell modules_options pointer to first module information
61 \ value verbose? indicates if user wants a verbose loading
62 \ value any_conf_read? indicates if a conf file was succesfully read
64 \ Other exported words:
65 \ note, strlen is internal
66 \ strdup ( addr len -- addr' len) similar to strdup(3)
67 \ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3)
68 \ s' ( | string' -- addr len | ) similar to s"
69 \ rudimentary structure support
76 4 constant ESETERROR \ error setting environment variable
77 5 constant EREAD \ error reading
79 7 constant EEXEC \ XXX never catched
80 8 constant EBEFORELOAD
93 \ Crude structure support
96 create here 0 , ['] drop , 0
97 does> create here swap dup @ allot cell+ @ execute
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: ;
121 \ Module options linked list
125 sizeof string member: module.name
126 sizeof string member: module.loadname
127 sizeof string member: module.type
128 sizeof string member: module.hash
129 sizeof string member: module.args
130 sizeof string member: module.largs
131 sizeof string member: module.beforeload
132 sizeof string member: module.afterload
133 sizeof string member: module.loaderror
137 \ Internal loader structures (preloaded_file, kernel_module, file_metadata)
138 \ must be in sync with the C struct in sys/boot/common/bootstrap.h
139 structure: preloaded_file
143 ptr pf.metadata \ file_metadata
147 ptr pf.modules \ kernel_module
148 ptr pf.next \ preloaded_file
151 structure: kernel_module
154 ptr km.fp \ preloaded_file
155 ptr km.next \ kernel_module
158 structure: file_metadata
160 2 member: md.type \ this is not ANS Forth compatible (XXX)
161 ptr md.next \ file_metadata
162 0 member: md.data \ variable size
170 create module_options sizeof module.next allot 0 module_options !
171 create last_module_option sizeof module.next allot 0 last_module_option !
174 \ Support string functions
175 : strdup { addr len -- addr' len' }
176 len allocate if ENOMEM throw then
177 addr over len move len
180 : strcat { addr len addr' len' -- addr len+len' }
181 addr' addr len + len' move
185 : strchr { addr len c -- addr' len' }
189 addr c@ c = if addr len exit then
196 : s' \ same as s", allows " in the string
198 state @ if postpone sliteral then
201 : 2>r postpone >r postpone >r ; immediate
202 : 2r> postpone r> postpone r> ; immediate
203 : 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate
205 : getenv? getenv -1 = if false else drop true then ;
207 \ determine if a word appears in a string, case-insensitive
208 : contains? ( addr1 len1 addr2 len2 -- 0 | -1 )
209 2 pick 0= if 2drop 2drop true exit then
210 dup 0= if 2drop 2drop false exit then
213 swap dup c@ dup 32 = over 9 = or over 10 = or
214 over 13 = or over 44 = or swap drop
215 while 1+ swap 1- repeat
216 swap 2 pick 1- over <
218 2over 2over drop over compare-insensitive 0= if
219 2 pick over = if 2drop 2drop true exit then
220 2 pick tuck - -rot + swap over c@ dup 32 =
221 over 9 = or over 10 = or over 13 = or over 44 = or
222 swap drop if 2drop 2drop true exit then
224 swap dup c@ dup 32 = over 9 = or over 10 = or
225 over 13 = or over 44 = or swap drop
226 if false else true then 2 pick 0> and
227 while 1+ swap 1- repeat
233 : boot_serial? ( -- 0 | -1 )
234 s" console" getenv dup -1 <> if
236 s" ttya" 2swap contains? ( addr len f )
237 -rot 2dup ( f addr len addr len )
238 s" ttyb" 2swap contains? ( f addr len f )
239 -rot 2dup ( f f addr len addr len )
240 s" ttyc" 2swap contains? ( f f addr len f )
241 -rot ( f f f addr len )
242 s" ttyd" 2swap contains? ( f f addr len f )
245 s" boot_serial" getenv dup -1 <> if
248 or \ console contains tty ( or ) boot_serial
249 s" boot_multicons" getenv dup -1 <> if
252 or \ previous boolean ( or ) boot_multicons
255 \ Private definitions
257 vocabulary support-functions
258 only forth also support-functions definitions
260 \ Some control characters constants
270 80 constant read_buffer_size
274 : load_module_suffix s" _load" ;
275 : module_loadname_suffix s" _name" ;
276 : module_type_suffix s" _type" ;
277 : module_hash_suffix s" _hash" ;
278 : module_args_suffix s" _flags" ;
279 : module_beforeload_suffix s" _before" ;
280 : module_afterload_suffix s" _after" ;
281 : module_loaderror_suffix s" _error" ;
288 \ Assorted support functions
290 : free-memory free if EFREE throw then ;
292 : strget { var -- addr len } var .addr @ var .len @ ;
294 \ assign addr len to variable.
295 : strset { addr len var -- } addr var .addr ! len var .len ! ;
297 \ free memory and reset fields
298 : strfree { var -- } var .addr @ ?dup if free-memory 0 0 var strset then ;
300 \ free old content, make a copy of the string and assign to variable
301 : string= { addr len var -- } var strfree addr len strdup var strset ;
303 : strtype ( str -- ) strget type ;
305 \ assign a reference to what is on the stack
306 : strref { addr len var -- addr len }
307 addr var .addr ! len var .len ! addr len
311 : unquote ( addr len -- addr len )
312 over c@ [char] " = if 2 chars - swap char+ swap then
315 \ Assignment data temporary storage
320 \ Line by line file reading functions
329 vocabulary line-reading
330 also line-reading definitions
332 \ File data temporary storage
335 0 value read_buffer_ptr
337 \ File's line reading function
339 get-current ( -- wid ) previous definitions
345 >search ( wid -- ) definitions
349 read_buffer .len @ read_buffer_ptr >
351 read_buffer .addr @ read_buffer_ptr + c@ lf = if
352 read_buffer_ptr char+ to read_buffer_ptr
359 : scan_buffer ( -- addr len )
362 read_buffer .len @ r@ >
364 read_buffer .addr @ r@ + c@ lf = if
365 read_buffer .addr @ read_buffer_ptr + ( -- addr )
366 r@ read_buffer_ptr - ( -- len )
367 r> to read_buffer_ptr
372 read_buffer .addr @ read_buffer_ptr + ( -- addr )
373 r@ read_buffer_ptr - ( -- len )
374 r> to read_buffer_ptr
377 : line_buffer_resize ( len -- len )
379 line_buffer .len @ if
381 line_buffer .len @ r@ +
382 resize if ENOMEM throw then
384 r@ allocate if ENOMEM throw then
390 : append_to_line_buffer ( addr len -- )
398 scan_buffer ( -- addr len )
399 line_buffer_resize ( len -- len )
400 append_to_line_buffer ( addr len -- )
404 read_buffer .len @ read_buffer_ptr =
410 read_buffer .addr @ 0= if
411 read_buffer_size allocate if ENOMEM throw then
414 fd @ read_buffer .addr @ read_buffer_size fread
415 dup -1 = if EREAD throw then
416 dup 0= if true to end_of_file? then
420 get-current ( -- wid ) previous definitions >search ( wid -- )
437 only forth also support-functions definitions
439 \ Conf file line parser:
440 \ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
441 \ <spaces>[<comment>]
442 \ <name> ::= <letter>{<letter>|<digit>|'_'|'-'}
443 \ <vname> ::= <letter>{<letter>|<digit>|'_'|'-'|','}
444 \ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <vname>
445 \ <character_set> ::= ASCII 32 to 126, except '\' and '"'
446 \ <comment> ::= '#'{<anything>}
448 \ bootenv line parser:
449 \ <line> ::= <spaces>setprop<spaces><name><spaces><value><spaces>[<comment>] |
450 \ <spaces>[<comment>]
459 vocabulary file-processing
460 also file-processing definitions
469 also parser definitions
471 0 value parsing_function
474 : end_of_line? line_pointer end_of_line = ;
476 \ classifiers for various character classes in the input line
495 : "quote? line_pointer c@ [char] " = ;
497 : 'quote? line_pointer c@ [char] ' = ;
499 : assignment_sign? line_pointer c@ [char] = = ;
501 : comment? line_pointer c@ [char] # = ;
503 : space? line_pointer c@ bl = line_pointer c@ tab = or ;
505 : backslash? line_pointer c@ [char] \ = ;
507 : underscore? line_pointer c@ [char] _ = ;
509 : dot? line_pointer c@ [char] . = ;
511 : dash? line_pointer c@ [char] - = ;
513 : comma? line_pointer c@ [char] , = ;
515 \ manipulation of input line
516 : skip_character line_pointer char+ to line_pointer ;
518 : skip_to_end_of_line end_of_line to line_pointer ;
522 end_of_line? if 0 else space? then
528 : parse_name ( -- addr len )
531 end_of_line? if 0 else
532 letter? digit? underscore? dot? dash?
542 : parse_value ( -- addr len )
545 end_of_line? if 0 else
546 letter? digit? underscore? dot? comma? dash?
556 : remove_backslashes { addr len | addr' len' -- addr' len' }
557 len allocate if ENOMEM throw then
561 addr c@ [char] \ <> if
562 addr c@ addr' len' + c!
572 : parse_quote ( xt -- addr len )
576 end_of_line? if ESYNTAX throw then
582 end_of_line? if ESYNTAX throw then
585 end_of_line? if ESYNTAX throw then
594 parse_name ( -- addr len )
600 ['] "quote? parse_quote ( -- addr len )
603 ['] 'quote? parse_quote ( -- addr len )
605 parse_value ( -- addr len )
617 comment? if ['] comment to parsing_function exit then
618 end_of_line? 0= if ESYNTAX throw then
623 ['] white_space_4 to parsing_function
628 letter? digit? "quote? 'quote? or or or if
629 ['] variable_value to parsing_function exit
636 ['] white_space_3 to parsing_function
641 assignment_sign? if ['] assignment_sign to parsing_function exit then
647 ['] white_space_2 to parsing_function
652 letter? if ['] variable_name to parsing_function exit then
653 comment? if ['] comment to parsing_function exit then
654 end_of_line? 0= if ESYNTAX throw then
660 ['] white_space_3 to parsing_function
665 s" setprop" line_pointer over compare 0=
666 if line_pointer 7 + to line_pointer
667 ['] prop_name to parsing_function exit
669 comment? if ['] comment to parsing_function exit then
670 end_of_line? 0= if ESYNTAX throw then
673 get-current ( -- wid ) previous definitions >search ( wid -- )
676 line_buffer strget + to end_of_line
677 line_buffer .addr @ to line_pointer
678 ['] white_space_1 to parsing_function
682 parsing_function execute
684 parsing_function ['] comment =
685 parsing_function ['] white_space_1 =
686 parsing_function ['] white_space_4 =
687 or or 0= if ESYNTAX throw then
691 line_buffer strget + to end_of_line
692 line_buffer .addr @ to line_pointer
693 ['] get_prop_cmd to parsing_function
697 parsing_function execute
699 parsing_function ['] comment =
700 parsing_function ['] get_prop_cmd =
701 parsing_function ['] white_space_4 =
702 or or 0= if ESYNTAX throw then
705 only forth also support-functions also file-processing definitions
709 : assignment_type? ( addr len -- flag )
714 : suffix_type? ( addr len -- flag )
715 name_buffer .len @ over <= if 2drop false exit then
716 name_buffer .len @ over - name_buffer .addr @ +
720 : loader_conf_files? s" loader_conf_files" assignment_type? ;
722 : verbose_flag? s" verbose_loading" assignment_type? ;
724 : execute? s" exec" assignment_type? ;
726 : module_load? load_module_suffix suffix_type? ;
728 : module_loadname? module_loadname_suffix suffix_type? ;
730 : module_type? module_type_suffix suffix_type? ;
732 : module_hash? module_hash_suffix suffix_type? ;
734 : module_args? module_args_suffix suffix_type? ;
736 : module_beforeload? module_beforeload_suffix suffix_type? ;
738 : module_afterload? module_afterload_suffix suffix_type? ;
740 : module_loaderror? module_loaderror_suffix suffix_type? ;
742 \ build a 'set' statement and execute it
743 : set_environment_variable
744 name_buffer .len @ value_buffer .len @ + 5 chars + \ size of result string
745 allocate if ENOMEM throw then
746 dup 0 \ start with an empty string and append the pieces
748 name_buffer strget strcat
750 value_buffer strget strcat
751 ['] evaluate catch if
760 set_environment_variable
761 s" loader_conf_files" getenv conf_files string=
764 : append_to_module_options_list ( addr -- )
765 module_options @ 0= if
769 dup last_module_option @ module.next !
774 : set_module_name { addr -- } \ check leaks
775 name_buffer strget addr module.name string=
779 value_buffer strget unquote
780 s" yes" compare-insensitive 0=
783 : find_module_option ( -- addr | 0 ) \ return ptr to entry matching name_buffer
788 dup module.name strget
790 compare 0= if exit then
795 : new_module_option ( -- addr )
796 sizeof module allocate if ENOMEM throw then
797 dup sizeof module erase
798 dup append_to_module_options_list
802 : get_module_option ( -- addr )
804 ?dup 0= if new_module_option then
808 name_buffer .len @ load_module_suffix nip - name_buffer .len !
809 yes_value? get_module_option module.flag !
813 name_buffer .len @ module_args_suffix nip - name_buffer .len !
814 value_buffer strget unquote
815 get_module_option module.args string=
818 : set_module_loadname
819 name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
820 value_buffer strget unquote
821 get_module_option module.loadname string=
825 name_buffer .len @ module_type_suffix nip - name_buffer .len !
826 value_buffer strget unquote
827 get_module_option module.type string=
831 name_buffer .len @ module_hash_suffix nip - name_buffer .len !
832 value_buffer strget unquote
833 get_module_option module.hash string=
836 : set_module_beforeload
837 name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
838 value_buffer strget unquote
839 get_module_option module.beforeload string=
842 : set_module_afterload
843 name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
844 value_buffer strget unquote
845 get_module_option module.afterload string=
848 : set_module_loaderror
849 name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
850 value_buffer strget unquote
851 get_module_option module.loaderror string=
855 yes_value? to verbose?
859 value_buffer strget unquote
860 ['] evaluate catch if EEXEC throw then
864 name_buffer .len @ 0= if exit then
865 loader_conf_files? if set_conf_files exit then
866 verbose_flag? if set_verbose exit then
867 execute? if execute_command exit then
868 module_load? if set_module_flag exit then
869 module_loadname? if set_module_loadname exit then
870 module_type? if set_module_type exit then
871 module_hash? if set_module_hash exit then
872 module_args? if set_module_args exit then
873 module_beforeload? if set_module_beforeload exit then
874 module_afterload? if set_module_afterload exit then
875 module_loaderror? if set_module_loaderror exit then
876 set_environment_variable
881 \ Free some pointers if needed. The code then tests for errors
882 \ in freeing, and throws an exception if needed. If a pointer is
883 \ not allocated, it's value (0) is used as flag.
890 \ Higher level file processing
892 get-current ( -- wid ) previous definitions >search ( wid -- )
901 ['] process_assignment catch
902 ['] free_buffers catch
914 ['] process_assignment catch
915 ['] free_buffers catch
920 : peek_file ( addr len -- )
924 fd @ -1 = if EOPEN throw then
928 ['] process_assignment catch
929 ['] free_buffers catch
934 only forth also support-functions definitions
936 \ Interface to loading conf files
938 : load_conf ( addr len -- )
942 fd @ -1 = if EOPEN throw then
943 ['] process_conf catch
948 : print_line line_buffer strtype cr ;
951 line_buffer strtype cr
962 : load_bootenv ( addr len -- )
966 fd @ -1 = if EOPEN throw then
967 ['] process_bootenv catch
972 \ Debugging support functions
974 only forth definitions also support-functions
977 ['] load_conf catch dup .
978 ESYNTAX = if cr print_syntax_error then
981 \ find a module name, leave addr on the stack (0 if not found)
982 : find-module ( <module> -- ptr | 0 )
983 bl parse ( addr len )
984 module_options @ >r ( store current pointer )
988 2dup ( addr len addr len )
989 r@ module.name strget
990 compare 0= if drop drop r> exit then ( found it )
993 type ." was not found" cr r>
996 : show-nonempty ( addr len mod -- )
997 strget dup verbose? or if
1003 : show-one-module { addr -- addr }
1004 ." Name: " addr module.name strtype cr
1005 s" Path: " addr module.loadname show-nonempty
1006 s" Type: " addr module.type show-nonempty
1007 s" Hash: " addr module.hash show-nonempty
1008 s" Flags: " addr module.args show-nonempty
1009 s" Before load: " addr module.beforeload show-nonempty
1010 s" After load: " addr module.afterload show-nonempty
1011 s" Error: " addr module.loaderror show-nonempty
1012 ." Status: " addr module.flag @ if ." Load" else ." Don't load" then cr
1017 : show-module-options
1027 : free-one-module { addr -- addr }
1028 addr module.name strfree
1029 addr module.loadname strfree
1030 addr module.type strfree
1031 addr module.hash strfree
1032 addr module.args strfree
1033 addr module.largs strfree
1034 addr module.beforeload strfree
1035 addr module.afterload strfree
1036 addr module.loaderror strfree
1040 : free-module-options
1050 0 last_module_option !
1053 only forth also support-functions definitions
1055 \ Variables used for processing multiple conf files
1057 string current_file_name_ref \ used to print the file name
1059 \ Indicates if any conf file was succesfully read
1061 0 value any_conf_read?
1063 \ loader_conf_files processing support functions
1065 \ true if string in addr1 is smaller than in addr2
1066 : compar ( addr1 addr2 -- flag )
1067 swap ( addr2 addr1 )
1068 dup cell+ ( addr2 addr1 addr )
1069 swap @ ( addr2 addr len )
1070 rot ( addr len addr2 )
1071 dup cell+ ( addr len addr2 addr' )
1072 swap @ ( addr len addr' len' )
1076 \ insertion sort algorithm. we dont expect large amounts of data to be
1077 \ sorted, so insert should be ok. compar needs to implement < operator.
1078 : insert ( start end -- start )
1079 dup @ >r ( r: v ) \ v = a[i]
1083 r@ over cell- @ compar \ a[j-1] > v
1086 dup @ over cell+ ! \ a[j] = a[j-1]
1088 r> swap ! \ a[j] = v
1091 : sort ( array len -- )
1092 1 ?do dup i cells + insert loop drop
1096 s" /boot/conf.d" fopendir if fd ! else
1101 : readdir ( addr len flag | flag )
1109 : entries ( -- n ) \ count directory entries
1110 ['] opendir catch ( n array )
1114 begin \ count the entries
1115 readdir ( i addr len flag | i flag )
1125 \ built-in prefix directory name; it must end with /, so we don't
1126 \ need to check and insert it.
1127 : make_cstring ( addr len -- addr' )
1128 dup ( addr len len )
1129 s" /boot/conf.d/" ( addr len len addr' len' )
1130 rot ( addr len addr' len' len )
1131 over + ( addr len addr' len' total ) \ space for prefix+str
1132 dup cell+ 1+ \ 1+ for '\0'
1134 -1 abort" malloc failed"
1136 ( addr len addr' len' total taddr )
1137 dup rot ( addr len addr' len' taddr taddr total )
1138 swap ! ( addr len addr' len' taddr ) \Â store length
1139 dup >r \Â save reference
1140 cell+ \ point to string area
1141 2dup 2>r ( addr len addr' len' taddr' ) ( R: taddr len' taddr' )
1142 swap move ( addr len )
1143 2r> + ( addr len taddr' ) ( R: taddr )
1144 swap 1+ move \ 1+ for '\0'
1148 : scan_conf_dir ( -- addr len -1 | 0 )
1149 s" currdev" getenv dup -1 <> if
1150 s" pxe0:" compare 0= if 0 exit then \ readdir does not work on tftp
1155 ['] entries catch if
1158 dup 0= if exit then \ nothing to do
1160 dup cells allocate ( n array flag ) \ allocate array
1162 ['] opendir catch if ( n array )
1167 readdir ( n array addr len flag | n array flag )
1168 0= if -1 abort" unexpected readdir error" then \ shouldnt happen
1169 ( n array addr len )
1170 \ we have relative name, make it absolute and convert to counted string
1171 make_cstring ( n array addr )
1172 over I cells + ! ( n array )
1176 \ we have now array of strings with directory entry names.
1177 \ calculate size of concatenated string
1178 over 0 swap 0 do ( n array 0 )
1179 over I cells + @ ( n array total array[I] )
1180 @ + 1+ ( n array total' )
1182 dup allocate if drop free 2drop 0 exit then
1183 ( n array len addr )
1184 \ now concatenate all entries.
1185 2swap ( len addr n array )
1186 over 0 swap 0 do ( len addr n array 0 )
1187 over I cells + @ ( len addr n array total array[I] )
1188 dup @ swap cell+ ( len addr n array total len addr' )
1189 over ( len addr n array total len addr' len )
1190 6 pick ( len addr n array total len addr' len addr )
1191 4 pick + ( len addr n array total len addr' len addr+total )
1192 swap move + ( len addr n array total+len )
1193 3 pick ( len addr n array total addr )
1194 over + bl swap c! 1+ ( len addr n array total )
1195 over I cells + @ free drop \ free array[I]
1197 drop free drop drop ( len addr )
1202 : get_conf_files ( -- addr len ) \ put addr/len on stack, reset var
1203 \ ." -- starting on <" conf_files strtype ." >" cr \ debugging
1204 scan_conf_dir if \ concatenate with conf_files
1206 dup conf_files .len @ + 2 + allocate abort" out of memory" ( addr len addr' )
1207 dup conf_files strget ( addr len addr' caddr clen )
1208 rot swap move ( addr len addr' )
1210 dup conf_files .len @ + ( addr len addr' addr'+clen )
1211 dup bl swap c! 1+ ( addr len addr' addr'' )
1212 3 pick swap ( addr len addr' addr addr'' )
1213 3 pick move ( addr len addr' )
1214 rot ( len addr' addr )
1215 free drop swap ( addr' len )
1216 conf_files .len @ + 1+ ( addr len )
1219 conf_files strget 0 0 conf_files strset
1223 : skip_leading_spaces { addr len pos -- addr len pos' }
1225 pos len = if 0 else addr pos + c@ bl = then
1232 \ return the file name at pos, or free the string if nothing left
1233 : get_file_name { addr len pos -- addr len pos' addr' len' || 0 }
1235 addr free abort" Fatal error freeing memory"
1240 \ stay in the loop until have chars and they are not blank
1241 pos len = if 0 else addr pos + c@ bl <> then
1245 addr len pos addr r@ + pos r> -
1248 : get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 )
1253 : print_current_file
1254 current_file_name_ref strtype
1257 : process_conf_errors
1258 dup 0= if true to any_conf_read? drop exit then
1261 ." Warning: syntax error on file " print_current_file cr
1262 print_syntax_error drop exit
1265 ." Warning: bad definition on file " print_current_file cr
1266 print_line drop exit
1269 ." Warning: error reading file " print_current_file cr drop exit
1272 verbose? if ." Warning: unable to open file " print_current_file cr then
1275 dup EFREE = abort" Fatal error freeing memory"
1276 dup ENOMEM = abort" Out of memory"
1277 throw \ Unknown error -- pass ahead
1280 \ Process loader_conf_files recursively
1281 \ Interface to loader_conf_files processing
1284 s" /boot/solaris/bootenv.rc"
1285 ['] load_bootenv catch
1286 dup 0= if drop exit then
1289 ." Warning: syntax error on /boot/solaris/bootenv.rc" cr drop exit
1292 ." Warning: error reading /boot/solaris/bootenv.rc" cr drop exit
1295 verbose? if ." Warning: unable to open /boot/solaris/bootenv.rc" cr then
1298 dup EFREE = abort" Fatal error freeing memory"
1299 dup ENOMEM = abort" Out of memory"
1300 throw \ Unknown error -- pass ahead
1304 s" /boot/transient.conf" ['] load_conf catch
1305 dup 0= if drop exit then \ no error
1308 ." Warning: syntax error on file /boot/transient.conf" cr
1312 ." Warning: bad definition on file /boot/transient.conf" cr
1316 ." Warning: error reading file /boot/transient.conf" cr drop exit
1319 verbose? if ." Warning: unable to open file /boot/transient.conf" cr then
1322 dup EFREE = abort" Fatal error freeing memory"
1323 dup ENOMEM = abort" Out of memory"
1324 throw \ Unknown error -- pass ahead
1327 : include_conf_files
1328 get_conf_files 0 ( addr len offset )
1330 get_next_file ?dup ( addr len 1 | 0 )
1332 current_file_name_ref strref
1335 conf_files .addr @ if recurse then
1339 \ Module loading functions
1341 \ concat two strings by allocating space
1342 : concat { a1 l1 a2 l2 -- a' l' }
1343 l1 l2 + allocate if ENOMEM throw then
1348 \ build module argument list as: "hash= name= module.args"
1349 \ if type is hash, name= will have module name without .hash suffix
1350 \ will free old largs and set new.
1352 : build_largs { addr -- addr }
1353 addr module.largs strfree
1354 addr module.hash .len @
1356 s" hash=" addr module.hash strget concat
1357 addr module.largs strset \ largs = "hash=" + module.hash
1360 addr module.type strget s" hash" compare 0=
1361 if ( module.type == "hash" )
1362 addr module.largs strget s" name=" concat
1364 addr module.loadname .len @
1365 if ( module.loadname != NULL )
1366 addr module.loadname strget concat
1368 addr module.name strget concat
1371 addr module.largs strfree
1372 addr module.largs strset \ largs = largs + name
1374 \ last thing to do is to strip off ".hash" suffix
1375 addr module.largs strget [char] . strchr
1376 dup if ( strchr module.largs '.' )
1377 s" .hash" compare 0=
1378 if ( it is ".hash" )
1379 addr module.largs .len @ 5 -
1380 addr module.largs .len !
1386 \ and now add up the module.args
1387 addr module.largs strget s" " concat
1388 addr module.args strget concat
1389 addr module.largs strfree
1390 addr module.largs strset
1394 : load_parameters { addr -- addr addrN lenN ... addr1 len1 N }
1396 addr module.largs strget
1397 addr module.loadname .len @ if
1398 addr module.loadname strget
1400 addr module.name strget
1402 addr module.type .len @ if
1403 addr module.type strget
1405 4 ( -t type name flags )
1411 : before_load ( addr -- addr )
1412 dup module.beforeload .len @ if
1413 dup module.beforeload strget
1414 ['] evaluate catch if EBEFORELOAD throw then
1418 : after_load ( addr -- addr )
1419 dup module.afterload .len @ if
1420 dup module.afterload strget
1421 ['] evaluate catch if EAFTERLOAD throw then
1425 : load_error ( addr -- addr )
1426 dup module.loaderror .len @ if
1427 dup module.loaderror strget
1428 evaluate \ This we do not intercept so it can throw errors
1432 : pre_load_message ( addr -- addr )
1434 dup module.name strtype
1439 : load_error_message verbose? if ." failed!" cr then ;
1441 : load_succesful_message verbose? if ." ok" cr then ;
1444 load_parameters load
1447 : process_module ( addr -- addr )
1451 ['] load_module catch if
1452 dup module.loaderror .len @ if
1453 load_error \ Command should return a flag!
1455 load_error_message true \ Do not retry
1459 load_succesful_message true \ Succesful, do not retry
1464 : process_module_errors ( addr ior -- )
1465 dup EBEFORELOAD = if
1468 dup module.name strtype
1469 dup module.loadname .len @ if
1470 ." (" dup module.loadname strtype ." )"
1473 ." Error executing "
1474 dup module.beforeload strtype cr \ XXX there was a typo here
1481 dup module.name .addr @ over module.name .len @ type
1482 dup module.loadname .len @ if
1483 ." (" dup module.loadname strtype ." )"
1486 ." Error executing "
1487 dup module.afterload strtype cr
1491 throw \ Don't know what it is all about -- pass ahead
1494 \ Module loading interface
1496 \ scan the list of modules, load enabled ones.
1497 : load_modules ( -- ) ( throws: abort & user-defined )
1498 module_options @ ( list_head )
1502 dup module.flag @ if
1503 ['] process_module catch
1504 process_module_errors
1510 \ h00h00 magic used to try loading either a kernel with a given name,
1511 \ or a kernel with the default name in a directory of a given name
1514 : bootpath s" /platform/" ;
1515 : modulepath s" module_path" ;
1517 \ Functions used to save and restore module_path's value.
1518 : saveenv ( addr len | -1 -- addr' len | 0 -1 )
1519 dup -1 = if 0 swap exit then
1522 : freeenv ( addr len | 0 -1 )
1523 -1 = if drop else free abort" Freeing error" then
1525 : restoreenv ( addr len | 0 -1 -- )
1526 dup -1 = if ( it wasn't set )
1532 r> free abort" Freeing error"
1536 : clip_args \ Drop second string if only one argument is passed
1547 \ Parse filename from a semicolon-separated list
1549 \ replacement, not working yet
1550 : newparse-; { addr len | a1 -- a' len-x addr x }
1551 addr len [char] ; strchr dup if ( a1 len1 )
1552 swap to a1 ( store address )
1553 1 - a1 @ 1 + swap ( remove match )
1560 : parse-; ( addr len -- addr' len-x addr x )
1561 over 0 2swap ( addr 0 addr len )
1563 dup 0 <> ( addr 0 addr len )
1565 over c@ [char] ; <> ( addr 0 addr len flag )
1576 \ Try loading one of multiple kernels specified
1578 : try_multiple_kernels ( addr len addr' len' args -- flag )
1584 s" DEBUG" getenv? if
1585 s" echo Module_path: ${module_path}" evaluate
1586 ." Kernel : " >r 2dup type r> cr
1587 dup 2 = if ." Flags : " >r 2over type r> cr then
1589 \ if it's xen, the xen kernel is loaded, unix needs to be loaded as module
1590 s" xen_kernel" getenv -1 = if
1591 1 load \ normal kernel
1594 >r s" kernel" s" -t " r> 2 + 1 load
1608 \ Try to load a kernel; the kernel name is taken from one of
1609 \ the following lists, as ordered:
1611 \ 1. The "bootfile" environment variable
1612 \ 2. The "kernel" environment variable
1614 \ Flags are passed, if available. If not, dummy values must be given.
1616 \ The kernel gets loaded from the current module_path.
1618 : load_a_kernel ( flags len 1 | x x 0 -- flag )
1624 \ Check if a default kernel name exists at all, exits if not
1625 s" bootfile" getenv dup -1 <> if
1627 flags kernel args 1+ try_multiple_kernels
1632 s" kernel" getenv dup -1 <> if
1639 \ Try all default kernel names
1640 flags kernel args 1+ try_multiple_kernels
1643 \ Try to load a kernel; the kernel name is taken from one of
1644 \ the following lists, as ordered:
1646 \ 1. The "bootfile" environment variable
1647 \ 2. The "kernel" environment variable
1649 \ Flags are passed, if provided.
1651 \ The kernel will be loaded from a directory computed from the
1652 \ path given. Two directories will be tried in the following order:
1657 \ The module_path variable is overridden if load is succesful, by
1658 \ prepending the successful path.
1660 : load_from_directory ( path len 1 | flags len' path len 2 -- flag )
1663 args 1 = if 0 0 then
1665 0 0 2local oldmodulepath \ like a string
1666 0 0 2local newmodulepath \ like a string
1669 \ Set the environment variable module_path, and try loading
1671 modulepath getenv saveenv to oldmodulepath
1673 \ Try prepending /boot/ first
1674 bootpath nip path nip + \ total length
1675 oldmodulepath nip dup -1 = if
1678 1+ + \ add oldpath -- XXX why the 1+ ?
1680 allocate if ( out of memory ) 1 exit then \ XXX throw ?
1685 2dup to newmodulepath
1688 \ Try all default kernel names
1689 flags args 1- load_a_kernel
1691 oldmodulepath nip -1 <> if
1692 newmodulepath s" ;" strcat
1693 oldmodulepath strcat
1695 newmodulepath drop free-memory
1696 oldmodulepath drop free-memory
1701 \ Well, try without the prepended /boot/
1702 path newmodulepath drop swap move
1703 newmodulepath drop path nip
1704 2dup to newmodulepath
1707 \ Try all default kernel names
1708 flags args 1- load_a_kernel
1709 if ( failed once more )
1710 oldmodulepath restoreenv
1711 newmodulepath drop free-memory
1714 oldmodulepath nip -1 <> if
1715 newmodulepath s" ;" strcat
1716 oldmodulepath strcat
1718 newmodulepath drop free-memory
1719 oldmodulepath drop free-memory
1725 \ Try to load a kernel; the kernel name is taken from one of
1726 \ the following lists, as ordered:
1728 \ 1. The "bootfile" environment variable
1729 \ 2. The "kernel" environment variable
1730 \ 3. The "path" argument
1732 \ Flags are passed, if provided.
1734 \ The kernel will be loaded from a directory computed from the
1735 \ path given. Two directories will be tried in the following order:
1740 \ Unless "path" is meant to be kernel name itself. In that case, it
1741 \ will first be tried as a full path, and, next, search on the
1742 \ directories pointed by module_path.
1744 \ The module_path variable is overridden if load is succesful, by
1745 \ prepending the successful path.
1747 : load_directory_or_file ( path len 1 | flags len' path len 2 -- flag )
1750 args 1 = if 0 0 then
1754 \ First, assume path is an absolute path to a directory
1755 flags path args clip_args load_from_directory
1756 dup 0= if exit else drop then
1758 \ Next, assume path points to the kernel
1759 flags path args try_multiple_kernels
1762 : initialize ( addr len -- )
1763 strdup conf_files strset
1766 : boot-args ( -- addr len 1 | 0 )
1767 s" boot-args" getenv
1768 dup -1 = if drop 0 else 1 then
1771 : standard_kernel_search ( flags 1 | 0 -- flag )
1776 dup -1 = if 0 swap then
1780 path nip -1 = if ( there isn't a "kernel" environment variable )
1781 flags args load_a_kernel
1783 flags path args 1+ clip_args load_directory_or_file
1787 : load_kernel ( -- ) ( throws: abort )
1788 s" xen_kernel" getenv -1 = if
1789 boot-args standard_kernel_search
1790 abort" Unable to load a kernel!"
1795 \ we have loaded the xen kernel, load unix as module
1796 s" bootfile" getenv dup -1 <> if
1797 s" kernel" s" -t " 3 1 load
1799 abort" Unable to load a kernel!"
1803 s" xen_kernel" getenv dup -1 <> if
1804 1 1 load ( c-addr/u flag N -- flag )
1811 : load_xen_throw ( -- ) ( throws: abort )
1813 abort" Unable to load Xen!"
1816 : set_defaultoptions ( -- )
1817 s" boot-args" getenv dup -1 = if
1820 s" temp_options" setenv
1824 \ pick the i-th argument, i starts at 0
1825 : argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
1826 2dup = if 0 0 exit then \ out of range
1828 1+ 2* ( skip N and ui )
1831 1+ 2* ( skip N and ai )
1835 : drop_args ( aN uN ... a1 u1 N -- )
1843 : queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 )
1851 : unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 )
1855 \ compute the length of the buffer including the spaces between words
1856 : strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len )
1857 dup 0= if 0 exit then
1872 : concat_argv ( aN uN ... a1 u1 N -- a u )
1873 strlen(argv) allocate if ENOMEM throw then
1874 0 2>r ( save addr 0 on return stack )
1879 unqueue_argv ( ... N a1 u1 )
1880 2r> 2swap ( old a1 u1 )
1882 s" " strcat ( append one space ) \ XXX this gives a trailing space
1883 2>r ( store string on the result stack )
1889 : set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
1890 \ Save the first argument, if it exists and is not a flag
1892 0 argv[] drop c@ [char] - <> if
1893 unqueue_argv 2>r \ Filename
1894 1 >r \ Filename present
1896 0 >r \ Filename not present
1899 0 >r \ Filename not present
1902 \ If there are other arguments, assume they are flags
1905 2dup s" temp_options" setenv
1906 drop free if EFREE throw then
1911 \ Bring back the filename, if one was provided
1912 r> if 2r> 1 else 0 then
1915 : get_arguments ( -- addrN lenN ... addr1 len1 N )
1918 \ Get next word on the command line
1923 drop ( empty string )
1926 : load_kernel_and_modules ( args -- flag )
1929 s" temp_options" getenv dup -1 <> if
1935 ?dup 0= if ( success )
1936 r> if ( a path was passed )
1937 load_directory_or_file
1939 standard_kernel_search
1941 ?dup 0= if ['] load_modules catch then
1945 only forth definitions