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
25 \ Loader.rc support functions:
27 \ initialize ( addr len -- ) as above, plus load_conf_files
28 \ load_conf ( addr len -- ) load conf file given
29 \ include_bootenv ( -- ) load bootenv.rc
30 \ include_conf_files ( -- ) load all conf files in load_conf_files
31 \ print_syntax_error ( -- ) print line and marker of where a syntax
33 \ print_line ( -- ) print last line processed
34 \ load_kernel ( -- ) load kernel
35 \ load_modules ( -- ) load modules flagged
37 \ Exported structures:
39 \ string counted string structure
40 \ cell .addr string address
41 \ cell .len string length
42 \ module module loading information structure
43 \ cell module.flag should we load it?
44 \ string module.name module's name
45 \ string module.loadname name to be used in loading the module
46 \ string module.type module's type (file | hash | rootfs)
47 \ string module.hash module's sha1 hash
48 \ string module.args flags to be passed during load
49 \ string module.largs internal argument list
50 \ string module.beforeload command to be executed before load
51 \ string module.afterload command to be executed after load
52 \ string module.loaderror command to be executed if load fails
53 \ cell module.next list chain
55 \ Exported global variables;
57 \ string conf_files configuration files to be loaded
58 \ cell modules_options pointer to first module information
59 \ value verbose? indicates if user wants a verbose loading
60 \ value any_conf_read? indicates if a conf file was successfully read
62 \ Other exported words:
63 \ note, strlen is internal
64 \ strdup ( addr len -- addr' len) similar to strdup(3)
65 \ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3)
66 \ s' ( | string' -- addr len | ) similar to s"
67 \ rudimentary structure support
74 4 constant ESETERROR \ error setting environment variable
75 5 constant EREAD \ error reading
77 7 constant EEXEC \ XXX never catched
78 8 constant EBEFORELOAD
91 \ Crude structure support
94 create here 0 , ['] drop , 0
95 does> create here swap dup @ allot cell+ @ execute
97 : member: create dup , over , + does> cell+ @ + ;
99 : constructor! >body cell+ ! ;
100 : constructor: over :noname ;
101 : ;constructor postpone ; swap cell+ ! ; immediate
102 : sizeof ' >body @ state @ if postpone literal then ; immediate
103 : offsetof ' >body cell+ @ state @ if postpone literal then ; immediate
104 : ptr 1 cells member: ;
105 : int 1 cells member: ;
119 \ Module options linked list
123 sizeof string member: module.name
124 sizeof string member: module.loadname
125 sizeof string member: module.type
126 sizeof string member: module.hash
127 sizeof string member: module.args
128 sizeof string member: module.largs
129 sizeof string member: module.beforeload
130 sizeof string member: module.afterload
131 sizeof string member: module.loaderror
135 \ Internal loader structures (preloaded_file, kernel_module, file_metadata)
136 \ must be in sync with the C struct in sys/boot/common/bootstrap.h
137 structure: preloaded_file
141 ptr pf.metadata \ file_metadata
145 ptr pf.modules \ kernel_module
146 ptr pf.next \ preloaded_file
149 structure: kernel_module
152 ptr km.fp \ preloaded_file
153 ptr km.next \ kernel_module
156 structure: file_metadata
158 2 member: md.type \ this is not ANS Forth compatible (XXX)
159 ptr md.next \ file_metadata
160 0 member: md.data \ variable size
168 create module_options sizeof module.next allot 0 module_options !
169 create last_module_option sizeof module.next allot 0 last_module_option !
172 \ Support string functions
173 : strdup { addr len -- addr' len' }
174 len allocate if ENOMEM throw then
175 addr over len move len
178 : strcat { addr len addr' len' -- addr len+len' }
179 addr' addr len + len' move
183 : strchr { addr len c -- addr' len' }
187 addr c@ c = if addr len exit then
194 : s' \ same as s", allows " in the string
196 state @ if postpone sliteral then
199 : 2>r postpone >r postpone >r ; immediate
200 : 2r> postpone r> postpone r> ; immediate
201 : 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate
203 : getenv? getenv -1 = if false else drop true then ;
205 \ determine if a word appears in a string, case-insensitive
206 : contains? ( addr1 len1 addr2 len2 -- 0 | -1 )
207 2 pick 0= if 2drop 2drop true exit then
208 dup 0= if 2drop 2drop false exit then
211 swap dup c@ dup 32 = over 9 = or over 10 = or
212 over 13 = or over 44 = or swap drop
213 while 1+ swap 1- repeat
214 swap 2 pick 1- over <
216 2over 2over drop over compare-insensitive 0= if
217 2 pick over = if 2drop 2drop true exit then
218 2 pick tuck - -rot + swap over c@ dup 32 =
219 over 9 = or over 10 = or over 13 = or over 44 = or
220 swap drop if 2drop 2drop true exit then
222 swap dup c@ dup 32 = over 9 = or over 10 = or
223 over 13 = or over 44 = or swap drop
224 if false else true then 2 pick 0> and
225 while 1+ swap 1- repeat
231 : boot_serial? ( -- 0 | -1 )
232 s" console" getenv dup -1 <> if
234 s" ttya" 2swap contains? ( addr len f )
235 -rot 2dup ( f addr len addr len )
236 s" ttyb" 2swap contains? ( f addr len f )
237 -rot 2dup ( f f addr len addr len )
238 s" ttyc" 2swap contains? ( f f addr len f )
239 -rot ( f f f addr len )
240 s" ttyd" 2swap contains? ( f f addr len f )
243 s" boot_serial" getenv dup -1 <> if
246 or \ console contains tty ( or ) boot_serial
247 s" boot_multicons" getenv dup -1 <> if
250 or \ previous boolean ( or ) boot_multicons
253 \ Private definitions
255 vocabulary support-functions
256 only forth also support-functions definitions
258 \ Some control characters constants
268 80 constant read_buffer_size
272 : load_module_suffix s" _load" ;
273 : module_loadname_suffix s" _name" ;
274 : module_type_suffix s" _type" ;
275 : module_hash_suffix s" _hash" ;
276 : module_args_suffix s" _flags" ;
277 : module_beforeload_suffix s" _before" ;
278 : module_afterload_suffix s" _after" ;
279 : module_loaderror_suffix s" _error" ;
286 \ Assorted support functions
288 : free-memory free if EFREE throw then ;
290 : strget { var -- addr len } var .addr @ var .len @ ;
292 \ assign addr len to variable.
293 : strset { addr len var -- } addr var .addr ! len var .len ! ;
295 \ free memory and reset fields
296 : strfree { var -- } var .addr @ ?dup if free-memory 0 0 var strset then ;
298 \ free old content, make a copy of the string and assign to variable
299 : string= { addr len var -- } var strfree addr len strdup var strset ;
301 : strtype ( str -- ) strget type ;
303 \ assign a reference to what is on the stack
304 : strref { addr len var -- addr len }
305 addr var .addr ! len var .len ! addr len
309 : unquote ( addr len -- addr len )
310 over c@ [char] " = if 2 chars - swap char+ swap then
313 \ Assignment data temporary storage
318 \ Line by line file reading functions
327 vocabulary line-reading
328 also line-reading definitions
330 \ File data temporary storage
333 0 value read_buffer_ptr
335 \ File's line reading function
337 get-current ( -- wid ) previous definitions
343 >search ( wid -- ) definitions
347 read_buffer .len @ read_buffer_ptr >
349 read_buffer .addr @ read_buffer_ptr + c@ lf = if
350 read_buffer_ptr char+ to read_buffer_ptr
357 : scan_buffer ( -- addr len )
360 read_buffer .len @ r@ >
362 read_buffer .addr @ r@ + c@ lf = if
363 read_buffer .addr @ read_buffer_ptr + ( -- addr )
364 r@ read_buffer_ptr - ( -- len )
365 r> to read_buffer_ptr
370 read_buffer .addr @ read_buffer_ptr + ( -- addr )
371 r@ read_buffer_ptr - ( -- len )
372 r> to read_buffer_ptr
375 : line_buffer_resize ( len -- len )
377 line_buffer .len @ if
379 line_buffer .len @ r@ +
380 resize if ENOMEM throw then
382 r@ allocate if ENOMEM throw then
388 : append_to_line_buffer ( addr len -- )
396 scan_buffer ( -- addr len )
397 line_buffer_resize ( len -- len )
398 append_to_line_buffer ( addr len -- )
402 read_buffer .len @ read_buffer_ptr =
408 read_buffer .addr @ 0= if
409 read_buffer_size allocate if ENOMEM throw then
412 fd @ read_buffer .addr @ read_buffer_size fread
413 dup -1 = if EREAD throw then
414 dup 0= if true to end_of_file? then
418 get-current ( -- wid ) previous definitions >search ( wid -- )
435 only forth also support-functions definitions
437 \ Conf file line parser:
438 \ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
439 \ <spaces>[<comment>]
440 \ <name> ::= <letter>{<letter>|<digit>|'_'|'-'}
441 \ <vname> ::= <letter>{<letter>|<digit>|'_'|'-'|','}
442 \ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <vname>
443 \ <character_set> ::= ASCII 32 to 126, except '\' and '"'
444 \ <comment> ::= '#'{<anything>}
446 \ bootenv line parser:
447 \ <line> ::= <spaces>setprop<spaces><name><spaces><value><spaces>[<comment>] |
448 \ <spaces>[<comment>]
457 vocabulary file-processing
458 also file-processing definitions
467 also parser definitions
469 0 value parsing_function
472 : end_of_line? line_pointer end_of_line = ;
474 \ classifiers for various character classes in the input line
493 : "quote? line_pointer c@ [char] " = ;
495 : 'quote? line_pointer c@ [char] ' = ;
497 : assignment_sign? line_pointer c@ [char] = = ;
499 : comment? line_pointer c@ [char] # = ;
501 : space? line_pointer c@ bl = line_pointer c@ tab = or ;
503 : backslash? line_pointer c@ [char] \ = ;
505 : underscore? line_pointer c@ [char] _ = ;
507 : dot? line_pointer c@ [char] . = ;
509 : dash? line_pointer c@ [char] - = ;
511 : comma? line_pointer c@ [char] , = ;
513 : at? line_pointer c@ [char] @ = ;
515 : slash? line_pointer c@ [char] / = ;
517 : colon? line_pointer c@ [char] : = ;
519 \ manipulation of input line
520 : skip_character line_pointer char+ to line_pointer ;
522 : skip_to_end_of_line end_of_line to line_pointer ;
526 end_of_line? if 0 else space? then
532 : parse_name ( -- addr len )
535 end_of_line? if 0 else
536 letter? digit? underscore? dot? dash?
546 : parse_value ( -- addr len )
549 end_of_line? if 0 else
550 letter? digit? underscore? dot? comma? dash? at? slash? colon?
551 or or or or or or or or
560 : remove_backslashes { addr len | addr' len' -- addr' len' }
561 len allocate if ENOMEM throw then
565 addr c@ [char] \ <> if
566 addr c@ addr' len' + c!
576 : parse_quote ( xt -- addr len )
580 end_of_line? if ESYNTAX throw then
586 end_of_line? if ESYNTAX throw then
589 end_of_line? if ESYNTAX throw then
598 parse_name ( -- addr len )
604 ['] "quote? parse_quote ( -- addr len )
607 ['] 'quote? parse_quote ( -- addr len )
609 parse_value ( -- addr len )
621 comment? if ['] comment to parsing_function exit then
622 end_of_line? 0= if ESYNTAX throw then
627 ['] white_space_4 to parsing_function
632 slash? letter? digit? "quote? 'quote? or or or or if
633 ['] variable_value to parsing_function exit
640 ['] white_space_3 to parsing_function
645 assignment_sign? if ['] assignment_sign to parsing_function exit then
651 ['] white_space_2 to parsing_function
656 letter? if ['] variable_name to parsing_function exit then
657 comment? if ['] comment to parsing_function exit then
658 end_of_line? 0= if ESYNTAX throw then
664 ['] white_space_3 to parsing_function
669 s" setprop" line_pointer over compare 0=
670 if line_pointer 7 + to line_pointer
671 ['] prop_name to parsing_function exit
673 comment? if ['] comment to parsing_function exit then
674 end_of_line? 0= if ESYNTAX throw then
677 get-current ( -- wid ) previous definitions >search ( wid -- )
680 line_buffer strget + to end_of_line
681 line_buffer .addr @ to line_pointer
682 ['] white_space_1 to parsing_function
686 parsing_function execute
688 parsing_function ['] comment =
689 parsing_function ['] white_space_1 =
690 parsing_function ['] white_space_4 =
691 or or 0= if ESYNTAX throw then
695 line_buffer strget + to end_of_line
696 line_buffer .addr @ to line_pointer
697 ['] get_prop_cmd to parsing_function
701 parsing_function execute
703 parsing_function ['] comment =
704 parsing_function ['] get_prop_cmd =
705 parsing_function ['] white_space_4 =
706 or or 0= if ESYNTAX throw then
709 only forth also support-functions also file-processing definitions
713 : assignment_type? ( addr len -- flag )
718 : suffix_type? ( addr len -- flag )
719 name_buffer .len @ over <= if 2drop false exit then
720 name_buffer .len @ over - name_buffer .addr @ +
724 : loader_conf_files? s" loader_conf_files" assignment_type? ;
726 : verbose_flag? s" verbose_loading" assignment_type? ;
728 : execute? s" exec" assignment_type? ;
730 : module_load? load_module_suffix suffix_type? ;
732 : module_loadname? module_loadname_suffix suffix_type? ;
734 : module_type? module_type_suffix suffix_type? ;
736 : module_hash? module_hash_suffix suffix_type? ;
738 : module_args? module_args_suffix suffix_type? ;
740 : module_beforeload? module_beforeload_suffix suffix_type? ;
742 : module_afterload? module_afterload_suffix suffix_type? ;
744 : module_loaderror? module_loaderror_suffix suffix_type? ;
746 \ build a 'set' statement and execute it
747 : set_environment_variable
748 name_buffer .len @ value_buffer .len @ + 5 chars + \ size of result string
749 allocate if ENOMEM throw then
750 dup 0 \ start with an empty string and append the pieces
752 name_buffer strget strcat
754 value_buffer strget strcat
755 ['] evaluate catch if
764 set_environment_variable
765 s" loader_conf_files" getenv conf_files string=
768 : append_to_module_options_list ( addr -- )
769 module_options @ 0= if
773 dup last_module_option @ module.next !
778 : set_module_name { addr -- } \ check leaks
779 name_buffer strget addr module.name string=
783 value_buffer strget unquote
784 s" yes" compare-insensitive 0=
787 : find_module_option ( -- addr | 0 ) \ return ptr to entry matching name_buffer
792 dup module.name strget
794 compare 0= if exit then
799 : new_module_option ( -- addr )
800 sizeof module allocate if ENOMEM throw then
801 dup sizeof module erase
802 dup append_to_module_options_list
806 : get_module_option ( -- addr )
808 ?dup 0= if new_module_option then
812 name_buffer .len @ load_module_suffix nip - name_buffer .len !
813 yes_value? get_module_option module.flag !
817 name_buffer .len @ module_args_suffix nip - name_buffer .len !
818 value_buffer strget unquote
819 get_module_option module.args string=
822 : set_module_loadname
823 name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
824 value_buffer strget unquote
825 get_module_option module.loadname string=
829 name_buffer .len @ module_type_suffix nip - name_buffer .len !
830 value_buffer strget unquote
831 get_module_option module.type string=
835 name_buffer .len @ module_hash_suffix nip - name_buffer .len !
836 value_buffer strget unquote
837 get_module_option module.hash string=
840 : set_module_beforeload
841 name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
842 value_buffer strget unquote
843 get_module_option module.beforeload string=
846 : set_module_afterload
847 name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
848 value_buffer strget unquote
849 get_module_option module.afterload string=
852 : set_module_loaderror
853 name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
854 value_buffer strget unquote
855 get_module_option module.loaderror string=
859 yes_value? to verbose?
863 value_buffer strget unquote
864 ['] evaluate catch if EEXEC throw then
868 name_buffer .len @ 0= if exit then
869 loader_conf_files? if set_conf_files exit then
870 verbose_flag? if set_verbose exit then
871 execute? if execute_command exit then
872 module_load? if set_module_flag exit then
873 module_loadname? if set_module_loadname exit then
874 module_type? if set_module_type exit then
875 module_hash? if set_module_hash exit then
876 module_args? if set_module_args exit then
877 module_beforeload? if set_module_beforeload exit then
878 module_afterload? if set_module_afterload exit then
879 module_loaderror? if set_module_loaderror exit then
880 set_environment_variable
885 \ Free some pointers if needed. The code then tests for errors
886 \ in freeing, and throws an exception if needed. If a pointer is
887 \ not allocated, it's value (0) is used as flag.
894 \ Higher level file processing
896 get-current ( -- wid ) previous definitions >search ( wid -- )
905 ['] process_assignment catch
906 ['] free_buffers catch
918 ['] process_assignment catch
919 ['] free_buffers catch
924 : peek_file ( addr len -- )
928 fd @ -1 = if EOPEN throw then
932 ['] process_assignment catch
933 ['] free_buffers catch
938 only forth also support-functions definitions
940 \ Interface to loading conf files
942 : load_conf ( addr len -- )
946 fd @ -1 = if EOPEN throw then
947 ['] process_conf catch
952 : print_line line_buffer strtype cr ;
955 line_buffer strtype cr
966 : load_bootenv ( addr len -- )
970 fd @ -1 = if EOPEN throw then
971 ['] process_bootenv catch
976 \ Debugging support functions
978 only forth definitions also support-functions
981 ['] load_conf catch dup .
982 ESYNTAX = if cr print_syntax_error then
985 \ find a module name, leave addr on the stack (0 if not found)
986 : find-module ( <module> -- ptr | 0 )
987 bl parse ( addr len )
988 module_options @ >r ( store current pointer )
992 2dup ( addr len addr len )
993 r@ module.name strget
994 compare 0= if drop drop r> exit then ( found it )
997 type ." was not found" cr r>
1000 : show-nonempty ( addr len mod -- )
1001 strget dup verbose? or if
1007 : show-one-module { addr -- addr }
1008 ." Name: " addr module.name strtype cr
1009 s" Path: " addr module.loadname show-nonempty
1010 s" Type: " addr module.type show-nonempty
1011 s" Hash: " addr module.hash show-nonempty
1012 s" Flags: " addr module.args show-nonempty
1013 s" Before load: " addr module.beforeload show-nonempty
1014 s" After load: " addr module.afterload show-nonempty
1015 s" Error: " addr module.loaderror show-nonempty
1016 ." Status: " addr module.flag @ if ." Load" else ." Don't load" then cr
1021 : show-module-options
1031 : free-one-module { addr -- addr }
1032 addr module.name strfree
1033 addr module.loadname strfree
1034 addr module.type strfree
1035 addr module.hash strfree
1036 addr module.args strfree
1037 addr module.largs strfree
1038 addr module.beforeload strfree
1039 addr module.afterload strfree
1040 addr module.loaderror strfree
1044 : free-module-options
1054 0 last_module_option !
1057 only forth also support-functions definitions
1059 \ Variables used for processing multiple conf files
1061 string current_file_name_ref \ used to print the file name
1063 \ Indicates if any conf file was successfully read
1065 0 value any_conf_read?
1067 \ loader_conf_files processing support functions
1069 \ true if string in addr1 is smaller than in addr2
1070 : compar ( addr1 addr2 -- flag )
1071 swap ( addr2 addr1 )
1072 dup cell+ ( addr2 addr1 addr )
1073 swap @ ( addr2 addr len )
1074 rot ( addr len addr2 )
1075 dup cell+ ( addr len addr2 addr' )
1076 swap @ ( addr len addr' len' )
1080 \ insertion sort algorithm. we dont expect large amounts of data to be
1081 \ sorted, so insert should be ok. compar needs to implement < operator.
1082 : insert ( start end -- start )
1083 dup @ >r ( r: v ) \ v = a[i]
1087 r@ over cell- @ compar \ a[j-1] > v
1090 dup @ over cell+ ! \ a[j] = a[j-1]
1092 r> swap ! \ a[j] = v
1095 : sort ( array len -- )
1096 1 ?do dup i cells + insert loop drop
1100 s" /boot/conf.d" fopendir if fd ! else
1105 : readdir ( addr len flag | flag )
1113 : entries ( -- n ) \ count directory entries
1114 ['] opendir catch ( n array )
1118 begin \ count the entries
1119 readdir ( i addr len flag | i flag )
1129 \ built-in prefix directory name; it must end with /, so we don't
1130 \ need to check and insert it.
1131 : make_cstring ( addr len -- addr' )
1132 dup ( addr len len )
1133 s" /boot/conf.d/" ( addr len len addr' len' )
1134 rot ( addr len addr' len' len )
1135 over + ( addr len addr' len' total ) \ space for prefix+str
1136 dup cell+ 1+ \ 1+ for '\0'
1138 -1 abort" malloc failed"
1140 ( addr len addr' len' total taddr )
1141 dup rot ( addr len addr' len' taddr taddr total )
1142 swap ! ( addr len addr' len' taddr ) \Â store length
1143 dup >r \Â save reference
1144 cell+ \ point to string area
1145 2dup 2>r ( addr len addr' len' taddr' ) ( R: taddr len' taddr' )
1146 swap move ( addr len )
1147 2r> + ( addr len taddr' ) ( R: taddr )
1148 swap 1+ move \ 1+ for '\0'
1152 : scan_conf_dir ( -- addr len -1 | 0 )
1153 s" currdev" getenv -1 <> if
1154 3 \ we only need first 3 chars
1155 s" net" compare 0= if
1156 s" boot.tftproot.server" getenv? if
1157 0 exit \ readdir does not work on tftp
1162 ['] entries catch if
1165 dup 0= if exit then \ nothing to do
1167 dup cells allocate ( n array flag ) \ allocate array
1169 ['] opendir catch if ( n array )
1174 readdir ( n array addr len flag | n array flag )
1175 0= if -1 abort" unexpected readdir error" then \ shouldnt happen
1176 ( n array addr len )
1177 \ we have relative name, make it absolute and convert to counted string
1178 make_cstring ( n array addr )
1179 over I cells + ! ( n array )
1183 \ we have now array of strings with directory entry names.
1184 \ calculate size of concatenated string
1185 over 0 swap 0 do ( n array 0 )
1186 over I cells + @ ( n array total array[I] )
1187 @ + 1+ ( n array total' )
1189 dup allocate if drop free 2drop 0 exit then
1190 ( n array len addr )
1191 \ now concatenate all entries.
1192 2swap ( len addr n array )
1193 over 0 swap 0 do ( len addr n array 0 )
1194 over I cells + @ ( len addr n array total array[I] )
1195 dup @ swap cell+ ( len addr n array total len addr' )
1196 over ( len addr n array total len addr' len )
1197 6 pick ( len addr n array total len addr' len addr )
1198 4 pick + ( len addr n array total len addr' len addr+total )
1199 swap move + ( len addr n array total+len )
1200 3 pick ( len addr n array total addr )
1201 over + bl swap c! 1+ ( len addr n array total )
1202 over I cells + @ free drop \ free array[I]
1204 drop free drop drop ( len addr )
1209 : get_conf_files ( -- addr len ) \ put addr/len on stack, reset var
1210 \ ." -- starting on <" conf_files strtype ." >" cr \ debugging
1211 scan_conf_dir if \ concatenate with conf_files
1213 dup conf_files .len @ + 2 + allocate abort" out of memory" ( addr len addr' )
1214 dup conf_files strget ( addr len addr' caddr clen )
1215 rot swap move ( addr len addr' )
1217 dup conf_files .len @ + ( addr len addr' addr'+clen )
1218 dup bl swap c! 1+ ( addr len addr' addr'' )
1219 3 pick swap ( addr len addr' addr addr'' )
1220 3 pick move ( addr len addr' )
1221 rot ( len addr' addr )
1222 free drop swap ( addr' len )
1223 conf_files .len @ + 1+ ( addr len )
1226 conf_files strget 0 0 conf_files strset
1230 : skip_leading_spaces { addr len pos -- addr len pos' }
1232 pos len = if 0 else addr pos + c@ bl = then
1239 \ return the file name at pos, or free the string if nothing left
1240 : get_file_name { addr len pos -- addr len pos' addr' len' || 0 }
1242 addr free abort" Fatal error freeing memory"
1247 \ stay in the loop until have chars and they are not blank
1248 pos len = if 0 else addr pos + c@ bl <> then
1252 addr len pos addr r@ + pos r> -
1255 : get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 )
1260 : print_current_file
1261 current_file_name_ref strtype
1264 : process_conf_errors
1265 dup 0= if true to any_conf_read? drop exit then
1268 ." Warning: syntax error on file " print_current_file cr
1269 print_syntax_error drop exit
1272 ." Warning: bad definition on file " print_current_file cr
1273 print_line drop exit
1276 ." Warning: error reading file " print_current_file cr drop exit
1279 verbose? if ." Warning: unable to open file " print_current_file cr then
1282 dup EFREE = abort" Fatal error freeing memory"
1283 dup ENOMEM = abort" Out of memory"
1284 throw \ Unknown error -- pass ahead
1287 \ Process loader_conf_files recursively
1288 \ Interface to loader_conf_files processing
1291 s" /boot/solaris/bootenv.rc"
1292 ['] load_bootenv catch
1293 dup 0= if drop exit then
1296 ." Warning: syntax error on /boot/solaris/bootenv.rc" cr drop exit
1299 ." Warning: error reading /boot/solaris/bootenv.rc" cr drop exit
1302 verbose? if ." Warning: unable to open /boot/solaris/bootenv.rc" cr then
1305 dup EFREE = abort" Fatal error freeing memory"
1306 dup ENOMEM = abort" Out of memory"
1307 throw \ Unknown error -- pass ahead
1311 s" /boot/transient.conf" ['] load_conf catch
1312 dup 0= if drop exit then \ no error
1315 ." Warning: syntax error on file /boot/transient.conf" cr
1319 ." Warning: bad definition on file /boot/transient.conf" cr
1323 ." Warning: error reading file /boot/transient.conf" cr drop exit
1326 verbose? if ." Warning: unable to open file /boot/transient.conf" cr then
1329 dup EFREE = abort" Fatal error freeing memory"
1330 dup ENOMEM = abort" Out of memory"
1331 throw \ Unknown error -- pass ahead
1334 : include_conf_files
1335 get_conf_files 0 ( addr len offset )
1337 get_next_file ?dup ( addr len 1 | 0 )
1339 current_file_name_ref strref
1342 conf_files .addr @ if recurse then
1346 \ Module loading functions
1348 \ concat two strings by allocating space
1349 : concat { a1 l1 a2 l2 -- a' l' }
1350 l1 l2 + allocate if ENOMEM throw then
1355 \ build module argument list as: "hash= name= module.args"
1356 \ if type is hash, name= will have module name without .hash suffix
1357 \ will free old largs and set new.
1359 : build_largs { addr -- addr }
1360 addr module.largs strfree
1361 addr module.hash .len @
1363 s" hash=" addr module.hash strget concat
1364 addr module.largs strset \ largs = "hash=" + module.hash
1367 addr module.type strget s" hash" compare 0=
1368 if ( module.type == "hash" )
1369 addr module.largs strget s" name=" concat
1371 addr module.loadname .len @
1372 if ( module.loadname != NULL )
1373 addr module.loadname strget concat
1375 addr module.name strget concat
1378 addr module.largs strfree
1379 addr module.largs strset \ largs = largs + name
1381 \ last thing to do is to strip off ".hash" suffix
1382 addr module.largs strget [char] . strchr
1383 dup if ( strchr module.largs '.' )
1384 s" .hash" compare 0=
1385 if ( it is ".hash" )
1386 addr module.largs .len @ 5 -
1387 addr module.largs .len !
1393 \ and now add up the module.args
1394 addr module.largs strget s" " concat
1395 addr module.args strget concat
1396 addr module.largs strfree
1397 addr module.largs strset
1401 : load_parameters { addr -- addr addrN lenN ... addr1 len1 N }
1403 addr module.largs strget
1404 addr module.loadname .len @ if
1405 addr module.loadname strget
1407 addr module.name strget
1409 addr module.type .len @ if
1410 addr module.type strget
1412 4 ( -t type name flags )
1418 : before_load ( addr -- addr )
1419 dup module.beforeload .len @ if
1420 dup module.beforeload strget
1421 ['] evaluate catch if EBEFORELOAD throw then
1425 : after_load ( addr -- addr )
1426 dup module.afterload .len @ if
1427 dup module.afterload strget
1428 ['] evaluate catch if EAFTERLOAD throw then
1432 : load_error ( addr -- addr )
1433 dup module.loaderror .len @ if
1434 dup module.loaderror strget
1435 evaluate \ This we do not intercept so it can throw errors
1439 : pre_load_message ( addr -- addr )
1441 dup module.name strtype
1446 : load_error_message verbose? if ." failed!" cr then ;
1448 : load_successful_message verbose? if ." ok" cr then ;
1451 load_parameters load
1454 : process_module ( addr -- addr )
1458 ['] load_module catch if
1459 dup module.loaderror .len @ if
1460 load_error \ Command should return a flag!
1462 load_error_message true \ Do not retry
1466 load_successful_message true \ Successful, do not retry
1471 : process_module_errors ( addr ior -- )
1472 dup EBEFORELOAD = if
1475 dup module.name strtype
1476 dup module.loadname .len @ if
1477 ." (" dup module.loadname strtype ." )"
1480 ." Error executing "
1481 dup module.beforeload strtype cr \ XXX there was a typo here
1488 dup module.name .addr @ over module.name .len @ type
1489 dup module.loadname .len @ if
1490 ." (" dup module.loadname strtype ." )"
1493 ." Error executing "
1494 dup module.afterload strtype cr
1498 throw \ Don't know what it is all about -- pass ahead
1501 \ Module loading interface
1503 \ scan the list of modules, load enabled ones.
1504 : load_modules ( -- ) ( throws: abort & user-defined )
1505 module_options @ ( list_head )
1509 dup module.flag @ if
1510 ['] process_module catch
1511 process_module_errors
1517 \ h00h00 magic used to try loading either a kernel with a given name,
1518 \ or a kernel with the default name in a directory of a given name
1521 : bootpath s" /platform/" ;
1522 : modulepath s" module_path" ;
1524 \ Functions used to save and restore module_path's value.
1525 : saveenv ( addr len | -1 -- addr' len | 0 -1 )
1526 dup -1 = if 0 swap exit then
1529 : freeenv ( addr len | 0 -1 )
1530 -1 = if drop else free abort" Freeing error" then
1532 : restoreenv ( addr len | 0 -1 -- )
1533 dup -1 = if ( it wasn't set )
1539 r> free abort" Freeing error"
1543 : clip_args \ Drop second string if only one argument is passed
1554 \ Parse filename from a semicolon-separated list
1556 : parse-; ( addr len -- addr' len-x addr x )
1557 over 0 2swap ( addr 0 addr len )
1559 dup 0 <> ( addr 0 addr len )
1561 over c@ [char] ; <> ( addr 0 addr len flag )
1572 \ Try loading one of multiple kernels specified
1574 : try_multiple_kernels ( addr len addr' len' args -- flag )
1580 s" DEBUG" getenv? if
1581 s" echo Module_path: ${module_path}" evaluate
1582 ." Kernel : " >r 2dup type r> cr
1583 dup 2 = if ." Flags : " >r 2over type r> cr then
1585 \ if it's xen, the xen kernel is loaded, unix needs to be loaded as module
1586 s" xen_kernel" getenv -1 <> if
1587 drop \ drop address from getenv
1588 >r \ argument count to R
1589 s" kernel" s" -t " \ push 2 strings into the stack
1590 r> 2 + \ increment argument count
1593 1 ['] load catch dup if
1594 ( addr0 len0 addr1 len1 ... args 1 error )
1595 >r \ error code to R
1597 0 do 2drop loop \ drop addr len pairs
1598 r> \Â set flag for while
1612 \ Try to load a kernel; the kernel name is taken from one of
1613 \ the following lists, as ordered:
1615 \ 1. The "bootfile" environment variable
1616 \ 2. The "kernel" environment variable
1618 \ Flags are passed, if available. If not, dummy values must be given.
1620 \ The kernel gets loaded from the current module_path.
1622 : load_a_kernel ( flags len 1 | x x 0 -- flag )
1628 \ Check if a default kernel name exists at all, exits if not
1629 s" bootfile" getenv dup -1 <> if
1631 flags kernel args 1+ try_multiple_kernels
1636 s" kernel" getenv dup -1 <> if
1643 \ Try all default kernel names
1644 flags kernel args 1+ try_multiple_kernels
1647 \ Try to load a kernel; the kernel name is taken from one of
1648 \ the following lists, as ordered:
1650 \ 1. The "bootfile" environment variable
1651 \ 2. The "kernel" environment variable
1653 \ Flags are passed, if provided.
1655 \ The kernel will be loaded from a directory computed from the
1656 \ path given. Two directories will be tried in the following order:
1661 \ The module_path variable is overridden if load is successful, by
1662 \ prepending the successful path.
1664 : load_from_directory ( path len 1 | flags len' path len 2 -- flag )
1667 args 1 = if 0 0 then
1669 0 0 2local oldmodulepath \ like a string
1670 0 0 2local newmodulepath \ like a string
1673 \ Set the environment variable module_path, and try loading
1675 modulepath getenv saveenv to oldmodulepath
1677 \ Try prepending /boot/ first
1678 bootpath nip path nip + \ total length
1679 oldmodulepath nip dup -1 = if
1682 1+ + \ add oldpath -- XXX why the 1+ ?
1684 allocate if ( out of memory ) 1 exit then \ XXX throw ?
1689 2dup to newmodulepath
1692 \ Try all default kernel names
1693 flags args 1- load_a_kernel
1695 oldmodulepath nip -1 <> if
1696 newmodulepath s" ;" strcat
1697 oldmodulepath strcat
1699 newmodulepath drop free-memory
1700 oldmodulepath drop free-memory
1705 \ Well, try without the prepended /boot/
1706 path newmodulepath drop swap move
1707 newmodulepath drop path nip
1708 2dup to newmodulepath
1711 \ Try all default kernel names
1712 flags args 1- load_a_kernel
1713 if ( failed once more )
1714 oldmodulepath restoreenv
1715 newmodulepath drop free-memory
1718 oldmodulepath nip -1 <> if
1719 newmodulepath s" ;" strcat
1720 oldmodulepath strcat
1722 newmodulepath drop free-memory
1723 oldmodulepath drop free-memory
1729 \ Try to load a kernel; the kernel name is taken from one of
1730 \ the following lists, as ordered:
1732 \ 1. The "bootfile" environment variable
1733 \ 2. The "kernel" environment variable
1734 \ 3. The "path" argument
1736 \ Flags are passed, if provided.
1738 \ The kernel will be loaded from a directory computed from the
1739 \ path given. Two directories will be tried in the following order:
1744 \ Unless "path" is meant to be kernel name itself. In that case, it
1745 \ will first be tried as a full path, and, next, search on the
1746 \ directories pointed by module_path.
1748 \ The module_path variable is overridden if load is successful, by
1749 \ prepending the successful path.
1751 : load_directory_or_file ( path len 1 | flags len' path len 2 -- flag )
1754 args 1 = if 0 0 then
1758 \ First, assume path is an absolute path to a directory
1759 flags path args clip_args load_from_directory
1760 dup 0= if exit else drop then
1762 \ Next, assume path points to the kernel
1763 flags path args try_multiple_kernels
1766 : initialize ( addr len -- )
1767 strdup conf_files strset
1770 : boot-args ( -- addr len 1 | 0 )
1771 s" boot-args" getenv
1772 dup -1 = if drop 0 else 1 then
1775 : standard_kernel_search ( flags 1 | 0 -- flag )
1780 dup -1 = if 0 swap then
1784 path nip -1 = if ( there isn't a "kernel" environment variable )
1785 flags args load_a_kernel
1787 flags path args 1+ clip_args load_directory_or_file
1791 : load_kernel ( -- ) ( throws: abort )
1792 s" xen_kernel" getenv -1 = if
1793 boot-args standard_kernel_search
1794 abort" Unable to load a kernel!"
1799 \ we have loaded the xen kernel, load unix as module
1800 s" bootfile" getenv dup -1 <> if
1801 s" kernel" s" -t " 3 1 load
1803 abort" Unable to load a kernel!"
1807 s" xen_kernel" getenv dup -1 <> if
1808 1 1 load ( c-addr/u flag N -- flag )
1815 : load_xen_throw ( -- ) ( throws: abort )
1817 abort" Unable to load Xen!"
1820 : set_defaultoptions ( -- )
1821 s" boot-args" getenv dup -1 = if
1824 s" temp_options" setenv
1828 \ pick the i-th argument, i starts at 0
1829 : argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
1830 2dup = if 0 0 exit then \ out of range
1832 1+ 2* ( skip N and ui )
1835 1+ 2* ( skip N and ai )
1839 : drop_args ( aN uN ... a1 u1 N -- )
1847 : queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 )
1855 : unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 )
1859 \ compute the length of the buffer including the spaces between words
1860 : strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len )
1861 dup 0= if 0 exit then
1876 : concat_argv ( aN uN ... a1 u1 N -- a u )
1877 strlen(argv) allocate if ENOMEM throw then
1878 0 2>r ( save addr 0 on return stack )
1883 unqueue_argv ( ... N a1 u1 )
1884 2r> 2swap ( old a1 u1 )
1886 s" " strcat ( append one space ) \ XXX this gives a trailing space
1887 2>r ( store string on the result stack )
1893 : set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
1894 \ Save the first argument, if it exists and is not a flag
1896 0 argv[] drop c@ [char] - <> if
1897 unqueue_argv 2>r \ Filename
1898 1 >r \ Filename present
1900 0 >r \ Filename not present
1903 0 >r \ Filename not present
1906 \ If there are other arguments, assume they are flags
1909 2dup s" temp_options" setenv
1910 drop free if EFREE throw then
1915 \ Bring back the filename, if one was provided
1916 r> if 2r> 1 else 0 then
1919 : get_arguments ( -- addrN lenN ... addr1 len1 N )
1922 \ Get next word on the command line
1927 drop ( empty string )
1930 : load_kernel_and_modules ( args -- flag )
1933 s" temp_options" getenv dup -1 <> if
1939 ?dup 0= if ( success )
1940 r> if ( a path was passed )
1941 load_directory_or_file
1943 standard_kernel_search
1945 ?dup 0= if ['] load_modules catch then
1949 only forth definitions