support.4th revision 97201
144603Sdcs\ Copyright (c) 1999 Daniel C. Sobral <dcs@freebsd.org> 244603Sdcs\ All rights reserved. 344603Sdcs\ 444603Sdcs\ Redistribution and use in source and binary forms, with or without 544603Sdcs\ modification, are permitted provided that the following conditions 644603Sdcs\ are met: 744603Sdcs\ 1. Redistributions of source code must retain the above copyright 844603Sdcs\ notice, this list of conditions and the following disclaimer. 944603Sdcs\ 2. Redistributions in binary form must reproduce the above copyright 1044603Sdcs\ notice, this list of conditions and the following disclaimer in the 1144603Sdcs\ documentation and/or other materials provided with the distribution. 1244603Sdcs\ 1344603Sdcs\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 1444603Sdcs\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 1544603Sdcs\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 1644603Sdcs\ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 1744603Sdcs\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 1844603Sdcs\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 1944603Sdcs\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 2044603Sdcs\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 2144603Sdcs\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 2244603Sdcs\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 2344603Sdcs\ SUCH DAMAGE. 2444603Sdcs\ 2550477Speter\ $FreeBSD: head/sys/boot/forth/support.4th 97201 2002-05-24 02:28:58Z gordon $ 2644603Sdcs 2744603Sdcs\ Loader.rc support functions: 2844603Sdcs\ 2944603Sdcs\ initialize_support ( -- ) initialize global variables 3044603Sdcs\ initialize ( addr len -- ) as above, plus load_conf_files 3144603Sdcs\ load_conf ( addr len -- ) load conf file given 3244603Sdcs\ include_conf_files ( -- ) load all conf files in load_conf_files 3344603Sdcs\ print_syntax_error ( -- ) print line and marker of where a syntax 3444603Sdcs\ error was detected 3544603Sdcs\ print_line ( -- ) print last line processed 3644603Sdcs\ load_kernel ( -- ) load kernel 3744603Sdcs\ load_modules ( -- ) load modules flagged 3844603Sdcs\ 3944603Sdcs\ Exported structures: 4044603Sdcs\ 4144603Sdcs\ string counted string structure 4244603Sdcs\ cell .addr string address 4344603Sdcs\ cell .len string length 4444603Sdcs\ module module loading information structure 4544603Sdcs\ cell module.flag should we load it? 4644603Sdcs\ string module.name module's name 4744603Sdcs\ string module.loadname name to be used in loading the module 4844603Sdcs\ string module.type module's type 4944603Sdcs\ string module.args flags to be passed during load 5044603Sdcs\ string module.beforeload command to be executed before load 5144603Sdcs\ string module.afterload command to be executed after load 5244603Sdcs\ string module.loaderror command to be executed if load fails 5344603Sdcs\ cell module.next list chain 5444603Sdcs\ 5544603Sdcs\ Exported global variables; 5644603Sdcs\ 5744603Sdcs\ string conf_files configuration files to be loaded 5853672Sdcs\ string password password 5944603Sdcs\ cell modules_options pointer to first module information 6044603Sdcs\ value verbose? indicates if user wants a verbose loading 6144603Sdcs\ value any_conf_read? indicates if a conf file was succesfully read 6244603Sdcs\ 6344603Sdcs\ Other exported words: 6444603Sdcs\ 6544603Sdcs\ strdup ( addr len -- addr' len) similar to strdup(3) 6644603Sdcs\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3) 6761373Sdcs\ strlen ( addr -- len ) similar to strlen(3) 6844603Sdcs\ s' ( | string' -- addr len | ) similar to s" 6944603Sdcs\ rudimentary structure support 7044603Sdcs 7144603Sdcs\ Exception values 7244603Sdcs 7344603Sdcs1 constant syntax_error 7444603Sdcs2 constant out_of_memory 7544603Sdcs3 constant free_error 7644603Sdcs4 constant set_error 7744603Sdcs5 constant read_error 7844603Sdcs6 constant open_error 7944603Sdcs7 constant exec_error 8044603Sdcs8 constant before_load_error 8144603Sdcs9 constant after_load_error 8244603Sdcs 8387636Sjhb\ I/O constants 8487636Sjhb 8587636Sjhb0 constant SEEK_SET 8687636Sjhb1 constant SEEK_CUR 8787636Sjhb2 constant SEEK_END 8887636Sjhb 8987636Sjhb0 constant O_RDONLY 9087636Sjhb1 constant O_WRONLY 9187636Sjhb2 constant O_RDWR 9287636Sjhb 9344603Sdcs\ Crude structure support 9444603Sdcs 9565615Sdcs: structure: 9665615Sdcs create here 0 , ['] drop , 0 9765615Sdcs does> create here swap dup @ allot cell+ @ execute 9865615Sdcs; 9944603Sdcs: member: create dup , over , + does> cell+ @ + ; 10044603Sdcs: ;structure swap ! ; 10165615Sdcs: constructor! >body cell+ ! ; 10265615Sdcs: constructor: over :noname ; 10365615Sdcs: ;constructor postpone ; swap cell+ ! ; immediate 10444603Sdcs: sizeof ' >body @ state @ if postpone literal then ; immediate 10544603Sdcs: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate 10644603Sdcs: ptr 1 cells member: ; 10744603Sdcs: int 1 cells member: ; 10844603Sdcs 10944603Sdcs\ String structure 11044603Sdcs 11144603Sdcsstructure: string 11244603Sdcs ptr .addr 11344603Sdcs int .len 11465615Sdcs constructor: 11565615Sdcs 0 over .addr ! 11665615Sdcs 0 swap .len ! 11765615Sdcs ;constructor 11844603Sdcs;structure 11944603Sdcs 12065615Sdcs 12144603Sdcs\ Module options linked list 12244603Sdcs 12344603Sdcsstructure: module 12444603Sdcs int module.flag 12544603Sdcs sizeof string member: module.name 12644603Sdcs sizeof string member: module.loadname 12744603Sdcs sizeof string member: module.type 12844603Sdcs sizeof string member: module.args 12944603Sdcs sizeof string member: module.beforeload 13044603Sdcs sizeof string member: module.afterload 13144603Sdcs sizeof string member: module.loaderror 13244603Sdcs ptr module.next 13344603Sdcs;structure 13444603Sdcs 13565615Sdcs\ Internal loader structures 13665615Sdcsstructure: preloaded_file 13765615Sdcs ptr pf.name 13865615Sdcs ptr pf.type 13965615Sdcs ptr pf.args 14065615Sdcs ptr pf.metadata \ file_metadata 14165615Sdcs int pf.loader 14265615Sdcs int pf.addr 14365615Sdcs int pf.size 14465615Sdcs ptr pf.modules \ kernel_module 14565615Sdcs ptr pf.next \ preloaded_file 14665615Sdcs;structure 14765615Sdcs 14865615Sdcsstructure: kernel_module 14965615Sdcs ptr km.name 15065615Sdcs \ ptr km.args 15165615Sdcs ptr km.fp \ preloaded_file 15265615Sdcs ptr km.next \ kernel_module 15365615Sdcs;structure 15465615Sdcs 15565615Sdcsstructure: file_metadata 15665615Sdcs int md.size 15765615Sdcs 2 member: md.type \ this is not ANS Forth compatible (XXX) 15865615Sdcs ptr md.next \ file_metadata 15965615Sdcs 0 member: md.data \ variable size 16065615Sdcs;structure 16165615Sdcs 16265615Sdcsstructure: config_resource 16365615Sdcs ptr cf.name 16465615Sdcs int cf.type 16565615Sdcs0 constant RES_INT 16665615Sdcs1 constant RES_STRING 16765615Sdcs2 constant RES_LONG 16865615Sdcs 2 cells member: u 16965615Sdcs;structure 17065615Sdcs 17165615Sdcsstructure: config_device 17265615Sdcs ptr cd.name 17365615Sdcs int cd.unit 17465615Sdcs int cd.resource_count 17565615Sdcs ptr cd.resources \ config_resource 17665615Sdcs;structure 17765615Sdcs 17865615Sdcsstructure: STAILQ_HEAD 17965615Sdcs ptr stqh_first \ type* 18065615Sdcs ptr stqh_last \ type** 18165615Sdcs;structure 18265615Sdcs 18365615Sdcsstructure: STAILQ_ENTRY 18465615Sdcs ptr stqe_next \ type* 18565615Sdcs;structure 18665615Sdcs 18765615Sdcsstructure: pnphandler 18865615Sdcs ptr pnph.name 18965615Sdcs ptr pnph.enumerate 19065615Sdcs;structure 19165615Sdcs 19265615Sdcsstructure: pnpident 19365615Sdcs ptr pnpid.ident \ char* 19465615Sdcs sizeof STAILQ_ENTRY cells member: pnpid.link \ pnpident 19565615Sdcs;structure 19665615Sdcs 19765615Sdcsstructure: pnpinfo 19865615Sdcs ptr pnpi.desc 19965615Sdcs int pnpi.revision 20065615Sdcs ptr pnpi.module \ (char*) module args 20165615Sdcs int pnpi.argc 20265615Sdcs ptr pnpi.argv 20365615Sdcs ptr pnpi.handler \ pnphandler 20465615Sdcs sizeof STAILQ_HEAD member: pnpi.ident \ pnpident 20565615Sdcs sizeof STAILQ_ENTRY member: pnpi.link \ pnpinfo 20665615Sdcs;structure 20765615Sdcs 20844603Sdcs\ Global variables 20944603Sdcs 21044603Sdcsstring conf_files 21197201Sgordonstring nextboot_conf_file 21253672Sdcsstring password 21365615Sdcscreate module_options sizeof module.next allot 0 module_options ! 21465615Sdcscreate last_module_option sizeof module.next allot 0 last_module_option ! 21544603Sdcs0 value verbose? 21697201Sgordon0 value nextboot? 21744603Sdcs 21844603Sdcs\ Support string functions 21944603Sdcs 22044603Sdcs: strdup ( addr len -- addr' len ) 22144603Sdcs >r r@ allocate if out_of_memory throw then 22244603Sdcs tuck r@ move 22344603Sdcs r> 22444603Sdcs; 22544603Sdcs 22644603Sdcs: strcat { addr len addr' len' -- addr len+len' } 22744603Sdcs addr' addr len + len' move 22844603Sdcs addr len len' + 22944603Sdcs; 23044603Sdcs 23161373Sdcs: strlen ( addr -- len ) 23261373Sdcs 0 >r 23361373Sdcs begin 23461373Sdcs dup c@ while 23561373Sdcs 1+ r> 1+ >r repeat 23661373Sdcs drop r> 23761373Sdcs; 23861373Sdcs 23944603Sdcs: s' 24044603Sdcs [char] ' parse 24144603Sdcs state @ if 24244603Sdcs postpone sliteral 24344603Sdcs then 24444603Sdcs; immediate 24544603Sdcs 24661373Sdcs: 2>r postpone >r postpone >r ; immediate 24761373Sdcs: 2r> postpone r> postpone r> ; immediate 24865883Sdcs: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate 24953672Sdcs 25065938Sdcs: getenv? 25165938Sdcs getenv 25265938Sdcs -1 = if false else drop true then 25365938Sdcs; 25465938Sdcs 25544603Sdcs\ Private definitions 25644603Sdcs 25744603Sdcsvocabulary support-functions 25844603Sdcsonly forth also support-functions definitions 25944603Sdcs 26044603Sdcs\ Some control characters constants 26144603Sdcs 26253672Sdcs7 constant bell 26353672Sdcs8 constant backspace 26444603Sdcs9 constant tab 26544603Sdcs10 constant lf 26653672Sdcs13 constant <cr> 26744603Sdcs 26844603Sdcs\ Read buffer size 26944603Sdcs 27044603Sdcs80 constant read_buffer_size 27144603Sdcs 27244603Sdcs\ Standard suffixes 27344603Sdcs 27444603Sdcs: load_module_suffix s" _load" ; 27544603Sdcs: module_loadname_suffix s" _name" ; 27644603Sdcs: module_type_suffix s" _type" ; 27744603Sdcs: module_args_suffix s" _flags" ; 27844603Sdcs: module_beforeload_suffix s" _before" ; 27944603Sdcs: module_afterload_suffix s" _after" ; 28044603Sdcs: module_loaderror_suffix s" _error" ; 28144603Sdcs 28244603Sdcs\ Support operators 28344603Sdcs 28444603Sdcs: >= < 0= ; 28544603Sdcs: <= > 0= ; 28644603Sdcs 28744603Sdcs\ Assorted support funcitons 28844603Sdcs 28944603Sdcs: free-memory free if free_error throw then ; 29044603Sdcs 29144603Sdcs\ Assignment data temporary storage 29244603Sdcs 29344603Sdcsstring name_buffer 29444603Sdcsstring value_buffer 29544603Sdcs 29665615Sdcs\ Line by line file reading functions 29765615Sdcs\ 29865615Sdcs\ exported: 29965615Sdcs\ line_buffer 30065615Sdcs\ end_of_file? 30165615Sdcs\ fd 30265615Sdcs\ read_line 30365615Sdcs\ reset_line_reading 30465615Sdcs 30565615Sdcsvocabulary line-reading 30665615Sdcsalso line-reading definitions also 30765615Sdcs 30844603Sdcs\ File data temporary storage 30944603Sdcs 31044603Sdcsstring read_buffer 31144603Sdcs0 value read_buffer_ptr 31244603Sdcs 31344603Sdcs\ File's line reading function 31444603Sdcs 31565615Sdcssupport-functions definitions 31665615Sdcs 31765615Sdcsstring line_buffer 31844603Sdcs0 value end_of_file? 31944603Sdcsvariable fd 32044603Sdcs 32165615Sdcsline-reading definitions 32265615Sdcs 32344603Sdcs: skip_newlines 32444603Sdcs begin 32544603Sdcs read_buffer .len @ read_buffer_ptr > 32644603Sdcs while 32744603Sdcs read_buffer .addr @ read_buffer_ptr + c@ lf = if 32844603Sdcs read_buffer_ptr char+ to read_buffer_ptr 32944603Sdcs else 33044603Sdcs exit 33144603Sdcs then 33244603Sdcs repeat 33344603Sdcs; 33444603Sdcs 33544603Sdcs: scan_buffer ( -- addr len ) 33644603Sdcs read_buffer_ptr >r 33744603Sdcs begin 33844603Sdcs read_buffer .len @ r@ > 33944603Sdcs while 34044603Sdcs read_buffer .addr @ r@ + c@ lf = if 34144603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 34244603Sdcs r@ read_buffer_ptr - ( -- len ) 34344603Sdcs r> to read_buffer_ptr 34444603Sdcs exit 34544603Sdcs then 34644603Sdcs r> char+ >r 34744603Sdcs repeat 34844603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 34944603Sdcs r@ read_buffer_ptr - ( -- len ) 35044603Sdcs r> to read_buffer_ptr 35144603Sdcs; 35244603Sdcs 35344603Sdcs: line_buffer_resize ( len -- len ) 35444603Sdcs >r 35544603Sdcs line_buffer .len @ if 35644603Sdcs line_buffer .addr @ 35744603Sdcs line_buffer .len @ r@ + 35844603Sdcs resize if out_of_memory throw then 35944603Sdcs else 36044603Sdcs r@ allocate if out_of_memory throw then 36144603Sdcs then 36244603Sdcs line_buffer .addr ! 36344603Sdcs r> 36444603Sdcs; 36544603Sdcs 36644603Sdcs: append_to_line_buffer ( addr len -- ) 36744603Sdcs line_buffer .addr @ line_buffer .len @ 36844603Sdcs 2swap strcat 36944603Sdcs line_buffer .len ! 37044603Sdcs drop 37144603Sdcs; 37244603Sdcs 37344603Sdcs: read_from_buffer 37444603Sdcs scan_buffer ( -- addr len ) 37544603Sdcs line_buffer_resize ( len -- len ) 37644603Sdcs append_to_line_buffer ( addr len -- ) 37744603Sdcs; 37844603Sdcs 37944603Sdcs: refill_required? 38044603Sdcs read_buffer .len @ read_buffer_ptr = 38144603Sdcs end_of_file? 0= and 38244603Sdcs; 38344603Sdcs 38444603Sdcs: refill_buffer 38544603Sdcs 0 to read_buffer_ptr 38644603Sdcs read_buffer .addr @ 0= if 38744603Sdcs read_buffer_size allocate if out_of_memory throw then 38844603Sdcs read_buffer .addr ! 38944603Sdcs then 39044603Sdcs fd @ read_buffer .addr @ read_buffer_size fread 39144603Sdcs dup -1 = if read_error throw then 39244603Sdcs dup 0= if true to end_of_file? then 39344603Sdcs read_buffer .len ! 39444603Sdcs; 39544603Sdcs 39644603Sdcs: reset_line_buffer 39765615Sdcs line_buffer .addr @ ?dup if 39865615Sdcs free-memory 39965615Sdcs then 40044603Sdcs 0 line_buffer .addr ! 40144603Sdcs 0 line_buffer .len ! 40244603Sdcs; 40344603Sdcs 40465615Sdcssupport-functions definitions 40565615Sdcs 40665615Sdcs: reset_line_reading 40765615Sdcs 0 to read_buffer_ptr 40865615Sdcs; 40965615Sdcs 41044603Sdcs: read_line 41144603Sdcs reset_line_buffer 41244603Sdcs skip_newlines 41344603Sdcs begin 41444603Sdcs read_from_buffer 41544603Sdcs refill_required? 41644603Sdcs while 41744603Sdcs refill_buffer 41844603Sdcs repeat 41944603Sdcs; 42044603Sdcs 42165615Sdcsonly forth also support-functions definitions 42265615Sdcs 42344603Sdcs\ Conf file line parser: 42444603Sdcs\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 42544603Sdcs\ <spaces>[<comment>] 42644603Sdcs\ <name> ::= <letter>{<letter>|<digit>|'_'} 42744603Sdcs\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 42844603Sdcs\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 42944603Sdcs\ <comment> ::= '#'{<anything>} 43065615Sdcs\ 43165615Sdcs\ exported: 43265615Sdcs\ line_pointer 43365615Sdcs\ process_conf 43444603Sdcs 43565615Sdcs0 value line_pointer 43665615Sdcs 43765615Sdcsvocabulary file-processing 43865615Sdcsalso file-processing definitions 43965615Sdcs 44065615Sdcs\ parser functions 44165615Sdcs\ 44265615Sdcs\ exported: 44365615Sdcs\ get_assignment 44465615Sdcs 44565615Sdcsvocabulary parser 44665615Sdcsalso parser definitions also 44765615Sdcs 44844603Sdcs0 value parsing_function 44944603Sdcs0 value end_of_line 45044603Sdcs 45144603Sdcs: end_of_line? 45244603Sdcs line_pointer end_of_line = 45344603Sdcs; 45444603Sdcs 45544603Sdcs: letter? 45644603Sdcs line_pointer c@ >r 45744603Sdcs r@ [char] A >= 45844603Sdcs r@ [char] Z <= and 45944603Sdcs r@ [char] a >= 46044603Sdcs r> [char] z <= and 46144603Sdcs or 46244603Sdcs; 46344603Sdcs 46444603Sdcs: digit? 46544603Sdcs line_pointer c@ >r 46644603Sdcs r@ [char] 0 >= 46744603Sdcs r> [char] 9 <= and 46844603Sdcs; 46944603Sdcs 47044603Sdcs: quote? 47144603Sdcs line_pointer c@ [char] " = 47244603Sdcs; 47344603Sdcs 47444603Sdcs: assignment_sign? 47544603Sdcs line_pointer c@ [char] = = 47644603Sdcs; 47744603Sdcs 47844603Sdcs: comment? 47944603Sdcs line_pointer c@ [char] # = 48044603Sdcs; 48144603Sdcs 48244603Sdcs: space? 48344603Sdcs line_pointer c@ bl = 48444603Sdcs line_pointer c@ tab = or 48544603Sdcs; 48644603Sdcs 48744603Sdcs: backslash? 48844603Sdcs line_pointer c@ [char] \ = 48944603Sdcs; 49044603Sdcs 49144603Sdcs: underscore? 49244603Sdcs line_pointer c@ [char] _ = 49344603Sdcs; 49444603Sdcs 49544603Sdcs: dot? 49644603Sdcs line_pointer c@ [char] . = 49744603Sdcs; 49844603Sdcs 49944603Sdcs: skip_character 50044603Sdcs line_pointer char+ to line_pointer 50144603Sdcs; 50244603Sdcs 50344603Sdcs: skip_to_end_of_line 50444603Sdcs end_of_line to line_pointer 50544603Sdcs; 50644603Sdcs 50744603Sdcs: eat_space 50844603Sdcs begin 50944603Sdcs space? 51044603Sdcs while 51144603Sdcs skip_character 51244603Sdcs end_of_line? if exit then 51344603Sdcs repeat 51444603Sdcs; 51544603Sdcs 51644603Sdcs: parse_name ( -- addr len ) 51744603Sdcs line_pointer 51844603Sdcs begin 51944603Sdcs letter? digit? underscore? dot? or or or 52044603Sdcs while 52144603Sdcs skip_character 52244603Sdcs end_of_line? if 52344603Sdcs line_pointer over - 52444603Sdcs strdup 52544603Sdcs exit 52644603Sdcs then 52744603Sdcs repeat 52844603Sdcs line_pointer over - 52944603Sdcs strdup 53044603Sdcs; 53144603Sdcs 53244603Sdcs: remove_backslashes { addr len | addr' len' -- addr' len' } 53344603Sdcs len allocate if out_of_memory throw then 53444603Sdcs to addr' 53544603Sdcs addr >r 53644603Sdcs begin 53744603Sdcs addr c@ [char] \ <> if 53844603Sdcs addr c@ addr' len' + c! 53944603Sdcs len' char+ to len' 54044603Sdcs then 54144603Sdcs addr char+ to addr 54244603Sdcs r@ len + addr = 54344603Sdcs until 54444603Sdcs r> drop 54544603Sdcs addr' len' 54644603Sdcs; 54744603Sdcs 54844603Sdcs: parse_quote ( -- addr len ) 54944603Sdcs line_pointer 55044603Sdcs skip_character 55144603Sdcs end_of_line? if syntax_error throw then 55244603Sdcs begin 55344603Sdcs quote? 0= 55444603Sdcs while 55544603Sdcs backslash? if 55644603Sdcs skip_character 55744603Sdcs end_of_line? if syntax_error throw then 55844603Sdcs then 55944603Sdcs skip_character 56044603Sdcs end_of_line? if syntax_error throw then 56144603Sdcs repeat 56244603Sdcs skip_character 56344603Sdcs line_pointer over - 56444603Sdcs remove_backslashes 56544603Sdcs; 56644603Sdcs 56744603Sdcs: read_name 56844603Sdcs parse_name ( -- addr len ) 56944603Sdcs name_buffer .len ! 57044603Sdcs name_buffer .addr ! 57144603Sdcs; 57244603Sdcs 57344603Sdcs: read_value 57444603Sdcs quote? if 57544603Sdcs parse_quote ( -- addr len ) 57644603Sdcs else 57744603Sdcs parse_name ( -- addr len ) 57844603Sdcs then 57944603Sdcs value_buffer .len ! 58044603Sdcs value_buffer .addr ! 58144603Sdcs; 58244603Sdcs 58344603Sdcs: comment 58444603Sdcs skip_to_end_of_line 58544603Sdcs; 58644603Sdcs 58744603Sdcs: white_space_4 58844603Sdcs eat_space 58944603Sdcs comment? if ['] comment to parsing_function exit then 59044603Sdcs end_of_line? 0= if syntax_error throw then 59144603Sdcs; 59244603Sdcs 59344603Sdcs: variable_value 59444603Sdcs read_value 59544603Sdcs ['] white_space_4 to parsing_function 59644603Sdcs; 59744603Sdcs 59844603Sdcs: white_space_3 59944603Sdcs eat_space 60044603Sdcs letter? digit? quote? or or if 60144603Sdcs ['] variable_value to parsing_function exit 60244603Sdcs then 60344603Sdcs syntax_error throw 60444603Sdcs; 60544603Sdcs 60644603Sdcs: assignment_sign 60744603Sdcs skip_character 60844603Sdcs ['] white_space_3 to parsing_function 60944603Sdcs; 61044603Sdcs 61144603Sdcs: white_space_2 61244603Sdcs eat_space 61344603Sdcs assignment_sign? if ['] assignment_sign to parsing_function exit then 61444603Sdcs syntax_error throw 61544603Sdcs; 61644603Sdcs 61744603Sdcs: variable_name 61844603Sdcs read_name 61944603Sdcs ['] white_space_2 to parsing_function 62044603Sdcs; 62144603Sdcs 62244603Sdcs: white_space_1 62344603Sdcs eat_space 62444603Sdcs letter? if ['] variable_name to parsing_function exit then 62544603Sdcs comment? if ['] comment to parsing_function exit then 62644603Sdcs end_of_line? 0= if syntax_error throw then 62744603Sdcs; 62844603Sdcs 62965615Sdcsfile-processing definitions 63065615Sdcs 63144603Sdcs: get_assignment 63244603Sdcs line_buffer .addr @ line_buffer .len @ + to end_of_line 63344603Sdcs line_buffer .addr @ to line_pointer 63444603Sdcs ['] white_space_1 to parsing_function 63544603Sdcs begin 63644603Sdcs end_of_line? 0= 63744603Sdcs while 63844603Sdcs parsing_function execute 63944603Sdcs repeat 64044603Sdcs parsing_function ['] comment = 64144603Sdcs parsing_function ['] white_space_1 = 64244603Sdcs parsing_function ['] white_space_4 = 64344603Sdcs or or 0= if syntax_error throw then 64444603Sdcs; 64544603Sdcs 64665615Sdcsonly forth also support-functions also file-processing definitions also 64765615Sdcs 64844603Sdcs\ Process line 64944603Sdcs 65044603Sdcs: assignment_type? ( addr len -- flag ) 65144603Sdcs name_buffer .addr @ name_buffer .len @ 65244603Sdcs compare 0= 65344603Sdcs; 65444603Sdcs 65544603Sdcs: suffix_type? ( addr len -- flag ) 65644603Sdcs name_buffer .len @ over <= if 2drop false exit then 65744603Sdcs name_buffer .len @ over - name_buffer .addr @ + 65844603Sdcs over compare 0= 65944603Sdcs; 66044603Sdcs 66144603Sdcs: loader_conf_files? 66244603Sdcs s" loader_conf_files" assignment_type? 66344603Sdcs; 66444603Sdcs 66597201Sgordon: nextboot_flag? 66697201Sgordon s" nextboot_enable" assignment_type? 66797201Sgordon; 66897201Sgordon 66997201Sgordon: nextboot_conf? 67097201Sgordon s" nextboot_conf" assignment_type? 67197201Sgordon; 67297201Sgordon 67344603Sdcs: verbose_flag? 67444603Sdcs s" verbose_loading" assignment_type? 67544603Sdcs; 67644603Sdcs 67744603Sdcs: execute? 67844603Sdcs s" exec" assignment_type? 67944603Sdcs; 68044603Sdcs 68153672Sdcs: password? 68253672Sdcs s" password" assignment_type? 68353672Sdcs; 68453672Sdcs 68544603Sdcs: module_load? 68644603Sdcs load_module_suffix suffix_type? 68744603Sdcs; 68844603Sdcs 68944603Sdcs: module_loadname? 69044603Sdcs module_loadname_suffix suffix_type? 69144603Sdcs; 69244603Sdcs 69344603Sdcs: module_type? 69444603Sdcs module_type_suffix suffix_type? 69544603Sdcs; 69644603Sdcs 69744603Sdcs: module_args? 69844603Sdcs module_args_suffix suffix_type? 69944603Sdcs; 70044603Sdcs 70144603Sdcs: module_beforeload? 70244603Sdcs module_beforeload_suffix suffix_type? 70344603Sdcs; 70444603Sdcs 70544603Sdcs: module_afterload? 70644603Sdcs module_afterload_suffix suffix_type? 70744603Sdcs; 70844603Sdcs 70944603Sdcs: module_loaderror? 71044603Sdcs module_loaderror_suffix suffix_type? 71144603Sdcs; 71244603Sdcs 71344603Sdcs: set_conf_files 71444603Sdcs conf_files .addr @ ?dup if 71544603Sdcs free-memory 71644603Sdcs then 71744603Sdcs value_buffer .addr @ c@ [char] " = if 71844603Sdcs value_buffer .addr @ char+ value_buffer .len @ 2 chars - 71944603Sdcs else 72044603Sdcs value_buffer .addr @ value_buffer .len @ 72144603Sdcs then 72244603Sdcs strdup 72344603Sdcs conf_files .len ! conf_files .addr ! 72444603Sdcs; 72544603Sdcs 72697201Sgordon: set_nextboot_conf 72797201Sgordon nextboot_conf_file .addr @ ?dup if 72897201Sgordon free-memory 72997201Sgordon then 73097201Sgordon value_buffer .addr @ c@ [char] " = if 73197201Sgordon value_buffer .addr @ char+ value_buffer .len @ 2 chars - 73297201Sgordon else 73397201Sgordon value_buffer .addr @ value_buffer .len @ 73497201Sgordon then 73597201Sgordon strdup 73697201Sgordon nextboot_conf_file .len ! nextboot_conf_file .addr ! 73797201Sgordon; 73897201Sgordon 73944603Sdcs: append_to_module_options_list ( addr -- ) 74044603Sdcs module_options @ 0= if 74144603Sdcs dup module_options ! 74244603Sdcs last_module_option ! 74344603Sdcs else 74444603Sdcs dup last_module_option @ module.next ! 74544603Sdcs last_module_option ! 74644603Sdcs then 74744603Sdcs; 74844603Sdcs 74944603Sdcs: set_module_name ( addr -- ) 75044603Sdcs name_buffer .addr @ name_buffer .len @ 75144603Sdcs strdup 75244603Sdcs >r over module.name .addr ! 75344603Sdcs r> swap module.name .len ! 75444603Sdcs; 75544603Sdcs 75644603Sdcs: yes_value? 75744603Sdcs value_buffer .addr @ value_buffer .len @ 75844603Sdcs 2dup s' "YES"' compare >r 75944603Sdcs 2dup s' "yes"' compare >r 76044603Sdcs 2dup s" YES" compare >r 76144603Sdcs s" yes" compare r> r> r> and and and 0= 76244603Sdcs; 76344603Sdcs 76444603Sdcs: find_module_option ( -- addr | 0 ) 76544603Sdcs module_options @ 76644603Sdcs begin 76744603Sdcs dup 76844603Sdcs while 76944603Sdcs dup module.name dup .addr @ swap .len @ 77044603Sdcs name_buffer .addr @ name_buffer .len @ 77144603Sdcs compare 0= if exit then 77244603Sdcs module.next @ 77344603Sdcs repeat 77444603Sdcs; 77544603Sdcs 77644603Sdcs: new_module_option ( -- addr ) 77744603Sdcs sizeof module allocate if out_of_memory throw then 77844603Sdcs dup sizeof module erase 77944603Sdcs dup append_to_module_options_list 78044603Sdcs dup set_module_name 78144603Sdcs; 78244603Sdcs 78344603Sdcs: get_module_option ( -- addr ) 78444603Sdcs find_module_option 78544603Sdcs ?dup 0= if new_module_option then 78644603Sdcs; 78744603Sdcs 78844603Sdcs: set_module_flag 78944603Sdcs name_buffer .len @ load_module_suffix nip - name_buffer .len ! 79044603Sdcs yes_value? get_module_option module.flag ! 79144603Sdcs; 79244603Sdcs 79344603Sdcs: set_module_args 79444603Sdcs name_buffer .len @ module_args_suffix nip - name_buffer .len ! 79544603Sdcs get_module_option module.args 79644603Sdcs dup .addr @ ?dup if free-memory then 79744603Sdcs value_buffer .addr @ value_buffer .len @ 79844603Sdcs over c@ [char] " = if 79944603Sdcs 2 chars - swap char+ swap 80044603Sdcs then 80144603Sdcs strdup 80244603Sdcs >r over .addr ! 80344603Sdcs r> swap .len ! 80444603Sdcs; 80544603Sdcs 80644603Sdcs: set_module_loadname 80744603Sdcs name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 80844603Sdcs get_module_option module.loadname 80944603Sdcs dup .addr @ ?dup if free-memory then 81044603Sdcs value_buffer .addr @ value_buffer .len @ 81144603Sdcs over c@ [char] " = if 81244603Sdcs 2 chars - swap char+ swap 81344603Sdcs then 81444603Sdcs strdup 81544603Sdcs >r over .addr ! 81644603Sdcs r> swap .len ! 81744603Sdcs; 81844603Sdcs 81944603Sdcs: set_module_type 82044603Sdcs name_buffer .len @ module_type_suffix nip - name_buffer .len ! 82144603Sdcs get_module_option module.type 82244603Sdcs dup .addr @ ?dup if free-memory then 82344603Sdcs value_buffer .addr @ value_buffer .len @ 82444603Sdcs over c@ [char] " = if 82544603Sdcs 2 chars - swap char+ swap 82644603Sdcs then 82744603Sdcs strdup 82844603Sdcs >r over .addr ! 82944603Sdcs r> swap .len ! 83044603Sdcs; 83144603Sdcs 83244603Sdcs: set_module_beforeload 83344603Sdcs name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 83444603Sdcs get_module_option module.beforeload 83544603Sdcs dup .addr @ ?dup if free-memory then 83644603Sdcs value_buffer .addr @ value_buffer .len @ 83744603Sdcs over c@ [char] " = if 83844603Sdcs 2 chars - swap char+ swap 83944603Sdcs then 84044603Sdcs strdup 84144603Sdcs >r over .addr ! 84244603Sdcs r> swap .len ! 84344603Sdcs; 84444603Sdcs 84544603Sdcs: set_module_afterload 84644603Sdcs name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 84744603Sdcs get_module_option module.afterload 84844603Sdcs dup .addr @ ?dup if free-memory then 84944603Sdcs value_buffer .addr @ value_buffer .len @ 85044603Sdcs over c@ [char] " = if 85144603Sdcs 2 chars - swap char+ swap 85244603Sdcs then 85344603Sdcs strdup 85444603Sdcs >r over .addr ! 85544603Sdcs r> swap .len ! 85644603Sdcs; 85744603Sdcs 85844603Sdcs: set_module_loaderror 85944603Sdcs name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 86044603Sdcs get_module_option module.loaderror 86144603Sdcs dup .addr @ ?dup if free-memory then 86244603Sdcs value_buffer .addr @ value_buffer .len @ 86344603Sdcs over c@ [char] " = if 86444603Sdcs 2 chars - swap char+ swap 86544603Sdcs then 86644603Sdcs strdup 86744603Sdcs >r over .addr ! 86844603Sdcs r> swap .len ! 86944603Sdcs; 87044603Sdcs 87144603Sdcs: set_environment_variable 87244603Sdcs name_buffer .len @ 87344603Sdcs value_buffer .len @ + 87444603Sdcs 5 chars + 87544603Sdcs allocate if out_of_memory throw then 87644603Sdcs dup 0 ( addr -- addr addr len ) 87744603Sdcs s" set " strcat 87844603Sdcs name_buffer .addr @ name_buffer .len @ strcat 87944603Sdcs s" =" strcat 88044603Sdcs value_buffer .addr @ value_buffer .len @ strcat 88144603Sdcs ['] evaluate catch if 88244603Sdcs 2drop free drop 88344603Sdcs set_error throw 88444603Sdcs else 88544603Sdcs free-memory 88644603Sdcs then 88744603Sdcs; 88844603Sdcs 88997201Sgordon: set_nextboot_flag 89097201Sgordon yes_value? to nextboot? 89197201Sgordon; 89297201Sgordon 89344603Sdcs: set_verbose 89444603Sdcs yes_value? to verbose? 89544603Sdcs; 89644603Sdcs 89744603Sdcs: execute_command 89844603Sdcs value_buffer .addr @ value_buffer .len @ 89944603Sdcs over c@ [char] " = if 90053672Sdcs 2 - swap char+ swap 90144603Sdcs then 90244603Sdcs ['] evaluate catch if exec_error throw then 90344603Sdcs; 90444603Sdcs 90553672Sdcs: set_password 90653672Sdcs password .addr @ ?dup if free if free_error throw then then 90753672Sdcs value_buffer .addr @ c@ [char] " = if 90853672Sdcs value_buffer .addr @ char+ value_buffer .len @ 2 - strdup 90953672Sdcs value_buffer .addr @ free if free_error throw then 91053672Sdcs else 91153672Sdcs value_buffer .addr @ value_buffer .len @ 91253672Sdcs then 91353672Sdcs password .len ! password .addr ! 91453672Sdcs 0 value_buffer .addr ! 91553672Sdcs; 91653672Sdcs 91744603Sdcs: process_assignment 91844603Sdcs name_buffer .len @ 0= if exit then 91944603Sdcs loader_conf_files? if set_conf_files exit then 92097201Sgordon nextboot_flag? if set_nextboot_flag exit then 92197201Sgordon nextboot_conf? if set_nextboot_conf exit then 92244603Sdcs verbose_flag? if set_verbose exit then 92344603Sdcs execute? if execute_command exit then 92453672Sdcs password? if set_password exit then 92544603Sdcs module_load? if set_module_flag exit then 92644603Sdcs module_loadname? if set_module_loadname exit then 92744603Sdcs module_type? if set_module_type exit then 92844603Sdcs module_args? if set_module_args exit then 92944603Sdcs module_beforeload? if set_module_beforeload exit then 93044603Sdcs module_afterload? if set_module_afterload exit then 93144603Sdcs module_loaderror? if set_module_loaderror exit then 93244603Sdcs set_environment_variable 93344603Sdcs; 93444603Sdcs 93553672Sdcs\ free_buffer ( -- ) 93653672Sdcs\ 93753672Sdcs\ Free some pointers if needed. The code then tests for errors 93853672Sdcs\ in freeing, and throws an exception if needed. If a pointer is 93953672Sdcs\ not allocated, it's value (0) is used as flag. 94053672Sdcs 94144603Sdcs: free_buffers 94244603Sdcs name_buffer .addr @ dup if free then 94344603Sdcs value_buffer .addr @ dup if free then 94465615Sdcs or if free_error throw then 94544603Sdcs; 94644603Sdcs 94744603Sdcs: reset_assignment_buffers 94844603Sdcs 0 name_buffer .addr ! 94944603Sdcs 0 name_buffer .len ! 95044603Sdcs 0 value_buffer .addr ! 95144603Sdcs 0 value_buffer .len ! 95244603Sdcs; 95344603Sdcs 95444603Sdcs\ Higher level file processing 95544603Sdcs 95665615Sdcssupport-functions definitions 95765615Sdcs 95844603Sdcs: process_conf 95944603Sdcs begin 96044603Sdcs end_of_file? 0= 96144603Sdcs while 96244603Sdcs reset_assignment_buffers 96344603Sdcs read_line 96444603Sdcs get_assignment 96544603Sdcs ['] process_assignment catch 96644603Sdcs ['] free_buffers catch 96744603Sdcs swap throw throw 96844603Sdcs repeat 96944603Sdcs; 97044603Sdcs 97197201Sgordon: peek_file 97297201Sgordon 0 to end_of_file? 97397201Sgordon reset_line_reading 97497201Sgordon O_RDONLY fopen fd ! 97597201Sgordon fd @ -1 = if open_error throw then 97697201Sgordon reset_assignment_buffers 97797201Sgordon read_line 97897201Sgordon get_assignment 97997201Sgordon ['] process_assignment catch 98097201Sgordon ['] free_buffers catch 98197201Sgordon fd @ fclose 98297201Sgordon; 98397201Sgordon 98465615Sdcsonly forth also support-functions definitions 98565615Sdcs 98644603Sdcs\ Interface to loading conf files 98744603Sdcs 98844603Sdcs: load_conf ( addr len -- ) 98944603Sdcs 0 to end_of_file? 99065615Sdcs reset_line_reading 99187636Sjhb O_RDONLY fopen fd ! 99244603Sdcs fd @ -1 = if open_error throw then 99344603Sdcs ['] process_conf catch 99444603Sdcs fd @ fclose 99544603Sdcs throw 99644603Sdcs; 99744603Sdcs 99844603Sdcs: print_line 99944603Sdcs line_buffer .addr @ line_buffer .len @ type cr 100044603Sdcs; 100144603Sdcs 100244603Sdcs: print_syntax_error 100344603Sdcs line_buffer .addr @ line_buffer .len @ type cr 100444603Sdcs line_buffer .addr @ 100544603Sdcs begin 100644603Sdcs line_pointer over <> 100744603Sdcs while 100844603Sdcs bl emit 100944603Sdcs char+ 101044603Sdcs repeat 101144603Sdcs drop 101244603Sdcs ." ^" cr 101344603Sdcs; 101444603Sdcs 101544603Sdcs\ Depuration support functions 101644603Sdcs 101744603Sdcsonly forth definitions also support-functions 101844603Sdcs 101944603Sdcs: test-file 102044603Sdcs ['] load_conf catch dup . 102144603Sdcs syntax_error = if cr print_syntax_error then 102244603Sdcs; 102344603Sdcs 102444603Sdcs: show-module-options 102544603Sdcs module_options @ 102644603Sdcs begin 102744603Sdcs ?dup 102844603Sdcs while 102944603Sdcs ." Name: " dup module.name dup .addr @ swap .len @ type cr 103044603Sdcs ." Path: " dup module.loadname dup .addr @ swap .len @ type cr 103144603Sdcs ." Type: " dup module.type dup .addr @ swap .len @ type cr 103244603Sdcs ." Flags: " dup module.args dup .addr @ swap .len @ type cr 103344603Sdcs ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr 103444603Sdcs ." After load: " dup module.afterload dup .addr @ swap .len @ type cr 103544603Sdcs ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr 103644603Sdcs ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr 103744603Sdcs module.next @ 103844603Sdcs repeat 103944603Sdcs; 104044603Sdcs 104144603Sdcsonly forth also support-functions definitions 104244603Sdcs 104344603Sdcs\ Variables used for processing multiple conf files 104444603Sdcs 104544603Sdcsstring current_file_name 104644603Sdcsvariable current_conf_files 104744603Sdcs 104844603Sdcs\ Indicates if any conf file was succesfully read 104944603Sdcs 105044603Sdcs0 value any_conf_read? 105144603Sdcs 105244603Sdcs\ loader_conf_files processing support functions 105344603Sdcs 105444603Sdcs: set_current_conf_files 105544603Sdcs conf_files .addr @ current_conf_files ! 105644603Sdcs; 105744603Sdcs 105844603Sdcs: get_conf_files 105944603Sdcs conf_files .addr @ conf_files .len @ strdup 106044603Sdcs; 106144603Sdcs 106244603Sdcs: recurse_on_conf_files? 106344603Sdcs current_conf_files @ conf_files .addr @ <> 106444603Sdcs; 106544603Sdcs 106653672Sdcs: skip_leading_spaces { addr len pos -- addr len pos' } 106744603Sdcs begin 106853672Sdcs pos len = if addr len pos exit then 106953672Sdcs addr pos + c@ bl = 107044603Sdcs while 107153672Sdcs pos char+ to pos 107244603Sdcs repeat 107353672Sdcs addr len pos 107444603Sdcs; 107544603Sdcs 107653672Sdcs: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 107753672Sdcs pos len = if 107844603Sdcs addr free abort" Fatal error freeing memory" 107944603Sdcs 0 exit 108044603Sdcs then 108153672Sdcs pos >r 108244603Sdcs begin 108353672Sdcs addr pos + c@ bl <> 108444603Sdcs while 108553672Sdcs pos char+ to pos 108653672Sdcs pos len = if 108753672Sdcs addr len pos addr r@ + pos r> - exit 108844603Sdcs then 108944603Sdcs repeat 109053672Sdcs addr len pos addr r@ + pos r> - 109144603Sdcs; 109244603Sdcs 109344603Sdcs: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 109444603Sdcs skip_leading_spaces 109544603Sdcs get_file_name 109644603Sdcs; 109744603Sdcs 109844603Sdcs: set_current_file_name 109944603Sdcs over current_file_name .addr ! 110044603Sdcs dup current_file_name .len ! 110144603Sdcs; 110244603Sdcs 110344603Sdcs: print_current_file 110444603Sdcs current_file_name .addr @ current_file_name .len @ type 110544603Sdcs; 110644603Sdcs 110744603Sdcs: process_conf_errors 110844603Sdcs dup 0= if true to any_conf_read? drop exit then 110944603Sdcs >r 2drop r> 111044603Sdcs dup syntax_error = if 111144603Sdcs ." Warning: syntax error on file " print_current_file cr 111244603Sdcs print_syntax_error drop exit 111344603Sdcs then 111444603Sdcs dup set_error = if 111544603Sdcs ." Warning: bad definition on file " print_current_file cr 111644603Sdcs print_line drop exit 111744603Sdcs then 111844603Sdcs dup read_error = if 111944603Sdcs ." Warning: error reading file " print_current_file cr drop exit 112044603Sdcs then 112144603Sdcs dup open_error = if 112244603Sdcs verbose? if ." Warning: unable to open file " print_current_file cr then 112344603Sdcs drop exit 112444603Sdcs then 112544603Sdcs dup free_error = abort" Fatal error freeing memory" 112644603Sdcs dup out_of_memory = abort" Out of memory" 112744603Sdcs throw \ Unknown error -- pass ahead 112844603Sdcs; 112944603Sdcs 113044603Sdcs\ Process loader_conf_files recursively 113144603Sdcs\ Interface to loader_conf_files processing 113244603Sdcs 113344603Sdcs: include_conf_files 113444603Sdcs set_current_conf_files 113544603Sdcs get_conf_files 0 113644603Sdcs begin 113744603Sdcs get_next_file ?dup 113844603Sdcs while 113944603Sdcs set_current_file_name 114044603Sdcs ['] load_conf catch 114144603Sdcs process_conf_errors 114244603Sdcs recurse_on_conf_files? if recurse then 114344603Sdcs repeat 114444603Sdcs; 114544603Sdcs 114697201Sgordon: get_nextboot_conf_file ( -- addr len ) 114797201Sgordon nextboot_conf_file .addr @ nextboot_conf_file .len @ strdup 114897201Sgordon; 114997201Sgordon 115097201Sgordon: rewrite_nextboot_file ( -- ) 115197201Sgordon get_nextboot_conf_file 115297201Sgordon O_WRONLY fopen fd ! 115397201Sgordon fd @ -1 = if open_error throw then 115497201Sgordon fd @ s' nextboot_enable="NO" ' fwrite 115597201Sgordon fd @ fclose 115697201Sgordon; 115797201Sgordon 115897201Sgordon: include_nextboot_file 115997201Sgordon get_nextboot_conf_file 116097201Sgordon ['] peek_file catch 116197201Sgordon nextboot? if 116297201Sgordon get_nextboot_conf_file 116397201Sgordon ['] load_conf catch 116497201Sgordon process_conf_errors 116597201Sgordon ['] rewrite_nextboot_file catch 116697201Sgordon then 116797201Sgordon; 116897201Sgordon 116944603Sdcs\ Module loading functions 117044603Sdcs 117144603Sdcs: load_module? 117244603Sdcs module.flag @ 117344603Sdcs; 117444603Sdcs 117544603Sdcs: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N ) 117644603Sdcs dup >r 117744603Sdcs r@ module.args .addr @ r@ module.args .len @ 117844603Sdcs r@ module.loadname .len @ if 117944603Sdcs r@ module.loadname .addr @ r@ module.loadname .len @ 118044603Sdcs else 118144603Sdcs r@ module.name .addr @ r@ module.name .len @ 118244603Sdcs then 118344603Sdcs r@ module.type .len @ if 118444603Sdcs r@ module.type .addr @ r@ module.type .len @ 118544603Sdcs s" -t " 118644603Sdcs 4 ( -t type name flags ) 118744603Sdcs else 118844603Sdcs 2 ( name flags ) 118944603Sdcs then 119044603Sdcs r> drop 119144603Sdcs; 119244603Sdcs 119344603Sdcs: before_load ( addr -- addr ) 119444603Sdcs dup module.beforeload .len @ if 119544603Sdcs dup module.beforeload .addr @ over module.beforeload .len @ 119644603Sdcs ['] evaluate catch if before_load_error throw then 119744603Sdcs then 119844603Sdcs; 119944603Sdcs 120044603Sdcs: after_load ( addr -- addr ) 120144603Sdcs dup module.afterload .len @ if 120244603Sdcs dup module.afterload .addr @ over module.afterload .len @ 120344603Sdcs ['] evaluate catch if after_load_error throw then 120444603Sdcs then 120544603Sdcs; 120644603Sdcs 120744603Sdcs: load_error ( addr -- addr ) 120844603Sdcs dup module.loaderror .len @ if 120944603Sdcs dup module.loaderror .addr @ over module.loaderror .len @ 121044603Sdcs evaluate \ This we do not intercept so it can throw errors 121144603Sdcs then 121244603Sdcs; 121344603Sdcs 121444603Sdcs: pre_load_message ( addr -- addr ) 121544603Sdcs verbose? if 121644603Sdcs dup module.name .addr @ over module.name .len @ type 121744603Sdcs ." ..." 121844603Sdcs then 121944603Sdcs; 122044603Sdcs 122144603Sdcs: load_error_message verbose? if ." failed!" cr then ; 122244603Sdcs 122344603Sdcs: load_succesful_message verbose? if ." ok" cr then ; 122444603Sdcs 122544603Sdcs: load_module 122644603Sdcs load_parameters load 122744603Sdcs; 122844603Sdcs 122944603Sdcs: process_module ( addr -- addr ) 123044603Sdcs pre_load_message 123144603Sdcs before_load 123244603Sdcs begin 123344603Sdcs ['] load_module catch if 123444603Sdcs dup module.loaderror .len @ if 123544603Sdcs load_error \ Command should return a flag! 123644603Sdcs else 123744603Sdcs load_error_message true \ Do not retry 123844603Sdcs then 123944603Sdcs else 124044603Sdcs after_load 124144603Sdcs load_succesful_message true \ Succesful, do not retry 124244603Sdcs then 124344603Sdcs until 124444603Sdcs; 124544603Sdcs 124644603Sdcs: process_module_errors ( addr ior -- ) 124744603Sdcs dup before_load_error = if 124844603Sdcs drop 124944603Sdcs ." Module " 125044603Sdcs dup module.name .addr @ over module.name .len @ type 125144603Sdcs dup module.loadname .len @ if 125244603Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 125344603Sdcs then 125444603Sdcs cr 125544603Sdcs ." Error executing " 125644603Sdcs dup module.beforeload .addr @ over module.afterload .len @ type cr 125744603Sdcs abort 125844603Sdcs then 125944603Sdcs 126044603Sdcs dup after_load_error = if 126144603Sdcs drop 126244603Sdcs ." Module " 126344603Sdcs dup module.name .addr @ over module.name .len @ type 126444603Sdcs dup module.loadname .len @ if 126544603Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 126644603Sdcs then 126744603Sdcs cr 126844603Sdcs ." Error executing " 126944603Sdcs dup module.afterload .addr @ over module.afterload .len @ type cr 127044603Sdcs abort 127144603Sdcs then 127244603Sdcs 127344603Sdcs throw \ Don't know what it is all about -- pass ahead 127444603Sdcs; 127544603Sdcs 127644603Sdcs\ Module loading interface 127744603Sdcs 127844603Sdcs: load_modules ( -- ) ( throws: abort & user-defined ) 127944603Sdcs module_options @ 128044603Sdcs begin 128144603Sdcs ?dup 128244603Sdcs while 128344603Sdcs dup load_module? if 128444603Sdcs ['] process_module catch 128544603Sdcs process_module_errors 128644603Sdcs then 128744603Sdcs module.next @ 128844603Sdcs repeat 128944603Sdcs; 129044603Sdcs 129165630Sdcs\ h00h00 magic used to try loading either a kernel with a given name, 129265630Sdcs\ or a kernel with the default name in a directory of a given name 129365630Sdcs\ (the pain!) 129444603Sdcs 129565630Sdcs: bootpath s" /boot/" ; 129665630Sdcs: modulepath s" module_path" ; 129765630Sdcs 129865630Sdcs\ Functions used to save and restore module_path's value. 129965630Sdcs: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 130065630Sdcs dup -1 = if 0 swap exit then 130165630Sdcs strdup 130265630Sdcs; 130365630Sdcs: freeenv ( addr len | 0 -1 ) 130465630Sdcs -1 = if drop else free abort" Freeing error" then 130565630Sdcs; 130665630Sdcs: restoreenv ( addr len | 0 -1 -- ) 130765630Sdcs dup -1 = if ( it wasn't set ) 130865630Sdcs 2drop 130965630Sdcs modulepath unsetenv 131065630Sdcs else 131165630Sdcs over >r 131265630Sdcs modulepath setenv 131365630Sdcs r> free abort" Freeing error" 131465630Sdcs then 131565630Sdcs; 131665630Sdcs 131765630Sdcs: clip_args \ Drop second string if only one argument is passed 131865630Sdcs 1 = if 131965630Sdcs 2swap 2drop 132065630Sdcs 1 132165630Sdcs else 132265630Sdcs 2 132365630Sdcs then 132465630Sdcs; 132565630Sdcs 132665630Sdcsalso builtins 132765630Sdcs 132865630Sdcs\ Parse filename from a comma-separated list 132965630Sdcs 133065630Sdcs: parse-; ( addr len -- addr' len-x addr x ) 133165630Sdcs over 0 2swap 133265630Sdcs begin 133365630Sdcs dup 0 <> 133465630Sdcs while 133565630Sdcs over c@ [char] ; <> 133665630Sdcs while 133765630Sdcs 1- swap 1+ swap 133865630Sdcs 2swap 1+ 2swap 133965630Sdcs repeat then 134065630Sdcs dup 0 <> if 134165630Sdcs 1- swap 1+ swap 134265630Sdcs then 134365630Sdcs 2swap 134465630Sdcs; 134565630Sdcs 134665630Sdcs\ Try loading one of multiple kernels specified 134765630Sdcs 134865630Sdcs: try_multiple_kernels ( addr len addr' len' args -- flag ) 134965630Sdcs >r 135065630Sdcs begin 135165630Sdcs parse-; 2>r 135265630Sdcs 2over 2r> 135365945Sdcs r@ clip_args 135465945Sdcs s" DEBUG" getenv? if 135565945Sdcs s" echo Module_path: ${module_path}" evaluate 135665945Sdcs ." Kernel : " >r 2dup type r> cr 135765945Sdcs dup 2 = if ." Flags : " >r 2over type r> cr then 135865945Sdcs then 135965945Sdcs 1 load 136065630Sdcs while 136165630Sdcs dup 0= 136265630Sdcs until 136365630Sdcs 1 >r \ Failure 136465630Sdcs else 136565630Sdcs 0 >r \ Success 136665630Sdcs then 136765630Sdcs 2drop 2drop 136865630Sdcs r> 136965630Sdcs r> drop 137065630Sdcs; 137165630Sdcs 137265630Sdcs\ Try to load a kernel; the kernel name is taken from one of 137365630Sdcs\ the following lists, as ordered: 137465630Sdcs\ 137565641Sdcs\ 1. The "bootfile" environment variable 137665641Sdcs\ 2. The "kernel" environment variable 137765630Sdcs\ 137865938Sdcs\ Flags are passed, if available. If not, dummy values must be given. 137965630Sdcs\ 138065630Sdcs\ The kernel gets loaded from the current module_path. 138165630Sdcs 138265938Sdcs: load_a_kernel ( flags len 1 | x x 0 -- flag ) 138365630Sdcs local args 138465630Sdcs 2local flags 138565630Sdcs 0 0 2local kernel 138665630Sdcs end-locals 138765630Sdcs 138865630Sdcs \ Check if a default kernel name exists at all, exits if not 138965641Sdcs s" bootfile" getenv dup -1 <> if 139065630Sdcs to kernel 139165883Sdcs flags kernel args 1+ try_multiple_kernels 139265630Sdcs dup 0= if exit then 139365630Sdcs then 139465630Sdcs drop 139565630Sdcs 139665641Sdcs s" kernel" getenv dup -1 <> if 139765630Sdcs to kernel 139865630Sdcs else 139965630Sdcs drop 140065630Sdcs 1 exit \ Failure 140165630Sdcs then 140265630Sdcs 140365630Sdcs \ Try all default kernel names 140465883Sdcs flags kernel args 1+ try_multiple_kernels 140565630Sdcs; 140665630Sdcs 140765630Sdcs\ Try to load a kernel; the kernel name is taken from one of 140865630Sdcs\ the following lists, as ordered: 140965630Sdcs\ 141065641Sdcs\ 1. The "bootfile" environment variable 141165641Sdcs\ 2. The "kernel" environment variable 141265630Sdcs\ 141365630Sdcs\ Flags are passed, if provided. 141465630Sdcs\ 141565630Sdcs\ The kernel will be loaded from a directory computed from the 141665630Sdcs\ path given. Two directories will be tried in the following order: 141765630Sdcs\ 141865630Sdcs\ 1. /boot/path 141965630Sdcs\ 2. path 142065630Sdcs\ 142165630Sdcs\ The module_path variable is overridden if load is succesful, by 142265630Sdcs\ prepending the successful path. 142365630Sdcs 142465630Sdcs: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 142565630Sdcs local args 142665630Sdcs 2local path 142765630Sdcs args 1 = if 0 0 then 142865630Sdcs 2local flags 142965630Sdcs 0 0 2local oldmodulepath 143065630Sdcs 0 0 2local newmodulepath 143165630Sdcs end-locals 143265630Sdcs 143365630Sdcs \ Set the environment variable module_path, and try loading 143465630Sdcs \ the kernel again. 143565630Sdcs modulepath getenv saveenv to oldmodulepath 143665630Sdcs 143765630Sdcs \ Try prepending /boot/ first 143865630Sdcs bootpath nip path nip + 143965630Sdcs oldmodulepath nip dup -1 = if 144065630Sdcs drop 144165630Sdcs else 144265630Sdcs 1+ + 144365630Sdcs then 144465630Sdcs allocate 144565630Sdcs if ( out of memory ) 144665630Sdcs 1 exit 144765630Sdcs then 144865630Sdcs 144965630Sdcs 0 145065630Sdcs bootpath strcat 145165630Sdcs path strcat 145265630Sdcs 2dup to newmodulepath 145365630Sdcs modulepath setenv 145465630Sdcs 145565630Sdcs \ Try all default kernel names 145665938Sdcs flags args 1- load_a_kernel 145765630Sdcs 0= if ( success ) 145865630Sdcs oldmodulepath nip -1 <> if 145965630Sdcs newmodulepath s" ;" strcat 146065630Sdcs oldmodulepath strcat 146165630Sdcs modulepath setenv 146265630Sdcs newmodulepath drop free-memory 146365630Sdcs oldmodulepath drop free-memory 146465630Sdcs then 146565630Sdcs 0 exit 146665630Sdcs then 146765630Sdcs 146865630Sdcs \ Well, try without the prepended /boot/ 146965630Sdcs path newmodulepath drop swap move 147065883Sdcs newmodulepath drop path nip 147165630Sdcs 2dup to newmodulepath 147265630Sdcs modulepath setenv 147365630Sdcs 147465630Sdcs \ Try all default kernel names 147565938Sdcs flags args 1- load_a_kernel 147665630Sdcs if ( failed once more ) 147765630Sdcs oldmodulepath restoreenv 147865630Sdcs newmodulepath drop free-memory 147965630Sdcs 1 148065630Sdcs else 148165630Sdcs oldmodulepath nip -1 <> if 148265630Sdcs newmodulepath s" ;" strcat 148365630Sdcs oldmodulepath strcat 148465630Sdcs modulepath setenv 148565630Sdcs newmodulepath drop free-memory 148665630Sdcs oldmodulepath drop free-memory 148765630Sdcs then 148865630Sdcs 0 148965630Sdcs then 149065630Sdcs; 149165630Sdcs 149265630Sdcs\ Try to load a kernel; the kernel name is taken from one of 149365630Sdcs\ the following lists, as ordered: 149465630Sdcs\ 149565641Sdcs\ 1. The "bootfile" environment variable 149665641Sdcs\ 2. The "kernel" environment variable 149765630Sdcs\ 3. The "path" argument 149865630Sdcs\ 149965630Sdcs\ Flags are passed, if provided. 150065630Sdcs\ 150165630Sdcs\ The kernel will be loaded from a directory computed from the 150265630Sdcs\ path given. Two directories will be tried in the following order: 150365630Sdcs\ 150465630Sdcs\ 1. /boot/path 150565630Sdcs\ 2. path 150665630Sdcs\ 150765630Sdcs\ Unless "path" is meant to be kernel name itself. In that case, it 150865630Sdcs\ will first be tried as a full path, and, next, search on the 150965630Sdcs\ directories pointed by module_path. 151065630Sdcs\ 151165630Sdcs\ The module_path variable is overridden if load is succesful, by 151265630Sdcs\ prepending the successful path. 151365630Sdcs 151465630Sdcs: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 151565630Sdcs local args 151665630Sdcs 2local path 151765630Sdcs args 1 = if 0 0 then 151865630Sdcs 2local flags 151965630Sdcs end-locals 152065630Sdcs 152165630Sdcs \ First, assume path is an absolute path to a directory 152265630Sdcs flags path args clip_args load_from_directory 152365630Sdcs dup 0= if exit else drop then 152465630Sdcs 152565630Sdcs \ Next, assume path points to the kernel 152665630Sdcs flags path args try_multiple_kernels 152765630Sdcs; 152865630Sdcs 152944603Sdcs: initialize ( addr len -- ) 153044603Sdcs strdup conf_files .len ! conf_files .addr ! 153144603Sdcs; 153244603Sdcs 153365883Sdcs: kernel_options ( -- addr len 1 | 0 ) 153465630Sdcs s" kernel_options" getenv 153565883Sdcs dup -1 = if drop 0 else 1 then 153665630Sdcs; 153765630Sdcs 153865938Sdcs: standard_kernel_search ( flags 1 | 0 -- flag ) 153965938Sdcs local args 154065938Sdcs args 0= if 0 0 then 154165938Sdcs 2local flags 154265630Sdcs s" kernel" getenv 154365938Sdcs dup -1 = if 0 swap then 154465938Sdcs 2local path 154565938Sdcs end-locals 154665938Sdcs 154766349Sdcs path nip -1 = if ( there isn't a "kernel" environment variable ) 154865938Sdcs flags args load_a_kernel 154965938Sdcs else 155065938Sdcs flags path args 1+ clip_args load_directory_or_file 155165938Sdcs then 155265630Sdcs; 155365630Sdcs 155444603Sdcs: load_kernel ( -- ) ( throws: abort ) 155565938Sdcs kernel_options standard_kernel_search 155665630Sdcs abort" Unable to load a kernel!" 155744603Sdcs; 155865883Sdcs 155965949Sdcs: set_defaultoptions ( -- ) 156065883Sdcs s" kernel_options" getenv dup -1 = if 156165883Sdcs drop 156265883Sdcs else 156365883Sdcs s" temp_options" setenv 156465883Sdcs then 156565883Sdcs; 156665883Sdcs 156765883Sdcs: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 156865883Sdcs 2dup = if 0 0 exit then 156965883Sdcs dup >r 157065883Sdcs 1+ 2* ( skip N and ui ) 157165883Sdcs pick 157265883Sdcs r> 157365883Sdcs 1+ 2* ( skip N and ai ) 157465883Sdcs pick 157565883Sdcs; 157665883Sdcs 157765949Sdcs: drop_args ( aN uN ... a1 u1 N -- ) 157865883Sdcs 0 ?do 2drop loop 157965883Sdcs; 158065883Sdcs 158165883Sdcs: argc 158265883Sdcs dup 158365883Sdcs; 158465883Sdcs 158565949Sdcs: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 158665883Sdcs >r 158765883Sdcs over 2* 1+ -roll 158865883Sdcs r> 158965883Sdcs over 2* 1+ -roll 159065883Sdcs 1+ 159165883Sdcs; 159265883Sdcs 159365949Sdcs: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 159465883Sdcs 1- -rot 159565883Sdcs; 159665883Sdcs 159765883Sdcs: strlen(argv) 159865883Sdcs dup 0= if 0 exit then 159965883Sdcs 0 >r \ Size 160065883Sdcs 0 >r \ Index 160165883Sdcs begin 160265883Sdcs argc r@ <> 160365883Sdcs while 160465883Sdcs r@ argv[] 160565883Sdcs nip 160665883Sdcs r> r> rot + 1+ 160765883Sdcs >r 1+ >r 160865883Sdcs repeat 160965883Sdcs r> drop 161065883Sdcs r> 161165883Sdcs; 161265883Sdcs 161365949Sdcs: concat_argv ( aN uN ... a1 u1 N -- a u ) 161465883Sdcs strlen(argv) allocate if out_of_memory throw then 161565883Sdcs 0 2>r 161665883Sdcs 161765883Sdcs begin 161865883Sdcs argc 161965883Sdcs while 162065949Sdcs unqueue_argv 162165883Sdcs 2r> 2swap 162265883Sdcs strcat 162365883Sdcs s" " strcat 162465883Sdcs 2>r 162565883Sdcs repeat 162665949Sdcs drop_args 162765883Sdcs 2r> 162865883Sdcs; 162965883Sdcs 163065949Sdcs: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 163165883Sdcs \ Save the first argument, if it exists and is not a flag 163265883Sdcs argc if 163365883Sdcs 0 argv[] drop c@ [char] - <> if 163465949Sdcs unqueue_argv 2>r \ Filename 163565883Sdcs 1 >r \ Filename present 163665883Sdcs else 163765883Sdcs 0 >r \ Filename not present 163865883Sdcs then 163965883Sdcs else 164065883Sdcs 0 >r \ Filename not present 164165883Sdcs then 164265883Sdcs 164365883Sdcs \ If there are other arguments, assume they are flags 164465883Sdcs ?dup if 164565949Sdcs concat_argv 164665883Sdcs 2dup s" temp_options" setenv 164765883Sdcs drop free if free_error throw then 164865883Sdcs else 164965949Sdcs set_defaultoptions 165065883Sdcs then 165165883Sdcs 165265883Sdcs \ Bring back the filename, if one was provided 165365883Sdcs r> if 2r> 1 else 0 then 165465883Sdcs; 165565883Sdcs 165665949Sdcs: get_arguments ( -- addrN lenN ... addr1 len1 N ) 165765883Sdcs 0 165865883Sdcs begin 165965883Sdcs \ Get next word on the command line 166065883Sdcs parse-word 166165883Sdcs ?dup while 166265949Sdcs queue_argv 166365883Sdcs repeat 166465883Sdcs drop ( empty string ) 166565883Sdcs; 166665883Sdcs 166765945Sdcs: load_kernel_and_modules ( args -- flag ) 166865949Sdcs set_tempoptions 166965883Sdcs argc >r 167065883Sdcs s" temp_options" getenv dup -1 <> if 167165949Sdcs queue_argv 167265883Sdcs else 167365883Sdcs drop 167465883Sdcs then 167565883Sdcs r> if ( a path was passed ) 167665938Sdcs load_directory_or_file 167765883Sdcs else 167865938Sdcs standard_kernel_search 167965883Sdcs then 168065938Sdcs ?dup 0= if ['] load_modules catch then 168165883Sdcs; 168265883Sdcs 168353672Sdcs: read-password { size | buf len -- } 168453672Sdcs size allocate if out_of_memory throw then 168553672Sdcs to buf 168653672Sdcs 0 to len 168753672Sdcs begin 168853672Sdcs key 168953672Sdcs dup backspace = if 169053672Sdcs drop 169153672Sdcs len if 169253672Sdcs backspace emit bl emit backspace emit 169353672Sdcs len 1 - to len 169453672Sdcs else 169553672Sdcs bell emit 169653672Sdcs then 169753672Sdcs else 169853672Sdcs dup <cr> = if cr drop buf len exit then 169953672Sdcs [char] * emit 170053672Sdcs len size < if 170153672Sdcs buf len chars + c! 170253672Sdcs else 170353672Sdcs drop 170453672Sdcs then 170553672Sdcs len 1+ to len 170653672Sdcs then 170753672Sdcs again 170853672Sdcs; 170953672Sdcs 171044603Sdcs\ Go back to straight forth vocabulary 171144603Sdcs 171244603Sdcsonly forth also definitions 171344603Sdcs 1714