support.4th revision 65630
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 65630 2000-09-09 04:52:34Z dcs $ 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 8344603Sdcs\ Crude structure support 8444603Sdcs 8565615Sdcs: structure: 8665615Sdcs create here 0 , ['] drop , 0 8765615Sdcs does> create here swap dup @ allot cell+ @ execute 8865615Sdcs; 8944603Sdcs: member: create dup , over , + does> cell+ @ + ; 9044603Sdcs: ;structure swap ! ; 9165615Sdcs: constructor! >body cell+ ! ; 9265615Sdcs: constructor: over :noname ; 9365615Sdcs: ;constructor postpone ; swap cell+ ! ; immediate 9444603Sdcs: sizeof ' >body @ state @ if postpone literal then ; immediate 9544603Sdcs: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate 9644603Sdcs: ptr 1 cells member: ; 9744603Sdcs: int 1 cells member: ; 9844603Sdcs 9944603Sdcs\ String structure 10044603Sdcs 10144603Sdcsstructure: string 10244603Sdcs ptr .addr 10344603Sdcs int .len 10465615Sdcs constructor: 10565615Sdcs 0 over .addr ! 10665615Sdcs 0 swap .len ! 10765615Sdcs ;constructor 10844603Sdcs;structure 10944603Sdcs 11065615Sdcs 11144603Sdcs\ Module options linked list 11244603Sdcs 11344603Sdcsstructure: module 11444603Sdcs int module.flag 11544603Sdcs sizeof string member: module.name 11644603Sdcs sizeof string member: module.loadname 11744603Sdcs sizeof string member: module.type 11844603Sdcs sizeof string member: module.args 11944603Sdcs sizeof string member: module.beforeload 12044603Sdcs sizeof string member: module.afterload 12144603Sdcs sizeof string member: module.loaderror 12244603Sdcs ptr module.next 12344603Sdcs;structure 12444603Sdcs 12565615Sdcs\ Internal loader structures 12665615Sdcsstructure: preloaded_file 12765615Sdcs ptr pf.name 12865615Sdcs ptr pf.type 12965615Sdcs ptr pf.args 13065615Sdcs ptr pf.metadata \ file_metadata 13165615Sdcs int pf.loader 13265615Sdcs int pf.addr 13365615Sdcs int pf.size 13465615Sdcs ptr pf.modules \ kernel_module 13565615Sdcs ptr pf.next \ preloaded_file 13665615Sdcs;structure 13765615Sdcs 13865615Sdcsstructure: kernel_module 13965615Sdcs ptr km.name 14065615Sdcs \ ptr km.args 14165615Sdcs ptr km.fp \ preloaded_file 14265615Sdcs ptr km.next \ kernel_module 14365615Sdcs;structure 14465615Sdcs 14565615Sdcsstructure: file_metadata 14665615Sdcs int md.size 14765615Sdcs 2 member: md.type \ this is not ANS Forth compatible (XXX) 14865615Sdcs ptr md.next \ file_metadata 14965615Sdcs 0 member: md.data \ variable size 15065615Sdcs;structure 15165615Sdcs 15265615Sdcsstructure: config_resource 15365615Sdcs ptr cf.name 15465615Sdcs int cf.type 15565615Sdcs0 constant RES_INT 15665615Sdcs1 constant RES_STRING 15765615Sdcs2 constant RES_LONG 15865615Sdcs 2 cells member: u 15965615Sdcs;structure 16065615Sdcs 16165615Sdcsstructure: config_device 16265615Sdcs ptr cd.name 16365615Sdcs int cd.unit 16465615Sdcs int cd.resource_count 16565615Sdcs ptr cd.resources \ config_resource 16665615Sdcs;structure 16765615Sdcs 16865615Sdcsstructure: STAILQ_HEAD 16965615Sdcs ptr stqh_first \ type* 17065615Sdcs ptr stqh_last \ type** 17165615Sdcs;structure 17265615Sdcs 17365615Sdcsstructure: STAILQ_ENTRY 17465615Sdcs ptr stqe_next \ type* 17565615Sdcs;structure 17665615Sdcs 17765615Sdcsstructure: pnphandler 17865615Sdcs ptr pnph.name 17965615Sdcs ptr pnph.enumerate 18065615Sdcs;structure 18165615Sdcs 18265615Sdcsstructure: pnpident 18365615Sdcs ptr pnpid.ident \ char* 18465615Sdcs sizeof STAILQ_ENTRY cells member: pnpid.link \ pnpident 18565615Sdcs;structure 18665615Sdcs 18765615Sdcsstructure: pnpinfo 18865615Sdcs ptr pnpi.desc 18965615Sdcs int pnpi.revision 19065615Sdcs ptr pnpi.module \ (char*) module args 19165615Sdcs int pnpi.argc 19265615Sdcs ptr pnpi.argv 19365615Sdcs ptr pnpi.handler \ pnphandler 19465615Sdcs sizeof STAILQ_HEAD member: pnpi.ident \ pnpident 19565615Sdcs sizeof STAILQ_ENTRY member: pnpi.link \ pnpinfo 19665615Sdcs;structure 19765615Sdcs 19844603Sdcs\ Global variables 19944603Sdcs 20044603Sdcsstring conf_files 20153672Sdcsstring password 20265615Sdcscreate module_options sizeof module.next allot 0 module_options ! 20365615Sdcscreate last_module_option sizeof module.next allot 0 last_module_option ! 20444603Sdcs0 value verbose? 20544603Sdcs 20644603Sdcs\ Support string functions 20744603Sdcs 20844603Sdcs: strdup ( addr len -- addr' len ) 20944603Sdcs >r r@ allocate if out_of_memory throw then 21044603Sdcs tuck r@ move 21144603Sdcs r> 21244603Sdcs; 21344603Sdcs 21444603Sdcs: strcat { addr len addr' len' -- addr len+len' } 21544603Sdcs addr' addr len + len' move 21644603Sdcs addr len len' + 21744603Sdcs; 21844603Sdcs 21961373Sdcs: strlen ( addr -- len ) 22061373Sdcs 0 >r 22161373Sdcs begin 22261373Sdcs dup c@ while 22361373Sdcs 1+ r> 1+ >r repeat 22461373Sdcs drop r> 22561373Sdcs; 22661373Sdcs 22744603Sdcs: s' 22844603Sdcs [char] ' parse 22944603Sdcs state @ if 23044603Sdcs postpone sliteral 23144603Sdcs then 23244603Sdcs; immediate 23344603Sdcs 23461373Sdcs: 2>r postpone >r postpone >r ; immediate 23561373Sdcs: 2r> postpone r> postpone r> ; immediate 23653672Sdcs 23744603Sdcs\ Private definitions 23844603Sdcs 23944603Sdcsvocabulary support-functions 24044603Sdcsonly forth also support-functions definitions 24144603Sdcs 24244603Sdcs\ Some control characters constants 24344603Sdcs 24453672Sdcs7 constant bell 24553672Sdcs8 constant backspace 24644603Sdcs9 constant tab 24744603Sdcs10 constant lf 24853672Sdcs13 constant <cr> 24944603Sdcs 25044603Sdcs\ Read buffer size 25144603Sdcs 25244603Sdcs80 constant read_buffer_size 25344603Sdcs 25444603Sdcs\ Standard suffixes 25544603Sdcs 25644603Sdcs: load_module_suffix s" _load" ; 25744603Sdcs: module_loadname_suffix s" _name" ; 25844603Sdcs: module_type_suffix s" _type" ; 25944603Sdcs: module_args_suffix s" _flags" ; 26044603Sdcs: module_beforeload_suffix s" _before" ; 26144603Sdcs: module_afterload_suffix s" _after" ; 26244603Sdcs: module_loaderror_suffix s" _error" ; 26344603Sdcs 26444603Sdcs\ Support operators 26544603Sdcs 26644603Sdcs: >= < 0= ; 26744603Sdcs: <= > 0= ; 26844603Sdcs 26944603Sdcs\ Assorted support funcitons 27044603Sdcs 27144603Sdcs: free-memory free if free_error throw then ; 27244603Sdcs 27344603Sdcs\ Assignment data temporary storage 27444603Sdcs 27544603Sdcsstring name_buffer 27644603Sdcsstring value_buffer 27744603Sdcs 27865615Sdcs\ Line by line file reading functions 27965615Sdcs\ 28065615Sdcs\ exported: 28165615Sdcs\ line_buffer 28265615Sdcs\ end_of_file? 28365615Sdcs\ fd 28465615Sdcs\ read_line 28565615Sdcs\ reset_line_reading 28665615Sdcs 28765615Sdcsvocabulary line-reading 28865615Sdcsalso line-reading definitions also 28965615Sdcs 29044603Sdcs\ File data temporary storage 29144603Sdcs 29244603Sdcsstring read_buffer 29344603Sdcs0 value read_buffer_ptr 29444603Sdcs 29544603Sdcs\ File's line reading function 29644603Sdcs 29765615Sdcssupport-functions definitions 29865615Sdcs 29965615Sdcsstring line_buffer 30044603Sdcs0 value end_of_file? 30144603Sdcsvariable fd 30244603Sdcs 30365615Sdcsline-reading definitions 30465615Sdcs 30544603Sdcs: skip_newlines 30644603Sdcs begin 30744603Sdcs read_buffer .len @ read_buffer_ptr > 30844603Sdcs while 30944603Sdcs read_buffer .addr @ read_buffer_ptr + c@ lf = if 31044603Sdcs read_buffer_ptr char+ to read_buffer_ptr 31144603Sdcs else 31244603Sdcs exit 31344603Sdcs then 31444603Sdcs repeat 31544603Sdcs; 31644603Sdcs 31744603Sdcs: scan_buffer ( -- addr len ) 31844603Sdcs read_buffer_ptr >r 31944603Sdcs begin 32044603Sdcs read_buffer .len @ r@ > 32144603Sdcs while 32244603Sdcs read_buffer .addr @ r@ + c@ lf = if 32344603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 32444603Sdcs r@ read_buffer_ptr - ( -- len ) 32544603Sdcs r> to read_buffer_ptr 32644603Sdcs exit 32744603Sdcs then 32844603Sdcs r> char+ >r 32944603Sdcs repeat 33044603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 33144603Sdcs r@ read_buffer_ptr - ( -- len ) 33244603Sdcs r> to read_buffer_ptr 33344603Sdcs; 33444603Sdcs 33544603Sdcs: line_buffer_resize ( len -- len ) 33644603Sdcs >r 33744603Sdcs line_buffer .len @ if 33844603Sdcs line_buffer .addr @ 33944603Sdcs line_buffer .len @ r@ + 34044603Sdcs resize if out_of_memory throw then 34144603Sdcs else 34244603Sdcs r@ allocate if out_of_memory throw then 34344603Sdcs then 34444603Sdcs line_buffer .addr ! 34544603Sdcs r> 34644603Sdcs; 34744603Sdcs 34844603Sdcs: append_to_line_buffer ( addr len -- ) 34944603Sdcs line_buffer .addr @ line_buffer .len @ 35044603Sdcs 2swap strcat 35144603Sdcs line_buffer .len ! 35244603Sdcs drop 35344603Sdcs; 35444603Sdcs 35544603Sdcs: read_from_buffer 35644603Sdcs scan_buffer ( -- addr len ) 35744603Sdcs line_buffer_resize ( len -- len ) 35844603Sdcs append_to_line_buffer ( addr len -- ) 35944603Sdcs; 36044603Sdcs 36144603Sdcs: refill_required? 36244603Sdcs read_buffer .len @ read_buffer_ptr = 36344603Sdcs end_of_file? 0= and 36444603Sdcs; 36544603Sdcs 36644603Sdcs: refill_buffer 36744603Sdcs 0 to read_buffer_ptr 36844603Sdcs read_buffer .addr @ 0= if 36944603Sdcs read_buffer_size allocate if out_of_memory throw then 37044603Sdcs read_buffer .addr ! 37144603Sdcs then 37244603Sdcs fd @ read_buffer .addr @ read_buffer_size fread 37344603Sdcs dup -1 = if read_error throw then 37444603Sdcs dup 0= if true to end_of_file? then 37544603Sdcs read_buffer .len ! 37644603Sdcs; 37744603Sdcs 37844603Sdcs: reset_line_buffer 37965615Sdcs line_buffer .addr @ ?dup if 38065615Sdcs free-memory 38165615Sdcs then 38244603Sdcs 0 line_buffer .addr ! 38344603Sdcs 0 line_buffer .len ! 38444603Sdcs; 38544603Sdcs 38665615Sdcssupport-functions definitions 38765615Sdcs 38865615Sdcs: reset_line_reading 38965615Sdcs 0 to read_buffer_ptr 39065615Sdcs; 39165615Sdcs 39244603Sdcs: read_line 39344603Sdcs reset_line_buffer 39444603Sdcs skip_newlines 39544603Sdcs begin 39644603Sdcs read_from_buffer 39744603Sdcs refill_required? 39844603Sdcs while 39944603Sdcs refill_buffer 40044603Sdcs repeat 40144603Sdcs; 40244603Sdcs 40365615Sdcsonly forth also support-functions definitions 40465615Sdcs 40544603Sdcs\ Conf file line parser: 40644603Sdcs\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 40744603Sdcs\ <spaces>[<comment>] 40844603Sdcs\ <name> ::= <letter>{<letter>|<digit>|'_'} 40944603Sdcs\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 41044603Sdcs\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 41144603Sdcs\ <comment> ::= '#'{<anything>} 41265615Sdcs\ 41365615Sdcs\ exported: 41465615Sdcs\ line_pointer 41565615Sdcs\ process_conf 41644603Sdcs 41765615Sdcs0 value line_pointer 41865615Sdcs 41965615Sdcsvocabulary file-processing 42065615Sdcsalso file-processing definitions 42165615Sdcs 42265615Sdcs\ parser functions 42365615Sdcs\ 42465615Sdcs\ exported: 42565615Sdcs\ get_assignment 42665615Sdcs 42765615Sdcsvocabulary parser 42865615Sdcsalso parser definitions also 42965615Sdcs 43044603Sdcs0 value parsing_function 43144603Sdcs0 value end_of_line 43244603Sdcs 43344603Sdcs: end_of_line? 43444603Sdcs line_pointer end_of_line = 43544603Sdcs; 43644603Sdcs 43744603Sdcs: letter? 43844603Sdcs line_pointer c@ >r 43944603Sdcs r@ [char] A >= 44044603Sdcs r@ [char] Z <= and 44144603Sdcs r@ [char] a >= 44244603Sdcs r> [char] z <= and 44344603Sdcs or 44444603Sdcs; 44544603Sdcs 44644603Sdcs: digit? 44744603Sdcs line_pointer c@ >r 44844603Sdcs r@ [char] 0 >= 44944603Sdcs r> [char] 9 <= and 45044603Sdcs; 45144603Sdcs 45244603Sdcs: quote? 45344603Sdcs line_pointer c@ [char] " = 45444603Sdcs; 45544603Sdcs 45644603Sdcs: assignment_sign? 45744603Sdcs line_pointer c@ [char] = = 45844603Sdcs; 45944603Sdcs 46044603Sdcs: comment? 46144603Sdcs line_pointer c@ [char] # = 46244603Sdcs; 46344603Sdcs 46444603Sdcs: space? 46544603Sdcs line_pointer c@ bl = 46644603Sdcs line_pointer c@ tab = or 46744603Sdcs; 46844603Sdcs 46944603Sdcs: backslash? 47044603Sdcs line_pointer c@ [char] \ = 47144603Sdcs; 47244603Sdcs 47344603Sdcs: underscore? 47444603Sdcs line_pointer c@ [char] _ = 47544603Sdcs; 47644603Sdcs 47744603Sdcs: dot? 47844603Sdcs line_pointer c@ [char] . = 47944603Sdcs; 48044603Sdcs 48144603Sdcs: skip_character 48244603Sdcs line_pointer char+ to line_pointer 48344603Sdcs; 48444603Sdcs 48544603Sdcs: skip_to_end_of_line 48644603Sdcs end_of_line to line_pointer 48744603Sdcs; 48844603Sdcs 48944603Sdcs: eat_space 49044603Sdcs begin 49144603Sdcs space? 49244603Sdcs while 49344603Sdcs skip_character 49444603Sdcs end_of_line? if exit then 49544603Sdcs repeat 49644603Sdcs; 49744603Sdcs 49844603Sdcs: parse_name ( -- addr len ) 49944603Sdcs line_pointer 50044603Sdcs begin 50144603Sdcs letter? digit? underscore? dot? or or or 50244603Sdcs while 50344603Sdcs skip_character 50444603Sdcs end_of_line? if 50544603Sdcs line_pointer over - 50644603Sdcs strdup 50744603Sdcs exit 50844603Sdcs then 50944603Sdcs repeat 51044603Sdcs line_pointer over - 51144603Sdcs strdup 51244603Sdcs; 51344603Sdcs 51444603Sdcs: remove_backslashes { addr len | addr' len' -- addr' len' } 51544603Sdcs len allocate if out_of_memory throw then 51644603Sdcs to addr' 51744603Sdcs addr >r 51844603Sdcs begin 51944603Sdcs addr c@ [char] \ <> if 52044603Sdcs addr c@ addr' len' + c! 52144603Sdcs len' char+ to len' 52244603Sdcs then 52344603Sdcs addr char+ to addr 52444603Sdcs r@ len + addr = 52544603Sdcs until 52644603Sdcs r> drop 52744603Sdcs addr' len' 52844603Sdcs; 52944603Sdcs 53044603Sdcs: parse_quote ( -- addr len ) 53144603Sdcs line_pointer 53244603Sdcs skip_character 53344603Sdcs end_of_line? if syntax_error throw then 53444603Sdcs begin 53544603Sdcs quote? 0= 53644603Sdcs while 53744603Sdcs backslash? if 53844603Sdcs skip_character 53944603Sdcs end_of_line? if syntax_error throw then 54044603Sdcs then 54144603Sdcs skip_character 54244603Sdcs end_of_line? if syntax_error throw then 54344603Sdcs repeat 54444603Sdcs skip_character 54544603Sdcs line_pointer over - 54644603Sdcs remove_backslashes 54744603Sdcs; 54844603Sdcs 54944603Sdcs: read_name 55044603Sdcs parse_name ( -- addr len ) 55144603Sdcs name_buffer .len ! 55244603Sdcs name_buffer .addr ! 55344603Sdcs; 55444603Sdcs 55544603Sdcs: read_value 55644603Sdcs quote? if 55744603Sdcs parse_quote ( -- addr len ) 55844603Sdcs else 55944603Sdcs parse_name ( -- addr len ) 56044603Sdcs then 56144603Sdcs value_buffer .len ! 56244603Sdcs value_buffer .addr ! 56344603Sdcs; 56444603Sdcs 56544603Sdcs: comment 56644603Sdcs skip_to_end_of_line 56744603Sdcs; 56844603Sdcs 56944603Sdcs: white_space_4 57044603Sdcs eat_space 57144603Sdcs comment? if ['] comment to parsing_function exit then 57244603Sdcs end_of_line? 0= if syntax_error throw then 57344603Sdcs; 57444603Sdcs 57544603Sdcs: variable_value 57644603Sdcs read_value 57744603Sdcs ['] white_space_4 to parsing_function 57844603Sdcs; 57944603Sdcs 58044603Sdcs: white_space_3 58144603Sdcs eat_space 58244603Sdcs letter? digit? quote? or or if 58344603Sdcs ['] variable_value to parsing_function exit 58444603Sdcs then 58544603Sdcs syntax_error throw 58644603Sdcs; 58744603Sdcs 58844603Sdcs: assignment_sign 58944603Sdcs skip_character 59044603Sdcs ['] white_space_3 to parsing_function 59144603Sdcs; 59244603Sdcs 59344603Sdcs: white_space_2 59444603Sdcs eat_space 59544603Sdcs assignment_sign? if ['] assignment_sign to parsing_function exit then 59644603Sdcs syntax_error throw 59744603Sdcs; 59844603Sdcs 59944603Sdcs: variable_name 60044603Sdcs read_name 60144603Sdcs ['] white_space_2 to parsing_function 60244603Sdcs; 60344603Sdcs 60444603Sdcs: white_space_1 60544603Sdcs eat_space 60644603Sdcs letter? if ['] variable_name to parsing_function exit then 60744603Sdcs comment? if ['] comment to parsing_function exit then 60844603Sdcs end_of_line? 0= if syntax_error throw then 60944603Sdcs; 61044603Sdcs 61165615Sdcsfile-processing definitions 61265615Sdcs 61344603Sdcs: get_assignment 61444603Sdcs line_buffer .addr @ line_buffer .len @ + to end_of_line 61544603Sdcs line_buffer .addr @ to line_pointer 61644603Sdcs ['] white_space_1 to parsing_function 61744603Sdcs begin 61844603Sdcs end_of_line? 0= 61944603Sdcs while 62044603Sdcs parsing_function execute 62144603Sdcs repeat 62244603Sdcs parsing_function ['] comment = 62344603Sdcs parsing_function ['] white_space_1 = 62444603Sdcs parsing_function ['] white_space_4 = 62544603Sdcs or or 0= if syntax_error throw then 62644603Sdcs; 62744603Sdcs 62865615Sdcsonly forth also support-functions also file-processing definitions also 62965615Sdcs 63044603Sdcs\ Process line 63144603Sdcs 63244603Sdcs: assignment_type? ( addr len -- flag ) 63344603Sdcs name_buffer .addr @ name_buffer .len @ 63444603Sdcs compare 0= 63544603Sdcs; 63644603Sdcs 63744603Sdcs: suffix_type? ( addr len -- flag ) 63844603Sdcs name_buffer .len @ over <= if 2drop false exit then 63944603Sdcs name_buffer .len @ over - name_buffer .addr @ + 64044603Sdcs over compare 0= 64144603Sdcs; 64244603Sdcs 64344603Sdcs: loader_conf_files? 64444603Sdcs s" loader_conf_files" assignment_type? 64544603Sdcs; 64644603Sdcs 64744603Sdcs: verbose_flag? 64844603Sdcs s" verbose_loading" assignment_type? 64944603Sdcs; 65044603Sdcs 65144603Sdcs: execute? 65244603Sdcs s" exec" assignment_type? 65344603Sdcs; 65444603Sdcs 65553672Sdcs: password? 65653672Sdcs s" password" assignment_type? 65753672Sdcs; 65853672Sdcs 65944603Sdcs: module_load? 66044603Sdcs load_module_suffix suffix_type? 66144603Sdcs; 66244603Sdcs 66344603Sdcs: module_loadname? 66444603Sdcs module_loadname_suffix suffix_type? 66544603Sdcs; 66644603Sdcs 66744603Sdcs: module_type? 66844603Sdcs module_type_suffix suffix_type? 66944603Sdcs; 67044603Sdcs 67144603Sdcs: module_args? 67244603Sdcs module_args_suffix suffix_type? 67344603Sdcs; 67444603Sdcs 67544603Sdcs: module_beforeload? 67644603Sdcs module_beforeload_suffix suffix_type? 67744603Sdcs; 67844603Sdcs 67944603Sdcs: module_afterload? 68044603Sdcs module_afterload_suffix suffix_type? 68144603Sdcs; 68244603Sdcs 68344603Sdcs: module_loaderror? 68444603Sdcs module_loaderror_suffix suffix_type? 68544603Sdcs; 68644603Sdcs 68744603Sdcs: set_conf_files 68844603Sdcs conf_files .addr @ ?dup if 68944603Sdcs free-memory 69044603Sdcs then 69144603Sdcs value_buffer .addr @ c@ [char] " = if 69244603Sdcs value_buffer .addr @ char+ value_buffer .len @ 2 chars - 69344603Sdcs else 69444603Sdcs value_buffer .addr @ value_buffer .len @ 69544603Sdcs then 69644603Sdcs strdup 69744603Sdcs conf_files .len ! conf_files .addr ! 69844603Sdcs; 69944603Sdcs 70044603Sdcs: append_to_module_options_list ( addr -- ) 70144603Sdcs module_options @ 0= if 70244603Sdcs dup module_options ! 70344603Sdcs last_module_option ! 70444603Sdcs else 70544603Sdcs dup last_module_option @ module.next ! 70644603Sdcs last_module_option ! 70744603Sdcs then 70844603Sdcs; 70944603Sdcs 71044603Sdcs: set_module_name ( addr -- ) 71144603Sdcs name_buffer .addr @ name_buffer .len @ 71244603Sdcs strdup 71344603Sdcs >r over module.name .addr ! 71444603Sdcs r> swap module.name .len ! 71544603Sdcs; 71644603Sdcs 71744603Sdcs: yes_value? 71844603Sdcs value_buffer .addr @ value_buffer .len @ 71944603Sdcs 2dup s' "YES"' compare >r 72044603Sdcs 2dup s' "yes"' compare >r 72144603Sdcs 2dup s" YES" compare >r 72244603Sdcs s" yes" compare r> r> r> and and and 0= 72344603Sdcs; 72444603Sdcs 72544603Sdcs: find_module_option ( -- addr | 0 ) 72644603Sdcs module_options @ 72744603Sdcs begin 72844603Sdcs dup 72944603Sdcs while 73044603Sdcs dup module.name dup .addr @ swap .len @ 73144603Sdcs name_buffer .addr @ name_buffer .len @ 73244603Sdcs compare 0= if exit then 73344603Sdcs module.next @ 73444603Sdcs repeat 73544603Sdcs; 73644603Sdcs 73744603Sdcs: new_module_option ( -- addr ) 73844603Sdcs sizeof module allocate if out_of_memory throw then 73944603Sdcs dup sizeof module erase 74044603Sdcs dup append_to_module_options_list 74144603Sdcs dup set_module_name 74244603Sdcs; 74344603Sdcs 74444603Sdcs: get_module_option ( -- addr ) 74544603Sdcs find_module_option 74644603Sdcs ?dup 0= if new_module_option then 74744603Sdcs; 74844603Sdcs 74944603Sdcs: set_module_flag 75044603Sdcs name_buffer .len @ load_module_suffix nip - name_buffer .len ! 75144603Sdcs yes_value? get_module_option module.flag ! 75244603Sdcs; 75344603Sdcs 75444603Sdcs: set_module_args 75544603Sdcs name_buffer .len @ module_args_suffix nip - name_buffer .len ! 75644603Sdcs get_module_option module.args 75744603Sdcs dup .addr @ ?dup if free-memory then 75844603Sdcs value_buffer .addr @ value_buffer .len @ 75944603Sdcs over c@ [char] " = if 76044603Sdcs 2 chars - swap char+ swap 76144603Sdcs then 76244603Sdcs strdup 76344603Sdcs >r over .addr ! 76444603Sdcs r> swap .len ! 76544603Sdcs; 76644603Sdcs 76744603Sdcs: set_module_loadname 76844603Sdcs name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 76944603Sdcs get_module_option module.loadname 77044603Sdcs dup .addr @ ?dup if free-memory then 77144603Sdcs value_buffer .addr @ value_buffer .len @ 77244603Sdcs over c@ [char] " = if 77344603Sdcs 2 chars - swap char+ swap 77444603Sdcs then 77544603Sdcs strdup 77644603Sdcs >r over .addr ! 77744603Sdcs r> swap .len ! 77844603Sdcs; 77944603Sdcs 78044603Sdcs: set_module_type 78144603Sdcs name_buffer .len @ module_type_suffix nip - name_buffer .len ! 78244603Sdcs get_module_option module.type 78344603Sdcs dup .addr @ ?dup if free-memory then 78444603Sdcs value_buffer .addr @ value_buffer .len @ 78544603Sdcs over c@ [char] " = if 78644603Sdcs 2 chars - swap char+ swap 78744603Sdcs then 78844603Sdcs strdup 78944603Sdcs >r over .addr ! 79044603Sdcs r> swap .len ! 79144603Sdcs; 79244603Sdcs 79344603Sdcs: set_module_beforeload 79444603Sdcs name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 79544603Sdcs get_module_option module.beforeload 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_afterload 80744603Sdcs name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 80844603Sdcs get_module_option module.afterload 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_loaderror 82044603Sdcs name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 82144603Sdcs get_module_option module.loaderror 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_environment_variable 83344603Sdcs name_buffer .len @ 83444603Sdcs value_buffer .len @ + 83544603Sdcs 5 chars + 83644603Sdcs allocate if out_of_memory throw then 83744603Sdcs dup 0 ( addr -- addr addr len ) 83844603Sdcs s" set " strcat 83944603Sdcs name_buffer .addr @ name_buffer .len @ strcat 84044603Sdcs s" =" strcat 84144603Sdcs value_buffer .addr @ value_buffer .len @ strcat 84244603Sdcs ['] evaluate catch if 84344603Sdcs 2drop free drop 84444603Sdcs set_error throw 84544603Sdcs else 84644603Sdcs free-memory 84744603Sdcs then 84844603Sdcs; 84944603Sdcs 85044603Sdcs: set_verbose 85144603Sdcs yes_value? to verbose? 85244603Sdcs; 85344603Sdcs 85444603Sdcs: execute_command 85544603Sdcs value_buffer .addr @ value_buffer .len @ 85644603Sdcs over c@ [char] " = if 85753672Sdcs 2 - swap char+ swap 85844603Sdcs then 85944603Sdcs ['] evaluate catch if exec_error throw then 86044603Sdcs; 86144603Sdcs 86253672Sdcs: set_password 86353672Sdcs password .addr @ ?dup if free if free_error throw then then 86453672Sdcs value_buffer .addr @ c@ [char] " = if 86553672Sdcs value_buffer .addr @ char+ value_buffer .len @ 2 - strdup 86653672Sdcs value_buffer .addr @ free if free_error throw then 86753672Sdcs else 86853672Sdcs value_buffer .addr @ value_buffer .len @ 86953672Sdcs then 87053672Sdcs password .len ! password .addr ! 87153672Sdcs 0 value_buffer .addr ! 87253672Sdcs; 87353672Sdcs 87444603Sdcs: process_assignment 87544603Sdcs name_buffer .len @ 0= if exit then 87644603Sdcs loader_conf_files? if set_conf_files exit then 87744603Sdcs verbose_flag? if set_verbose exit then 87844603Sdcs execute? if execute_command exit then 87953672Sdcs password? if set_password exit then 88044603Sdcs module_load? if set_module_flag exit then 88144603Sdcs module_loadname? if set_module_loadname exit then 88244603Sdcs module_type? if set_module_type exit then 88344603Sdcs module_args? if set_module_args exit then 88444603Sdcs module_beforeload? if set_module_beforeload exit then 88544603Sdcs module_afterload? if set_module_afterload exit then 88644603Sdcs module_loaderror? if set_module_loaderror exit then 88744603Sdcs set_environment_variable 88844603Sdcs; 88944603Sdcs 89053672Sdcs\ free_buffer ( -- ) 89153672Sdcs\ 89253672Sdcs\ Free some pointers if needed. The code then tests for errors 89353672Sdcs\ in freeing, and throws an exception if needed. If a pointer is 89453672Sdcs\ not allocated, it's value (0) is used as flag. 89553672Sdcs 89644603Sdcs: free_buffers 89744603Sdcs name_buffer .addr @ dup if free then 89844603Sdcs value_buffer .addr @ dup if free then 89965615Sdcs or if free_error throw then 90044603Sdcs; 90144603Sdcs 90244603Sdcs: reset_assignment_buffers 90344603Sdcs 0 name_buffer .addr ! 90444603Sdcs 0 name_buffer .len ! 90544603Sdcs 0 value_buffer .addr ! 90644603Sdcs 0 value_buffer .len ! 90744603Sdcs; 90844603Sdcs 90944603Sdcs\ Higher level file processing 91044603Sdcs 91165615Sdcssupport-functions definitions 91265615Sdcs 91344603Sdcs: process_conf 91444603Sdcs begin 91544603Sdcs end_of_file? 0= 91644603Sdcs while 91744603Sdcs reset_assignment_buffers 91844603Sdcs read_line 91944603Sdcs get_assignment 92044603Sdcs ['] process_assignment catch 92144603Sdcs ['] free_buffers catch 92244603Sdcs swap throw throw 92344603Sdcs repeat 92444603Sdcs; 92544603Sdcs 92665615Sdcsonly forth also support-functions definitions 92765615Sdcs 92844603Sdcs: create_null_terminated_string { addr len -- addr' len } 92944603Sdcs len char+ allocate if out_of_memory throw then 93044603Sdcs >r 93144603Sdcs addr r@ len move 93244603Sdcs 0 r@ len + c! 93344603Sdcs r> len 93444603Sdcs; 93544603Sdcs 93644603Sdcs\ Interface to loading conf files 93744603Sdcs 93844603Sdcs: load_conf ( addr len -- ) 93944603Sdcs 0 to end_of_file? 94065615Sdcs reset_line_reading 94144603Sdcs create_null_terminated_string 94244603Sdcs over >r 94344603Sdcs fopen fd ! 94444603Sdcs r> free-memory 94544603Sdcs fd @ -1 = if open_error throw then 94644603Sdcs ['] process_conf catch 94744603Sdcs fd @ fclose 94844603Sdcs throw 94944603Sdcs; 95044603Sdcs 95144603Sdcs: print_line 95244603Sdcs line_buffer .addr @ line_buffer .len @ type cr 95344603Sdcs; 95444603Sdcs 95544603Sdcs: print_syntax_error 95644603Sdcs line_buffer .addr @ line_buffer .len @ type cr 95744603Sdcs line_buffer .addr @ 95844603Sdcs begin 95944603Sdcs line_pointer over <> 96044603Sdcs while 96144603Sdcs bl emit 96244603Sdcs char+ 96344603Sdcs repeat 96444603Sdcs drop 96544603Sdcs ." ^" cr 96644603Sdcs; 96744603Sdcs 96844603Sdcs\ Depuration support functions 96944603Sdcs 97044603Sdcsonly forth definitions also support-functions 97144603Sdcs 97244603Sdcs: test-file 97344603Sdcs ['] load_conf catch dup . 97444603Sdcs syntax_error = if cr print_syntax_error then 97544603Sdcs; 97644603Sdcs 97744603Sdcs: show-module-options 97844603Sdcs module_options @ 97944603Sdcs begin 98044603Sdcs ?dup 98144603Sdcs while 98244603Sdcs ." Name: " dup module.name dup .addr @ swap .len @ type cr 98344603Sdcs ." Path: " dup module.loadname dup .addr @ swap .len @ type cr 98444603Sdcs ." Type: " dup module.type dup .addr @ swap .len @ type cr 98544603Sdcs ." Flags: " dup module.args dup .addr @ swap .len @ type cr 98644603Sdcs ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr 98744603Sdcs ." After load: " dup module.afterload dup .addr @ swap .len @ type cr 98844603Sdcs ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr 98944603Sdcs ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr 99044603Sdcs module.next @ 99144603Sdcs repeat 99244603Sdcs; 99344603Sdcs 99444603Sdcsonly forth also support-functions definitions 99544603Sdcs 99644603Sdcs\ Variables used for processing multiple conf files 99744603Sdcs 99844603Sdcsstring current_file_name 99944603Sdcsvariable current_conf_files 100044603Sdcs 100144603Sdcs\ Indicates if any conf file was succesfully read 100244603Sdcs 100344603Sdcs0 value any_conf_read? 100444603Sdcs 100544603Sdcs\ loader_conf_files processing support functions 100644603Sdcs 100744603Sdcs: set_current_conf_files 100844603Sdcs conf_files .addr @ current_conf_files ! 100944603Sdcs; 101044603Sdcs 101144603Sdcs: get_conf_files 101244603Sdcs conf_files .addr @ conf_files .len @ strdup 101344603Sdcs; 101444603Sdcs 101544603Sdcs: recurse_on_conf_files? 101644603Sdcs current_conf_files @ conf_files .addr @ <> 101744603Sdcs; 101844603Sdcs 101953672Sdcs: skip_leading_spaces { addr len pos -- addr len pos' } 102044603Sdcs begin 102153672Sdcs pos len = if addr len pos exit then 102253672Sdcs addr pos + c@ bl = 102344603Sdcs while 102453672Sdcs pos char+ to pos 102544603Sdcs repeat 102653672Sdcs addr len pos 102744603Sdcs; 102844603Sdcs 102953672Sdcs: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 103053672Sdcs pos len = if 103144603Sdcs addr free abort" Fatal error freeing memory" 103244603Sdcs 0 exit 103344603Sdcs then 103453672Sdcs pos >r 103544603Sdcs begin 103653672Sdcs addr pos + c@ bl <> 103744603Sdcs while 103853672Sdcs pos char+ to pos 103953672Sdcs pos len = if 104053672Sdcs addr len pos addr r@ + pos r> - exit 104144603Sdcs then 104244603Sdcs repeat 104353672Sdcs addr len pos addr r@ + pos r> - 104444603Sdcs; 104544603Sdcs 104644603Sdcs: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 104744603Sdcs skip_leading_spaces 104844603Sdcs get_file_name 104944603Sdcs; 105044603Sdcs 105144603Sdcs: set_current_file_name 105244603Sdcs over current_file_name .addr ! 105344603Sdcs dup current_file_name .len ! 105444603Sdcs; 105544603Sdcs 105644603Sdcs: print_current_file 105744603Sdcs current_file_name .addr @ current_file_name .len @ type 105844603Sdcs; 105944603Sdcs 106044603Sdcs: process_conf_errors 106144603Sdcs dup 0= if true to any_conf_read? drop exit then 106244603Sdcs >r 2drop r> 106344603Sdcs dup syntax_error = if 106444603Sdcs ." Warning: syntax error on file " print_current_file cr 106544603Sdcs print_syntax_error drop exit 106644603Sdcs then 106744603Sdcs dup set_error = if 106844603Sdcs ." Warning: bad definition on file " print_current_file cr 106944603Sdcs print_line drop exit 107044603Sdcs then 107144603Sdcs dup read_error = if 107244603Sdcs ." Warning: error reading file " print_current_file cr drop exit 107344603Sdcs then 107444603Sdcs dup open_error = if 107544603Sdcs verbose? if ." Warning: unable to open file " print_current_file cr then 107644603Sdcs drop exit 107744603Sdcs then 107844603Sdcs dup free_error = abort" Fatal error freeing memory" 107944603Sdcs dup out_of_memory = abort" Out of memory" 108044603Sdcs throw \ Unknown error -- pass ahead 108144603Sdcs; 108244603Sdcs 108344603Sdcs\ Process loader_conf_files recursively 108444603Sdcs\ Interface to loader_conf_files processing 108544603Sdcs 108644603Sdcs: include_conf_files 108744603Sdcs set_current_conf_files 108844603Sdcs get_conf_files 0 108944603Sdcs begin 109044603Sdcs get_next_file ?dup 109144603Sdcs while 109244603Sdcs set_current_file_name 109344603Sdcs ['] load_conf catch 109444603Sdcs process_conf_errors 109544603Sdcs recurse_on_conf_files? if recurse then 109644603Sdcs repeat 109744603Sdcs; 109844603Sdcs 109944603Sdcs\ Module loading functions 110044603Sdcs 110144603Sdcs: load_module? 110244603Sdcs module.flag @ 110344603Sdcs; 110444603Sdcs 110544603Sdcs: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N ) 110644603Sdcs dup >r 110744603Sdcs r@ module.args .addr @ r@ module.args .len @ 110844603Sdcs r@ module.loadname .len @ if 110944603Sdcs r@ module.loadname .addr @ r@ module.loadname .len @ 111044603Sdcs else 111144603Sdcs r@ module.name .addr @ r@ module.name .len @ 111244603Sdcs then 111344603Sdcs r@ module.type .len @ if 111444603Sdcs r@ module.type .addr @ r@ module.type .len @ 111544603Sdcs s" -t " 111644603Sdcs 4 ( -t type name flags ) 111744603Sdcs else 111844603Sdcs 2 ( name flags ) 111944603Sdcs then 112044603Sdcs r> drop 112144603Sdcs; 112244603Sdcs 112344603Sdcs: before_load ( addr -- addr ) 112444603Sdcs dup module.beforeload .len @ if 112544603Sdcs dup module.beforeload .addr @ over module.beforeload .len @ 112644603Sdcs ['] evaluate catch if before_load_error throw then 112744603Sdcs then 112844603Sdcs; 112944603Sdcs 113044603Sdcs: after_load ( addr -- addr ) 113144603Sdcs dup module.afterload .len @ if 113244603Sdcs dup module.afterload .addr @ over module.afterload .len @ 113344603Sdcs ['] evaluate catch if after_load_error throw then 113444603Sdcs then 113544603Sdcs; 113644603Sdcs 113744603Sdcs: load_error ( addr -- addr ) 113844603Sdcs dup module.loaderror .len @ if 113944603Sdcs dup module.loaderror .addr @ over module.loaderror .len @ 114044603Sdcs evaluate \ This we do not intercept so it can throw errors 114144603Sdcs then 114244603Sdcs; 114344603Sdcs 114444603Sdcs: pre_load_message ( addr -- addr ) 114544603Sdcs verbose? if 114644603Sdcs dup module.name .addr @ over module.name .len @ type 114744603Sdcs ." ..." 114844603Sdcs then 114944603Sdcs; 115044603Sdcs 115144603Sdcs: load_error_message verbose? if ." failed!" cr then ; 115244603Sdcs 115344603Sdcs: load_succesful_message verbose? if ." ok" cr then ; 115444603Sdcs 115544603Sdcs: load_module 115644603Sdcs load_parameters load 115744603Sdcs; 115844603Sdcs 115944603Sdcs: process_module ( addr -- addr ) 116044603Sdcs pre_load_message 116144603Sdcs before_load 116244603Sdcs begin 116344603Sdcs ['] load_module catch if 116444603Sdcs dup module.loaderror .len @ if 116544603Sdcs load_error \ Command should return a flag! 116644603Sdcs else 116744603Sdcs load_error_message true \ Do not retry 116844603Sdcs then 116944603Sdcs else 117044603Sdcs after_load 117144603Sdcs load_succesful_message true \ Succesful, do not retry 117244603Sdcs then 117344603Sdcs until 117444603Sdcs; 117544603Sdcs 117644603Sdcs: process_module_errors ( addr ior -- ) 117744603Sdcs dup before_load_error = if 117844603Sdcs drop 117944603Sdcs ." Module " 118044603Sdcs dup module.name .addr @ over module.name .len @ type 118144603Sdcs dup module.loadname .len @ if 118244603Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 118344603Sdcs then 118444603Sdcs cr 118544603Sdcs ." Error executing " 118644603Sdcs dup module.beforeload .addr @ over module.afterload .len @ type cr 118744603Sdcs abort 118844603Sdcs then 118944603Sdcs 119044603Sdcs dup after_load_error = if 119144603Sdcs drop 119244603Sdcs ." Module " 119344603Sdcs dup module.name .addr @ over module.name .len @ type 119444603Sdcs dup module.loadname .len @ if 119544603Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 119644603Sdcs then 119744603Sdcs cr 119844603Sdcs ." Error executing " 119944603Sdcs dup module.afterload .addr @ over module.afterload .len @ type cr 120044603Sdcs abort 120144603Sdcs then 120244603Sdcs 120344603Sdcs throw \ Don't know what it is all about -- pass ahead 120444603Sdcs; 120544603Sdcs 120644603Sdcs\ Module loading interface 120744603Sdcs 120844603Sdcs: load_modules ( -- ) ( throws: abort & user-defined ) 120944603Sdcs module_options @ 121044603Sdcs begin 121144603Sdcs ?dup 121244603Sdcs while 121344603Sdcs dup load_module? if 121444603Sdcs ['] process_module catch 121544603Sdcs process_module_errors 121644603Sdcs then 121744603Sdcs module.next @ 121844603Sdcs repeat 121944603Sdcs; 122044603Sdcs 122165630Sdcs\ h00h00 magic used to try loading either a kernel with a given name, 122265630Sdcs\ or a kernel with the default name in a directory of a given name 122365630Sdcs\ (the pain!) 122444603Sdcs 122565630Sdcs: bootpath s" /boot/" ; 122665630Sdcs: modulepath s" module_path" ; 122765630Sdcs 122865630Sdcs\ Functions used to save and restore module_path's value. 122965630Sdcs: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 123065630Sdcs dup -1 = if 0 swap exit then 123165630Sdcs strdup 123265630Sdcs; 123365630Sdcs: freeenv ( addr len | 0 -1 ) 123465630Sdcs -1 = if drop else free abort" Freeing error" then 123565630Sdcs; 123665630Sdcs: restoreenv ( addr len | 0 -1 -- ) 123765630Sdcs dup -1 = if ( it wasn't set ) 123865630Sdcs 2drop 123965630Sdcs modulepath unsetenv 124065630Sdcs else 124165630Sdcs over >r 124265630Sdcs modulepath setenv 124365630Sdcs r> free abort" Freeing error" 124465630Sdcs then 124565630Sdcs; 124665630Sdcs 124765630Sdcs: clip_args \ Drop second string if only one argument is passed 124865630Sdcs 1 = if 124965630Sdcs 2swap 2drop 125065630Sdcs 1 125165630Sdcs else 125265630Sdcs 2 125365630Sdcs then 125465630Sdcs; 125565630Sdcs 125665630Sdcsalso builtins 125765630Sdcs 125865630Sdcs\ Parse filename from a comma-separated list 125965630Sdcs 126065630Sdcs: parse-; ( addr len -- addr' len-x addr x ) 126165630Sdcs over 0 2swap 126265630Sdcs begin 126365630Sdcs dup 0 <> 126465630Sdcs while 126565630Sdcs over c@ [char] ; <> 126665630Sdcs while 126765630Sdcs 1- swap 1+ swap 126865630Sdcs 2swap 1+ 2swap 126965630Sdcs repeat then 127065630Sdcs dup 0 <> if 127165630Sdcs 1- swap 1+ swap 127265630Sdcs then 127365630Sdcs 2swap 127465630Sdcs; 127565630Sdcs 127665630Sdcs\ Try loading one of multiple kernels specified 127765630Sdcs 127865630Sdcs: try_multiple_kernels ( addr len addr' len' args -- flag ) 127965630Sdcs >r 128065630Sdcs begin 128165630Sdcs parse-; 2>r 128265630Sdcs 2over 2r> 128365630Sdcs r@ clip_args 1 load 128465630Sdcs while 128565630Sdcs dup 0= 128665630Sdcs until 128765630Sdcs 1 >r \ Failure 128865630Sdcs else 128965630Sdcs 0 >r \ Success 129065630Sdcs then 129165630Sdcs 2drop 2drop 129265630Sdcs r> 129365630Sdcs r> drop 129465630Sdcs; 129565630Sdcs 129665630Sdcs\ Try to load a kernel; the kernel name is taken from one of 129765630Sdcs\ the following lists, as ordered: 129865630Sdcs\ 129965630Sdcs\ 1. The "kernel" environment variable 130065630Sdcs\ 2. The "bootfile" environment variable 130165630Sdcs\ 130265630Sdcs\ Flags are passed, if available. The parameter args must be 2 130365630Sdcs\ if flags are being passed, or 1 if they should be ignored. 130465630Sdcs\ Dummy flags and len must be passed in the latter case. 130565630Sdcs\ 130665630Sdcs\ The kernel gets loaded from the current module_path. 130765630Sdcs 130865630Sdcs: load_a_kernel ( flags len args -- flag ) 130965630Sdcs local args 131065630Sdcs 2local flags 131165630Sdcs 0 0 2local kernel 131265630Sdcs end-locals 131365630Sdcs 131465630Sdcs \ Check if a default kernel name exists at all, exits if not 131565630Sdcs s" kernel" getenv dup -1 <> if 131665630Sdcs to kernel 131765630Sdcs flags kernel args try_multiple_kernels 131865630Sdcs dup 0= if exit then 131965630Sdcs then 132065630Sdcs drop 132165630Sdcs 132265630Sdcs s" bootfile" getenv dup -1 <> if 132365630Sdcs to kernel 132465630Sdcs else 132565630Sdcs drop 132665630Sdcs 1 exit \ Failure 132765630Sdcs then 132865630Sdcs 132965630Sdcs \ Try all default kernel names 133065630Sdcs flags kernel args try_multiple_kernels 133165630Sdcs; 133265630Sdcs 133365630Sdcs\ Try to load a kernel; the kernel name is taken from one of 133465630Sdcs\ the following lists, as ordered: 133565630Sdcs\ 133665630Sdcs\ 1. The "kernel" environment variable 133765630Sdcs\ 2. The "bootfile" environment variable 133865630Sdcs\ 133965630Sdcs\ Flags are passed, if provided. 134065630Sdcs\ 134165630Sdcs\ The kernel will be loaded from a directory computed from the 134265630Sdcs\ path given. Two directories will be tried in the following order: 134365630Sdcs\ 134465630Sdcs\ 1. /boot/path 134565630Sdcs\ 2. path 134665630Sdcs\ 134765630Sdcs\ The module_path variable is overridden if load is succesful, by 134865630Sdcs\ prepending the successful path. 134965630Sdcs 135065630Sdcs: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 135165630Sdcs local args 135265630Sdcs 2local path 135365630Sdcs args 1 = if 0 0 then 135465630Sdcs 2local flags 135565630Sdcs 0 0 2local oldmodulepath 135665630Sdcs 0 0 2local newmodulepath 135765630Sdcs end-locals 135865630Sdcs 135965630Sdcs \ Set the environment variable module_path, and try loading 136065630Sdcs \ the kernel again. 136165630Sdcs modulepath getenv saveenv to oldmodulepath 136265630Sdcs 136365630Sdcs \ Try prepending /boot/ first 136465630Sdcs bootpath nip path nip + 136565630Sdcs oldmodulepath nip dup -1 = if 136665630Sdcs drop 136765630Sdcs else 136865630Sdcs 1+ + 136965630Sdcs then 137065630Sdcs allocate 137165630Sdcs if ( out of memory ) 137265630Sdcs 1 exit 137365630Sdcs then 137465630Sdcs 137565630Sdcs 0 137665630Sdcs bootpath strcat 137765630Sdcs path strcat 137865630Sdcs 2dup to newmodulepath 137965630Sdcs modulepath setenv 138065630Sdcs 138165630Sdcs \ Try all default kernel names 138265630Sdcs flags args load_a_kernel 138365630Sdcs 0= if ( success ) 138465630Sdcs oldmodulepath nip -1 <> if 138565630Sdcs newmodulepath s" ;" strcat 138665630Sdcs oldmodulepath strcat 138765630Sdcs modulepath setenv 138865630Sdcs newmodulepath drop free-memory 138965630Sdcs oldmodulepath drop free-memory 139065630Sdcs then 139165630Sdcs 0 exit 139265630Sdcs then 139365630Sdcs 139465630Sdcs \ Well, try without the prepended /boot/ 139565630Sdcs path newmodulepath drop swap move 139665630Sdcs path nip 139765630Sdcs 2dup to newmodulepath 139865630Sdcs modulepath setenv 139965630Sdcs 140065630Sdcs \ Try all default kernel names 140165630Sdcs flags args load_a_kernel 140265630Sdcs if ( failed once more ) 140365630Sdcs oldmodulepath restoreenv 140465630Sdcs newmodulepath drop free-memory 140565630Sdcs 1 140665630Sdcs else 140765630Sdcs oldmodulepath nip -1 <> if 140865630Sdcs newmodulepath s" ;" strcat 140965630Sdcs oldmodulepath strcat 141065630Sdcs modulepath setenv 141165630Sdcs newmodulepath drop free-memory 141265630Sdcs oldmodulepath drop free-memory 141365630Sdcs then 141465630Sdcs 0 141565630Sdcs then 141665630Sdcs; 141765630Sdcs 141865630Sdcs\ Try to load a kernel; the kernel name is taken from one of 141965630Sdcs\ the following lists, as ordered: 142065630Sdcs\ 142165630Sdcs\ 1. The "kernel" environment variable 142265630Sdcs\ 2. The "bootfile" environment variable 142365630Sdcs\ 3. The "path" argument 142465630Sdcs\ 142565630Sdcs\ Flags are passed, if provided. 142665630Sdcs\ 142765630Sdcs\ The kernel will be loaded from a directory computed from the 142865630Sdcs\ path given. Two directories will be tried in the following order: 142965630Sdcs\ 143065630Sdcs\ 1. /boot/path 143165630Sdcs\ 2. path 143265630Sdcs\ 143365630Sdcs\ Unless "path" is meant to be kernel name itself. In that case, it 143465630Sdcs\ will first be tried as a full path, and, next, search on the 143565630Sdcs\ directories pointed by module_path. 143665630Sdcs\ 143765630Sdcs\ The module_path variable is overridden if load is succesful, by 143865630Sdcs\ prepending the successful path. 143965630Sdcs 144065630Sdcs: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 144165630Sdcs local args 144265630Sdcs 2local path 144365630Sdcs args 1 = if 0 0 then 144465630Sdcs 2local flags 144565630Sdcs end-locals 144665630Sdcs 144765630Sdcs \ First, assume path is an absolute path to a directory 144865630Sdcs flags path args clip_args load_from_directory 144965630Sdcs dup 0= if exit else drop then 145065630Sdcs 145165630Sdcs \ Next, assume path points to the kernel 145265630Sdcs flags path args try_multiple_kernels 145365630Sdcs; 145465630Sdcs 145565630Sdcs: load_kernel_and_modules ( flags len path len' 2 | path len' 1 -- flag ) 145665630Sdcs load_directory_or_file 145765630Sdcs 0= if ['] load_modules catch then 145865630Sdcs; 145965630Sdcs 146044603Sdcs: initialize ( addr len -- ) 146144603Sdcs strdup conf_files .len ! conf_files .addr ! 146244603Sdcs; 146344603Sdcs 146465630Sdcs: kernel_options ( -- addr len 2 | 0 0 1 ) 146565630Sdcs s" kernel_options" getenv 146665630Sdcs dup -1 = if 0 0 1 else 2 then 146765630Sdcs; 146865630Sdcs 146965630Sdcs: kernel_and_options 147065630Sdcs kernel_options 147165630Sdcs s" kernel" getenv 147265630Sdcs rot 147365630Sdcs; 147465630Sdcs 147544603Sdcs: load_kernel ( -- ) ( throws: abort ) 147665630Sdcs s" kernel" getenv 147765630Sdcs dup -1 = if 147865630Sdcs \ If unset, try any kernel 147965630Sdcs drop 148065630Sdcs kernel_options load_a_kernel 148165630Sdcs else 148265630Sdcs \ If set, try first directory, next file name 148365630Sdcs kernel_options >r 2swap r> clip_args load_from_directory 148465630Sdcs dup if 148565630Sdcs drop 148665630Sdcs kernel_and_options try_multiple_kernels 148765630Sdcs then 148865630Sdcs then 148965630Sdcs abort" Unable to load a kernel!" 149044603Sdcs; 149165630Sdcs 149253672Sdcs: read-password { size | buf len -- } 149353672Sdcs size allocate if out_of_memory throw then 149453672Sdcs to buf 149553672Sdcs 0 to len 149653672Sdcs begin 149753672Sdcs key 149853672Sdcs dup backspace = if 149953672Sdcs drop 150053672Sdcs len if 150153672Sdcs backspace emit bl emit backspace emit 150253672Sdcs len 1 - to len 150353672Sdcs else 150453672Sdcs bell emit 150553672Sdcs then 150653672Sdcs else 150753672Sdcs dup <cr> = if cr drop buf len exit then 150853672Sdcs [char] * emit 150953672Sdcs len size < if 151053672Sdcs buf len chars + c! 151153672Sdcs else 151253672Sdcs drop 151353672Sdcs then 151453672Sdcs len 1+ to len 151553672Sdcs then 151653672Sdcs again 151753672Sdcs; 151853672Sdcs 151944603Sdcs\ Go back to straight forth vocabulary 152044603Sdcs 152144603Sdcsonly forth also definitions 152244603Sdcs 1523