support.4th revision 87636
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 87636 2001-12-11 00:49:34Z jhb $ 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 21153672Sdcsstring password 21265615Sdcscreate module_options sizeof module.next allot 0 module_options ! 21365615Sdcscreate last_module_option sizeof module.next allot 0 last_module_option ! 21444603Sdcs0 value verbose? 21544603Sdcs 21644603Sdcs\ Support string functions 21744603Sdcs 21844603Sdcs: strdup ( addr len -- addr' len ) 21944603Sdcs >r r@ allocate if out_of_memory throw then 22044603Sdcs tuck r@ move 22144603Sdcs r> 22244603Sdcs; 22344603Sdcs 22444603Sdcs: strcat { addr len addr' len' -- addr len+len' } 22544603Sdcs addr' addr len + len' move 22644603Sdcs addr len len' + 22744603Sdcs; 22844603Sdcs 22961373Sdcs: strlen ( addr -- len ) 23061373Sdcs 0 >r 23161373Sdcs begin 23261373Sdcs dup c@ while 23361373Sdcs 1+ r> 1+ >r repeat 23461373Sdcs drop r> 23561373Sdcs; 23661373Sdcs 23744603Sdcs: s' 23844603Sdcs [char] ' parse 23944603Sdcs state @ if 24044603Sdcs postpone sliteral 24144603Sdcs then 24244603Sdcs; immediate 24344603Sdcs 24461373Sdcs: 2>r postpone >r postpone >r ; immediate 24561373Sdcs: 2r> postpone r> postpone r> ; immediate 24665883Sdcs: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate 24753672Sdcs 24865938Sdcs: getenv? 24965938Sdcs getenv 25065938Sdcs -1 = if false else drop true then 25165938Sdcs; 25265938Sdcs 25344603Sdcs\ Private definitions 25444603Sdcs 25544603Sdcsvocabulary support-functions 25644603Sdcsonly forth also support-functions definitions 25744603Sdcs 25844603Sdcs\ Some control characters constants 25944603Sdcs 26053672Sdcs7 constant bell 26153672Sdcs8 constant backspace 26244603Sdcs9 constant tab 26344603Sdcs10 constant lf 26453672Sdcs13 constant <cr> 26544603Sdcs 26644603Sdcs\ Read buffer size 26744603Sdcs 26844603Sdcs80 constant read_buffer_size 26944603Sdcs 27044603Sdcs\ Standard suffixes 27144603Sdcs 27244603Sdcs: load_module_suffix s" _load" ; 27344603Sdcs: module_loadname_suffix s" _name" ; 27444603Sdcs: module_type_suffix s" _type" ; 27544603Sdcs: module_args_suffix s" _flags" ; 27644603Sdcs: module_beforeload_suffix s" _before" ; 27744603Sdcs: module_afterload_suffix s" _after" ; 27844603Sdcs: module_loaderror_suffix s" _error" ; 27944603Sdcs 28044603Sdcs\ Support operators 28144603Sdcs 28244603Sdcs: >= < 0= ; 28344603Sdcs: <= > 0= ; 28444603Sdcs 28544603Sdcs\ Assorted support funcitons 28644603Sdcs 28744603Sdcs: free-memory free if free_error throw then ; 28844603Sdcs 28944603Sdcs\ Assignment data temporary storage 29044603Sdcs 29144603Sdcsstring name_buffer 29244603Sdcsstring value_buffer 29344603Sdcs 29465615Sdcs\ Line by line file reading functions 29565615Sdcs\ 29665615Sdcs\ exported: 29765615Sdcs\ line_buffer 29865615Sdcs\ end_of_file? 29965615Sdcs\ fd 30065615Sdcs\ read_line 30165615Sdcs\ reset_line_reading 30265615Sdcs 30365615Sdcsvocabulary line-reading 30465615Sdcsalso line-reading definitions also 30565615Sdcs 30644603Sdcs\ File data temporary storage 30744603Sdcs 30844603Sdcsstring read_buffer 30944603Sdcs0 value read_buffer_ptr 31044603Sdcs 31144603Sdcs\ File's line reading function 31244603Sdcs 31365615Sdcssupport-functions definitions 31465615Sdcs 31565615Sdcsstring line_buffer 31644603Sdcs0 value end_of_file? 31744603Sdcsvariable fd 31844603Sdcs 31965615Sdcsline-reading definitions 32065615Sdcs 32144603Sdcs: skip_newlines 32244603Sdcs begin 32344603Sdcs read_buffer .len @ read_buffer_ptr > 32444603Sdcs while 32544603Sdcs read_buffer .addr @ read_buffer_ptr + c@ lf = if 32644603Sdcs read_buffer_ptr char+ to read_buffer_ptr 32744603Sdcs else 32844603Sdcs exit 32944603Sdcs then 33044603Sdcs repeat 33144603Sdcs; 33244603Sdcs 33344603Sdcs: scan_buffer ( -- addr len ) 33444603Sdcs read_buffer_ptr >r 33544603Sdcs begin 33644603Sdcs read_buffer .len @ r@ > 33744603Sdcs while 33844603Sdcs read_buffer .addr @ r@ + c@ lf = if 33944603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 34044603Sdcs r@ read_buffer_ptr - ( -- len ) 34144603Sdcs r> to read_buffer_ptr 34244603Sdcs exit 34344603Sdcs then 34444603Sdcs r> char+ >r 34544603Sdcs repeat 34644603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 34744603Sdcs r@ read_buffer_ptr - ( -- len ) 34844603Sdcs r> to read_buffer_ptr 34944603Sdcs; 35044603Sdcs 35144603Sdcs: line_buffer_resize ( len -- len ) 35244603Sdcs >r 35344603Sdcs line_buffer .len @ if 35444603Sdcs line_buffer .addr @ 35544603Sdcs line_buffer .len @ r@ + 35644603Sdcs resize if out_of_memory throw then 35744603Sdcs else 35844603Sdcs r@ allocate if out_of_memory throw then 35944603Sdcs then 36044603Sdcs line_buffer .addr ! 36144603Sdcs r> 36244603Sdcs; 36344603Sdcs 36444603Sdcs: append_to_line_buffer ( addr len -- ) 36544603Sdcs line_buffer .addr @ line_buffer .len @ 36644603Sdcs 2swap strcat 36744603Sdcs line_buffer .len ! 36844603Sdcs drop 36944603Sdcs; 37044603Sdcs 37144603Sdcs: read_from_buffer 37244603Sdcs scan_buffer ( -- addr len ) 37344603Sdcs line_buffer_resize ( len -- len ) 37444603Sdcs append_to_line_buffer ( addr len -- ) 37544603Sdcs; 37644603Sdcs 37744603Sdcs: refill_required? 37844603Sdcs read_buffer .len @ read_buffer_ptr = 37944603Sdcs end_of_file? 0= and 38044603Sdcs; 38144603Sdcs 38244603Sdcs: refill_buffer 38344603Sdcs 0 to read_buffer_ptr 38444603Sdcs read_buffer .addr @ 0= if 38544603Sdcs read_buffer_size allocate if out_of_memory throw then 38644603Sdcs read_buffer .addr ! 38744603Sdcs then 38844603Sdcs fd @ read_buffer .addr @ read_buffer_size fread 38944603Sdcs dup -1 = if read_error throw then 39044603Sdcs dup 0= if true to end_of_file? then 39144603Sdcs read_buffer .len ! 39244603Sdcs; 39344603Sdcs 39444603Sdcs: reset_line_buffer 39565615Sdcs line_buffer .addr @ ?dup if 39665615Sdcs free-memory 39765615Sdcs then 39844603Sdcs 0 line_buffer .addr ! 39944603Sdcs 0 line_buffer .len ! 40044603Sdcs; 40144603Sdcs 40265615Sdcssupport-functions definitions 40365615Sdcs 40465615Sdcs: reset_line_reading 40565615Sdcs 0 to read_buffer_ptr 40665615Sdcs; 40765615Sdcs 40844603Sdcs: read_line 40944603Sdcs reset_line_buffer 41044603Sdcs skip_newlines 41144603Sdcs begin 41244603Sdcs read_from_buffer 41344603Sdcs refill_required? 41444603Sdcs while 41544603Sdcs refill_buffer 41644603Sdcs repeat 41744603Sdcs; 41844603Sdcs 41965615Sdcsonly forth also support-functions definitions 42065615Sdcs 42144603Sdcs\ Conf file line parser: 42244603Sdcs\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 42344603Sdcs\ <spaces>[<comment>] 42444603Sdcs\ <name> ::= <letter>{<letter>|<digit>|'_'} 42544603Sdcs\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 42644603Sdcs\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 42744603Sdcs\ <comment> ::= '#'{<anything>} 42865615Sdcs\ 42965615Sdcs\ exported: 43065615Sdcs\ line_pointer 43165615Sdcs\ process_conf 43244603Sdcs 43365615Sdcs0 value line_pointer 43465615Sdcs 43565615Sdcsvocabulary file-processing 43665615Sdcsalso file-processing definitions 43765615Sdcs 43865615Sdcs\ parser functions 43965615Sdcs\ 44065615Sdcs\ exported: 44165615Sdcs\ get_assignment 44265615Sdcs 44365615Sdcsvocabulary parser 44465615Sdcsalso parser definitions also 44565615Sdcs 44644603Sdcs0 value parsing_function 44744603Sdcs0 value end_of_line 44844603Sdcs 44944603Sdcs: end_of_line? 45044603Sdcs line_pointer end_of_line = 45144603Sdcs; 45244603Sdcs 45344603Sdcs: letter? 45444603Sdcs line_pointer c@ >r 45544603Sdcs r@ [char] A >= 45644603Sdcs r@ [char] Z <= and 45744603Sdcs r@ [char] a >= 45844603Sdcs r> [char] z <= and 45944603Sdcs or 46044603Sdcs; 46144603Sdcs 46244603Sdcs: digit? 46344603Sdcs line_pointer c@ >r 46444603Sdcs r@ [char] 0 >= 46544603Sdcs r> [char] 9 <= and 46644603Sdcs; 46744603Sdcs 46844603Sdcs: quote? 46944603Sdcs line_pointer c@ [char] " = 47044603Sdcs; 47144603Sdcs 47244603Sdcs: assignment_sign? 47344603Sdcs line_pointer c@ [char] = = 47444603Sdcs; 47544603Sdcs 47644603Sdcs: comment? 47744603Sdcs line_pointer c@ [char] # = 47844603Sdcs; 47944603Sdcs 48044603Sdcs: space? 48144603Sdcs line_pointer c@ bl = 48244603Sdcs line_pointer c@ tab = or 48344603Sdcs; 48444603Sdcs 48544603Sdcs: backslash? 48644603Sdcs line_pointer c@ [char] \ = 48744603Sdcs; 48844603Sdcs 48944603Sdcs: underscore? 49044603Sdcs line_pointer c@ [char] _ = 49144603Sdcs; 49244603Sdcs 49344603Sdcs: dot? 49444603Sdcs line_pointer c@ [char] . = 49544603Sdcs; 49644603Sdcs 49744603Sdcs: skip_character 49844603Sdcs line_pointer char+ to line_pointer 49944603Sdcs; 50044603Sdcs 50144603Sdcs: skip_to_end_of_line 50244603Sdcs end_of_line to line_pointer 50344603Sdcs; 50444603Sdcs 50544603Sdcs: eat_space 50644603Sdcs begin 50744603Sdcs space? 50844603Sdcs while 50944603Sdcs skip_character 51044603Sdcs end_of_line? if exit then 51144603Sdcs repeat 51244603Sdcs; 51344603Sdcs 51444603Sdcs: parse_name ( -- addr len ) 51544603Sdcs line_pointer 51644603Sdcs begin 51744603Sdcs letter? digit? underscore? dot? or or or 51844603Sdcs while 51944603Sdcs skip_character 52044603Sdcs end_of_line? if 52144603Sdcs line_pointer over - 52244603Sdcs strdup 52344603Sdcs exit 52444603Sdcs then 52544603Sdcs repeat 52644603Sdcs line_pointer over - 52744603Sdcs strdup 52844603Sdcs; 52944603Sdcs 53044603Sdcs: remove_backslashes { addr len | addr' len' -- addr' len' } 53144603Sdcs len allocate if out_of_memory throw then 53244603Sdcs to addr' 53344603Sdcs addr >r 53444603Sdcs begin 53544603Sdcs addr c@ [char] \ <> if 53644603Sdcs addr c@ addr' len' + c! 53744603Sdcs len' char+ to len' 53844603Sdcs then 53944603Sdcs addr char+ to addr 54044603Sdcs r@ len + addr = 54144603Sdcs until 54244603Sdcs r> drop 54344603Sdcs addr' len' 54444603Sdcs; 54544603Sdcs 54644603Sdcs: parse_quote ( -- addr len ) 54744603Sdcs line_pointer 54844603Sdcs skip_character 54944603Sdcs end_of_line? if syntax_error throw then 55044603Sdcs begin 55144603Sdcs quote? 0= 55244603Sdcs while 55344603Sdcs backslash? if 55444603Sdcs skip_character 55544603Sdcs end_of_line? if syntax_error throw then 55644603Sdcs then 55744603Sdcs skip_character 55844603Sdcs end_of_line? if syntax_error throw then 55944603Sdcs repeat 56044603Sdcs skip_character 56144603Sdcs line_pointer over - 56244603Sdcs remove_backslashes 56344603Sdcs; 56444603Sdcs 56544603Sdcs: read_name 56644603Sdcs parse_name ( -- addr len ) 56744603Sdcs name_buffer .len ! 56844603Sdcs name_buffer .addr ! 56944603Sdcs; 57044603Sdcs 57144603Sdcs: read_value 57244603Sdcs quote? if 57344603Sdcs parse_quote ( -- addr len ) 57444603Sdcs else 57544603Sdcs parse_name ( -- addr len ) 57644603Sdcs then 57744603Sdcs value_buffer .len ! 57844603Sdcs value_buffer .addr ! 57944603Sdcs; 58044603Sdcs 58144603Sdcs: comment 58244603Sdcs skip_to_end_of_line 58344603Sdcs; 58444603Sdcs 58544603Sdcs: white_space_4 58644603Sdcs eat_space 58744603Sdcs comment? if ['] comment to parsing_function exit then 58844603Sdcs end_of_line? 0= if syntax_error throw then 58944603Sdcs; 59044603Sdcs 59144603Sdcs: variable_value 59244603Sdcs read_value 59344603Sdcs ['] white_space_4 to parsing_function 59444603Sdcs; 59544603Sdcs 59644603Sdcs: white_space_3 59744603Sdcs eat_space 59844603Sdcs letter? digit? quote? or or if 59944603Sdcs ['] variable_value to parsing_function exit 60044603Sdcs then 60144603Sdcs syntax_error throw 60244603Sdcs; 60344603Sdcs 60444603Sdcs: assignment_sign 60544603Sdcs skip_character 60644603Sdcs ['] white_space_3 to parsing_function 60744603Sdcs; 60844603Sdcs 60944603Sdcs: white_space_2 61044603Sdcs eat_space 61144603Sdcs assignment_sign? if ['] assignment_sign to parsing_function exit then 61244603Sdcs syntax_error throw 61344603Sdcs; 61444603Sdcs 61544603Sdcs: variable_name 61644603Sdcs read_name 61744603Sdcs ['] white_space_2 to parsing_function 61844603Sdcs; 61944603Sdcs 62044603Sdcs: white_space_1 62144603Sdcs eat_space 62244603Sdcs letter? if ['] variable_name to parsing_function exit then 62344603Sdcs comment? if ['] comment to parsing_function exit then 62444603Sdcs end_of_line? 0= if syntax_error throw then 62544603Sdcs; 62644603Sdcs 62765615Sdcsfile-processing definitions 62865615Sdcs 62944603Sdcs: get_assignment 63044603Sdcs line_buffer .addr @ line_buffer .len @ + to end_of_line 63144603Sdcs line_buffer .addr @ to line_pointer 63244603Sdcs ['] white_space_1 to parsing_function 63344603Sdcs begin 63444603Sdcs end_of_line? 0= 63544603Sdcs while 63644603Sdcs parsing_function execute 63744603Sdcs repeat 63844603Sdcs parsing_function ['] comment = 63944603Sdcs parsing_function ['] white_space_1 = 64044603Sdcs parsing_function ['] white_space_4 = 64144603Sdcs or or 0= if syntax_error throw then 64244603Sdcs; 64344603Sdcs 64465615Sdcsonly forth also support-functions also file-processing definitions also 64565615Sdcs 64644603Sdcs\ Process line 64744603Sdcs 64844603Sdcs: assignment_type? ( addr len -- flag ) 64944603Sdcs name_buffer .addr @ name_buffer .len @ 65044603Sdcs compare 0= 65144603Sdcs; 65244603Sdcs 65344603Sdcs: suffix_type? ( addr len -- flag ) 65444603Sdcs name_buffer .len @ over <= if 2drop false exit then 65544603Sdcs name_buffer .len @ over - name_buffer .addr @ + 65644603Sdcs over compare 0= 65744603Sdcs; 65844603Sdcs 65944603Sdcs: loader_conf_files? 66044603Sdcs s" loader_conf_files" assignment_type? 66144603Sdcs; 66244603Sdcs 66344603Sdcs: verbose_flag? 66444603Sdcs s" verbose_loading" assignment_type? 66544603Sdcs; 66644603Sdcs 66744603Sdcs: execute? 66844603Sdcs s" exec" assignment_type? 66944603Sdcs; 67044603Sdcs 67153672Sdcs: password? 67253672Sdcs s" password" assignment_type? 67353672Sdcs; 67453672Sdcs 67544603Sdcs: module_load? 67644603Sdcs load_module_suffix suffix_type? 67744603Sdcs; 67844603Sdcs 67944603Sdcs: module_loadname? 68044603Sdcs module_loadname_suffix suffix_type? 68144603Sdcs; 68244603Sdcs 68344603Sdcs: module_type? 68444603Sdcs module_type_suffix suffix_type? 68544603Sdcs; 68644603Sdcs 68744603Sdcs: module_args? 68844603Sdcs module_args_suffix suffix_type? 68944603Sdcs; 69044603Sdcs 69144603Sdcs: module_beforeload? 69244603Sdcs module_beforeload_suffix suffix_type? 69344603Sdcs; 69444603Sdcs 69544603Sdcs: module_afterload? 69644603Sdcs module_afterload_suffix suffix_type? 69744603Sdcs; 69844603Sdcs 69944603Sdcs: module_loaderror? 70044603Sdcs module_loaderror_suffix suffix_type? 70144603Sdcs; 70244603Sdcs 70344603Sdcs: set_conf_files 70444603Sdcs conf_files .addr @ ?dup if 70544603Sdcs free-memory 70644603Sdcs then 70744603Sdcs value_buffer .addr @ c@ [char] " = if 70844603Sdcs value_buffer .addr @ char+ value_buffer .len @ 2 chars - 70944603Sdcs else 71044603Sdcs value_buffer .addr @ value_buffer .len @ 71144603Sdcs then 71244603Sdcs strdup 71344603Sdcs conf_files .len ! conf_files .addr ! 71444603Sdcs; 71544603Sdcs 71644603Sdcs: append_to_module_options_list ( addr -- ) 71744603Sdcs module_options @ 0= if 71844603Sdcs dup module_options ! 71944603Sdcs last_module_option ! 72044603Sdcs else 72144603Sdcs dup last_module_option @ module.next ! 72244603Sdcs last_module_option ! 72344603Sdcs then 72444603Sdcs; 72544603Sdcs 72644603Sdcs: set_module_name ( addr -- ) 72744603Sdcs name_buffer .addr @ name_buffer .len @ 72844603Sdcs strdup 72944603Sdcs >r over module.name .addr ! 73044603Sdcs r> swap module.name .len ! 73144603Sdcs; 73244603Sdcs 73344603Sdcs: yes_value? 73444603Sdcs value_buffer .addr @ value_buffer .len @ 73544603Sdcs 2dup s' "YES"' compare >r 73644603Sdcs 2dup s' "yes"' compare >r 73744603Sdcs 2dup s" YES" compare >r 73844603Sdcs s" yes" compare r> r> r> and and and 0= 73944603Sdcs; 74044603Sdcs 74144603Sdcs: find_module_option ( -- addr | 0 ) 74244603Sdcs module_options @ 74344603Sdcs begin 74444603Sdcs dup 74544603Sdcs while 74644603Sdcs dup module.name dup .addr @ swap .len @ 74744603Sdcs name_buffer .addr @ name_buffer .len @ 74844603Sdcs compare 0= if exit then 74944603Sdcs module.next @ 75044603Sdcs repeat 75144603Sdcs; 75244603Sdcs 75344603Sdcs: new_module_option ( -- addr ) 75444603Sdcs sizeof module allocate if out_of_memory throw then 75544603Sdcs dup sizeof module erase 75644603Sdcs dup append_to_module_options_list 75744603Sdcs dup set_module_name 75844603Sdcs; 75944603Sdcs 76044603Sdcs: get_module_option ( -- addr ) 76144603Sdcs find_module_option 76244603Sdcs ?dup 0= if new_module_option then 76344603Sdcs; 76444603Sdcs 76544603Sdcs: set_module_flag 76644603Sdcs name_buffer .len @ load_module_suffix nip - name_buffer .len ! 76744603Sdcs yes_value? get_module_option module.flag ! 76844603Sdcs; 76944603Sdcs 77044603Sdcs: set_module_args 77144603Sdcs name_buffer .len @ module_args_suffix nip - name_buffer .len ! 77244603Sdcs get_module_option module.args 77344603Sdcs dup .addr @ ?dup if free-memory then 77444603Sdcs value_buffer .addr @ value_buffer .len @ 77544603Sdcs over c@ [char] " = if 77644603Sdcs 2 chars - swap char+ swap 77744603Sdcs then 77844603Sdcs strdup 77944603Sdcs >r over .addr ! 78044603Sdcs r> swap .len ! 78144603Sdcs; 78244603Sdcs 78344603Sdcs: set_module_loadname 78444603Sdcs name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 78544603Sdcs get_module_option module.loadname 78644603Sdcs dup .addr @ ?dup if free-memory then 78744603Sdcs value_buffer .addr @ value_buffer .len @ 78844603Sdcs over c@ [char] " = if 78944603Sdcs 2 chars - swap char+ swap 79044603Sdcs then 79144603Sdcs strdup 79244603Sdcs >r over .addr ! 79344603Sdcs r> swap .len ! 79444603Sdcs; 79544603Sdcs 79644603Sdcs: set_module_type 79744603Sdcs name_buffer .len @ module_type_suffix nip - name_buffer .len ! 79844603Sdcs get_module_option module.type 79944603Sdcs dup .addr @ ?dup if free-memory then 80044603Sdcs value_buffer .addr @ value_buffer .len @ 80144603Sdcs over c@ [char] " = if 80244603Sdcs 2 chars - swap char+ swap 80344603Sdcs then 80444603Sdcs strdup 80544603Sdcs >r over .addr ! 80644603Sdcs r> swap .len ! 80744603Sdcs; 80844603Sdcs 80944603Sdcs: set_module_beforeload 81044603Sdcs name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 81144603Sdcs get_module_option module.beforeload 81244603Sdcs dup .addr @ ?dup if free-memory then 81344603Sdcs value_buffer .addr @ value_buffer .len @ 81444603Sdcs over c@ [char] " = if 81544603Sdcs 2 chars - swap char+ swap 81644603Sdcs then 81744603Sdcs strdup 81844603Sdcs >r over .addr ! 81944603Sdcs r> swap .len ! 82044603Sdcs; 82144603Sdcs 82244603Sdcs: set_module_afterload 82344603Sdcs name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 82444603Sdcs get_module_option module.afterload 82544603Sdcs dup .addr @ ?dup if free-memory then 82644603Sdcs value_buffer .addr @ value_buffer .len @ 82744603Sdcs over c@ [char] " = if 82844603Sdcs 2 chars - swap char+ swap 82944603Sdcs then 83044603Sdcs strdup 83144603Sdcs >r over .addr ! 83244603Sdcs r> swap .len ! 83344603Sdcs; 83444603Sdcs 83544603Sdcs: set_module_loaderror 83644603Sdcs name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 83744603Sdcs get_module_option module.loaderror 83844603Sdcs dup .addr @ ?dup if free-memory then 83944603Sdcs value_buffer .addr @ value_buffer .len @ 84044603Sdcs over c@ [char] " = if 84144603Sdcs 2 chars - swap char+ swap 84244603Sdcs then 84344603Sdcs strdup 84444603Sdcs >r over .addr ! 84544603Sdcs r> swap .len ! 84644603Sdcs; 84744603Sdcs 84844603Sdcs: set_environment_variable 84944603Sdcs name_buffer .len @ 85044603Sdcs value_buffer .len @ + 85144603Sdcs 5 chars + 85244603Sdcs allocate if out_of_memory throw then 85344603Sdcs dup 0 ( addr -- addr addr len ) 85444603Sdcs s" set " strcat 85544603Sdcs name_buffer .addr @ name_buffer .len @ strcat 85644603Sdcs s" =" strcat 85744603Sdcs value_buffer .addr @ value_buffer .len @ strcat 85844603Sdcs ['] evaluate catch if 85944603Sdcs 2drop free drop 86044603Sdcs set_error throw 86144603Sdcs else 86244603Sdcs free-memory 86344603Sdcs then 86444603Sdcs; 86544603Sdcs 86644603Sdcs: set_verbose 86744603Sdcs yes_value? to verbose? 86844603Sdcs; 86944603Sdcs 87044603Sdcs: execute_command 87144603Sdcs value_buffer .addr @ value_buffer .len @ 87244603Sdcs over c@ [char] " = if 87353672Sdcs 2 - swap char+ swap 87444603Sdcs then 87544603Sdcs ['] evaluate catch if exec_error throw then 87644603Sdcs; 87744603Sdcs 87853672Sdcs: set_password 87953672Sdcs password .addr @ ?dup if free if free_error throw then then 88053672Sdcs value_buffer .addr @ c@ [char] " = if 88153672Sdcs value_buffer .addr @ char+ value_buffer .len @ 2 - strdup 88253672Sdcs value_buffer .addr @ free if free_error throw then 88353672Sdcs else 88453672Sdcs value_buffer .addr @ value_buffer .len @ 88553672Sdcs then 88653672Sdcs password .len ! password .addr ! 88753672Sdcs 0 value_buffer .addr ! 88853672Sdcs; 88953672Sdcs 89044603Sdcs: process_assignment 89144603Sdcs name_buffer .len @ 0= if exit then 89244603Sdcs loader_conf_files? if set_conf_files exit then 89344603Sdcs verbose_flag? if set_verbose exit then 89444603Sdcs execute? if execute_command exit then 89553672Sdcs password? if set_password exit then 89644603Sdcs module_load? if set_module_flag exit then 89744603Sdcs module_loadname? if set_module_loadname exit then 89844603Sdcs module_type? if set_module_type exit then 89944603Sdcs module_args? if set_module_args exit then 90044603Sdcs module_beforeload? if set_module_beforeload exit then 90144603Sdcs module_afterload? if set_module_afterload exit then 90244603Sdcs module_loaderror? if set_module_loaderror exit then 90344603Sdcs set_environment_variable 90444603Sdcs; 90544603Sdcs 90653672Sdcs\ free_buffer ( -- ) 90753672Sdcs\ 90853672Sdcs\ Free some pointers if needed. The code then tests for errors 90953672Sdcs\ in freeing, and throws an exception if needed. If a pointer is 91053672Sdcs\ not allocated, it's value (0) is used as flag. 91153672Sdcs 91244603Sdcs: free_buffers 91344603Sdcs name_buffer .addr @ dup if free then 91444603Sdcs value_buffer .addr @ dup if free then 91565615Sdcs or if free_error throw then 91644603Sdcs; 91744603Sdcs 91844603Sdcs: reset_assignment_buffers 91944603Sdcs 0 name_buffer .addr ! 92044603Sdcs 0 name_buffer .len ! 92144603Sdcs 0 value_buffer .addr ! 92244603Sdcs 0 value_buffer .len ! 92344603Sdcs; 92444603Sdcs 92544603Sdcs\ Higher level file processing 92644603Sdcs 92765615Sdcssupport-functions definitions 92865615Sdcs 92944603Sdcs: process_conf 93044603Sdcs begin 93144603Sdcs end_of_file? 0= 93244603Sdcs while 93344603Sdcs reset_assignment_buffers 93444603Sdcs read_line 93544603Sdcs get_assignment 93644603Sdcs ['] process_assignment catch 93744603Sdcs ['] free_buffers catch 93844603Sdcs swap throw throw 93944603Sdcs repeat 94044603Sdcs; 94144603Sdcs 94265615Sdcsonly forth also support-functions definitions 94365615Sdcs 94444603Sdcs\ Interface to loading conf files 94544603Sdcs 94644603Sdcs: load_conf ( addr len -- ) 94744603Sdcs 0 to end_of_file? 94865615Sdcs reset_line_reading 94987636Sjhb O_RDONLY fopen fd ! 95044603Sdcs fd @ -1 = if open_error throw then 95144603Sdcs ['] process_conf catch 95244603Sdcs fd @ fclose 95344603Sdcs throw 95444603Sdcs; 95544603Sdcs 95644603Sdcs: print_line 95744603Sdcs line_buffer .addr @ line_buffer .len @ type cr 95844603Sdcs; 95944603Sdcs 96044603Sdcs: print_syntax_error 96144603Sdcs line_buffer .addr @ line_buffer .len @ type cr 96244603Sdcs line_buffer .addr @ 96344603Sdcs begin 96444603Sdcs line_pointer over <> 96544603Sdcs while 96644603Sdcs bl emit 96744603Sdcs char+ 96844603Sdcs repeat 96944603Sdcs drop 97044603Sdcs ." ^" cr 97144603Sdcs; 97244603Sdcs 97344603Sdcs\ Depuration support functions 97444603Sdcs 97544603Sdcsonly forth definitions also support-functions 97644603Sdcs 97744603Sdcs: test-file 97844603Sdcs ['] load_conf catch dup . 97944603Sdcs syntax_error = if cr print_syntax_error then 98044603Sdcs; 98144603Sdcs 98244603Sdcs: show-module-options 98344603Sdcs module_options @ 98444603Sdcs begin 98544603Sdcs ?dup 98644603Sdcs while 98744603Sdcs ." Name: " dup module.name dup .addr @ swap .len @ type cr 98844603Sdcs ." Path: " dup module.loadname dup .addr @ swap .len @ type cr 98944603Sdcs ." Type: " dup module.type dup .addr @ swap .len @ type cr 99044603Sdcs ." Flags: " dup module.args dup .addr @ swap .len @ type cr 99144603Sdcs ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr 99244603Sdcs ." After load: " dup module.afterload dup .addr @ swap .len @ type cr 99344603Sdcs ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr 99444603Sdcs ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr 99544603Sdcs module.next @ 99644603Sdcs repeat 99744603Sdcs; 99844603Sdcs 99944603Sdcsonly forth also support-functions definitions 100044603Sdcs 100144603Sdcs\ Variables used for processing multiple conf files 100244603Sdcs 100344603Sdcsstring current_file_name 100444603Sdcsvariable current_conf_files 100544603Sdcs 100644603Sdcs\ Indicates if any conf file was succesfully read 100744603Sdcs 100844603Sdcs0 value any_conf_read? 100944603Sdcs 101044603Sdcs\ loader_conf_files processing support functions 101144603Sdcs 101244603Sdcs: set_current_conf_files 101344603Sdcs conf_files .addr @ current_conf_files ! 101444603Sdcs; 101544603Sdcs 101644603Sdcs: get_conf_files 101744603Sdcs conf_files .addr @ conf_files .len @ strdup 101844603Sdcs; 101944603Sdcs 102044603Sdcs: recurse_on_conf_files? 102144603Sdcs current_conf_files @ conf_files .addr @ <> 102244603Sdcs; 102344603Sdcs 102453672Sdcs: skip_leading_spaces { addr len pos -- addr len pos' } 102544603Sdcs begin 102653672Sdcs pos len = if addr len pos exit then 102753672Sdcs addr pos + c@ bl = 102844603Sdcs while 102953672Sdcs pos char+ to pos 103044603Sdcs repeat 103153672Sdcs addr len pos 103244603Sdcs; 103344603Sdcs 103453672Sdcs: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 103553672Sdcs pos len = if 103644603Sdcs addr free abort" Fatal error freeing memory" 103744603Sdcs 0 exit 103844603Sdcs then 103953672Sdcs pos >r 104044603Sdcs begin 104153672Sdcs addr pos + c@ bl <> 104244603Sdcs while 104353672Sdcs pos char+ to pos 104453672Sdcs pos len = if 104553672Sdcs addr len pos addr r@ + pos r> - exit 104644603Sdcs then 104744603Sdcs repeat 104853672Sdcs addr len pos addr r@ + pos r> - 104944603Sdcs; 105044603Sdcs 105144603Sdcs: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 105244603Sdcs skip_leading_spaces 105344603Sdcs get_file_name 105444603Sdcs; 105544603Sdcs 105644603Sdcs: set_current_file_name 105744603Sdcs over current_file_name .addr ! 105844603Sdcs dup current_file_name .len ! 105944603Sdcs; 106044603Sdcs 106144603Sdcs: print_current_file 106244603Sdcs current_file_name .addr @ current_file_name .len @ type 106344603Sdcs; 106444603Sdcs 106544603Sdcs: process_conf_errors 106644603Sdcs dup 0= if true to any_conf_read? drop exit then 106744603Sdcs >r 2drop r> 106844603Sdcs dup syntax_error = if 106944603Sdcs ." Warning: syntax error on file " print_current_file cr 107044603Sdcs print_syntax_error drop exit 107144603Sdcs then 107244603Sdcs dup set_error = if 107344603Sdcs ." Warning: bad definition on file " print_current_file cr 107444603Sdcs print_line drop exit 107544603Sdcs then 107644603Sdcs dup read_error = if 107744603Sdcs ." Warning: error reading file " print_current_file cr drop exit 107844603Sdcs then 107944603Sdcs dup open_error = if 108044603Sdcs verbose? if ." Warning: unable to open file " print_current_file cr then 108144603Sdcs drop exit 108244603Sdcs then 108344603Sdcs dup free_error = abort" Fatal error freeing memory" 108444603Sdcs dup out_of_memory = abort" Out of memory" 108544603Sdcs throw \ Unknown error -- pass ahead 108644603Sdcs; 108744603Sdcs 108844603Sdcs\ Process loader_conf_files recursively 108944603Sdcs\ Interface to loader_conf_files processing 109044603Sdcs 109144603Sdcs: include_conf_files 109244603Sdcs set_current_conf_files 109344603Sdcs get_conf_files 0 109444603Sdcs begin 109544603Sdcs get_next_file ?dup 109644603Sdcs while 109744603Sdcs set_current_file_name 109844603Sdcs ['] load_conf catch 109944603Sdcs process_conf_errors 110044603Sdcs recurse_on_conf_files? if recurse then 110144603Sdcs repeat 110244603Sdcs; 110344603Sdcs 110444603Sdcs\ Module loading functions 110544603Sdcs 110644603Sdcs: load_module? 110744603Sdcs module.flag @ 110844603Sdcs; 110944603Sdcs 111044603Sdcs: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N ) 111144603Sdcs dup >r 111244603Sdcs r@ module.args .addr @ r@ module.args .len @ 111344603Sdcs r@ module.loadname .len @ if 111444603Sdcs r@ module.loadname .addr @ r@ module.loadname .len @ 111544603Sdcs else 111644603Sdcs r@ module.name .addr @ r@ module.name .len @ 111744603Sdcs then 111844603Sdcs r@ module.type .len @ if 111944603Sdcs r@ module.type .addr @ r@ module.type .len @ 112044603Sdcs s" -t " 112144603Sdcs 4 ( -t type name flags ) 112244603Sdcs else 112344603Sdcs 2 ( name flags ) 112444603Sdcs then 112544603Sdcs r> drop 112644603Sdcs; 112744603Sdcs 112844603Sdcs: before_load ( addr -- addr ) 112944603Sdcs dup module.beforeload .len @ if 113044603Sdcs dup module.beforeload .addr @ over module.beforeload .len @ 113144603Sdcs ['] evaluate catch if before_load_error throw then 113244603Sdcs then 113344603Sdcs; 113444603Sdcs 113544603Sdcs: after_load ( addr -- addr ) 113644603Sdcs dup module.afterload .len @ if 113744603Sdcs dup module.afterload .addr @ over module.afterload .len @ 113844603Sdcs ['] evaluate catch if after_load_error throw then 113944603Sdcs then 114044603Sdcs; 114144603Sdcs 114244603Sdcs: load_error ( addr -- addr ) 114344603Sdcs dup module.loaderror .len @ if 114444603Sdcs dup module.loaderror .addr @ over module.loaderror .len @ 114544603Sdcs evaluate \ This we do not intercept so it can throw errors 114644603Sdcs then 114744603Sdcs; 114844603Sdcs 114944603Sdcs: pre_load_message ( addr -- addr ) 115044603Sdcs verbose? if 115144603Sdcs dup module.name .addr @ over module.name .len @ type 115244603Sdcs ." ..." 115344603Sdcs then 115444603Sdcs; 115544603Sdcs 115644603Sdcs: load_error_message verbose? if ." failed!" cr then ; 115744603Sdcs 115844603Sdcs: load_succesful_message verbose? if ." ok" cr then ; 115944603Sdcs 116044603Sdcs: load_module 116144603Sdcs load_parameters load 116244603Sdcs; 116344603Sdcs 116444603Sdcs: process_module ( addr -- addr ) 116544603Sdcs pre_load_message 116644603Sdcs before_load 116744603Sdcs begin 116844603Sdcs ['] load_module catch if 116944603Sdcs dup module.loaderror .len @ if 117044603Sdcs load_error \ Command should return a flag! 117144603Sdcs else 117244603Sdcs load_error_message true \ Do not retry 117344603Sdcs then 117444603Sdcs else 117544603Sdcs after_load 117644603Sdcs load_succesful_message true \ Succesful, do not retry 117744603Sdcs then 117844603Sdcs until 117944603Sdcs; 118044603Sdcs 118144603Sdcs: process_module_errors ( addr ior -- ) 118244603Sdcs dup before_load_error = if 118344603Sdcs drop 118444603Sdcs ." Module " 118544603Sdcs dup module.name .addr @ over module.name .len @ type 118644603Sdcs dup module.loadname .len @ if 118744603Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 118844603Sdcs then 118944603Sdcs cr 119044603Sdcs ." Error executing " 119144603Sdcs dup module.beforeload .addr @ over module.afterload .len @ type cr 119244603Sdcs abort 119344603Sdcs then 119444603Sdcs 119544603Sdcs dup after_load_error = if 119644603Sdcs drop 119744603Sdcs ." Module " 119844603Sdcs dup module.name .addr @ over module.name .len @ type 119944603Sdcs dup module.loadname .len @ if 120044603Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 120144603Sdcs then 120244603Sdcs cr 120344603Sdcs ." Error executing " 120444603Sdcs dup module.afterload .addr @ over module.afterload .len @ type cr 120544603Sdcs abort 120644603Sdcs then 120744603Sdcs 120844603Sdcs throw \ Don't know what it is all about -- pass ahead 120944603Sdcs; 121044603Sdcs 121144603Sdcs\ Module loading interface 121244603Sdcs 121344603Sdcs: load_modules ( -- ) ( throws: abort & user-defined ) 121444603Sdcs module_options @ 121544603Sdcs begin 121644603Sdcs ?dup 121744603Sdcs while 121844603Sdcs dup load_module? if 121944603Sdcs ['] process_module catch 122044603Sdcs process_module_errors 122144603Sdcs then 122244603Sdcs module.next @ 122344603Sdcs repeat 122444603Sdcs; 122544603Sdcs 122665630Sdcs\ h00h00 magic used to try loading either a kernel with a given name, 122765630Sdcs\ or a kernel with the default name in a directory of a given name 122865630Sdcs\ (the pain!) 122944603Sdcs 123065630Sdcs: bootpath s" /boot/" ; 123165630Sdcs: modulepath s" module_path" ; 123265630Sdcs 123365630Sdcs\ Functions used to save and restore module_path's value. 123465630Sdcs: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 123565630Sdcs dup -1 = if 0 swap exit then 123665630Sdcs strdup 123765630Sdcs; 123865630Sdcs: freeenv ( addr len | 0 -1 ) 123965630Sdcs -1 = if drop else free abort" Freeing error" then 124065630Sdcs; 124165630Sdcs: restoreenv ( addr len | 0 -1 -- ) 124265630Sdcs dup -1 = if ( it wasn't set ) 124365630Sdcs 2drop 124465630Sdcs modulepath unsetenv 124565630Sdcs else 124665630Sdcs over >r 124765630Sdcs modulepath setenv 124865630Sdcs r> free abort" Freeing error" 124965630Sdcs then 125065630Sdcs; 125165630Sdcs 125265630Sdcs: clip_args \ Drop second string if only one argument is passed 125365630Sdcs 1 = if 125465630Sdcs 2swap 2drop 125565630Sdcs 1 125665630Sdcs else 125765630Sdcs 2 125865630Sdcs then 125965630Sdcs; 126065630Sdcs 126165630Sdcsalso builtins 126265630Sdcs 126365630Sdcs\ Parse filename from a comma-separated list 126465630Sdcs 126565630Sdcs: parse-; ( addr len -- addr' len-x addr x ) 126665630Sdcs over 0 2swap 126765630Sdcs begin 126865630Sdcs dup 0 <> 126965630Sdcs while 127065630Sdcs over c@ [char] ; <> 127165630Sdcs while 127265630Sdcs 1- swap 1+ swap 127365630Sdcs 2swap 1+ 2swap 127465630Sdcs repeat then 127565630Sdcs dup 0 <> if 127665630Sdcs 1- swap 1+ swap 127765630Sdcs then 127865630Sdcs 2swap 127965630Sdcs; 128065630Sdcs 128165630Sdcs\ Try loading one of multiple kernels specified 128265630Sdcs 128365630Sdcs: try_multiple_kernels ( addr len addr' len' args -- flag ) 128465630Sdcs >r 128565630Sdcs begin 128665630Sdcs parse-; 2>r 128765630Sdcs 2over 2r> 128865945Sdcs r@ clip_args 128965945Sdcs s" DEBUG" getenv? if 129065945Sdcs s" echo Module_path: ${module_path}" evaluate 129165945Sdcs ." Kernel : " >r 2dup type r> cr 129265945Sdcs dup 2 = if ." Flags : " >r 2over type r> cr then 129365945Sdcs then 129465945Sdcs 1 load 129565630Sdcs while 129665630Sdcs dup 0= 129765630Sdcs until 129865630Sdcs 1 >r \ Failure 129965630Sdcs else 130065630Sdcs 0 >r \ Success 130165630Sdcs then 130265630Sdcs 2drop 2drop 130365630Sdcs r> 130465630Sdcs r> drop 130565630Sdcs; 130665630Sdcs 130765630Sdcs\ Try to load a kernel; the kernel name is taken from one of 130865630Sdcs\ the following lists, as ordered: 130965630Sdcs\ 131065641Sdcs\ 1. The "bootfile" environment variable 131165641Sdcs\ 2. The "kernel" environment variable 131265630Sdcs\ 131365938Sdcs\ Flags are passed, if available. If not, dummy values must be given. 131465630Sdcs\ 131565630Sdcs\ The kernel gets loaded from the current module_path. 131665630Sdcs 131765938Sdcs: load_a_kernel ( flags len 1 | x x 0 -- flag ) 131865630Sdcs local args 131965630Sdcs 2local flags 132065630Sdcs 0 0 2local kernel 132165630Sdcs end-locals 132265630Sdcs 132365630Sdcs \ Check if a default kernel name exists at all, exits if not 132465641Sdcs s" bootfile" getenv dup -1 <> if 132565630Sdcs to kernel 132665883Sdcs flags kernel args 1+ try_multiple_kernels 132765630Sdcs dup 0= if exit then 132865630Sdcs then 132965630Sdcs drop 133065630Sdcs 133165641Sdcs s" kernel" getenv dup -1 <> if 133265630Sdcs to kernel 133365630Sdcs else 133465630Sdcs drop 133565630Sdcs 1 exit \ Failure 133665630Sdcs then 133765630Sdcs 133865630Sdcs \ Try all default kernel names 133965883Sdcs flags kernel args 1+ try_multiple_kernels 134065630Sdcs; 134165630Sdcs 134265630Sdcs\ Try to load a kernel; the kernel name is taken from one of 134365630Sdcs\ the following lists, as ordered: 134465630Sdcs\ 134565641Sdcs\ 1. The "bootfile" environment variable 134665641Sdcs\ 2. The "kernel" environment variable 134765630Sdcs\ 134865630Sdcs\ Flags are passed, if provided. 134965630Sdcs\ 135065630Sdcs\ The kernel will be loaded from a directory computed from the 135165630Sdcs\ path given. Two directories will be tried in the following order: 135265630Sdcs\ 135365630Sdcs\ 1. /boot/path 135465630Sdcs\ 2. path 135565630Sdcs\ 135665630Sdcs\ The module_path variable is overridden if load is succesful, by 135765630Sdcs\ prepending the successful path. 135865630Sdcs 135965630Sdcs: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 136065630Sdcs local args 136165630Sdcs 2local path 136265630Sdcs args 1 = if 0 0 then 136365630Sdcs 2local flags 136465630Sdcs 0 0 2local oldmodulepath 136565630Sdcs 0 0 2local newmodulepath 136665630Sdcs end-locals 136765630Sdcs 136865630Sdcs \ Set the environment variable module_path, and try loading 136965630Sdcs \ the kernel again. 137065630Sdcs modulepath getenv saveenv to oldmodulepath 137165630Sdcs 137265630Sdcs \ Try prepending /boot/ first 137365630Sdcs bootpath nip path nip + 137465630Sdcs oldmodulepath nip dup -1 = if 137565630Sdcs drop 137665630Sdcs else 137765630Sdcs 1+ + 137865630Sdcs then 137965630Sdcs allocate 138065630Sdcs if ( out of memory ) 138165630Sdcs 1 exit 138265630Sdcs then 138365630Sdcs 138465630Sdcs 0 138565630Sdcs bootpath strcat 138665630Sdcs path strcat 138765630Sdcs 2dup to newmodulepath 138865630Sdcs modulepath setenv 138965630Sdcs 139065630Sdcs \ Try all default kernel names 139165938Sdcs flags args 1- load_a_kernel 139265630Sdcs 0= if ( success ) 139365630Sdcs oldmodulepath nip -1 <> if 139465630Sdcs newmodulepath s" ;" strcat 139565630Sdcs oldmodulepath strcat 139665630Sdcs modulepath setenv 139765630Sdcs newmodulepath drop free-memory 139865630Sdcs oldmodulepath drop free-memory 139965630Sdcs then 140065630Sdcs 0 exit 140165630Sdcs then 140265630Sdcs 140365630Sdcs \ Well, try without the prepended /boot/ 140465630Sdcs path newmodulepath drop swap move 140565883Sdcs newmodulepath drop path nip 140665630Sdcs 2dup to newmodulepath 140765630Sdcs modulepath setenv 140865630Sdcs 140965630Sdcs \ Try all default kernel names 141065938Sdcs flags args 1- load_a_kernel 141165630Sdcs if ( failed once more ) 141265630Sdcs oldmodulepath restoreenv 141365630Sdcs newmodulepath drop free-memory 141465630Sdcs 1 141565630Sdcs else 141665630Sdcs oldmodulepath nip -1 <> if 141765630Sdcs newmodulepath s" ;" strcat 141865630Sdcs oldmodulepath strcat 141965630Sdcs modulepath setenv 142065630Sdcs newmodulepath drop free-memory 142165630Sdcs oldmodulepath drop free-memory 142265630Sdcs then 142365630Sdcs 0 142465630Sdcs then 142565630Sdcs; 142665630Sdcs 142765630Sdcs\ Try to load a kernel; the kernel name is taken from one of 142865630Sdcs\ the following lists, as ordered: 142965630Sdcs\ 143065641Sdcs\ 1. The "bootfile" environment variable 143165641Sdcs\ 2. The "kernel" environment variable 143265630Sdcs\ 3. The "path" argument 143365630Sdcs\ 143465630Sdcs\ Flags are passed, if provided. 143565630Sdcs\ 143665630Sdcs\ The kernel will be loaded from a directory computed from the 143765630Sdcs\ path given. Two directories will be tried in the following order: 143865630Sdcs\ 143965630Sdcs\ 1. /boot/path 144065630Sdcs\ 2. path 144165630Sdcs\ 144265630Sdcs\ Unless "path" is meant to be kernel name itself. In that case, it 144365630Sdcs\ will first be tried as a full path, and, next, search on the 144465630Sdcs\ directories pointed by module_path. 144565630Sdcs\ 144665630Sdcs\ The module_path variable is overridden if load is succesful, by 144765630Sdcs\ prepending the successful path. 144865630Sdcs 144965630Sdcs: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 145065630Sdcs local args 145165630Sdcs 2local path 145265630Sdcs args 1 = if 0 0 then 145365630Sdcs 2local flags 145465630Sdcs end-locals 145565630Sdcs 145665630Sdcs \ First, assume path is an absolute path to a directory 145765630Sdcs flags path args clip_args load_from_directory 145865630Sdcs dup 0= if exit else drop then 145965630Sdcs 146065630Sdcs \ Next, assume path points to the kernel 146165630Sdcs flags path args try_multiple_kernels 146265630Sdcs; 146365630Sdcs 146444603Sdcs: initialize ( addr len -- ) 146544603Sdcs strdup conf_files .len ! conf_files .addr ! 146644603Sdcs; 146744603Sdcs 146865883Sdcs: kernel_options ( -- addr len 1 | 0 ) 146965630Sdcs s" kernel_options" getenv 147065883Sdcs dup -1 = if drop 0 else 1 then 147165630Sdcs; 147265630Sdcs 147365938Sdcs: standard_kernel_search ( flags 1 | 0 -- flag ) 147465938Sdcs local args 147565938Sdcs args 0= if 0 0 then 147665938Sdcs 2local flags 147765630Sdcs s" kernel" getenv 147865938Sdcs dup -1 = if 0 swap then 147965938Sdcs 2local path 148065938Sdcs end-locals 148165938Sdcs 148266349Sdcs path nip -1 = if ( there isn't a "kernel" environment variable ) 148365938Sdcs flags args load_a_kernel 148465938Sdcs else 148565938Sdcs flags path args 1+ clip_args load_directory_or_file 148665938Sdcs then 148765630Sdcs; 148865630Sdcs 148944603Sdcs: load_kernel ( -- ) ( throws: abort ) 149065938Sdcs kernel_options standard_kernel_search 149165630Sdcs abort" Unable to load a kernel!" 149244603Sdcs; 149365883Sdcs 149465949Sdcs: set_defaultoptions ( -- ) 149565883Sdcs s" kernel_options" getenv dup -1 = if 149665883Sdcs drop 149765883Sdcs else 149865883Sdcs s" temp_options" setenv 149965883Sdcs then 150065883Sdcs; 150165883Sdcs 150265883Sdcs: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 150365883Sdcs 2dup = if 0 0 exit then 150465883Sdcs dup >r 150565883Sdcs 1+ 2* ( skip N and ui ) 150665883Sdcs pick 150765883Sdcs r> 150865883Sdcs 1+ 2* ( skip N and ai ) 150965883Sdcs pick 151065883Sdcs; 151165883Sdcs 151265949Sdcs: drop_args ( aN uN ... a1 u1 N -- ) 151365883Sdcs 0 ?do 2drop loop 151465883Sdcs; 151565883Sdcs 151665883Sdcs: argc 151765883Sdcs dup 151865883Sdcs; 151965883Sdcs 152065949Sdcs: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 152165883Sdcs >r 152265883Sdcs over 2* 1+ -roll 152365883Sdcs r> 152465883Sdcs over 2* 1+ -roll 152565883Sdcs 1+ 152665883Sdcs; 152765883Sdcs 152865949Sdcs: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 152965883Sdcs 1- -rot 153065883Sdcs; 153165883Sdcs 153265883Sdcs: strlen(argv) 153365883Sdcs dup 0= if 0 exit then 153465883Sdcs 0 >r \ Size 153565883Sdcs 0 >r \ Index 153665883Sdcs begin 153765883Sdcs argc r@ <> 153865883Sdcs while 153965883Sdcs r@ argv[] 154065883Sdcs nip 154165883Sdcs r> r> rot + 1+ 154265883Sdcs >r 1+ >r 154365883Sdcs repeat 154465883Sdcs r> drop 154565883Sdcs r> 154665883Sdcs; 154765883Sdcs 154865949Sdcs: concat_argv ( aN uN ... a1 u1 N -- a u ) 154965883Sdcs strlen(argv) allocate if out_of_memory throw then 155065883Sdcs 0 2>r 155165883Sdcs 155265883Sdcs begin 155365883Sdcs argc 155465883Sdcs while 155565949Sdcs unqueue_argv 155665883Sdcs 2r> 2swap 155765883Sdcs strcat 155865883Sdcs s" " strcat 155965883Sdcs 2>r 156065883Sdcs repeat 156165949Sdcs drop_args 156265883Sdcs 2r> 156365883Sdcs; 156465883Sdcs 156565949Sdcs: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 156665883Sdcs \ Save the first argument, if it exists and is not a flag 156765883Sdcs argc if 156865883Sdcs 0 argv[] drop c@ [char] - <> if 156965949Sdcs unqueue_argv 2>r \ Filename 157065883Sdcs 1 >r \ Filename present 157165883Sdcs else 157265883Sdcs 0 >r \ Filename not present 157365883Sdcs then 157465883Sdcs else 157565883Sdcs 0 >r \ Filename not present 157665883Sdcs then 157765883Sdcs 157865883Sdcs \ If there are other arguments, assume they are flags 157965883Sdcs ?dup if 158065949Sdcs concat_argv 158165883Sdcs 2dup s" temp_options" setenv 158265883Sdcs drop free if free_error throw then 158365883Sdcs else 158465949Sdcs set_defaultoptions 158565883Sdcs then 158665883Sdcs 158765883Sdcs \ Bring back the filename, if one was provided 158865883Sdcs r> if 2r> 1 else 0 then 158965883Sdcs; 159065883Sdcs 159165949Sdcs: get_arguments ( -- addrN lenN ... addr1 len1 N ) 159265883Sdcs 0 159365883Sdcs begin 159465883Sdcs \ Get next word on the command line 159565883Sdcs parse-word 159665883Sdcs ?dup while 159765949Sdcs queue_argv 159865883Sdcs repeat 159965883Sdcs drop ( empty string ) 160065883Sdcs; 160165883Sdcs 160265945Sdcs: load_kernel_and_modules ( args -- flag ) 160365949Sdcs set_tempoptions 160465883Sdcs argc >r 160565883Sdcs s" temp_options" getenv dup -1 <> if 160665949Sdcs queue_argv 160765883Sdcs else 160865883Sdcs drop 160965883Sdcs then 161065883Sdcs r> if ( a path was passed ) 161165938Sdcs load_directory_or_file 161265883Sdcs else 161365938Sdcs standard_kernel_search 161465883Sdcs then 161565938Sdcs ?dup 0= if ['] load_modules catch then 161665883Sdcs; 161765883Sdcs 161853672Sdcs: read-password { size | buf len -- } 161953672Sdcs size allocate if out_of_memory throw then 162053672Sdcs to buf 162153672Sdcs 0 to len 162253672Sdcs begin 162353672Sdcs key 162453672Sdcs dup backspace = if 162553672Sdcs drop 162653672Sdcs len if 162753672Sdcs backspace emit bl emit backspace emit 162853672Sdcs len 1 - to len 162953672Sdcs else 163053672Sdcs bell emit 163153672Sdcs then 163253672Sdcs else 163353672Sdcs dup <cr> = if cr drop buf len exit then 163453672Sdcs [char] * emit 163553672Sdcs len size < if 163653672Sdcs buf len chars + c! 163753672Sdcs else 163853672Sdcs drop 163953672Sdcs then 164053672Sdcs len 1+ to len 164153672Sdcs then 164253672Sdcs again 164353672Sdcs; 164453672Sdcs 164544603Sdcs\ Go back to straight forth vocabulary 164644603Sdcs 164744603Sdcsonly forth also definitions 164844603Sdcs 1649