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_support ( -- ) initialize global variables
30 \ initialize ( addr len -- ) as above, plus load_conf_files
31 \ load_conf ( addr len -- ) load conf file given
32 \ include_conf_files ( -- ) load all conf files in load_conf_files
33 \ print_syntax_error ( -- ) print line and marker of where a syntax
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
49 \ string module.args flags to be passed during load
50 \ string module.beforeload command to be executed before load
51 \ string module.afterload command to be executed after load
52 \ string module.loaderror command to be executed if load fails
53 \ cell module.next list chain
55 \ Exported global variables;
57 \ string conf_files configuration files to be loaded
58 \ string password password
59 \ cell modules_options pointer to first module information
60 \ value verbose? indicates if user wants a verbose loading
61 \ value any_conf_read? indicates if a conf file was succesfully read
63 \ Other exported words:
65 \ strdup ( addr len -- addr' len) similar to strdup(3)
66 \ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3)
67 \ strlen ( addr -- len ) similar to strlen(3)
68 \ s' ( | string' -- addr len | ) similar to s"
69 \ rudimentary structure support
73 1 constant syntax_error
74 2 constant out_of_memory
80 8 constant before_load_error
81 9 constant after_load_error
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.args
129 sizeof string member: module.beforeload
130 sizeof string member: module.afterload
131 sizeof string member: module.loaderror
135 \ Internal loader structures
136 structure: preloaded_file
140 ptr pf.metadata \ file_metadata
144 ptr pf.modules \ kernel_module
145 ptr pf.next \ preloaded_file
148 structure: kernel_module
151 ptr km.fp \ preloaded_file
152 ptr km.next \ kernel_module
155 structure: file_metadata
157 2 member: md.type \ this is not ANS Forth compatible (XXX)
158 ptr md.next \ file_metadata
159 0 member: md.data \ variable size
162 structure: config_resource
166 1 constant RES_STRING
171 structure: config_device
174 int cd.resource_count
175 ptr cd.resources \ config_resource
178 structure: STAILQ_HEAD
179 ptr stqh_first \ type*
180 ptr stqh_last \ type**
183 structure: STAILQ_ENTRY
184 ptr stqe_next \ type*
187 structure: pnphandler
193 ptr pnpid.ident \ char*
194 sizeof STAILQ_ENTRY cells member: pnpid.link \ pnpident
200 ptr pnpi.module \ (char*) module args
203 ptr pnpi.handler \ pnphandler
204 sizeof STAILQ_HEAD member: pnpi.ident \ pnpident
205 sizeof STAILQ_ENTRY member: pnpi.link \ pnpinfo
211 string nextboot_conf_file
213 create module_options sizeof module.next allot 0 module_options !
214 create last_module_option sizeof module.next allot 0 last_module_option !
218 \ Support string functions
220 : strdup ( addr len -- addr' len )
221 >r r@ allocate if out_of_memory throw then
226 : strcat { addr len addr' len' -- addr len+len' }
227 addr' addr len + len' move
231 : strlen ( addr -- len )
246 : 2>r postpone >r postpone >r ; immediate
247 : 2r> postpone r> postpone r> ; immediate
248 : 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate
252 -1 = if false else drop true then
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_args_suffix s" _flags" ;
278 : module_beforeload_suffix s" _before" ;
279 : module_afterload_suffix s" _after" ;
280 : module_loaderror_suffix s" _error" ;
287 \ Assorted support funcitons
289 : free-memory free if free_error throw then ;
291 \ Assignment data temporary storage
296 \ Line by line file reading functions
305 vocabulary line-reading
306 also line-reading definitions also
308 \ File data temporary storage
311 0 value read_buffer_ptr
313 \ File's line reading function
315 support-functions definitions
321 line-reading definitions
325 read_buffer .len @ read_buffer_ptr >
327 read_buffer .addr @ read_buffer_ptr + c@ lf = if
328 read_buffer_ptr char+ to read_buffer_ptr
335 : scan_buffer ( -- addr len )
338 read_buffer .len @ r@ >
340 read_buffer .addr @ r@ + c@ lf = if
341 read_buffer .addr @ read_buffer_ptr + ( -- addr )
342 r@ read_buffer_ptr - ( -- len )
343 r> to read_buffer_ptr
348 read_buffer .addr @ read_buffer_ptr + ( -- addr )
349 r@ read_buffer_ptr - ( -- len )
350 r> to read_buffer_ptr
353 : line_buffer_resize ( len -- len )
355 line_buffer .len @ if
357 line_buffer .len @ r@ +
358 resize if out_of_memory throw then
360 r@ allocate if out_of_memory throw then
366 : append_to_line_buffer ( addr len -- )
367 line_buffer .addr @ line_buffer .len @
374 scan_buffer ( -- addr len )
375 line_buffer_resize ( len -- len )
376 append_to_line_buffer ( addr len -- )
380 read_buffer .len @ read_buffer_ptr =
386 read_buffer .addr @ 0= if
387 read_buffer_size allocate if out_of_memory throw then
390 fd @ read_buffer .addr @ read_buffer_size fread
391 dup -1 = if read_error throw then
392 dup 0= if true to end_of_file? then
397 line_buffer .addr @ ?dup if
400 0 line_buffer .addr !
404 support-functions definitions
421 only forth also support-functions definitions
423 \ Conf file line parser:
424 \ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
425 \ <spaces>[<comment>]
426 \ <name> ::= <letter>{<letter>|<digit>|'_'}
427 \ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name>
428 \ <character_set> ::= ASCII 32 to 126, except '\' and '"'
429 \ <comment> ::= '#'{<anything>}
437 vocabulary file-processing
438 also file-processing definitions
446 also parser definitions also
448 0 value parsing_function
452 line_pointer end_of_line =
471 line_pointer c@ [char] " =
475 line_pointer c@ [char] = =
479 line_pointer c@ [char] # =
484 line_pointer c@ tab = or
488 line_pointer c@ [char] \ =
492 line_pointer c@ [char] _ =
496 line_pointer c@ [char] . =
500 line_pointer char+ to line_pointer
503 : skip_to_end_of_line
504 end_of_line to line_pointer
512 end_of_line? if exit then
516 : parse_name ( -- addr len )
519 letter? digit? underscore? dot? or or or
532 : remove_backslashes { addr len | addr' len' -- addr' len' }
533 len allocate if out_of_memory throw then
537 addr c@ [char] \ <> if
538 addr c@ addr' len' + c!
548 : parse_quote ( -- addr len )
551 end_of_line? if syntax_error throw then
557 end_of_line? if syntax_error throw then
560 end_of_line? if syntax_error throw then
568 parse_name ( -- addr len )
575 parse_quote ( -- addr len )
577 parse_name ( -- addr len )
589 comment? if ['] comment to parsing_function exit then
590 end_of_line? 0= if syntax_error throw then
595 ['] white_space_4 to parsing_function
600 letter? digit? quote? or or if
601 ['] variable_value to parsing_function exit
608 ['] white_space_3 to parsing_function
613 assignment_sign? if ['] assignment_sign to parsing_function exit then
619 ['] white_space_2 to parsing_function
624 letter? if ['] variable_name to parsing_function exit then
625 comment? if ['] comment to parsing_function exit then
626 end_of_line? 0= if syntax_error throw then
629 file-processing definitions
632 line_buffer .addr @ line_buffer .len @ + to end_of_line
633 line_buffer .addr @ to line_pointer
634 ['] white_space_1 to parsing_function
638 parsing_function execute
640 parsing_function ['] comment =
641 parsing_function ['] white_space_1 =
642 parsing_function ['] white_space_4 =
643 or or 0= if syntax_error throw then
646 only forth also support-functions also file-processing definitions also
650 : assignment_type? ( addr len -- flag )
651 name_buffer .addr @ name_buffer .len @
655 : suffix_type? ( addr len -- flag )
656 name_buffer .len @ over <= if 2drop false exit then
657 name_buffer .len @ over - name_buffer .addr @ +
662 s" loader_conf_files" assignment_type?
666 s" nextboot_enable" assignment_type?
670 s" nextboot_conf" assignment_type?
674 s" verbose_loading" assignment_type?
678 s" exec" assignment_type?
682 s" password" assignment_type?
686 load_module_suffix suffix_type?
690 module_loadname_suffix suffix_type?
694 module_type_suffix suffix_type?
698 module_args_suffix suffix_type?
702 module_beforeload_suffix suffix_type?
706 module_afterload_suffix suffix_type?
710 module_loaderror_suffix suffix_type?
714 conf_files .addr @ ?dup if
717 value_buffer .addr @ c@ [char] " = if
718 value_buffer .addr @ char+ value_buffer .len @ 2 chars -
720 value_buffer .addr @ value_buffer .len @
723 conf_files .len ! conf_files .addr !
727 nextboot_conf_file .addr @ ?dup if
730 value_buffer .addr @ c@ [char] " = if
731 value_buffer .addr @ char+ value_buffer .len @ 2 chars -
733 value_buffer .addr @ value_buffer .len @
736 nextboot_conf_file .len ! nextboot_conf_file .addr !
739 : append_to_module_options_list ( addr -- )
740 module_options @ 0= if
744 dup last_module_option @ module.next !
749 : set_module_name ( addr -- )
750 name_buffer .addr @ name_buffer .len @
752 >r over module.name .addr !
753 r> swap module.name .len !
757 value_buffer .addr @ value_buffer .len @
758 2dup s' "YES"' compare >r
759 2dup s' "yes"' compare >r
760 2dup s" YES" compare >r
761 s" yes" compare r> r> r> and and and 0=
764 : find_module_option ( -- addr | 0 )
769 dup module.name dup .addr @ swap .len @
770 name_buffer .addr @ name_buffer .len @
771 compare 0= if exit then
776 : new_module_option ( -- addr )
777 sizeof module allocate if out_of_memory throw then
778 dup sizeof module erase
779 dup append_to_module_options_list
783 : get_module_option ( -- addr )
785 ?dup 0= if new_module_option then
789 name_buffer .len @ load_module_suffix nip - name_buffer .len !
790 yes_value? get_module_option module.flag !
794 name_buffer .len @ module_args_suffix nip - name_buffer .len !
795 get_module_option module.args
796 dup .addr @ ?dup if free-memory then
797 value_buffer .addr @ value_buffer .len @
798 over c@ [char] " = if
799 2 chars - swap char+ swap
806 : set_module_loadname
807 name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
808 get_module_option module.loadname
809 dup .addr @ ?dup if free-memory then
810 value_buffer .addr @ value_buffer .len @
811 over c@ [char] " = if
812 2 chars - swap char+ swap
820 name_buffer .len @ module_type_suffix nip - name_buffer .len !
821 get_module_option module.type
822 dup .addr @ ?dup if free-memory then
823 value_buffer .addr @ value_buffer .len @
824 over c@ [char] " = if
825 2 chars - swap char+ swap
832 : set_module_beforeload
833 name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
834 get_module_option module.beforeload
835 dup .addr @ ?dup if free-memory then
836 value_buffer .addr @ value_buffer .len @
837 over c@ [char] " = if
838 2 chars - swap char+ swap
845 : set_module_afterload
846 name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
847 get_module_option module.afterload
848 dup .addr @ ?dup if free-memory then
849 value_buffer .addr @ value_buffer .len @
850 over c@ [char] " = if
851 2 chars - swap char+ swap
858 : set_module_loaderror
859 name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
860 get_module_option module.loaderror
861 dup .addr @ ?dup if free-memory then
862 value_buffer .addr @ value_buffer .len @
863 over c@ [char] " = if
864 2 chars - swap char+ swap
871 : set_environment_variable
873 value_buffer .len @ +
875 allocate if out_of_memory throw then
876 dup 0 ( addr -- addr addr len )
878 name_buffer .addr @ name_buffer .len @ strcat
880 value_buffer .addr @ value_buffer .len @ strcat
881 ['] evaluate catch if
890 yes_value? to nextboot?
894 yes_value? to verbose?
898 value_buffer .addr @ value_buffer .len @
899 over c@ [char] " = if
902 ['] evaluate catch if exec_error throw then
906 password .addr @ ?dup if free if free_error throw then then
907 value_buffer .addr @ c@ [char] " = if
908 value_buffer .addr @ char+ value_buffer .len @ 2 - strdup
909 value_buffer .addr @ free if free_error throw then
911 value_buffer .addr @ value_buffer .len @
913 password .len ! password .addr !
914 0 value_buffer .addr !
918 name_buffer .len @ 0= if exit then
919 loader_conf_files? if set_conf_files exit then
920 nextboot_flag? if set_nextboot_flag exit then
921 nextboot_conf? if set_nextboot_conf exit then
922 verbose_flag? if set_verbose exit then
923 execute? if execute_command exit then
924 password? if set_password exit then
925 module_load? if set_module_flag exit then
926 module_loadname? if set_module_loadname exit then
927 module_type? if set_module_type exit then
928 module_args? if set_module_args exit then
929 module_beforeload? if set_module_beforeload exit then
930 module_afterload? if set_module_afterload exit then
931 module_loaderror? if set_module_loaderror exit then
932 set_environment_variable
937 \ Free some pointers if needed. The code then tests for errors
938 \ in freeing, and throws an exception if needed. If a pointer is
939 \ not allocated, it's value (0) is used as flag.
942 name_buffer .addr @ dup if free then
943 value_buffer .addr @ dup if free then
944 or if free_error throw then
947 : reset_assignment_buffers
948 0 name_buffer .addr !
950 0 value_buffer .addr !
951 0 value_buffer .len !
954 \ Higher level file processing
956 support-functions definitions
962 reset_assignment_buffers
965 ['] process_assignment catch
966 ['] free_buffers catch
975 fd @ -1 = if open_error throw then
976 reset_assignment_buffers
979 ['] process_assignment catch
980 ['] free_buffers catch
984 only forth also support-functions definitions
986 \ Interface to loading conf files
988 : load_conf ( addr len -- )
992 fd @ -1 = if open_error throw then
993 ['] process_conf catch
999 line_buffer .addr @ line_buffer .len @ type cr
1002 : print_syntax_error
1003 line_buffer .addr @ line_buffer .len @ type cr
1006 line_pointer over <>
1015 \ Depuration support functions
1017 only forth definitions also support-functions
1020 ['] load_conf catch dup .
1021 syntax_error = if cr print_syntax_error then
1024 : show-module-options
1029 ." Name: " dup module.name dup .addr @ swap .len @ type cr
1030 ." Path: " dup module.loadname dup .addr @ swap .len @ type cr
1031 ." Type: " dup module.type dup .addr @ swap .len @ type cr
1032 ." Flags: " dup module.args dup .addr @ swap .len @ type cr
1033 ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr
1034 ." After load: " dup module.afterload dup .addr @ swap .len @ type cr
1035 ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr
1036 ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr
1041 only forth also support-functions definitions
1043 \ Variables used for processing multiple conf files
1045 string current_file_name
1046 variable current_conf_files
1048 \ Indicates if any conf file was succesfully read
1050 0 value any_conf_read?
1052 \ loader_conf_files processing support functions
1054 : set_current_conf_files
1055 conf_files .addr @ current_conf_files !
1059 conf_files .addr @ conf_files .len @ strdup
1062 : recurse_on_conf_files?
1063 current_conf_files @ conf_files .addr @ <>
1066 : skip_leading_spaces { addr len pos -- addr len pos' }
1068 pos len = if addr len pos exit then
1076 : get_file_name { addr len pos -- addr len pos' addr' len' || 0 }
1078 addr free abort" Fatal error freeing memory"
1087 addr len pos addr r@ + pos r> - exit
1090 addr len pos addr r@ + pos r> -
1093 : get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 )
1098 : set_current_file_name
1099 over current_file_name .addr !
1100 dup current_file_name .len !
1103 : print_current_file
1104 current_file_name .addr @ current_file_name .len @ type
1107 : process_conf_errors
1108 dup 0= if true to any_conf_read? drop exit then
1110 dup syntax_error = if
1111 ." Warning: syntax error on file " print_current_file cr
1112 print_syntax_error drop exit
1115 ." Warning: bad definition on file " print_current_file cr
1116 print_line drop exit
1119 ." Warning: error reading file " print_current_file cr drop exit
1122 verbose? if ." Warning: unable to open file " print_current_file cr then
1125 dup free_error = abort" Fatal error freeing memory"
1126 dup out_of_memory = abort" Out of memory"
1127 throw \ Unknown error -- pass ahead
1130 \ Process loader_conf_files recursively
1131 \ Interface to loader_conf_files processing
1133 : include_conf_files
1134 set_current_conf_files
1139 set_current_file_name
1142 recurse_on_conf_files? if recurse then
1146 : get_nextboot_conf_file ( -- addr len )
1147 nextboot_conf_file .addr @ nextboot_conf_file .len @ strdup
1150 : rewrite_nextboot_file ( -- )
1151 get_nextboot_conf_file
1153 fd @ -1 = if open_error throw then
1154 fd @ s' nextboot_enable="NO" ' fwrite
1158 : include_nextboot_file
1159 get_nextboot_conf_file
1162 get_nextboot_conf_file
1165 ['] rewrite_nextboot_file catch
1169 \ Module loading functions
1175 : load_parameters ( addr -- addr addrN lenN ... addr1 len1 N )
1177 r@ module.args .addr @ r@ module.args .len @
1178 r@ module.loadname .len @ if
1179 r@ module.loadname .addr @ r@ module.loadname .len @
1181 r@ module.name .addr @ r@ module.name .len @
1183 r@ module.type .len @ if
1184 r@ module.type .addr @ r@ module.type .len @
1186 4 ( -t type name flags )
1193 : before_load ( addr -- addr )
1194 dup module.beforeload .len @ if
1195 dup module.beforeload .addr @ over module.beforeload .len @
1196 ['] evaluate catch if before_load_error throw then
1200 : after_load ( addr -- addr )
1201 dup module.afterload .len @ if
1202 dup module.afterload .addr @ over module.afterload .len @
1203 ['] evaluate catch if after_load_error throw then
1207 : load_error ( addr -- addr )
1208 dup module.loaderror .len @ if
1209 dup module.loaderror .addr @ over module.loaderror .len @
1210 evaluate \ This we do not intercept so it can throw errors
1214 : pre_load_message ( addr -- addr )
1216 dup module.name .addr @ over module.name .len @ type
1221 : load_error_message verbose? if ." failed!" cr then ;
1223 : load_succesful_message verbose? if ." ok" cr then ;
1226 load_parameters load
1229 : process_module ( addr -- addr )
1233 ['] load_module catch if
1234 dup module.loaderror .len @ if
1235 load_error \ Command should return a flag!
1237 load_error_message true \ Do not retry
1241 load_succesful_message true \ Succesful, do not retry
1246 : process_module_errors ( addr ior -- )
1247 dup before_load_error = if
1250 dup module.name .addr @ over module.name .len @ type
1251 dup module.loadname .len @ if
1252 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1255 ." Error executing "
1256 dup module.beforeload .addr @ over module.afterload .len @ type cr
1260 dup after_load_error = if
1263 dup module.name .addr @ over module.name .len @ type
1264 dup module.loadname .len @ if
1265 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1268 ." Error executing "
1269 dup module.afterload .addr @ over module.afterload .len @ type cr
1273 throw \ Don't know what it is all about -- pass ahead
1276 \ Module loading interface
1278 : load_modules ( -- ) ( throws: abort & user-defined )
1284 ['] process_module catch
1285 process_module_errors
1291 \ h00h00 magic used to try loading either a kernel with a given name,
1292 \ or a kernel with the default name in a directory of a given name
1295 : bootpath s" /boot/" ;
1296 : modulepath s" module_path" ;
1298 \ Functions used to save and restore module_path's value.
1299 : saveenv ( addr len | -1 -- addr' len | 0 -1 )
1300 dup -1 = if 0 swap exit then
1303 : freeenv ( addr len | 0 -1 )
1304 -1 = if drop else free abort" Freeing error" then
1306 : restoreenv ( addr len | 0 -1 -- )
1307 dup -1 = if ( it wasn't set )
1313 r> free abort" Freeing error"
1317 : clip_args \ Drop second string if only one argument is passed
1328 \ Parse filename from a comma-separated list
1330 : parse-; ( addr len -- addr' len-x addr x )
1346 \ Try loading one of multiple kernels specified
1348 : try_multiple_kernels ( addr len addr' len' args -- flag )
1354 s" DEBUG" getenv? if
1355 s" echo Module_path: ${module_path}" evaluate
1356 ." Kernel : " >r 2dup type r> cr
1357 dup 2 = if ." Flags : " >r 2over type r> cr then
1372 \ Try to load a kernel; the kernel name is taken from one of
1373 \ the following lists, as ordered:
1375 \ 1. The "bootfile" environment variable
1376 \ 2. The "kernel" environment variable
1378 \ Flags are passed, if available. If not, dummy values must be given.
1380 \ The kernel gets loaded from the current module_path.
1382 : load_a_kernel ( flags len 1 | x x 0 -- flag )
1388 \ Check if a default kernel name exists at all, exits if not
1389 s" bootfile" getenv dup -1 <> if
1391 flags kernel args 1+ try_multiple_kernels
1396 s" kernel" getenv dup -1 <> if
1403 \ Try all default kernel names
1404 flags kernel args 1+ try_multiple_kernels
1407 \ Try to load a kernel; the kernel name is taken from one of
1408 \ the following lists, as ordered:
1410 \ 1. The "bootfile" environment variable
1411 \ 2. The "kernel" environment variable
1413 \ Flags are passed, if provided.
1415 \ The kernel will be loaded from a directory computed from the
1416 \ path given. Two directories will be tried in the following order:
1421 \ The module_path variable is overridden if load is succesful, by
1422 \ prepending the successful path.
1424 : load_from_directory ( path len 1 | flags len' path len 2 -- flag )
1427 args 1 = if 0 0 then
1429 0 0 2local oldmodulepath
1430 0 0 2local newmodulepath
1433 \ Set the environment variable module_path, and try loading
1435 modulepath getenv saveenv to oldmodulepath
1437 \ Try prepending /boot/ first
1438 bootpath nip path nip +
1439 oldmodulepath nip dup -1 = if
1445 if ( out of memory )
1452 2dup to newmodulepath
1455 \ Try all default kernel names
1456 flags args 1- load_a_kernel
1458 oldmodulepath nip -1 <> if
1459 newmodulepath s" ;" strcat
1460 oldmodulepath strcat
1462 newmodulepath drop free-memory
1463 oldmodulepath drop free-memory
1468 \ Well, try without the prepended /boot/
1469 path newmodulepath drop swap move
1470 newmodulepath drop path nip
1471 2dup to newmodulepath
1474 \ Try all default kernel names
1475 flags args 1- load_a_kernel
1476 if ( failed once more )
1477 oldmodulepath restoreenv
1478 newmodulepath drop free-memory
1481 oldmodulepath nip -1 <> if
1482 newmodulepath s" ;" strcat
1483 oldmodulepath strcat
1485 newmodulepath drop free-memory
1486 oldmodulepath drop free-memory
1492 \ Try to load a kernel; the kernel name is taken from one of
1493 \ the following lists, as ordered:
1495 \ 1. The "bootfile" environment variable
1496 \ 2. The "kernel" environment variable
1497 \ 3. The "path" argument
1499 \ Flags are passed, if provided.
1501 \ The kernel will be loaded from a directory computed from the
1502 \ path given. Two directories will be tried in the following order:
1507 \ Unless "path" is meant to be kernel name itself. In that case, it
1508 \ will first be tried as a full path, and, next, search on the
1509 \ directories pointed by module_path.
1511 \ The module_path variable is overridden if load is succesful, by
1512 \ prepending the successful path.
1514 : load_directory_or_file ( path len 1 | flags len' path len 2 -- flag )
1517 args 1 = if 0 0 then
1521 \ First, assume path is an absolute path to a directory
1522 flags path args clip_args load_from_directory
1523 dup 0= if exit else drop then
1525 \ Next, assume path points to the kernel
1526 flags path args try_multiple_kernels
1529 : initialize ( addr len -- )
1530 strdup conf_files .len ! conf_files .addr !
1533 : kernel_options ( -- addr len 1 | 0 )
1534 s" kernel_options" getenv
1535 dup -1 = if drop 0 else 1 then
1538 : standard_kernel_search ( flags 1 | 0 -- flag )
1543 dup -1 = if 0 swap then
1547 path nip -1 = if ( there isn't a "kernel" environment variable )
1548 flags args load_a_kernel
1550 flags path args 1+ clip_args load_directory_or_file
1554 : load_kernel ( -- ) ( throws: abort )
1555 kernel_options standard_kernel_search
1556 abort" Unable to load a kernel!"
1559 : set_defaultoptions ( -- )
1560 s" kernel_options" getenv dup -1 = if
1563 s" temp_options" setenv
1567 : argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
1568 2dup = if 0 0 exit then
1570 1+ 2* ( skip N and ui )
1573 1+ 2* ( skip N and ai )
1577 : drop_args ( aN uN ... a1 u1 N -- )
1585 : queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 )
1593 : unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 )
1598 dup 0= if 0 exit then
1613 : concat_argv ( aN uN ... a1 u1 N -- a u )
1614 strlen(argv) allocate if out_of_memory throw then
1630 : set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
1631 \ Save the first argument, if it exists and is not a flag
1633 0 argv[] drop c@ [char] - <> if
1634 unqueue_argv 2>r \ Filename
1635 1 >r \ Filename present
1637 0 >r \ Filename not present
1640 0 >r \ Filename not present
1643 \ If there are other arguments, assume they are flags
1646 2dup s" temp_options" setenv
1647 drop free if free_error throw then
1652 \ Bring back the filename, if one was provided
1653 r> if 2r> 1 else 0 then
1656 : get_arguments ( -- addrN lenN ... addr1 len1 N )
1659 \ Get next word on the command line
1664 drop ( empty string )
1667 : load_kernel_and_modules ( args -- flag )
1670 s" temp_options" getenv dup -1 <> if
1675 r> if ( a path was passed )
1676 load_directory_or_file
1678 standard_kernel_search
1680 ?dup 0= if ['] load_modules catch then
1683 : read-password { size | buf len -- }
1684 size allocate if out_of_memory throw then
1692 backspace emit bl emit backspace emit
1698 dup <cr> = if cr drop buf len exit then
1710 \ Go back to straight forth vocabulary
1712 only forth also definitions