support.4th revision 185746
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 185746 2008-12-07 19:42:20Z luigi $ 2644603Sdcs 2744603Sdcs\ Loader.rc support functions: 2844603Sdcs\ 2944603Sdcs\ initialize_support ( -- ) initialize global variables 3044603Sdcs\ initialize ( addr len -- ) as above, plus load_conf_files 3144603Sdcs\ load_conf ( addr len -- ) load conf file given 3244603Sdcs\ include_conf_files ( -- ) load all conf files in load_conf_files 3344603Sdcs\ print_syntax_error ( -- ) print line and marker of where a syntax 3444603Sdcs\ error was detected 3544603Sdcs\ print_line ( -- ) print last line processed 3644603Sdcs\ load_kernel ( -- ) load kernel 3744603Sdcs\ load_modules ( -- ) load modules flagged 3844603Sdcs\ 3944603Sdcs\ Exported structures: 4044603Sdcs\ 4144603Sdcs\ string counted string structure 4244603Sdcs\ cell .addr string address 4344603Sdcs\ cell .len string length 4444603Sdcs\ module module loading information structure 4544603Sdcs\ cell module.flag should we load it? 4644603Sdcs\ string module.name module's name 4744603Sdcs\ string module.loadname name to be used in loading the module 4844603Sdcs\ string module.type module's type 4944603Sdcs\ string module.args flags to be passed during load 5044603Sdcs\ string module.beforeload command to be executed before load 5144603Sdcs\ string module.afterload command to be executed after load 5244603Sdcs\ string module.loaderror command to be executed if load fails 5344603Sdcs\ cell module.next list chain 5444603Sdcs\ 5544603Sdcs\ Exported global variables; 5644603Sdcs\ 5744603Sdcs\ string conf_files configuration files to be loaded 5853672Sdcs\ string password password 5944603Sdcs\ cell modules_options pointer to first module information 6044603Sdcs\ value verbose? indicates if user wants a verbose loading 6144603Sdcs\ value any_conf_read? indicates if a conf file was succesfully read 6244603Sdcs\ 6344603Sdcs\ Other exported words: 6444603Sdcs\ 6544603Sdcs\ strdup ( addr len -- addr' len) similar to strdup(3) 6644603Sdcs\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3) 6761373Sdcs\ strlen ( addr -- len ) similar to strlen(3) 6844603Sdcs\ s' ( | string' -- addr len | ) similar to s" 6944603Sdcs\ rudimentary structure support 7044603Sdcs 7144603Sdcs\ Exception values 7244603Sdcs 7344603Sdcs1 constant syntax_error 7444603Sdcs2 constant out_of_memory 7544603Sdcs3 constant free_error 7644603Sdcs4 constant set_error 7744603Sdcs5 constant read_error 7844603Sdcs6 constant open_error 7944603Sdcs7 constant exec_error 8044603Sdcs8 constant before_load_error 8144603Sdcs9 constant after_load_error 8244603Sdcs 8387636Sjhb\ I/O constants 8487636Sjhb 8587636Sjhb0 constant SEEK_SET 8687636Sjhb1 constant SEEK_CUR 8787636Sjhb2 constant SEEK_END 8887636Sjhb 8987636Sjhb0 constant O_RDONLY 9087636Sjhb1 constant O_WRONLY 9187636Sjhb2 constant O_RDWR 9287636Sjhb 9344603Sdcs\ Crude structure support 9444603Sdcs 9565615Sdcs: structure: 9665615Sdcs create here 0 , ['] drop , 0 9765615Sdcs does> create here swap dup @ allot cell+ @ execute 9865615Sdcs; 9944603Sdcs: member: create dup , over , + does> cell+ @ + ; 10044603Sdcs: ;structure swap ! ; 10165615Sdcs: constructor! >body cell+ ! ; 10265615Sdcs: constructor: over :noname ; 10365615Sdcs: ;constructor postpone ; swap cell+ ! ; immediate 10444603Sdcs: sizeof ' >body @ state @ if postpone literal then ; immediate 10544603Sdcs: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate 10644603Sdcs: ptr 1 cells member: ; 10744603Sdcs: int 1 cells member: ; 10844603Sdcs 10944603Sdcs\ String structure 11044603Sdcs 11144603Sdcsstructure: string 11244603Sdcs ptr .addr 11344603Sdcs int .len 11465615Sdcs constructor: 11565615Sdcs 0 over .addr ! 11665615Sdcs 0 swap .len ! 11765615Sdcs ;constructor 11844603Sdcs;structure 11944603Sdcs 12065615Sdcs 12144603Sdcs\ Module options linked list 12244603Sdcs 12344603Sdcsstructure: module 12444603Sdcs int module.flag 12544603Sdcs sizeof string member: module.name 12644603Sdcs sizeof string member: module.loadname 12744603Sdcs sizeof string member: module.type 12844603Sdcs sizeof string member: module.args 12944603Sdcs sizeof string member: module.beforeload 13044603Sdcs sizeof string member: module.afterload 13144603Sdcs sizeof string member: module.loaderror 13244603Sdcs ptr module.next 13344603Sdcs;structure 13444603Sdcs 13565615Sdcs\ Internal loader structures 13665615Sdcsstructure: preloaded_file 13765615Sdcs ptr pf.name 13865615Sdcs ptr pf.type 13965615Sdcs ptr pf.args 14065615Sdcs ptr pf.metadata \ file_metadata 14165615Sdcs int pf.loader 14265615Sdcs int pf.addr 14365615Sdcs int pf.size 14465615Sdcs ptr pf.modules \ kernel_module 14565615Sdcs ptr pf.next \ preloaded_file 14665615Sdcs;structure 14765615Sdcs 14865615Sdcsstructure: kernel_module 14965615Sdcs ptr km.name 15065615Sdcs \ ptr km.args 15165615Sdcs ptr km.fp \ preloaded_file 15265615Sdcs ptr km.next \ kernel_module 15365615Sdcs;structure 15465615Sdcs 15565615Sdcsstructure: file_metadata 15665615Sdcs int md.size 15765615Sdcs 2 member: md.type \ this is not ANS Forth compatible (XXX) 15865615Sdcs ptr md.next \ file_metadata 15965615Sdcs 0 member: md.data \ variable size 16065615Sdcs;structure 16165615Sdcs 16265615Sdcsstructure: config_resource 16365615Sdcs ptr cf.name 16465615Sdcs int cf.type 16565615Sdcs0 constant RES_INT 16665615Sdcs1 constant RES_STRING 16765615Sdcs2 constant RES_LONG 16865615Sdcs 2 cells member: u 16965615Sdcs;structure 17065615Sdcs 17165615Sdcsstructure: config_device 17265615Sdcs ptr cd.name 17365615Sdcs int cd.unit 17465615Sdcs int cd.resource_count 17565615Sdcs ptr cd.resources \ config_resource 17665615Sdcs;structure 17765615Sdcs 17865615Sdcsstructure: STAILQ_HEAD 17965615Sdcs ptr stqh_first \ type* 18065615Sdcs ptr stqh_last \ type** 18165615Sdcs;structure 18265615Sdcs 18365615Sdcsstructure: STAILQ_ENTRY 18465615Sdcs ptr stqe_next \ type* 18565615Sdcs;structure 18665615Sdcs 18765615Sdcsstructure: pnphandler 18865615Sdcs ptr pnph.name 18965615Sdcs ptr pnph.enumerate 19065615Sdcs;structure 19165615Sdcs 19265615Sdcsstructure: pnpident 19365615Sdcs ptr pnpid.ident \ char* 19465615Sdcs sizeof STAILQ_ENTRY cells member: pnpid.link \ pnpident 19565615Sdcs;structure 19665615Sdcs 19765615Sdcsstructure: pnpinfo 19865615Sdcs ptr pnpi.desc 19965615Sdcs int pnpi.revision 20065615Sdcs ptr pnpi.module \ (char*) module args 20165615Sdcs int pnpi.argc 20265615Sdcs ptr pnpi.argv 20365615Sdcs ptr pnpi.handler \ pnphandler 20465615Sdcs sizeof STAILQ_HEAD member: pnpi.ident \ pnpident 20565615Sdcs sizeof STAILQ_ENTRY member: pnpi.link \ pnpinfo 20665615Sdcs;structure 20765615Sdcs 20844603Sdcs\ Global variables 20944603Sdcs 21044603Sdcsstring conf_files 21197201Sgordonstring nextboot_conf_file 21253672Sdcsstring password 21365615Sdcscreate module_options sizeof module.next allot 0 module_options ! 21465615Sdcscreate last_module_option sizeof module.next allot 0 last_module_option ! 21544603Sdcs0 value verbose? 21697201Sgordon0 value nextboot? 21744603Sdcs 21844603Sdcs\ Support string functions 21944603Sdcs 22044603Sdcs: strdup ( addr len -- addr' len ) 22144603Sdcs >r r@ allocate if out_of_memory throw then 22244603Sdcs tuck r@ move 22344603Sdcs r> 22444603Sdcs; 22544603Sdcs 22644603Sdcs: strcat { addr len addr' len' -- addr len+len' } 22744603Sdcs addr' addr len + len' move 22844603Sdcs addr len len' + 22944603Sdcs; 23044603Sdcs 23161373Sdcs: strlen ( addr -- len ) 23261373Sdcs 0 >r 23361373Sdcs begin 23461373Sdcs dup c@ while 23561373Sdcs 1+ r> 1+ >r repeat 23661373Sdcs drop r> 23761373Sdcs; 23861373Sdcs 23944603Sdcs: s' 24044603Sdcs [char] ' parse 24144603Sdcs state @ if 24244603Sdcs postpone sliteral 24344603Sdcs then 24444603Sdcs; immediate 24544603Sdcs 24661373Sdcs: 2>r postpone >r postpone >r ; immediate 24761373Sdcs: 2r> postpone r> postpone r> ; immediate 24865883Sdcs: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate 24953672Sdcs 25065938Sdcs: getenv? 25165938Sdcs getenv 25265938Sdcs -1 = if false else drop true then 25365938Sdcs; 25465938Sdcs 25544603Sdcs\ Private definitions 25644603Sdcs 25744603Sdcsvocabulary support-functions 25844603Sdcsonly forth also support-functions definitions 25944603Sdcs 26044603Sdcs\ Some control characters constants 26144603Sdcs 26253672Sdcs7 constant bell 26353672Sdcs8 constant backspace 26444603Sdcs9 constant tab 26544603Sdcs10 constant lf 26653672Sdcs13 constant <cr> 26744603Sdcs 26844603Sdcs\ Read buffer size 26944603Sdcs 27044603Sdcs80 constant read_buffer_size 27144603Sdcs 27244603Sdcs\ Standard suffixes 27344603Sdcs 27444603Sdcs: load_module_suffix s" _load" ; 27544603Sdcs: module_loadname_suffix s" _name" ; 27644603Sdcs: module_type_suffix s" _type" ; 27744603Sdcs: module_args_suffix s" _flags" ; 27844603Sdcs: module_beforeload_suffix s" _before" ; 27944603Sdcs: module_afterload_suffix s" _after" ; 28044603Sdcs: module_loaderror_suffix s" _error" ; 28144603Sdcs 28244603Sdcs\ Support operators 28344603Sdcs 28444603Sdcs: >= < 0= ; 28544603Sdcs: <= > 0= ; 28644603Sdcs 28744603Sdcs\ Assorted support funcitons 28844603Sdcs 28944603Sdcs: free-memory free if free_error throw then ; 29044603Sdcs 291185746Sluigi: strget { var -- addr len } var .addr @ var .len @ ; 292185746Sluigi 293185746Sluigi\ assign addr len to variable. 294185746Sluigi: strset { addr len var -- } addr var .addr ! len var .len ! ; 295185746Sluigi 296185746Sluigi\ free memory and reset fields 297185746Sluigi: strfree { var -- } var .addr @ ?dup if free-memory 0 0 var strset then ; 298185746Sluigi 299185746Sluigi\ free old content, make a copy of the string and assign to variable 300185746Sluigi: string= { addr len var -- } var strfree addr len strdup var strset ; 301185746Sluigi 30244603Sdcs\ Assignment data temporary storage 30344603Sdcs 30444603Sdcsstring name_buffer 30544603Sdcsstring value_buffer 30644603Sdcs 30765615Sdcs\ Line by line file reading functions 30865615Sdcs\ 30965615Sdcs\ exported: 31065615Sdcs\ line_buffer 31165615Sdcs\ end_of_file? 31265615Sdcs\ fd 31365615Sdcs\ read_line 31465615Sdcs\ reset_line_reading 31565615Sdcs 31665615Sdcsvocabulary line-reading 31765615Sdcsalso line-reading definitions also 31865615Sdcs 31944603Sdcs\ File data temporary storage 32044603Sdcs 32144603Sdcsstring read_buffer 32244603Sdcs0 value read_buffer_ptr 32344603Sdcs 32444603Sdcs\ File's line reading function 32544603Sdcs 32665615Sdcssupport-functions definitions 32765615Sdcs 32865615Sdcsstring line_buffer 32944603Sdcs0 value end_of_file? 33044603Sdcsvariable fd 33144603Sdcs 33265615Sdcsline-reading definitions 33365615Sdcs 33444603Sdcs: skip_newlines 33544603Sdcs begin 33644603Sdcs read_buffer .len @ read_buffer_ptr > 33744603Sdcs while 33844603Sdcs read_buffer .addr @ read_buffer_ptr + c@ lf = if 33944603Sdcs read_buffer_ptr char+ to read_buffer_ptr 34044603Sdcs else 34144603Sdcs exit 34244603Sdcs then 34344603Sdcs repeat 34444603Sdcs; 34544603Sdcs 34644603Sdcs: scan_buffer ( -- addr len ) 34744603Sdcs read_buffer_ptr >r 34844603Sdcs begin 34944603Sdcs read_buffer .len @ r@ > 35044603Sdcs while 35144603Sdcs read_buffer .addr @ r@ + c@ lf = if 35244603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 35344603Sdcs r@ read_buffer_ptr - ( -- len ) 35444603Sdcs r> to read_buffer_ptr 35544603Sdcs exit 35644603Sdcs then 35744603Sdcs r> char+ >r 35844603Sdcs repeat 35944603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 36044603Sdcs r@ read_buffer_ptr - ( -- len ) 36144603Sdcs r> to read_buffer_ptr 36244603Sdcs; 36344603Sdcs 36444603Sdcs: line_buffer_resize ( len -- len ) 36544603Sdcs >r 36644603Sdcs line_buffer .len @ if 36744603Sdcs line_buffer .addr @ 36844603Sdcs line_buffer .len @ r@ + 36944603Sdcs resize if out_of_memory throw then 37044603Sdcs else 37144603Sdcs r@ allocate if out_of_memory throw then 37244603Sdcs then 37344603Sdcs line_buffer .addr ! 37444603Sdcs r> 37544603Sdcs; 37644603Sdcs 37744603Sdcs: append_to_line_buffer ( addr len -- ) 37844603Sdcs line_buffer .addr @ line_buffer .len @ 37944603Sdcs 2swap strcat 38044603Sdcs line_buffer .len ! 38144603Sdcs drop 38244603Sdcs; 38344603Sdcs 38444603Sdcs: read_from_buffer 38544603Sdcs scan_buffer ( -- addr len ) 38644603Sdcs line_buffer_resize ( len -- len ) 38744603Sdcs append_to_line_buffer ( addr len -- ) 38844603Sdcs; 38944603Sdcs 39044603Sdcs: refill_required? 39144603Sdcs read_buffer .len @ read_buffer_ptr = 39244603Sdcs end_of_file? 0= and 39344603Sdcs; 39444603Sdcs 39544603Sdcs: refill_buffer 39644603Sdcs 0 to read_buffer_ptr 39744603Sdcs read_buffer .addr @ 0= if 39844603Sdcs read_buffer_size allocate if out_of_memory throw then 39944603Sdcs read_buffer .addr ! 40044603Sdcs then 40144603Sdcs fd @ read_buffer .addr @ read_buffer_size fread 40244603Sdcs dup -1 = if read_error throw then 40344603Sdcs dup 0= if true to end_of_file? then 40444603Sdcs read_buffer .len ! 40544603Sdcs; 40644603Sdcs 40744603Sdcs: reset_line_buffer 40865615Sdcs line_buffer .addr @ ?dup if 40965615Sdcs free-memory 41065615Sdcs then 41144603Sdcs 0 line_buffer .addr ! 41244603Sdcs 0 line_buffer .len ! 41344603Sdcs; 41444603Sdcs 41565615Sdcssupport-functions definitions 41665615Sdcs 41765615Sdcs: reset_line_reading 41865615Sdcs 0 to read_buffer_ptr 41965615Sdcs; 42065615Sdcs 42144603Sdcs: read_line 42244603Sdcs reset_line_buffer 42344603Sdcs skip_newlines 42444603Sdcs begin 42544603Sdcs read_from_buffer 42644603Sdcs refill_required? 42744603Sdcs while 42844603Sdcs refill_buffer 42944603Sdcs repeat 43044603Sdcs; 43144603Sdcs 43265615Sdcsonly forth also support-functions definitions 43365615Sdcs 43444603Sdcs\ Conf file line parser: 43544603Sdcs\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 43644603Sdcs\ <spaces>[<comment>] 43744603Sdcs\ <name> ::= <letter>{<letter>|<digit>|'_'} 43844603Sdcs\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 43944603Sdcs\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 44044603Sdcs\ <comment> ::= '#'{<anything>} 44165615Sdcs\ 44265615Sdcs\ exported: 44365615Sdcs\ line_pointer 44465615Sdcs\ process_conf 44544603Sdcs 44665615Sdcs0 value line_pointer 44765615Sdcs 44865615Sdcsvocabulary file-processing 44965615Sdcsalso file-processing definitions 45065615Sdcs 45165615Sdcs\ parser functions 45265615Sdcs\ 45365615Sdcs\ exported: 45465615Sdcs\ get_assignment 45565615Sdcs 45665615Sdcsvocabulary parser 45765615Sdcsalso parser definitions also 45865615Sdcs 45944603Sdcs0 value parsing_function 46044603Sdcs0 value end_of_line 46144603Sdcs 46244603Sdcs: end_of_line? 46344603Sdcs line_pointer end_of_line = 46444603Sdcs; 46544603Sdcs 46644603Sdcs: letter? 46744603Sdcs line_pointer c@ >r 46844603Sdcs r@ [char] A >= 46944603Sdcs r@ [char] Z <= and 47044603Sdcs r@ [char] a >= 47144603Sdcs r> [char] z <= and 47244603Sdcs or 47344603Sdcs; 47444603Sdcs 47544603Sdcs: digit? 47644603Sdcs line_pointer c@ >r 477174777Sambrisko r@ [char] - = 47844603Sdcs r@ [char] 0 >= 47944603Sdcs r> [char] 9 <= and 480174777Sambrisko or 48144603Sdcs; 48244603Sdcs 48344603Sdcs: quote? 48444603Sdcs line_pointer c@ [char] " = 48544603Sdcs; 48644603Sdcs 48744603Sdcs: assignment_sign? 48844603Sdcs line_pointer c@ [char] = = 48944603Sdcs; 49044603Sdcs 49144603Sdcs: comment? 49244603Sdcs line_pointer c@ [char] # = 49344603Sdcs; 49444603Sdcs 49544603Sdcs: space? 49644603Sdcs line_pointer c@ bl = 49744603Sdcs line_pointer c@ tab = or 49844603Sdcs; 49944603Sdcs 50044603Sdcs: backslash? 50144603Sdcs line_pointer c@ [char] \ = 50244603Sdcs; 50344603Sdcs 50444603Sdcs: underscore? 50544603Sdcs line_pointer c@ [char] _ = 50644603Sdcs; 50744603Sdcs 50844603Sdcs: dot? 50944603Sdcs line_pointer c@ [char] . = 51044603Sdcs; 51144603Sdcs 51244603Sdcs: skip_character 51344603Sdcs line_pointer char+ to line_pointer 51444603Sdcs; 51544603Sdcs 51644603Sdcs: skip_to_end_of_line 51744603Sdcs end_of_line to line_pointer 51844603Sdcs; 51944603Sdcs 52044603Sdcs: eat_space 52144603Sdcs begin 52244603Sdcs space? 52344603Sdcs while 52444603Sdcs skip_character 52544603Sdcs end_of_line? if exit then 52644603Sdcs repeat 52744603Sdcs; 52844603Sdcs 52944603Sdcs: parse_name ( -- addr len ) 53044603Sdcs line_pointer 53144603Sdcs begin 53244603Sdcs letter? digit? underscore? dot? or or or 53344603Sdcs while 53444603Sdcs skip_character 53544603Sdcs end_of_line? if 53644603Sdcs line_pointer over - 53744603Sdcs strdup 53844603Sdcs exit 53944603Sdcs then 54044603Sdcs repeat 54144603Sdcs line_pointer over - 54244603Sdcs strdup 54344603Sdcs; 54444603Sdcs 54544603Sdcs: remove_backslashes { addr len | addr' len' -- addr' len' } 54644603Sdcs len allocate if out_of_memory throw then 54744603Sdcs to addr' 54844603Sdcs addr >r 54944603Sdcs begin 55044603Sdcs addr c@ [char] \ <> if 55144603Sdcs addr c@ addr' len' + c! 55244603Sdcs len' char+ to len' 55344603Sdcs then 55444603Sdcs addr char+ to addr 55544603Sdcs r@ len + addr = 55644603Sdcs until 55744603Sdcs r> drop 55844603Sdcs addr' len' 55944603Sdcs; 56044603Sdcs 56144603Sdcs: parse_quote ( -- addr len ) 56244603Sdcs line_pointer 56344603Sdcs skip_character 56444603Sdcs end_of_line? if syntax_error throw then 56544603Sdcs begin 56644603Sdcs quote? 0= 56744603Sdcs while 56844603Sdcs backslash? if 56944603Sdcs skip_character 57044603Sdcs end_of_line? if syntax_error throw then 57144603Sdcs then 57244603Sdcs skip_character 57344603Sdcs end_of_line? if syntax_error throw then 57444603Sdcs repeat 57544603Sdcs skip_character 57644603Sdcs line_pointer over - 57744603Sdcs remove_backslashes 57844603Sdcs; 57944603Sdcs 58044603Sdcs: read_name 58144603Sdcs parse_name ( -- addr len ) 58244603Sdcs name_buffer .len ! 58344603Sdcs name_buffer .addr ! 58444603Sdcs; 58544603Sdcs 58644603Sdcs: read_value 58744603Sdcs quote? if 58844603Sdcs parse_quote ( -- addr len ) 58944603Sdcs else 59044603Sdcs parse_name ( -- addr len ) 59144603Sdcs then 59244603Sdcs value_buffer .len ! 59344603Sdcs value_buffer .addr ! 59444603Sdcs; 59544603Sdcs 59644603Sdcs: comment 59744603Sdcs skip_to_end_of_line 59844603Sdcs; 59944603Sdcs 60044603Sdcs: white_space_4 60144603Sdcs eat_space 60244603Sdcs comment? if ['] comment to parsing_function exit then 60344603Sdcs end_of_line? 0= if syntax_error throw then 60444603Sdcs; 60544603Sdcs 60644603Sdcs: variable_value 60744603Sdcs read_value 60844603Sdcs ['] white_space_4 to parsing_function 60944603Sdcs; 61044603Sdcs 61144603Sdcs: white_space_3 61244603Sdcs eat_space 61344603Sdcs letter? digit? quote? or or if 61444603Sdcs ['] variable_value to parsing_function exit 61544603Sdcs then 61644603Sdcs syntax_error throw 61744603Sdcs; 61844603Sdcs 61944603Sdcs: assignment_sign 62044603Sdcs skip_character 62144603Sdcs ['] white_space_3 to parsing_function 62244603Sdcs; 62344603Sdcs 62444603Sdcs: white_space_2 62544603Sdcs eat_space 62644603Sdcs assignment_sign? if ['] assignment_sign to parsing_function exit then 62744603Sdcs syntax_error throw 62844603Sdcs; 62944603Sdcs 63044603Sdcs: variable_name 63144603Sdcs read_name 63244603Sdcs ['] white_space_2 to parsing_function 63344603Sdcs; 63444603Sdcs 63544603Sdcs: white_space_1 63644603Sdcs eat_space 63744603Sdcs letter? if ['] variable_name to parsing_function exit then 63844603Sdcs comment? if ['] comment to parsing_function exit then 63944603Sdcs end_of_line? 0= if syntax_error throw then 64044603Sdcs; 64144603Sdcs 64265615Sdcsfile-processing definitions 64365615Sdcs 64444603Sdcs: get_assignment 64544603Sdcs line_buffer .addr @ line_buffer .len @ + to end_of_line 64644603Sdcs line_buffer .addr @ to line_pointer 64744603Sdcs ['] white_space_1 to parsing_function 64844603Sdcs begin 64944603Sdcs end_of_line? 0= 65044603Sdcs while 65144603Sdcs parsing_function execute 65244603Sdcs repeat 65344603Sdcs parsing_function ['] comment = 65444603Sdcs parsing_function ['] white_space_1 = 65544603Sdcs parsing_function ['] white_space_4 = 65644603Sdcs or or 0= if syntax_error throw then 65744603Sdcs; 65844603Sdcs 65965615Sdcsonly forth also support-functions also file-processing definitions also 66065615Sdcs 66144603Sdcs\ Process line 66244603Sdcs 66344603Sdcs: assignment_type? ( addr len -- flag ) 66444603Sdcs name_buffer .addr @ name_buffer .len @ 66544603Sdcs compare 0= 66644603Sdcs; 66744603Sdcs 66844603Sdcs: suffix_type? ( addr len -- flag ) 66944603Sdcs name_buffer .len @ over <= if 2drop false exit then 67044603Sdcs name_buffer .len @ over - name_buffer .addr @ + 67144603Sdcs over compare 0= 67244603Sdcs; 67344603Sdcs 67444603Sdcs: loader_conf_files? 67544603Sdcs s" loader_conf_files" assignment_type? 67644603Sdcs; 67744603Sdcs 67897201Sgordon: nextboot_flag? 67997201Sgordon s" nextboot_enable" assignment_type? 68097201Sgordon; 68197201Sgordon 68297201Sgordon: nextboot_conf? 68397201Sgordon s" nextboot_conf" assignment_type? 68497201Sgordon; 68597201Sgordon 68644603Sdcs: verbose_flag? 68744603Sdcs s" verbose_loading" assignment_type? 68844603Sdcs; 68944603Sdcs 69044603Sdcs: execute? 69144603Sdcs s" exec" assignment_type? 69244603Sdcs; 69344603Sdcs 69453672Sdcs: password? 69553672Sdcs s" password" assignment_type? 69653672Sdcs; 69753672Sdcs 69844603Sdcs: module_load? 69944603Sdcs load_module_suffix suffix_type? 70044603Sdcs; 70144603Sdcs 70244603Sdcs: module_loadname? 70344603Sdcs module_loadname_suffix suffix_type? 70444603Sdcs; 70544603Sdcs 70644603Sdcs: module_type? 70744603Sdcs module_type_suffix suffix_type? 70844603Sdcs; 70944603Sdcs 71044603Sdcs: module_args? 71144603Sdcs module_args_suffix suffix_type? 71244603Sdcs; 71344603Sdcs 71444603Sdcs: module_beforeload? 71544603Sdcs module_beforeload_suffix suffix_type? 71644603Sdcs; 71744603Sdcs 71844603Sdcs: module_afterload? 71944603Sdcs module_afterload_suffix suffix_type? 72044603Sdcs; 72144603Sdcs 72244603Sdcs: module_loaderror? 72344603Sdcs module_loaderror_suffix suffix_type? 72444603Sdcs; 72544603Sdcs 72697201Sgordon: set_nextboot_conf 72797201Sgordon nextboot_conf_file .addr @ ?dup if 72897201Sgordon free-memory 72997201Sgordon then 73097201Sgordon value_buffer .addr @ c@ [char] " = if 73197201Sgordon value_buffer .addr @ char+ value_buffer .len @ 2 chars - 73297201Sgordon else 73397201Sgordon value_buffer .addr @ value_buffer .len @ 73497201Sgordon then 73597201Sgordon strdup 73697201Sgordon nextboot_conf_file .len ! nextboot_conf_file .addr ! 73797201Sgordon; 73897201Sgordon 73944603Sdcs: append_to_module_options_list ( addr -- ) 74044603Sdcs module_options @ 0= if 74144603Sdcs dup module_options ! 74244603Sdcs last_module_option ! 74344603Sdcs else 74444603Sdcs dup last_module_option @ module.next ! 74544603Sdcs last_module_option ! 74644603Sdcs then 74744603Sdcs; 74844603Sdcs 74944603Sdcs: set_module_name ( addr -- ) 75044603Sdcs name_buffer .addr @ name_buffer .len @ 75144603Sdcs strdup 75244603Sdcs >r over module.name .addr ! 75344603Sdcs r> swap module.name .len ! 75444603Sdcs; 75544603Sdcs 75644603Sdcs: yes_value? 75744603Sdcs value_buffer .addr @ value_buffer .len @ 75844603Sdcs 2dup s' "YES"' compare >r 75944603Sdcs 2dup s' "yes"' compare >r 76044603Sdcs 2dup s" YES" compare >r 76144603Sdcs s" yes" compare r> r> r> and and and 0= 76244603Sdcs; 76344603Sdcs 76444603Sdcs: find_module_option ( -- addr | 0 ) 76544603Sdcs module_options @ 76644603Sdcs begin 76744603Sdcs dup 76844603Sdcs while 76944603Sdcs dup module.name dup .addr @ swap .len @ 77044603Sdcs name_buffer .addr @ name_buffer .len @ 77144603Sdcs compare 0= if exit then 77244603Sdcs module.next @ 77344603Sdcs repeat 77444603Sdcs; 77544603Sdcs 77644603Sdcs: new_module_option ( -- addr ) 77744603Sdcs sizeof module allocate if out_of_memory throw then 77844603Sdcs dup sizeof module erase 77944603Sdcs dup append_to_module_options_list 78044603Sdcs dup set_module_name 78144603Sdcs; 78244603Sdcs 78344603Sdcs: get_module_option ( -- addr ) 78444603Sdcs find_module_option 78544603Sdcs ?dup 0= if new_module_option then 78644603Sdcs; 78744603Sdcs 78844603Sdcs: set_module_flag 78944603Sdcs name_buffer .len @ load_module_suffix nip - name_buffer .len ! 79044603Sdcs yes_value? get_module_option module.flag ! 79144603Sdcs; 79244603Sdcs 79344603Sdcs: set_module_args 79444603Sdcs name_buffer .len @ module_args_suffix nip - name_buffer .len ! 79544603Sdcs get_module_option module.args 79644603Sdcs dup .addr @ ?dup if free-memory then 79744603Sdcs value_buffer .addr @ value_buffer .len @ 79844603Sdcs over c@ [char] " = if 79944603Sdcs 2 chars - swap char+ swap 80044603Sdcs then 80144603Sdcs strdup 80244603Sdcs >r over .addr ! 80344603Sdcs r> swap .len ! 80444603Sdcs; 80544603Sdcs 80644603Sdcs: set_module_loadname 80744603Sdcs name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 80844603Sdcs get_module_option module.loadname 80944603Sdcs dup .addr @ ?dup if free-memory then 81044603Sdcs value_buffer .addr @ value_buffer .len @ 81144603Sdcs over c@ [char] " = if 81244603Sdcs 2 chars - swap char+ swap 81344603Sdcs then 81444603Sdcs strdup 81544603Sdcs >r over .addr ! 81644603Sdcs r> swap .len ! 81744603Sdcs; 81844603Sdcs 81944603Sdcs: set_module_type 82044603Sdcs name_buffer .len @ module_type_suffix nip - name_buffer .len ! 82144603Sdcs get_module_option module.type 82244603Sdcs dup .addr @ ?dup if free-memory then 82344603Sdcs value_buffer .addr @ value_buffer .len @ 82444603Sdcs over c@ [char] " = if 82544603Sdcs 2 chars - swap char+ swap 82644603Sdcs then 82744603Sdcs strdup 82844603Sdcs >r over .addr ! 82944603Sdcs r> swap .len ! 83044603Sdcs; 83144603Sdcs 83244603Sdcs: set_module_beforeload 83344603Sdcs name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 83444603Sdcs get_module_option module.beforeload 83544603Sdcs dup .addr @ ?dup if free-memory then 83644603Sdcs value_buffer .addr @ value_buffer .len @ 83744603Sdcs over c@ [char] " = if 83844603Sdcs 2 chars - swap char+ swap 83944603Sdcs then 84044603Sdcs strdup 84144603Sdcs >r over .addr ! 84244603Sdcs r> swap .len ! 84344603Sdcs; 84444603Sdcs 84544603Sdcs: set_module_afterload 84644603Sdcs name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 84744603Sdcs get_module_option module.afterload 84844603Sdcs dup .addr @ ?dup if free-memory then 84944603Sdcs value_buffer .addr @ value_buffer .len @ 85044603Sdcs over c@ [char] " = if 85144603Sdcs 2 chars - swap char+ swap 85244603Sdcs then 85344603Sdcs strdup 85444603Sdcs >r over .addr ! 85544603Sdcs r> swap .len ! 85644603Sdcs; 85744603Sdcs 85844603Sdcs: set_module_loaderror 85944603Sdcs name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 86044603Sdcs get_module_option module.loaderror 86144603Sdcs dup .addr @ ?dup if free-memory then 86244603Sdcs value_buffer .addr @ value_buffer .len @ 86344603Sdcs over c@ [char] " = if 86444603Sdcs 2 chars - swap char+ swap 86544603Sdcs then 86644603Sdcs strdup 86744603Sdcs >r over .addr ! 86844603Sdcs r> swap .len ! 86944603Sdcs; 87044603Sdcs 87144603Sdcs: set_environment_variable 87244603Sdcs name_buffer .len @ 87344603Sdcs value_buffer .len @ + 87444603Sdcs 5 chars + 87544603Sdcs allocate if out_of_memory throw then 87644603Sdcs dup 0 ( addr -- addr addr len ) 87744603Sdcs s" set " strcat 87844603Sdcs name_buffer .addr @ name_buffer .len @ strcat 87944603Sdcs s" =" strcat 88044603Sdcs value_buffer .addr @ value_buffer .len @ strcat 88144603Sdcs ['] evaluate catch if 88244603Sdcs 2drop free drop 88344603Sdcs set_error throw 88444603Sdcs else 88544603Sdcs free-memory 88644603Sdcs then 88744603Sdcs; 88844603Sdcs 889185746Sluigi: set_conf_files 890185746Sluigi set_environment_variable 891185746Sluigi s" loader_conf_files" getenv conf_files string= 892185746Sluigi; 893185746Sluigi 89497201Sgordon: set_nextboot_flag 89597201Sgordon yes_value? to nextboot? 89697201Sgordon; 89797201Sgordon 89844603Sdcs: set_verbose 89944603Sdcs yes_value? to verbose? 90044603Sdcs; 90144603Sdcs 90244603Sdcs: execute_command 90344603Sdcs value_buffer .addr @ value_buffer .len @ 90444603Sdcs over c@ [char] " = if 90553672Sdcs 2 - swap char+ swap 90644603Sdcs then 90744603Sdcs ['] evaluate catch if exec_error throw then 90844603Sdcs; 90944603Sdcs 91053672Sdcs: set_password 91153672Sdcs password .addr @ ?dup if free if free_error throw then then 91253672Sdcs value_buffer .addr @ c@ [char] " = if 91353672Sdcs value_buffer .addr @ char+ value_buffer .len @ 2 - strdup 91453672Sdcs value_buffer .addr @ free if free_error throw then 91553672Sdcs else 91653672Sdcs value_buffer .addr @ value_buffer .len @ 91753672Sdcs then 91853672Sdcs password .len ! password .addr ! 91953672Sdcs 0 value_buffer .addr ! 92053672Sdcs; 92153672Sdcs 92244603Sdcs: process_assignment 92344603Sdcs name_buffer .len @ 0= if exit then 92444603Sdcs loader_conf_files? if set_conf_files exit then 92597201Sgordon nextboot_flag? if set_nextboot_flag exit then 92697201Sgordon nextboot_conf? if set_nextboot_conf exit then 92744603Sdcs verbose_flag? if set_verbose exit then 92844603Sdcs execute? if execute_command exit then 92953672Sdcs password? if set_password exit then 93044603Sdcs module_load? if set_module_flag exit then 93144603Sdcs module_loadname? if set_module_loadname exit then 93244603Sdcs module_type? if set_module_type exit then 93344603Sdcs module_args? if set_module_args exit then 93444603Sdcs module_beforeload? if set_module_beforeload exit then 93544603Sdcs module_afterload? if set_module_afterload exit then 93644603Sdcs module_loaderror? if set_module_loaderror exit then 93744603Sdcs set_environment_variable 93844603Sdcs; 93944603Sdcs 94053672Sdcs\ free_buffer ( -- ) 94153672Sdcs\ 94253672Sdcs\ Free some pointers if needed. The code then tests for errors 94353672Sdcs\ in freeing, and throws an exception if needed. If a pointer is 94453672Sdcs\ not allocated, it's value (0) is used as flag. 94553672Sdcs 94644603Sdcs: free_buffers 94744603Sdcs name_buffer .addr @ dup if free then 94844603Sdcs value_buffer .addr @ dup if free then 94965615Sdcs or if free_error throw then 95044603Sdcs; 95144603Sdcs 95244603Sdcs: reset_assignment_buffers 95344603Sdcs 0 name_buffer .addr ! 95444603Sdcs 0 name_buffer .len ! 95544603Sdcs 0 value_buffer .addr ! 95644603Sdcs 0 value_buffer .len ! 95744603Sdcs; 95844603Sdcs 95944603Sdcs\ Higher level file processing 96044603Sdcs 96165615Sdcssupport-functions definitions 96265615Sdcs 96344603Sdcs: process_conf 96444603Sdcs begin 96544603Sdcs end_of_file? 0= 96644603Sdcs while 96744603Sdcs reset_assignment_buffers 96844603Sdcs read_line 96944603Sdcs get_assignment 97044603Sdcs ['] process_assignment catch 97144603Sdcs ['] free_buffers catch 97244603Sdcs swap throw throw 97344603Sdcs repeat 97444603Sdcs; 97544603Sdcs 97697201Sgordon: peek_file 97797201Sgordon 0 to end_of_file? 97897201Sgordon reset_line_reading 97997201Sgordon O_RDONLY fopen fd ! 98097201Sgordon fd @ -1 = if open_error throw then 98197201Sgordon reset_assignment_buffers 98297201Sgordon read_line 98397201Sgordon get_assignment 98497201Sgordon ['] process_assignment catch 98597201Sgordon ['] free_buffers catch 98697201Sgordon fd @ fclose 98797201Sgordon; 98897201Sgordon 98965615Sdcsonly forth also support-functions definitions 99065615Sdcs 99144603Sdcs\ Interface to loading conf files 99244603Sdcs 99344603Sdcs: load_conf ( addr len -- ) 99444603Sdcs 0 to end_of_file? 99565615Sdcs reset_line_reading 99687636Sjhb O_RDONLY fopen fd ! 99744603Sdcs fd @ -1 = if open_error throw then 99844603Sdcs ['] process_conf catch 99944603Sdcs fd @ fclose 100044603Sdcs throw 100144603Sdcs; 100244603Sdcs 100344603Sdcs: print_line 100444603Sdcs line_buffer .addr @ line_buffer .len @ type cr 100544603Sdcs; 100644603Sdcs 100744603Sdcs: print_syntax_error 100844603Sdcs line_buffer .addr @ line_buffer .len @ type cr 100944603Sdcs line_buffer .addr @ 101044603Sdcs begin 101144603Sdcs line_pointer over <> 101244603Sdcs while 101344603Sdcs bl emit 101444603Sdcs char+ 101544603Sdcs repeat 101644603Sdcs drop 101744603Sdcs ." ^" cr 101844603Sdcs; 101944603Sdcs 1020163327Sru\ Debugging support functions 102144603Sdcs 102244603Sdcsonly forth definitions also support-functions 102344603Sdcs 102444603Sdcs: test-file 102544603Sdcs ['] load_conf catch dup . 102644603Sdcs syntax_error = if cr print_syntax_error then 102744603Sdcs; 102844603Sdcs 102944603Sdcs: show-module-options 103044603Sdcs module_options @ 103144603Sdcs begin 103244603Sdcs ?dup 103344603Sdcs while 103444603Sdcs ." Name: " dup module.name dup .addr @ swap .len @ type cr 103544603Sdcs ." Path: " dup module.loadname dup .addr @ swap .len @ type cr 103644603Sdcs ." Type: " dup module.type dup .addr @ swap .len @ type cr 103744603Sdcs ." Flags: " dup module.args dup .addr @ swap .len @ type cr 103844603Sdcs ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr 103944603Sdcs ." After load: " dup module.afterload dup .addr @ swap .len @ type cr 104044603Sdcs ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr 104144603Sdcs ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr 104244603Sdcs module.next @ 104344603Sdcs repeat 104444603Sdcs; 104544603Sdcs 104644603Sdcsonly forth also support-functions definitions 104744603Sdcs 104844603Sdcs\ Variables used for processing multiple conf files 104944603Sdcs 105044603Sdcsstring current_file_name 105144603Sdcs 105244603Sdcs\ Indicates if any conf file was succesfully read 105344603Sdcs 105444603Sdcs0 value any_conf_read? 105544603Sdcs 105644603Sdcs\ loader_conf_files processing support functions 105744603Sdcs 1058185746Sluigi: get_conf_files ( -- addr len ) \ put addr/len on stack, reset var 1059185746Sluigi conf_files strget 0 0 conf_files strset 106044603Sdcs; 106144603Sdcs 106253672Sdcs: skip_leading_spaces { addr len pos -- addr len pos' } 106344603Sdcs begin 106453672Sdcs pos len = if addr len pos exit then 106553672Sdcs addr pos + c@ bl = 106644603Sdcs while 106753672Sdcs pos char+ to pos 106844603Sdcs repeat 106953672Sdcs addr len pos 107044603Sdcs; 107144603Sdcs 107253672Sdcs: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 107353672Sdcs pos len = if 107444603Sdcs addr free abort" Fatal error freeing memory" 107544603Sdcs 0 exit 107644603Sdcs then 107753672Sdcs pos >r 107844603Sdcs begin 107953672Sdcs addr pos + c@ bl <> 108044603Sdcs while 108153672Sdcs pos char+ to pos 108253672Sdcs pos len = if 108353672Sdcs addr len pos addr r@ + pos r> - exit 108444603Sdcs then 108544603Sdcs repeat 108653672Sdcs addr len pos addr r@ + pos r> - 108744603Sdcs; 108844603Sdcs 108944603Sdcs: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 109044603Sdcs skip_leading_spaces 109144603Sdcs get_file_name 109244603Sdcs; 109344603Sdcs 109444603Sdcs: set_current_file_name 109544603Sdcs over current_file_name .addr ! 109644603Sdcs dup current_file_name .len ! 109744603Sdcs; 109844603Sdcs 109944603Sdcs: print_current_file 110044603Sdcs current_file_name .addr @ current_file_name .len @ type 110144603Sdcs; 110244603Sdcs 110344603Sdcs: process_conf_errors 110444603Sdcs dup 0= if true to any_conf_read? drop exit then 110544603Sdcs >r 2drop r> 110644603Sdcs dup syntax_error = if 110744603Sdcs ." Warning: syntax error on file " print_current_file cr 110844603Sdcs print_syntax_error drop exit 110944603Sdcs then 111044603Sdcs dup set_error = if 111144603Sdcs ." Warning: bad definition on file " print_current_file cr 111244603Sdcs print_line drop exit 111344603Sdcs then 111444603Sdcs dup read_error = if 111544603Sdcs ." Warning: error reading file " print_current_file cr drop exit 111644603Sdcs then 111744603Sdcs dup open_error = if 111844603Sdcs verbose? if ." Warning: unable to open file " print_current_file cr then 111944603Sdcs drop exit 112044603Sdcs then 112144603Sdcs dup free_error = abort" Fatal error freeing memory" 112244603Sdcs dup out_of_memory = abort" Out of memory" 112344603Sdcs throw \ Unknown error -- pass ahead 112444603Sdcs; 112544603Sdcs 112644603Sdcs\ Process loader_conf_files recursively 112744603Sdcs\ Interface to loader_conf_files processing 112844603Sdcs 112944603Sdcs: include_conf_files 113044603Sdcs get_conf_files 0 113144603Sdcs begin 113244603Sdcs get_next_file ?dup 113344603Sdcs while 113444603Sdcs set_current_file_name 113544603Sdcs ['] load_conf catch 113644603Sdcs process_conf_errors 1137185746Sluigi conf_files .addr @ if recurse then 113844603Sdcs repeat 113944603Sdcs; 114044603Sdcs 114197201Sgordon: get_nextboot_conf_file ( -- addr len ) 114297201Sgordon nextboot_conf_file .addr @ nextboot_conf_file .len @ strdup 114397201Sgordon; 114497201Sgordon 114597201Sgordon: rewrite_nextboot_file ( -- ) 114697201Sgordon get_nextboot_conf_file 114797201Sgordon O_WRONLY fopen fd ! 114897201Sgordon fd @ -1 = if open_error throw then 114997201Sgordon fd @ s' nextboot_enable="NO" ' fwrite 115097201Sgordon fd @ fclose 115197201Sgordon; 115297201Sgordon 115397201Sgordon: include_nextboot_file 115497201Sgordon get_nextboot_conf_file 115597201Sgordon ['] peek_file catch 115697201Sgordon nextboot? if 115797201Sgordon get_nextboot_conf_file 115897201Sgordon ['] load_conf catch 115997201Sgordon process_conf_errors 116097201Sgordon ['] rewrite_nextboot_file catch 116197201Sgordon then 116297201Sgordon; 116397201Sgordon 116444603Sdcs\ Module loading functions 116544603Sdcs 116644603Sdcs: load_module? 116744603Sdcs module.flag @ 116844603Sdcs; 116944603Sdcs 117044603Sdcs: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N ) 117144603Sdcs dup >r 117244603Sdcs r@ module.args .addr @ r@ module.args .len @ 117344603Sdcs r@ module.loadname .len @ if 117444603Sdcs r@ module.loadname .addr @ r@ module.loadname .len @ 117544603Sdcs else 117644603Sdcs r@ module.name .addr @ r@ module.name .len @ 117744603Sdcs then 117844603Sdcs r@ module.type .len @ if 117944603Sdcs r@ module.type .addr @ r@ module.type .len @ 118044603Sdcs s" -t " 118144603Sdcs 4 ( -t type name flags ) 118244603Sdcs else 118344603Sdcs 2 ( name flags ) 118444603Sdcs then 118544603Sdcs r> drop 118644603Sdcs; 118744603Sdcs 118844603Sdcs: before_load ( addr -- addr ) 118944603Sdcs dup module.beforeload .len @ if 119044603Sdcs dup module.beforeload .addr @ over module.beforeload .len @ 119144603Sdcs ['] evaluate catch if before_load_error throw then 119244603Sdcs then 119344603Sdcs; 119444603Sdcs 119544603Sdcs: after_load ( addr -- addr ) 119644603Sdcs dup module.afterload .len @ if 119744603Sdcs dup module.afterload .addr @ over module.afterload .len @ 119844603Sdcs ['] evaluate catch if after_load_error throw then 119944603Sdcs then 120044603Sdcs; 120144603Sdcs 120244603Sdcs: load_error ( addr -- addr ) 120344603Sdcs dup module.loaderror .len @ if 120444603Sdcs dup module.loaderror .addr @ over module.loaderror .len @ 120544603Sdcs evaluate \ This we do not intercept so it can throw errors 120644603Sdcs then 120744603Sdcs; 120844603Sdcs 120944603Sdcs: pre_load_message ( addr -- addr ) 121044603Sdcs verbose? if 121144603Sdcs dup module.name .addr @ over module.name .len @ type 121244603Sdcs ." ..." 121344603Sdcs then 121444603Sdcs; 121544603Sdcs 121644603Sdcs: load_error_message verbose? if ." failed!" cr then ; 121744603Sdcs 121844603Sdcs: load_succesful_message verbose? if ." ok" cr then ; 121944603Sdcs 122044603Sdcs: load_module 122144603Sdcs load_parameters load 122244603Sdcs; 122344603Sdcs 122444603Sdcs: process_module ( addr -- addr ) 122544603Sdcs pre_load_message 122644603Sdcs before_load 122744603Sdcs begin 122844603Sdcs ['] load_module catch if 122944603Sdcs dup module.loaderror .len @ if 123044603Sdcs load_error \ Command should return a flag! 123144603Sdcs else 123244603Sdcs load_error_message true \ Do not retry 123344603Sdcs then 123444603Sdcs else 123544603Sdcs after_load 123644603Sdcs load_succesful_message true \ Succesful, do not retry 123744603Sdcs then 123844603Sdcs until 123944603Sdcs; 124044603Sdcs 124144603Sdcs: process_module_errors ( addr ior -- ) 124244603Sdcs dup before_load_error = if 124344603Sdcs drop 124444603Sdcs ." Module " 124544603Sdcs dup module.name .addr @ over module.name .len @ type 124644603Sdcs dup module.loadname .len @ if 124744603Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 124844603Sdcs then 124944603Sdcs cr 125044603Sdcs ." Error executing " 125144603Sdcs dup module.beforeload .addr @ over module.afterload .len @ type cr 125244603Sdcs abort 125344603Sdcs then 125444603Sdcs 125544603Sdcs dup after_load_error = if 125644603Sdcs drop 125744603Sdcs ." Module " 125844603Sdcs dup module.name .addr @ over module.name .len @ type 125944603Sdcs dup module.loadname .len @ if 126044603Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 126144603Sdcs then 126244603Sdcs cr 126344603Sdcs ." Error executing " 126444603Sdcs dup module.afterload .addr @ over module.afterload .len @ type cr 126544603Sdcs abort 126644603Sdcs then 126744603Sdcs 126844603Sdcs throw \ Don't know what it is all about -- pass ahead 126944603Sdcs; 127044603Sdcs 127144603Sdcs\ Module loading interface 127244603Sdcs 127344603Sdcs: load_modules ( -- ) ( throws: abort & user-defined ) 127444603Sdcs module_options @ 127544603Sdcs begin 127644603Sdcs ?dup 127744603Sdcs while 127844603Sdcs dup load_module? if 127944603Sdcs ['] process_module catch 128044603Sdcs process_module_errors 128144603Sdcs then 128244603Sdcs module.next @ 128344603Sdcs repeat 128444603Sdcs; 128544603Sdcs 128665630Sdcs\ h00h00 magic used to try loading either a kernel with a given name, 128765630Sdcs\ or a kernel with the default name in a directory of a given name 128865630Sdcs\ (the pain!) 128944603Sdcs 129065630Sdcs: bootpath s" /boot/" ; 129165630Sdcs: modulepath s" module_path" ; 129265630Sdcs 129365630Sdcs\ Functions used to save and restore module_path's value. 129465630Sdcs: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 129565630Sdcs dup -1 = if 0 swap exit then 129665630Sdcs strdup 129765630Sdcs; 129865630Sdcs: freeenv ( addr len | 0 -1 ) 129965630Sdcs -1 = if drop else free abort" Freeing error" then 130065630Sdcs; 130165630Sdcs: restoreenv ( addr len | 0 -1 -- ) 130265630Sdcs dup -1 = if ( it wasn't set ) 130365630Sdcs 2drop 130465630Sdcs modulepath unsetenv 130565630Sdcs else 130665630Sdcs over >r 130765630Sdcs modulepath setenv 130865630Sdcs r> free abort" Freeing error" 130965630Sdcs then 131065630Sdcs; 131165630Sdcs 131265630Sdcs: clip_args \ Drop second string if only one argument is passed 131365630Sdcs 1 = if 131465630Sdcs 2swap 2drop 131565630Sdcs 1 131665630Sdcs else 131765630Sdcs 2 131865630Sdcs then 131965630Sdcs; 132065630Sdcs 132165630Sdcsalso builtins 132265630Sdcs 132365630Sdcs\ Parse filename from a comma-separated list 132465630Sdcs 132565630Sdcs: parse-; ( addr len -- addr' len-x addr x ) 132665630Sdcs over 0 2swap 132765630Sdcs begin 132865630Sdcs dup 0 <> 132965630Sdcs while 133065630Sdcs over c@ [char] ; <> 133165630Sdcs while 133265630Sdcs 1- swap 1+ swap 133365630Sdcs 2swap 1+ 2swap 133465630Sdcs repeat then 133565630Sdcs dup 0 <> if 133665630Sdcs 1- swap 1+ swap 133765630Sdcs then 133865630Sdcs 2swap 133965630Sdcs; 134065630Sdcs 134165630Sdcs\ Try loading one of multiple kernels specified 134265630Sdcs 134365630Sdcs: try_multiple_kernels ( addr len addr' len' args -- flag ) 134465630Sdcs >r 134565630Sdcs begin 134665630Sdcs parse-; 2>r 134765630Sdcs 2over 2r> 134865945Sdcs r@ clip_args 134965945Sdcs s" DEBUG" getenv? if 135065945Sdcs s" echo Module_path: ${module_path}" evaluate 135165945Sdcs ." Kernel : " >r 2dup type r> cr 135265945Sdcs dup 2 = if ." Flags : " >r 2over type r> cr then 135365945Sdcs then 135465945Sdcs 1 load 135565630Sdcs while 135665630Sdcs dup 0= 135765630Sdcs until 135865630Sdcs 1 >r \ Failure 135965630Sdcs else 136065630Sdcs 0 >r \ Success 136165630Sdcs then 136265630Sdcs 2drop 2drop 136365630Sdcs r> 136465630Sdcs r> drop 136565630Sdcs; 136665630Sdcs 136765630Sdcs\ Try to load a kernel; the kernel name is taken from one of 136865630Sdcs\ the following lists, as ordered: 136965630Sdcs\ 137065641Sdcs\ 1. The "bootfile" environment variable 137165641Sdcs\ 2. The "kernel" environment variable 137265630Sdcs\ 137365938Sdcs\ Flags are passed, if available. If not, dummy values must be given. 137465630Sdcs\ 137565630Sdcs\ The kernel gets loaded from the current module_path. 137665630Sdcs 137765938Sdcs: load_a_kernel ( flags len 1 | x x 0 -- flag ) 137865630Sdcs local args 137965630Sdcs 2local flags 138065630Sdcs 0 0 2local kernel 138165630Sdcs end-locals 138265630Sdcs 138365630Sdcs \ Check if a default kernel name exists at all, exits if not 138465641Sdcs s" bootfile" getenv dup -1 <> if 138565630Sdcs to kernel 138665883Sdcs flags kernel args 1+ try_multiple_kernels 138765630Sdcs dup 0= if exit then 138865630Sdcs then 138965630Sdcs drop 139065630Sdcs 139165641Sdcs s" kernel" getenv dup -1 <> if 139265630Sdcs to kernel 139365630Sdcs else 139465630Sdcs drop 139565630Sdcs 1 exit \ Failure 139665630Sdcs then 139765630Sdcs 139865630Sdcs \ Try all default kernel names 139965883Sdcs flags kernel args 1+ try_multiple_kernels 140065630Sdcs; 140165630Sdcs 140265630Sdcs\ Try to load a kernel; the kernel name is taken from one of 140365630Sdcs\ the following lists, as ordered: 140465630Sdcs\ 140565641Sdcs\ 1. The "bootfile" environment variable 140665641Sdcs\ 2. The "kernel" environment variable 140765630Sdcs\ 140865630Sdcs\ Flags are passed, if provided. 140965630Sdcs\ 141065630Sdcs\ The kernel will be loaded from a directory computed from the 141165630Sdcs\ path given. Two directories will be tried in the following order: 141265630Sdcs\ 141365630Sdcs\ 1. /boot/path 141465630Sdcs\ 2. path 141565630Sdcs\ 141665630Sdcs\ The module_path variable is overridden if load is succesful, by 141765630Sdcs\ prepending the successful path. 141865630Sdcs 141965630Sdcs: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 142065630Sdcs local args 142165630Sdcs 2local path 142265630Sdcs args 1 = if 0 0 then 142365630Sdcs 2local flags 142465630Sdcs 0 0 2local oldmodulepath 142565630Sdcs 0 0 2local newmodulepath 142665630Sdcs end-locals 142765630Sdcs 142865630Sdcs \ Set the environment variable module_path, and try loading 142965630Sdcs \ the kernel again. 143065630Sdcs modulepath getenv saveenv to oldmodulepath 143165630Sdcs 143265630Sdcs \ Try prepending /boot/ first 143365630Sdcs bootpath nip path nip + 143465630Sdcs oldmodulepath nip dup -1 = if 143565630Sdcs drop 143665630Sdcs else 143765630Sdcs 1+ + 143865630Sdcs then 143965630Sdcs allocate 144065630Sdcs if ( out of memory ) 144165630Sdcs 1 exit 144265630Sdcs then 144365630Sdcs 144465630Sdcs 0 144565630Sdcs bootpath strcat 144665630Sdcs path strcat 144765630Sdcs 2dup to newmodulepath 144865630Sdcs modulepath setenv 144965630Sdcs 145065630Sdcs \ Try all default kernel names 145165938Sdcs flags args 1- load_a_kernel 145265630Sdcs 0= if ( success ) 145365630Sdcs oldmodulepath nip -1 <> if 145465630Sdcs newmodulepath s" ;" strcat 145565630Sdcs oldmodulepath strcat 145665630Sdcs modulepath setenv 145765630Sdcs newmodulepath drop free-memory 145865630Sdcs oldmodulepath drop free-memory 145965630Sdcs then 146065630Sdcs 0 exit 146165630Sdcs then 146265630Sdcs 146365630Sdcs \ Well, try without the prepended /boot/ 146465630Sdcs path newmodulepath drop swap move 146565883Sdcs newmodulepath drop path nip 146665630Sdcs 2dup to newmodulepath 146765630Sdcs modulepath setenv 146865630Sdcs 146965630Sdcs \ Try all default kernel names 147065938Sdcs flags args 1- load_a_kernel 147165630Sdcs if ( failed once more ) 147265630Sdcs oldmodulepath restoreenv 147365630Sdcs newmodulepath drop free-memory 147465630Sdcs 1 147565630Sdcs else 147665630Sdcs oldmodulepath nip -1 <> if 147765630Sdcs newmodulepath s" ;" strcat 147865630Sdcs oldmodulepath strcat 147965630Sdcs modulepath setenv 148065630Sdcs newmodulepath drop free-memory 148165630Sdcs oldmodulepath drop free-memory 148265630Sdcs then 148365630Sdcs 0 148465630Sdcs then 148565630Sdcs; 148665630Sdcs 148765630Sdcs\ Try to load a kernel; the kernel name is taken from one of 148865630Sdcs\ the following lists, as ordered: 148965630Sdcs\ 149065641Sdcs\ 1. The "bootfile" environment variable 149165641Sdcs\ 2. The "kernel" environment variable 149265630Sdcs\ 3. The "path" argument 149365630Sdcs\ 149465630Sdcs\ Flags are passed, if provided. 149565630Sdcs\ 149665630Sdcs\ The kernel will be loaded from a directory computed from the 149765630Sdcs\ path given. Two directories will be tried in the following order: 149865630Sdcs\ 149965630Sdcs\ 1. /boot/path 150065630Sdcs\ 2. path 150165630Sdcs\ 150265630Sdcs\ Unless "path" is meant to be kernel name itself. In that case, it 150365630Sdcs\ will first be tried as a full path, and, next, search on the 150465630Sdcs\ directories pointed by module_path. 150565630Sdcs\ 150665630Sdcs\ The module_path variable is overridden if load is succesful, by 150765630Sdcs\ prepending the successful path. 150865630Sdcs 150965630Sdcs: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 151065630Sdcs local args 151165630Sdcs 2local path 151265630Sdcs args 1 = if 0 0 then 151365630Sdcs 2local flags 151465630Sdcs end-locals 151565630Sdcs 151665630Sdcs \ First, assume path is an absolute path to a directory 151765630Sdcs flags path args clip_args load_from_directory 151865630Sdcs dup 0= if exit else drop then 151965630Sdcs 152065630Sdcs \ Next, assume path points to the kernel 152165630Sdcs flags path args try_multiple_kernels 152265630Sdcs; 152365630Sdcs 152444603Sdcs: initialize ( addr len -- ) 152544603Sdcs strdup conf_files .len ! conf_files .addr ! 152644603Sdcs; 152744603Sdcs 152865883Sdcs: kernel_options ( -- addr len 1 | 0 ) 152965630Sdcs s" kernel_options" getenv 153065883Sdcs dup -1 = if drop 0 else 1 then 153165630Sdcs; 153265630Sdcs 153365938Sdcs: standard_kernel_search ( flags 1 | 0 -- flag ) 153465938Sdcs local args 153565938Sdcs args 0= if 0 0 then 153665938Sdcs 2local flags 153765630Sdcs s" kernel" getenv 153865938Sdcs dup -1 = if 0 swap then 153965938Sdcs 2local path 154065938Sdcs end-locals 154165938Sdcs 154266349Sdcs path nip -1 = if ( there isn't a "kernel" environment variable ) 154365938Sdcs flags args load_a_kernel 154465938Sdcs else 154565938Sdcs flags path args 1+ clip_args load_directory_or_file 154665938Sdcs then 154765630Sdcs; 154865630Sdcs 154944603Sdcs: load_kernel ( -- ) ( throws: abort ) 155065938Sdcs kernel_options standard_kernel_search 155165630Sdcs abort" Unable to load a kernel!" 155244603Sdcs; 155365883Sdcs 155465949Sdcs: set_defaultoptions ( -- ) 155565883Sdcs s" kernel_options" getenv dup -1 = if 155665883Sdcs drop 155765883Sdcs else 155865883Sdcs s" temp_options" setenv 155965883Sdcs then 156065883Sdcs; 156165883Sdcs 156265883Sdcs: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 156365883Sdcs 2dup = if 0 0 exit then 156465883Sdcs dup >r 156565883Sdcs 1+ 2* ( skip N and ui ) 156665883Sdcs pick 156765883Sdcs r> 156865883Sdcs 1+ 2* ( skip N and ai ) 156965883Sdcs pick 157065883Sdcs; 157165883Sdcs 157265949Sdcs: drop_args ( aN uN ... a1 u1 N -- ) 157365883Sdcs 0 ?do 2drop loop 157465883Sdcs; 157565883Sdcs 157665883Sdcs: argc 157765883Sdcs dup 157865883Sdcs; 157965883Sdcs 158065949Sdcs: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 158165883Sdcs >r 158265883Sdcs over 2* 1+ -roll 158365883Sdcs r> 158465883Sdcs over 2* 1+ -roll 158565883Sdcs 1+ 158665883Sdcs; 158765883Sdcs 158865949Sdcs: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 158965883Sdcs 1- -rot 159065883Sdcs; 159165883Sdcs 159265883Sdcs: strlen(argv) 159365883Sdcs dup 0= if 0 exit then 159465883Sdcs 0 >r \ Size 159565883Sdcs 0 >r \ Index 159665883Sdcs begin 159765883Sdcs argc r@ <> 159865883Sdcs while 159965883Sdcs r@ argv[] 160065883Sdcs nip 160165883Sdcs r> r> rot + 1+ 160265883Sdcs >r 1+ >r 160365883Sdcs repeat 160465883Sdcs r> drop 160565883Sdcs r> 160665883Sdcs; 160765883Sdcs 160865949Sdcs: concat_argv ( aN uN ... a1 u1 N -- a u ) 160965883Sdcs strlen(argv) allocate if out_of_memory throw then 161065883Sdcs 0 2>r 161165883Sdcs 161265883Sdcs begin 161365883Sdcs argc 161465883Sdcs while 161565949Sdcs unqueue_argv 161665883Sdcs 2r> 2swap 161765883Sdcs strcat 161865883Sdcs s" " strcat 161965883Sdcs 2>r 162065883Sdcs repeat 162165949Sdcs drop_args 162265883Sdcs 2r> 162365883Sdcs; 162465883Sdcs 162565949Sdcs: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 162665883Sdcs \ Save the first argument, if it exists and is not a flag 162765883Sdcs argc if 162865883Sdcs 0 argv[] drop c@ [char] - <> if 162965949Sdcs unqueue_argv 2>r \ Filename 163065883Sdcs 1 >r \ Filename present 163165883Sdcs else 163265883Sdcs 0 >r \ Filename not present 163365883Sdcs then 163465883Sdcs else 163565883Sdcs 0 >r \ Filename not present 163665883Sdcs then 163765883Sdcs 163865883Sdcs \ If there are other arguments, assume they are flags 163965883Sdcs ?dup if 164065949Sdcs concat_argv 164165883Sdcs 2dup s" temp_options" setenv 164265883Sdcs drop free if free_error throw then 164365883Sdcs else 164465949Sdcs set_defaultoptions 164565883Sdcs then 164665883Sdcs 164765883Sdcs \ Bring back the filename, if one was provided 164865883Sdcs r> if 2r> 1 else 0 then 164965883Sdcs; 165065883Sdcs 165165949Sdcs: get_arguments ( -- addrN lenN ... addr1 len1 N ) 165265883Sdcs 0 165365883Sdcs begin 165465883Sdcs \ Get next word on the command line 165565883Sdcs parse-word 165665883Sdcs ?dup while 165765949Sdcs queue_argv 165865883Sdcs repeat 165965883Sdcs drop ( empty string ) 166065883Sdcs; 166165883Sdcs 166265945Sdcs: load_kernel_and_modules ( args -- flag ) 166365949Sdcs set_tempoptions 166465883Sdcs argc >r 166565883Sdcs s" temp_options" getenv dup -1 <> if 166665949Sdcs queue_argv 166765883Sdcs else 166865883Sdcs drop 166965883Sdcs then 167065883Sdcs r> if ( a path was passed ) 167165938Sdcs load_directory_or_file 167265883Sdcs else 167365938Sdcs standard_kernel_search 167465883Sdcs then 167565938Sdcs ?dup 0= if ['] load_modules catch then 167665883Sdcs; 167765883Sdcs 167853672Sdcs: read-password { size | buf len -- } 167953672Sdcs size allocate if out_of_memory throw then 168053672Sdcs to buf 168153672Sdcs 0 to len 168253672Sdcs begin 168353672Sdcs key 168453672Sdcs dup backspace = if 168553672Sdcs drop 168653672Sdcs len if 168753672Sdcs backspace emit bl emit backspace emit 168853672Sdcs len 1 - to len 168953672Sdcs else 169053672Sdcs bell emit 169153672Sdcs then 169253672Sdcs else 169353672Sdcs dup <cr> = if cr drop buf len exit then 169453672Sdcs [char] * emit 169553672Sdcs len size < if 169653672Sdcs buf len chars + c! 169753672Sdcs else 169853672Sdcs drop 169953672Sdcs then 170053672Sdcs len 1+ to len 170153672Sdcs then 170253672Sdcs again 170353672Sdcs; 170453672Sdcs 170544603Sdcs\ Go back to straight forth vocabulary 170644603Sdcs 170744603Sdcsonly forth also definitions 170844603Sdcs 1709