support.4th revision 65938
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 65938 2000-09-16 19:49:52Z dcs $ 2644603Sdcs 2744603Sdcs\ Loader.rc support functions: 2844603Sdcs\ 2944603Sdcs\ initialize_support ( -- ) initialize global variables 3044603Sdcs\ initialize ( addr len -- ) as above, plus load_conf_files 3144603Sdcs\ load_conf ( addr len -- ) load conf file given 3244603Sdcs\ include_conf_files ( -- ) load all conf files in load_conf_files 3344603Sdcs\ print_syntax_error ( -- ) print line and marker of where a syntax 3444603Sdcs\ error was detected 3544603Sdcs\ print_line ( -- ) print last line processed 3644603Sdcs\ load_kernel ( -- ) load kernel 3744603Sdcs\ load_modules ( -- ) load modules flagged 3844603Sdcs\ 3944603Sdcs\ Exported structures: 4044603Sdcs\ 4144603Sdcs\ string counted string structure 4244603Sdcs\ cell .addr string address 4344603Sdcs\ cell .len string length 4444603Sdcs\ module module loading information structure 4544603Sdcs\ cell module.flag should we load it? 4644603Sdcs\ string module.name module's name 4744603Sdcs\ string module.loadname name to be used in loading the module 4844603Sdcs\ string module.type module's type 4944603Sdcs\ string module.args flags to be passed during load 5044603Sdcs\ string module.beforeload command to be executed before load 5144603Sdcs\ string module.afterload command to be executed after load 5244603Sdcs\ string module.loaderror command to be executed if load fails 5344603Sdcs\ cell module.next list chain 5444603Sdcs\ 5544603Sdcs\ Exported global variables; 5644603Sdcs\ 5744603Sdcs\ string conf_files configuration files to be loaded 5853672Sdcs\ string password password 5944603Sdcs\ cell modules_options pointer to first module information 6044603Sdcs\ value verbose? indicates if user wants a verbose loading 6144603Sdcs\ value any_conf_read? indicates if a conf file was succesfully read 6244603Sdcs\ 6344603Sdcs\ Other exported words: 6444603Sdcs\ 6544603Sdcs\ strdup ( addr len -- addr' len) similar to strdup(3) 6644603Sdcs\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3) 6761373Sdcs\ strlen ( addr -- len ) similar to strlen(3) 6844603Sdcs\ s' ( | string' -- addr len | ) similar to s" 6944603Sdcs\ rudimentary structure support 7044603Sdcs 7144603Sdcs\ Exception values 7244603Sdcs 7344603Sdcs1 constant syntax_error 7444603Sdcs2 constant out_of_memory 7544603Sdcs3 constant free_error 7644603Sdcs4 constant set_error 7744603Sdcs5 constant read_error 7844603Sdcs6 constant open_error 7944603Sdcs7 constant exec_error 8044603Sdcs8 constant before_load_error 8144603Sdcs9 constant after_load_error 8244603Sdcs 8344603Sdcs\ Crude structure support 8444603Sdcs 8565615Sdcs: structure: 8665615Sdcs create here 0 , ['] drop , 0 8765615Sdcs does> create here swap dup @ allot cell+ @ execute 8865615Sdcs; 8944603Sdcs: member: create dup , over , + does> cell+ @ + ; 9044603Sdcs: ;structure swap ! ; 9165615Sdcs: constructor! >body cell+ ! ; 9265615Sdcs: constructor: over :noname ; 9365615Sdcs: ;constructor postpone ; swap cell+ ! ; immediate 9444603Sdcs: sizeof ' >body @ state @ if postpone literal then ; immediate 9544603Sdcs: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate 9644603Sdcs: ptr 1 cells member: ; 9744603Sdcs: int 1 cells member: ; 9844603Sdcs 9944603Sdcs\ String structure 10044603Sdcs 10144603Sdcsstructure: string 10244603Sdcs ptr .addr 10344603Sdcs int .len 10465615Sdcs constructor: 10565615Sdcs 0 over .addr ! 10665615Sdcs 0 swap .len ! 10765615Sdcs ;constructor 10844603Sdcs;structure 10944603Sdcs 11065615Sdcs 11144603Sdcs\ Module options linked list 11244603Sdcs 11344603Sdcsstructure: module 11444603Sdcs int module.flag 11544603Sdcs sizeof string member: module.name 11644603Sdcs sizeof string member: module.loadname 11744603Sdcs sizeof string member: module.type 11844603Sdcs sizeof string member: module.args 11944603Sdcs sizeof string member: module.beforeload 12044603Sdcs sizeof string member: module.afterload 12144603Sdcs sizeof string member: module.loaderror 12244603Sdcs ptr module.next 12344603Sdcs;structure 12444603Sdcs 12565615Sdcs\ Internal loader structures 12665615Sdcsstructure: preloaded_file 12765615Sdcs ptr pf.name 12865615Sdcs ptr pf.type 12965615Sdcs ptr pf.args 13065615Sdcs ptr pf.metadata \ file_metadata 13165615Sdcs int pf.loader 13265615Sdcs int pf.addr 13365615Sdcs int pf.size 13465615Sdcs ptr pf.modules \ kernel_module 13565615Sdcs ptr pf.next \ preloaded_file 13665615Sdcs;structure 13765615Sdcs 13865615Sdcsstructure: kernel_module 13965615Sdcs ptr km.name 14065615Sdcs \ ptr km.args 14165615Sdcs ptr km.fp \ preloaded_file 14265615Sdcs ptr km.next \ kernel_module 14365615Sdcs;structure 14465615Sdcs 14565615Sdcsstructure: file_metadata 14665615Sdcs int md.size 14765615Sdcs 2 member: md.type \ this is not ANS Forth compatible (XXX) 14865615Sdcs ptr md.next \ file_metadata 14965615Sdcs 0 member: md.data \ variable size 15065615Sdcs;structure 15165615Sdcs 15265615Sdcsstructure: config_resource 15365615Sdcs ptr cf.name 15465615Sdcs int cf.type 15565615Sdcs0 constant RES_INT 15665615Sdcs1 constant RES_STRING 15765615Sdcs2 constant RES_LONG 15865615Sdcs 2 cells member: u 15965615Sdcs;structure 16065615Sdcs 16165615Sdcsstructure: config_device 16265615Sdcs ptr cd.name 16365615Sdcs int cd.unit 16465615Sdcs int cd.resource_count 16565615Sdcs ptr cd.resources \ config_resource 16665615Sdcs;structure 16765615Sdcs 16865615Sdcsstructure: STAILQ_HEAD 16965615Sdcs ptr stqh_first \ type* 17065615Sdcs ptr stqh_last \ type** 17165615Sdcs;structure 17265615Sdcs 17365615Sdcsstructure: STAILQ_ENTRY 17465615Sdcs ptr stqe_next \ type* 17565615Sdcs;structure 17665615Sdcs 17765615Sdcsstructure: pnphandler 17865615Sdcs ptr pnph.name 17965615Sdcs ptr pnph.enumerate 18065615Sdcs;structure 18165615Sdcs 18265615Sdcsstructure: pnpident 18365615Sdcs ptr pnpid.ident \ char* 18465615Sdcs sizeof STAILQ_ENTRY cells member: pnpid.link \ pnpident 18565615Sdcs;structure 18665615Sdcs 18765615Sdcsstructure: pnpinfo 18865615Sdcs ptr pnpi.desc 18965615Sdcs int pnpi.revision 19065615Sdcs ptr pnpi.module \ (char*) module args 19165615Sdcs int pnpi.argc 19265615Sdcs ptr pnpi.argv 19365615Sdcs ptr pnpi.handler \ pnphandler 19465615Sdcs sizeof STAILQ_HEAD member: pnpi.ident \ pnpident 19565615Sdcs sizeof STAILQ_ENTRY member: pnpi.link \ pnpinfo 19665615Sdcs;structure 19765615Sdcs 19844603Sdcs\ Global variables 19944603Sdcs 20044603Sdcsstring conf_files 20153672Sdcsstring password 20265615Sdcscreate module_options sizeof module.next allot 0 module_options ! 20365615Sdcscreate last_module_option sizeof module.next allot 0 last_module_option ! 20444603Sdcs0 value verbose? 20544603Sdcs 20644603Sdcs\ Support string functions 20744603Sdcs 20844603Sdcs: strdup ( addr len -- addr' len ) 20944603Sdcs >r r@ allocate if out_of_memory throw then 21044603Sdcs tuck r@ move 21144603Sdcs r> 21244603Sdcs; 21344603Sdcs 21444603Sdcs: strcat { addr len addr' len' -- addr len+len' } 21544603Sdcs addr' addr len + len' move 21644603Sdcs addr len len' + 21744603Sdcs; 21844603Sdcs 21961373Sdcs: strlen ( addr -- len ) 22061373Sdcs 0 >r 22161373Sdcs begin 22261373Sdcs dup c@ while 22361373Sdcs 1+ r> 1+ >r repeat 22461373Sdcs drop r> 22561373Sdcs; 22661373Sdcs 22744603Sdcs: s' 22844603Sdcs [char] ' parse 22944603Sdcs state @ if 23044603Sdcs postpone sliteral 23144603Sdcs then 23244603Sdcs; immediate 23344603Sdcs 23461373Sdcs: 2>r postpone >r postpone >r ; immediate 23561373Sdcs: 2r> postpone r> postpone r> ; immediate 23665883Sdcs: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate 23753672Sdcs 23865938Sdcs: getenv? 23965938Sdcs getenv 24065938Sdcs -1 = if false else drop true then 24165938Sdcs; 24265938Sdcs 24344603Sdcs\ Private definitions 24444603Sdcs 24544603Sdcsvocabulary support-functions 24644603Sdcsonly forth also support-functions definitions 24744603Sdcs 24844603Sdcs\ Some control characters constants 24944603Sdcs 25053672Sdcs7 constant bell 25153672Sdcs8 constant backspace 25244603Sdcs9 constant tab 25344603Sdcs10 constant lf 25453672Sdcs13 constant <cr> 25544603Sdcs 25644603Sdcs\ Read buffer size 25744603Sdcs 25844603Sdcs80 constant read_buffer_size 25944603Sdcs 26044603Sdcs\ Standard suffixes 26144603Sdcs 26244603Sdcs: load_module_suffix s" _load" ; 26344603Sdcs: module_loadname_suffix s" _name" ; 26444603Sdcs: module_type_suffix s" _type" ; 26544603Sdcs: module_args_suffix s" _flags" ; 26644603Sdcs: module_beforeload_suffix s" _before" ; 26744603Sdcs: module_afterload_suffix s" _after" ; 26844603Sdcs: module_loaderror_suffix s" _error" ; 26944603Sdcs 27044603Sdcs\ Support operators 27144603Sdcs 27244603Sdcs: >= < 0= ; 27344603Sdcs: <= > 0= ; 27444603Sdcs 27544603Sdcs\ Assorted support funcitons 27644603Sdcs 27744603Sdcs: free-memory free if free_error throw then ; 27844603Sdcs 27944603Sdcs\ Assignment data temporary storage 28044603Sdcs 28144603Sdcsstring name_buffer 28244603Sdcsstring value_buffer 28344603Sdcs 28465615Sdcs\ Line by line file reading functions 28565615Sdcs\ 28665615Sdcs\ exported: 28765615Sdcs\ line_buffer 28865615Sdcs\ end_of_file? 28965615Sdcs\ fd 29065615Sdcs\ read_line 29165615Sdcs\ reset_line_reading 29265615Sdcs 29365615Sdcsvocabulary line-reading 29465615Sdcsalso line-reading definitions also 29565615Sdcs 29644603Sdcs\ File data temporary storage 29744603Sdcs 29844603Sdcsstring read_buffer 29944603Sdcs0 value read_buffer_ptr 30044603Sdcs 30144603Sdcs\ File's line reading function 30244603Sdcs 30365615Sdcssupport-functions definitions 30465615Sdcs 30565615Sdcsstring line_buffer 30644603Sdcs0 value end_of_file? 30744603Sdcsvariable fd 30844603Sdcs 30965615Sdcsline-reading definitions 31065615Sdcs 31144603Sdcs: skip_newlines 31244603Sdcs begin 31344603Sdcs read_buffer .len @ read_buffer_ptr > 31444603Sdcs while 31544603Sdcs read_buffer .addr @ read_buffer_ptr + c@ lf = if 31644603Sdcs read_buffer_ptr char+ to read_buffer_ptr 31744603Sdcs else 31844603Sdcs exit 31944603Sdcs then 32044603Sdcs repeat 32144603Sdcs; 32244603Sdcs 32344603Sdcs: scan_buffer ( -- addr len ) 32444603Sdcs read_buffer_ptr >r 32544603Sdcs begin 32644603Sdcs read_buffer .len @ r@ > 32744603Sdcs while 32844603Sdcs read_buffer .addr @ r@ + c@ lf = if 32944603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 33044603Sdcs r@ read_buffer_ptr - ( -- len ) 33144603Sdcs r> to read_buffer_ptr 33244603Sdcs exit 33344603Sdcs then 33444603Sdcs r> char+ >r 33544603Sdcs repeat 33644603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 33744603Sdcs r@ read_buffer_ptr - ( -- len ) 33844603Sdcs r> to read_buffer_ptr 33944603Sdcs; 34044603Sdcs 34144603Sdcs: line_buffer_resize ( len -- len ) 34244603Sdcs >r 34344603Sdcs line_buffer .len @ if 34444603Sdcs line_buffer .addr @ 34544603Sdcs line_buffer .len @ r@ + 34644603Sdcs resize if out_of_memory throw then 34744603Sdcs else 34844603Sdcs r@ allocate if out_of_memory throw then 34944603Sdcs then 35044603Sdcs line_buffer .addr ! 35144603Sdcs r> 35244603Sdcs; 35344603Sdcs 35444603Sdcs: append_to_line_buffer ( addr len -- ) 35544603Sdcs line_buffer .addr @ line_buffer .len @ 35644603Sdcs 2swap strcat 35744603Sdcs line_buffer .len ! 35844603Sdcs drop 35944603Sdcs; 36044603Sdcs 36144603Sdcs: read_from_buffer 36244603Sdcs scan_buffer ( -- addr len ) 36344603Sdcs line_buffer_resize ( len -- len ) 36444603Sdcs append_to_line_buffer ( addr len -- ) 36544603Sdcs; 36644603Sdcs 36744603Sdcs: refill_required? 36844603Sdcs read_buffer .len @ read_buffer_ptr = 36944603Sdcs end_of_file? 0= and 37044603Sdcs; 37144603Sdcs 37244603Sdcs: refill_buffer 37344603Sdcs 0 to read_buffer_ptr 37444603Sdcs read_buffer .addr @ 0= if 37544603Sdcs read_buffer_size allocate if out_of_memory throw then 37644603Sdcs read_buffer .addr ! 37744603Sdcs then 37844603Sdcs fd @ read_buffer .addr @ read_buffer_size fread 37944603Sdcs dup -1 = if read_error throw then 38044603Sdcs dup 0= if true to end_of_file? then 38144603Sdcs read_buffer .len ! 38244603Sdcs; 38344603Sdcs 38444603Sdcs: reset_line_buffer 38565615Sdcs line_buffer .addr @ ?dup if 38665615Sdcs free-memory 38765615Sdcs then 38844603Sdcs 0 line_buffer .addr ! 38944603Sdcs 0 line_buffer .len ! 39044603Sdcs; 39144603Sdcs 39265615Sdcssupport-functions definitions 39365615Sdcs 39465615Sdcs: reset_line_reading 39565615Sdcs 0 to read_buffer_ptr 39665615Sdcs; 39765615Sdcs 39844603Sdcs: read_line 39944603Sdcs reset_line_buffer 40044603Sdcs skip_newlines 40144603Sdcs begin 40244603Sdcs read_from_buffer 40344603Sdcs refill_required? 40444603Sdcs while 40544603Sdcs refill_buffer 40644603Sdcs repeat 40744603Sdcs; 40844603Sdcs 40965615Sdcsonly forth also support-functions definitions 41065615Sdcs 41144603Sdcs\ Conf file line parser: 41244603Sdcs\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 41344603Sdcs\ <spaces>[<comment>] 41444603Sdcs\ <name> ::= <letter>{<letter>|<digit>|'_'} 41544603Sdcs\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 41644603Sdcs\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 41744603Sdcs\ <comment> ::= '#'{<anything>} 41865615Sdcs\ 41965615Sdcs\ exported: 42065615Sdcs\ line_pointer 42165615Sdcs\ process_conf 42244603Sdcs 42365615Sdcs0 value line_pointer 42465615Sdcs 42565615Sdcsvocabulary file-processing 42665615Sdcsalso file-processing definitions 42765615Sdcs 42865615Sdcs\ parser functions 42965615Sdcs\ 43065615Sdcs\ exported: 43165615Sdcs\ get_assignment 43265615Sdcs 43365615Sdcsvocabulary parser 43465615Sdcsalso parser definitions also 43565615Sdcs 43644603Sdcs0 value parsing_function 43744603Sdcs0 value end_of_line 43844603Sdcs 43944603Sdcs: end_of_line? 44044603Sdcs line_pointer end_of_line = 44144603Sdcs; 44244603Sdcs 44344603Sdcs: letter? 44444603Sdcs line_pointer c@ >r 44544603Sdcs r@ [char] A >= 44644603Sdcs r@ [char] Z <= and 44744603Sdcs r@ [char] a >= 44844603Sdcs r> [char] z <= and 44944603Sdcs or 45044603Sdcs; 45144603Sdcs 45244603Sdcs: digit? 45344603Sdcs line_pointer c@ >r 45444603Sdcs r@ [char] 0 >= 45544603Sdcs r> [char] 9 <= and 45644603Sdcs; 45744603Sdcs 45844603Sdcs: quote? 45944603Sdcs line_pointer c@ [char] " = 46044603Sdcs; 46144603Sdcs 46244603Sdcs: assignment_sign? 46344603Sdcs line_pointer c@ [char] = = 46444603Sdcs; 46544603Sdcs 46644603Sdcs: comment? 46744603Sdcs line_pointer c@ [char] # = 46844603Sdcs; 46944603Sdcs 47044603Sdcs: space? 47144603Sdcs line_pointer c@ bl = 47244603Sdcs line_pointer c@ tab = or 47344603Sdcs; 47444603Sdcs 47544603Sdcs: backslash? 47644603Sdcs line_pointer c@ [char] \ = 47744603Sdcs; 47844603Sdcs 47944603Sdcs: underscore? 48044603Sdcs line_pointer c@ [char] _ = 48144603Sdcs; 48244603Sdcs 48344603Sdcs: dot? 48444603Sdcs line_pointer c@ [char] . = 48544603Sdcs; 48644603Sdcs 48744603Sdcs: skip_character 48844603Sdcs line_pointer char+ to line_pointer 48944603Sdcs; 49044603Sdcs 49144603Sdcs: skip_to_end_of_line 49244603Sdcs end_of_line to line_pointer 49344603Sdcs; 49444603Sdcs 49544603Sdcs: eat_space 49644603Sdcs begin 49744603Sdcs space? 49844603Sdcs while 49944603Sdcs skip_character 50044603Sdcs end_of_line? if exit then 50144603Sdcs repeat 50244603Sdcs; 50344603Sdcs 50444603Sdcs: parse_name ( -- addr len ) 50544603Sdcs line_pointer 50644603Sdcs begin 50744603Sdcs letter? digit? underscore? dot? or or or 50844603Sdcs while 50944603Sdcs skip_character 51044603Sdcs end_of_line? if 51144603Sdcs line_pointer over - 51244603Sdcs strdup 51344603Sdcs exit 51444603Sdcs then 51544603Sdcs repeat 51644603Sdcs line_pointer over - 51744603Sdcs strdup 51844603Sdcs; 51944603Sdcs 52044603Sdcs: remove_backslashes { addr len | addr' len' -- addr' len' } 52144603Sdcs len allocate if out_of_memory throw then 52244603Sdcs to addr' 52344603Sdcs addr >r 52444603Sdcs begin 52544603Sdcs addr c@ [char] \ <> if 52644603Sdcs addr c@ addr' len' + c! 52744603Sdcs len' char+ to len' 52844603Sdcs then 52944603Sdcs addr char+ to addr 53044603Sdcs r@ len + addr = 53144603Sdcs until 53244603Sdcs r> drop 53344603Sdcs addr' len' 53444603Sdcs; 53544603Sdcs 53644603Sdcs: parse_quote ( -- addr len ) 53744603Sdcs line_pointer 53844603Sdcs skip_character 53944603Sdcs end_of_line? if syntax_error throw then 54044603Sdcs begin 54144603Sdcs quote? 0= 54244603Sdcs while 54344603Sdcs backslash? if 54444603Sdcs skip_character 54544603Sdcs end_of_line? if syntax_error throw then 54644603Sdcs then 54744603Sdcs skip_character 54844603Sdcs end_of_line? if syntax_error throw then 54944603Sdcs repeat 55044603Sdcs skip_character 55144603Sdcs line_pointer over - 55244603Sdcs remove_backslashes 55344603Sdcs; 55444603Sdcs 55544603Sdcs: read_name 55644603Sdcs parse_name ( -- addr len ) 55744603Sdcs name_buffer .len ! 55844603Sdcs name_buffer .addr ! 55944603Sdcs; 56044603Sdcs 56144603Sdcs: read_value 56244603Sdcs quote? if 56344603Sdcs parse_quote ( -- addr len ) 56444603Sdcs else 56544603Sdcs parse_name ( -- addr len ) 56644603Sdcs then 56744603Sdcs value_buffer .len ! 56844603Sdcs value_buffer .addr ! 56944603Sdcs; 57044603Sdcs 57144603Sdcs: comment 57244603Sdcs skip_to_end_of_line 57344603Sdcs; 57444603Sdcs 57544603Sdcs: white_space_4 57644603Sdcs eat_space 57744603Sdcs comment? if ['] comment to parsing_function exit then 57844603Sdcs end_of_line? 0= if syntax_error throw then 57944603Sdcs; 58044603Sdcs 58144603Sdcs: variable_value 58244603Sdcs read_value 58344603Sdcs ['] white_space_4 to parsing_function 58444603Sdcs; 58544603Sdcs 58644603Sdcs: white_space_3 58744603Sdcs eat_space 58844603Sdcs letter? digit? quote? or or if 58944603Sdcs ['] variable_value to parsing_function exit 59044603Sdcs then 59144603Sdcs syntax_error throw 59244603Sdcs; 59344603Sdcs 59444603Sdcs: assignment_sign 59544603Sdcs skip_character 59644603Sdcs ['] white_space_3 to parsing_function 59744603Sdcs; 59844603Sdcs 59944603Sdcs: white_space_2 60044603Sdcs eat_space 60144603Sdcs assignment_sign? if ['] assignment_sign to parsing_function exit then 60244603Sdcs syntax_error throw 60344603Sdcs; 60444603Sdcs 60544603Sdcs: variable_name 60644603Sdcs read_name 60744603Sdcs ['] white_space_2 to parsing_function 60844603Sdcs; 60944603Sdcs 61044603Sdcs: white_space_1 61144603Sdcs eat_space 61244603Sdcs letter? if ['] variable_name to parsing_function exit then 61344603Sdcs comment? if ['] comment to parsing_function exit then 61444603Sdcs end_of_line? 0= if syntax_error throw then 61544603Sdcs; 61644603Sdcs 61765615Sdcsfile-processing definitions 61865615Sdcs 61944603Sdcs: get_assignment 62044603Sdcs line_buffer .addr @ line_buffer .len @ + to end_of_line 62144603Sdcs line_buffer .addr @ to line_pointer 62244603Sdcs ['] white_space_1 to parsing_function 62344603Sdcs begin 62444603Sdcs end_of_line? 0= 62544603Sdcs while 62644603Sdcs parsing_function execute 62744603Sdcs repeat 62844603Sdcs parsing_function ['] comment = 62944603Sdcs parsing_function ['] white_space_1 = 63044603Sdcs parsing_function ['] white_space_4 = 63144603Sdcs or or 0= if syntax_error throw then 63244603Sdcs; 63344603Sdcs 63465615Sdcsonly forth also support-functions also file-processing definitions also 63565615Sdcs 63644603Sdcs\ Process line 63744603Sdcs 63844603Sdcs: assignment_type? ( addr len -- flag ) 63944603Sdcs name_buffer .addr @ name_buffer .len @ 64044603Sdcs compare 0= 64144603Sdcs; 64244603Sdcs 64344603Sdcs: suffix_type? ( addr len -- flag ) 64444603Sdcs name_buffer .len @ over <= if 2drop false exit then 64544603Sdcs name_buffer .len @ over - name_buffer .addr @ + 64644603Sdcs over compare 0= 64744603Sdcs; 64844603Sdcs 64944603Sdcs: loader_conf_files? 65044603Sdcs s" loader_conf_files" assignment_type? 65144603Sdcs; 65244603Sdcs 65344603Sdcs: verbose_flag? 65444603Sdcs s" verbose_loading" assignment_type? 65544603Sdcs; 65644603Sdcs 65744603Sdcs: execute? 65844603Sdcs s" exec" assignment_type? 65944603Sdcs; 66044603Sdcs 66153672Sdcs: password? 66253672Sdcs s" password" assignment_type? 66353672Sdcs; 66453672Sdcs 66544603Sdcs: module_load? 66644603Sdcs load_module_suffix suffix_type? 66744603Sdcs; 66844603Sdcs 66944603Sdcs: module_loadname? 67044603Sdcs module_loadname_suffix suffix_type? 67144603Sdcs; 67244603Sdcs 67344603Sdcs: module_type? 67444603Sdcs module_type_suffix suffix_type? 67544603Sdcs; 67644603Sdcs 67744603Sdcs: module_args? 67844603Sdcs module_args_suffix suffix_type? 67944603Sdcs; 68044603Sdcs 68144603Sdcs: module_beforeload? 68244603Sdcs module_beforeload_suffix suffix_type? 68344603Sdcs; 68444603Sdcs 68544603Sdcs: module_afterload? 68644603Sdcs module_afterload_suffix suffix_type? 68744603Sdcs; 68844603Sdcs 68944603Sdcs: module_loaderror? 69044603Sdcs module_loaderror_suffix suffix_type? 69144603Sdcs; 69244603Sdcs 69344603Sdcs: set_conf_files 69444603Sdcs conf_files .addr @ ?dup if 69544603Sdcs free-memory 69644603Sdcs then 69744603Sdcs value_buffer .addr @ c@ [char] " = if 69844603Sdcs value_buffer .addr @ char+ value_buffer .len @ 2 chars - 69944603Sdcs else 70044603Sdcs value_buffer .addr @ value_buffer .len @ 70144603Sdcs then 70244603Sdcs strdup 70344603Sdcs conf_files .len ! conf_files .addr ! 70444603Sdcs; 70544603Sdcs 70644603Sdcs: append_to_module_options_list ( addr -- ) 70744603Sdcs module_options @ 0= if 70844603Sdcs dup module_options ! 70944603Sdcs last_module_option ! 71044603Sdcs else 71144603Sdcs dup last_module_option @ module.next ! 71244603Sdcs last_module_option ! 71344603Sdcs then 71444603Sdcs; 71544603Sdcs 71644603Sdcs: set_module_name ( addr -- ) 71744603Sdcs name_buffer .addr @ name_buffer .len @ 71844603Sdcs strdup 71944603Sdcs >r over module.name .addr ! 72044603Sdcs r> swap module.name .len ! 72144603Sdcs; 72244603Sdcs 72344603Sdcs: yes_value? 72444603Sdcs value_buffer .addr @ value_buffer .len @ 72544603Sdcs 2dup s' "YES"' compare >r 72644603Sdcs 2dup s' "yes"' compare >r 72744603Sdcs 2dup s" YES" compare >r 72844603Sdcs s" yes" compare r> r> r> and and and 0= 72944603Sdcs; 73044603Sdcs 73144603Sdcs: find_module_option ( -- addr | 0 ) 73244603Sdcs module_options @ 73344603Sdcs begin 73444603Sdcs dup 73544603Sdcs while 73644603Sdcs dup module.name dup .addr @ swap .len @ 73744603Sdcs name_buffer .addr @ name_buffer .len @ 73844603Sdcs compare 0= if exit then 73944603Sdcs module.next @ 74044603Sdcs repeat 74144603Sdcs; 74244603Sdcs 74344603Sdcs: new_module_option ( -- addr ) 74444603Sdcs sizeof module allocate if out_of_memory throw then 74544603Sdcs dup sizeof module erase 74644603Sdcs dup append_to_module_options_list 74744603Sdcs dup set_module_name 74844603Sdcs; 74944603Sdcs 75044603Sdcs: get_module_option ( -- addr ) 75144603Sdcs find_module_option 75244603Sdcs ?dup 0= if new_module_option then 75344603Sdcs; 75444603Sdcs 75544603Sdcs: set_module_flag 75644603Sdcs name_buffer .len @ load_module_suffix nip - name_buffer .len ! 75744603Sdcs yes_value? get_module_option module.flag ! 75844603Sdcs; 75944603Sdcs 76044603Sdcs: set_module_args 76144603Sdcs name_buffer .len @ module_args_suffix nip - name_buffer .len ! 76244603Sdcs get_module_option module.args 76344603Sdcs dup .addr @ ?dup if free-memory then 76444603Sdcs value_buffer .addr @ value_buffer .len @ 76544603Sdcs over c@ [char] " = if 76644603Sdcs 2 chars - swap char+ swap 76744603Sdcs then 76844603Sdcs strdup 76944603Sdcs >r over .addr ! 77044603Sdcs r> swap .len ! 77144603Sdcs; 77244603Sdcs 77344603Sdcs: set_module_loadname 77444603Sdcs name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 77544603Sdcs get_module_option module.loadname 77644603Sdcs dup .addr @ ?dup if free-memory then 77744603Sdcs value_buffer .addr @ value_buffer .len @ 77844603Sdcs over c@ [char] " = if 77944603Sdcs 2 chars - swap char+ swap 78044603Sdcs then 78144603Sdcs strdup 78244603Sdcs >r over .addr ! 78344603Sdcs r> swap .len ! 78444603Sdcs; 78544603Sdcs 78644603Sdcs: set_module_type 78744603Sdcs name_buffer .len @ module_type_suffix nip - name_buffer .len ! 78844603Sdcs get_module_option module.type 78944603Sdcs dup .addr @ ?dup if free-memory then 79044603Sdcs value_buffer .addr @ value_buffer .len @ 79144603Sdcs over c@ [char] " = if 79244603Sdcs 2 chars - swap char+ swap 79344603Sdcs then 79444603Sdcs strdup 79544603Sdcs >r over .addr ! 79644603Sdcs r> swap .len ! 79744603Sdcs; 79844603Sdcs 79944603Sdcs: set_module_beforeload 80044603Sdcs name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 80144603Sdcs get_module_option module.beforeload 80244603Sdcs dup .addr @ ?dup if free-memory then 80344603Sdcs value_buffer .addr @ value_buffer .len @ 80444603Sdcs over c@ [char] " = if 80544603Sdcs 2 chars - swap char+ swap 80644603Sdcs then 80744603Sdcs strdup 80844603Sdcs >r over .addr ! 80944603Sdcs r> swap .len ! 81044603Sdcs; 81144603Sdcs 81244603Sdcs: set_module_afterload 81344603Sdcs name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 81444603Sdcs get_module_option module.afterload 81544603Sdcs dup .addr @ ?dup if free-memory then 81644603Sdcs value_buffer .addr @ value_buffer .len @ 81744603Sdcs over c@ [char] " = if 81844603Sdcs 2 chars - swap char+ swap 81944603Sdcs then 82044603Sdcs strdup 82144603Sdcs >r over .addr ! 82244603Sdcs r> swap .len ! 82344603Sdcs; 82444603Sdcs 82544603Sdcs: set_module_loaderror 82644603Sdcs name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 82744603Sdcs get_module_option module.loaderror 82844603Sdcs dup .addr @ ?dup if free-memory then 82944603Sdcs value_buffer .addr @ value_buffer .len @ 83044603Sdcs over c@ [char] " = if 83144603Sdcs 2 chars - swap char+ swap 83244603Sdcs then 83344603Sdcs strdup 83444603Sdcs >r over .addr ! 83544603Sdcs r> swap .len ! 83644603Sdcs; 83744603Sdcs 83844603Sdcs: set_environment_variable 83944603Sdcs name_buffer .len @ 84044603Sdcs value_buffer .len @ + 84144603Sdcs 5 chars + 84244603Sdcs allocate if out_of_memory throw then 84344603Sdcs dup 0 ( addr -- addr addr len ) 84444603Sdcs s" set " strcat 84544603Sdcs name_buffer .addr @ name_buffer .len @ strcat 84644603Sdcs s" =" strcat 84744603Sdcs value_buffer .addr @ value_buffer .len @ strcat 84844603Sdcs ['] evaluate catch if 84944603Sdcs 2drop free drop 85044603Sdcs set_error throw 85144603Sdcs else 85244603Sdcs free-memory 85344603Sdcs then 85444603Sdcs; 85544603Sdcs 85644603Sdcs: set_verbose 85744603Sdcs yes_value? to verbose? 85844603Sdcs; 85944603Sdcs 86044603Sdcs: execute_command 86144603Sdcs value_buffer .addr @ value_buffer .len @ 86244603Sdcs over c@ [char] " = if 86353672Sdcs 2 - swap char+ swap 86444603Sdcs then 86544603Sdcs ['] evaluate catch if exec_error throw then 86644603Sdcs; 86744603Sdcs 86853672Sdcs: set_password 86953672Sdcs password .addr @ ?dup if free if free_error throw then then 87053672Sdcs value_buffer .addr @ c@ [char] " = if 87153672Sdcs value_buffer .addr @ char+ value_buffer .len @ 2 - strdup 87253672Sdcs value_buffer .addr @ free if free_error throw then 87353672Sdcs else 87453672Sdcs value_buffer .addr @ value_buffer .len @ 87553672Sdcs then 87653672Sdcs password .len ! password .addr ! 87753672Sdcs 0 value_buffer .addr ! 87853672Sdcs; 87953672Sdcs 88044603Sdcs: process_assignment 88144603Sdcs name_buffer .len @ 0= if exit then 88244603Sdcs loader_conf_files? if set_conf_files exit then 88344603Sdcs verbose_flag? if set_verbose exit then 88444603Sdcs execute? if execute_command exit then 88553672Sdcs password? if set_password exit then 88644603Sdcs module_load? if set_module_flag exit then 88744603Sdcs module_loadname? if set_module_loadname exit then 88844603Sdcs module_type? if set_module_type exit then 88944603Sdcs module_args? if set_module_args exit then 89044603Sdcs module_beforeload? if set_module_beforeload exit then 89144603Sdcs module_afterload? if set_module_afterload exit then 89244603Sdcs module_loaderror? if set_module_loaderror exit then 89344603Sdcs set_environment_variable 89444603Sdcs; 89544603Sdcs 89653672Sdcs\ free_buffer ( -- ) 89753672Sdcs\ 89853672Sdcs\ Free some pointers if needed. The code then tests for errors 89953672Sdcs\ in freeing, and throws an exception if needed. If a pointer is 90053672Sdcs\ not allocated, it's value (0) is used as flag. 90153672Sdcs 90244603Sdcs: free_buffers 90344603Sdcs name_buffer .addr @ dup if free then 90444603Sdcs value_buffer .addr @ dup if free then 90565615Sdcs or if free_error throw then 90644603Sdcs; 90744603Sdcs 90844603Sdcs: reset_assignment_buffers 90944603Sdcs 0 name_buffer .addr ! 91044603Sdcs 0 name_buffer .len ! 91144603Sdcs 0 value_buffer .addr ! 91244603Sdcs 0 value_buffer .len ! 91344603Sdcs; 91444603Sdcs 91544603Sdcs\ Higher level file processing 91644603Sdcs 91765615Sdcssupport-functions definitions 91865615Sdcs 91944603Sdcs: process_conf 92044603Sdcs begin 92144603Sdcs end_of_file? 0= 92244603Sdcs while 92344603Sdcs reset_assignment_buffers 92444603Sdcs read_line 92544603Sdcs get_assignment 92644603Sdcs ['] process_assignment catch 92744603Sdcs ['] free_buffers catch 92844603Sdcs swap throw throw 92944603Sdcs repeat 93044603Sdcs; 93144603Sdcs 93265615Sdcsonly forth also support-functions definitions 93365615Sdcs 93444603Sdcs: create_null_terminated_string { addr len -- addr' len } 93544603Sdcs len char+ allocate if out_of_memory throw then 93644603Sdcs >r 93744603Sdcs addr r@ len move 93844603Sdcs 0 r@ len + c! 93944603Sdcs r> len 94044603Sdcs; 94144603Sdcs 94244603Sdcs\ Interface to loading conf files 94344603Sdcs 94444603Sdcs: load_conf ( addr len -- ) 94544603Sdcs 0 to end_of_file? 94665615Sdcs reset_line_reading 94744603Sdcs create_null_terminated_string 94844603Sdcs over >r 94944603Sdcs fopen fd ! 95044603Sdcs r> free-memory 95144603Sdcs fd @ -1 = if open_error throw then 95244603Sdcs ['] process_conf catch 95344603Sdcs fd @ fclose 95444603Sdcs throw 95544603Sdcs; 95644603Sdcs 95744603Sdcs: print_line 95844603Sdcs line_buffer .addr @ line_buffer .len @ type cr 95944603Sdcs; 96044603Sdcs 96144603Sdcs: print_syntax_error 96244603Sdcs line_buffer .addr @ line_buffer .len @ type cr 96344603Sdcs line_buffer .addr @ 96444603Sdcs begin 96544603Sdcs line_pointer over <> 96644603Sdcs while 96744603Sdcs bl emit 96844603Sdcs char+ 96944603Sdcs repeat 97044603Sdcs drop 97144603Sdcs ." ^" cr 97244603Sdcs; 97344603Sdcs 97444603Sdcs\ Depuration support functions 97544603Sdcs 97644603Sdcsonly forth definitions also support-functions 97744603Sdcs 97844603Sdcs: test-file 97944603Sdcs ['] load_conf catch dup . 98044603Sdcs syntax_error = if cr print_syntax_error then 98144603Sdcs; 98244603Sdcs 98344603Sdcs: show-module-options 98444603Sdcs module_options @ 98544603Sdcs begin 98644603Sdcs ?dup 98744603Sdcs while 98844603Sdcs ." Name: " dup module.name dup .addr @ swap .len @ type cr 98944603Sdcs ." Path: " dup module.loadname dup .addr @ swap .len @ type cr 99044603Sdcs ." Type: " dup module.type dup .addr @ swap .len @ type cr 99144603Sdcs ." Flags: " dup module.args dup .addr @ swap .len @ type cr 99244603Sdcs ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr 99344603Sdcs ." After load: " dup module.afterload dup .addr @ swap .len @ type cr 99444603Sdcs ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr 99544603Sdcs ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr 99644603Sdcs module.next @ 99744603Sdcs repeat 99844603Sdcs; 99944603Sdcs 100044603Sdcsonly forth also support-functions definitions 100144603Sdcs 100244603Sdcs\ Variables used for processing multiple conf files 100344603Sdcs 100444603Sdcsstring current_file_name 100544603Sdcsvariable current_conf_files 100644603Sdcs 100744603Sdcs\ Indicates if any conf file was succesfully read 100844603Sdcs 100944603Sdcs0 value any_conf_read? 101044603Sdcs 101144603Sdcs\ loader_conf_files processing support functions 101244603Sdcs 101344603Sdcs: set_current_conf_files 101444603Sdcs conf_files .addr @ current_conf_files ! 101544603Sdcs; 101644603Sdcs 101744603Sdcs: get_conf_files 101844603Sdcs conf_files .addr @ conf_files .len @ strdup 101944603Sdcs; 102044603Sdcs 102144603Sdcs: recurse_on_conf_files? 102244603Sdcs current_conf_files @ conf_files .addr @ <> 102344603Sdcs; 102444603Sdcs 102553672Sdcs: skip_leading_spaces { addr len pos -- addr len pos' } 102644603Sdcs begin 102753672Sdcs pos len = if addr len pos exit then 102853672Sdcs addr pos + c@ bl = 102944603Sdcs while 103053672Sdcs pos char+ to pos 103144603Sdcs repeat 103253672Sdcs addr len pos 103344603Sdcs; 103444603Sdcs 103553672Sdcs: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 103653672Sdcs pos len = if 103744603Sdcs addr free abort" Fatal error freeing memory" 103844603Sdcs 0 exit 103944603Sdcs then 104053672Sdcs pos >r 104144603Sdcs begin 104253672Sdcs addr pos + c@ bl <> 104344603Sdcs while 104453672Sdcs pos char+ to pos 104553672Sdcs pos len = if 104653672Sdcs addr len pos addr r@ + pos r> - exit 104744603Sdcs then 104844603Sdcs repeat 104953672Sdcs addr len pos addr r@ + pos r> - 105044603Sdcs; 105144603Sdcs 105244603Sdcs: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 105344603Sdcs skip_leading_spaces 105444603Sdcs get_file_name 105544603Sdcs; 105644603Sdcs 105744603Sdcs: set_current_file_name 105844603Sdcs over current_file_name .addr ! 105944603Sdcs dup current_file_name .len ! 106044603Sdcs; 106144603Sdcs 106244603Sdcs: print_current_file 106344603Sdcs current_file_name .addr @ current_file_name .len @ type 106444603Sdcs; 106544603Sdcs 106644603Sdcs: process_conf_errors 106744603Sdcs dup 0= if true to any_conf_read? drop exit then 106844603Sdcs >r 2drop r> 106944603Sdcs dup syntax_error = if 107044603Sdcs ." Warning: syntax error on file " print_current_file cr 107144603Sdcs print_syntax_error drop exit 107244603Sdcs then 107344603Sdcs dup set_error = if 107444603Sdcs ." Warning: bad definition on file " print_current_file cr 107544603Sdcs print_line drop exit 107644603Sdcs then 107744603Sdcs dup read_error = if 107844603Sdcs ." Warning: error reading file " print_current_file cr drop exit 107944603Sdcs then 108044603Sdcs dup open_error = if 108144603Sdcs verbose? if ." Warning: unable to open file " print_current_file cr then 108244603Sdcs drop exit 108344603Sdcs then 108444603Sdcs dup free_error = abort" Fatal error freeing memory" 108544603Sdcs dup out_of_memory = abort" Out of memory" 108644603Sdcs throw \ Unknown error -- pass ahead 108744603Sdcs; 108844603Sdcs 108944603Sdcs\ Process loader_conf_files recursively 109044603Sdcs\ Interface to loader_conf_files processing 109144603Sdcs 109244603Sdcs: include_conf_files 109344603Sdcs set_current_conf_files 109444603Sdcs get_conf_files 0 109544603Sdcs begin 109644603Sdcs get_next_file ?dup 109744603Sdcs while 109844603Sdcs set_current_file_name 109944603Sdcs ['] load_conf catch 110044603Sdcs process_conf_errors 110144603Sdcs recurse_on_conf_files? if recurse then 110244603Sdcs repeat 110344603Sdcs; 110444603Sdcs 110544603Sdcs\ Module loading functions 110644603Sdcs 110744603Sdcs: load_module? 110844603Sdcs module.flag @ 110944603Sdcs; 111044603Sdcs 111144603Sdcs: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N ) 111244603Sdcs dup >r 111344603Sdcs r@ module.args .addr @ r@ module.args .len @ 111444603Sdcs r@ module.loadname .len @ if 111544603Sdcs r@ module.loadname .addr @ r@ module.loadname .len @ 111644603Sdcs else 111744603Sdcs r@ module.name .addr @ r@ module.name .len @ 111844603Sdcs then 111944603Sdcs r@ module.type .len @ if 112044603Sdcs r@ module.type .addr @ r@ module.type .len @ 112144603Sdcs s" -t " 112244603Sdcs 4 ( -t type name flags ) 112344603Sdcs else 112444603Sdcs 2 ( name flags ) 112544603Sdcs then 112644603Sdcs r> drop 112744603Sdcs; 112844603Sdcs 112944603Sdcs: before_load ( addr -- addr ) 113044603Sdcs dup module.beforeload .len @ if 113144603Sdcs dup module.beforeload .addr @ over module.beforeload .len @ 113244603Sdcs ['] evaluate catch if before_load_error throw then 113344603Sdcs then 113444603Sdcs; 113544603Sdcs 113644603Sdcs: after_load ( addr -- addr ) 113744603Sdcs dup module.afterload .len @ if 113844603Sdcs dup module.afterload .addr @ over module.afterload .len @ 113944603Sdcs ['] evaluate catch if after_load_error throw then 114044603Sdcs then 114144603Sdcs; 114244603Sdcs 114344603Sdcs: load_error ( addr -- addr ) 114444603Sdcs dup module.loaderror .len @ if 114544603Sdcs dup module.loaderror .addr @ over module.loaderror .len @ 114644603Sdcs evaluate \ This we do not intercept so it can throw errors 114744603Sdcs then 114844603Sdcs; 114944603Sdcs 115044603Sdcs: pre_load_message ( addr -- addr ) 115144603Sdcs verbose? if 115244603Sdcs dup module.name .addr @ over module.name .len @ type 115344603Sdcs ." ..." 115444603Sdcs then 115544603Sdcs; 115644603Sdcs 115744603Sdcs: load_error_message verbose? if ." failed!" cr then ; 115844603Sdcs 115944603Sdcs: load_succesful_message verbose? if ." ok" cr then ; 116044603Sdcs 116144603Sdcs: load_module 116244603Sdcs load_parameters load 116344603Sdcs; 116444603Sdcs 116544603Sdcs: process_module ( addr -- addr ) 116644603Sdcs pre_load_message 116744603Sdcs before_load 116844603Sdcs begin 116944603Sdcs ['] load_module catch if 117044603Sdcs dup module.loaderror .len @ if 117144603Sdcs load_error \ Command should return a flag! 117244603Sdcs else 117344603Sdcs load_error_message true \ Do not retry 117444603Sdcs then 117544603Sdcs else 117644603Sdcs after_load 117744603Sdcs load_succesful_message true \ Succesful, do not retry 117844603Sdcs then 117944603Sdcs until 118044603Sdcs; 118144603Sdcs 118244603Sdcs: process_module_errors ( addr ior -- ) 118344603Sdcs dup before_load_error = if 118444603Sdcs drop 118544603Sdcs ." Module " 118644603Sdcs dup module.name .addr @ over module.name .len @ type 118744603Sdcs dup module.loadname .len @ if 118844603Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 118944603Sdcs then 119044603Sdcs cr 119144603Sdcs ." Error executing " 119244603Sdcs dup module.beforeload .addr @ over module.afterload .len @ type cr 119344603Sdcs abort 119444603Sdcs then 119544603Sdcs 119644603Sdcs dup after_load_error = if 119744603Sdcs drop 119844603Sdcs ." Module " 119944603Sdcs dup module.name .addr @ over module.name .len @ type 120044603Sdcs dup module.loadname .len @ if 120144603Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 120244603Sdcs then 120344603Sdcs cr 120444603Sdcs ." Error executing " 120544603Sdcs dup module.afterload .addr @ over module.afterload .len @ type cr 120644603Sdcs abort 120744603Sdcs then 120844603Sdcs 120944603Sdcs throw \ Don't know what it is all about -- pass ahead 121044603Sdcs; 121144603Sdcs 121244603Sdcs\ Module loading interface 121344603Sdcs 121444603Sdcs: load_modules ( -- ) ( throws: abort & user-defined ) 121544603Sdcs module_options @ 121644603Sdcs begin 121744603Sdcs ?dup 121844603Sdcs while 121944603Sdcs dup load_module? if 122044603Sdcs ['] process_module catch 122144603Sdcs process_module_errors 122244603Sdcs then 122344603Sdcs module.next @ 122444603Sdcs repeat 122544603Sdcs; 122644603Sdcs 122765630Sdcs\ h00h00 magic used to try loading either a kernel with a given name, 122865630Sdcs\ or a kernel with the default name in a directory of a given name 122965630Sdcs\ (the pain!) 123044603Sdcs 123165630Sdcs: bootpath s" /boot/" ; 123265630Sdcs: modulepath s" module_path" ; 123365630Sdcs 123465630Sdcs\ Functions used to save and restore module_path's value. 123565630Sdcs: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 123665630Sdcs dup -1 = if 0 swap exit then 123765630Sdcs strdup 123865630Sdcs; 123965630Sdcs: freeenv ( addr len | 0 -1 ) 124065630Sdcs -1 = if drop else free abort" Freeing error" then 124165630Sdcs; 124265630Sdcs: restoreenv ( addr len | 0 -1 -- ) 124365630Sdcs dup -1 = if ( it wasn't set ) 124465630Sdcs 2drop 124565630Sdcs modulepath unsetenv 124665630Sdcs else 124765630Sdcs over >r 124865630Sdcs modulepath setenv 124965630Sdcs r> free abort" Freeing error" 125065630Sdcs then 125165630Sdcs; 125265630Sdcs 125365630Sdcs: clip_args \ Drop second string if only one argument is passed 125465630Sdcs 1 = if 125565630Sdcs 2swap 2drop 125665630Sdcs 1 125765630Sdcs else 125865630Sdcs 2 125965630Sdcs then 126065630Sdcs; 126165630Sdcs 126265630Sdcsalso builtins 126365630Sdcs 126465630Sdcs\ Parse filename from a comma-separated list 126565630Sdcs 126665630Sdcs: parse-; ( addr len -- addr' len-x addr x ) 126765630Sdcs over 0 2swap 126865630Sdcs begin 126965630Sdcs dup 0 <> 127065630Sdcs while 127165630Sdcs over c@ [char] ; <> 127265630Sdcs while 127365630Sdcs 1- swap 1+ swap 127465630Sdcs 2swap 1+ 2swap 127565630Sdcs repeat then 127665630Sdcs dup 0 <> if 127765630Sdcs 1- swap 1+ swap 127865630Sdcs then 127965630Sdcs 2swap 128065630Sdcs; 128165630Sdcs 128265630Sdcs\ Try loading one of multiple kernels specified 128365630Sdcs 128465630Sdcs: try_multiple_kernels ( addr len addr' len' args -- flag ) 128565630Sdcs >r 128665630Sdcs begin 128765630Sdcs parse-; 2>r 128865630Sdcs 2over 2r> 128965630Sdcs r@ clip_args 1 load 129065630Sdcs while 129165630Sdcs dup 0= 129265630Sdcs until 129365630Sdcs 1 >r \ Failure 129465630Sdcs else 129565630Sdcs 0 >r \ Success 129665630Sdcs then 129765630Sdcs 2drop 2drop 129865630Sdcs r> 129965630Sdcs r> drop 130065630Sdcs; 130165630Sdcs 130265630Sdcs\ Try to load a kernel; the kernel name is taken from one of 130365630Sdcs\ the following lists, as ordered: 130465630Sdcs\ 130565641Sdcs\ 1. The "bootfile" environment variable 130665641Sdcs\ 2. The "kernel" environment variable 130765630Sdcs\ 130865938Sdcs\ Flags are passed, if available. If not, dummy values must be given. 130965630Sdcs\ 131065630Sdcs\ The kernel gets loaded from the current module_path. 131165630Sdcs 131265938Sdcs: load_a_kernel ( flags len 1 | x x 0 -- flag ) 131365630Sdcs local args 131465630Sdcs 2local flags 131565630Sdcs 0 0 2local kernel 131665630Sdcs end-locals 131765630Sdcs 131865630Sdcs \ Check if a default kernel name exists at all, exits if not 131965641Sdcs s" bootfile" getenv dup -1 <> if 132065630Sdcs to kernel 132165883Sdcs flags kernel args 1+ try_multiple_kernels 132265630Sdcs dup 0= if exit then 132365630Sdcs then 132465630Sdcs drop 132565630Sdcs 132665641Sdcs s" kernel" getenv dup -1 <> if 132765630Sdcs to kernel 132865630Sdcs else 132965630Sdcs drop 133065630Sdcs 1 exit \ Failure 133165630Sdcs then 133265630Sdcs 133365630Sdcs \ Try all default kernel names 133465883Sdcs flags kernel args 1+ try_multiple_kernels 133565630Sdcs; 133665630Sdcs 133765630Sdcs\ Try to load a kernel; the kernel name is taken from one of 133865630Sdcs\ the following lists, as ordered: 133965630Sdcs\ 134065641Sdcs\ 1. The "bootfile" environment variable 134165641Sdcs\ 2. The "kernel" environment variable 134265630Sdcs\ 134365630Sdcs\ Flags are passed, if provided. 134465630Sdcs\ 134565630Sdcs\ The kernel will be loaded from a directory computed from the 134665630Sdcs\ path given. Two directories will be tried in the following order: 134765630Sdcs\ 134865630Sdcs\ 1. /boot/path 134965630Sdcs\ 2. path 135065630Sdcs\ 135165630Sdcs\ The module_path variable is overridden if load is succesful, by 135265630Sdcs\ prepending the successful path. 135365630Sdcs 135465630Sdcs: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 135565630Sdcs local args 135665630Sdcs 2local path 135765630Sdcs args 1 = if 0 0 then 135865630Sdcs 2local flags 135965630Sdcs 0 0 2local oldmodulepath 136065630Sdcs 0 0 2local newmodulepath 136165630Sdcs end-locals 136265630Sdcs 136365630Sdcs \ Set the environment variable module_path, and try loading 136465630Sdcs \ the kernel again. 136565630Sdcs modulepath getenv saveenv to oldmodulepath 136665630Sdcs 136765630Sdcs \ Try prepending /boot/ first 136865630Sdcs bootpath nip path nip + 136965630Sdcs oldmodulepath nip dup -1 = if 137065630Sdcs drop 137165630Sdcs else 137265630Sdcs 1+ + 137365630Sdcs then 137465630Sdcs allocate 137565630Sdcs if ( out of memory ) 137665630Sdcs 1 exit 137765630Sdcs then 137865630Sdcs 137965630Sdcs 0 138065630Sdcs bootpath strcat 138165630Sdcs path strcat 138265630Sdcs 2dup to newmodulepath 138365630Sdcs modulepath setenv 138465630Sdcs 138565630Sdcs \ Try all default kernel names 138665938Sdcs flags args 1- load_a_kernel 138765630Sdcs 0= if ( success ) 138865630Sdcs oldmodulepath nip -1 <> if 138965630Sdcs newmodulepath s" ;" strcat 139065630Sdcs oldmodulepath strcat 139165630Sdcs modulepath setenv 139265630Sdcs newmodulepath drop free-memory 139365630Sdcs oldmodulepath drop free-memory 139465630Sdcs then 139565630Sdcs 0 exit 139665630Sdcs then 139765630Sdcs 139865630Sdcs \ Well, try without the prepended /boot/ 139965630Sdcs path newmodulepath drop swap move 140065883Sdcs newmodulepath drop path nip 140165630Sdcs 2dup to newmodulepath 140265630Sdcs modulepath setenv 140365630Sdcs 140465630Sdcs \ Try all default kernel names 140565938Sdcs flags args 1- load_a_kernel 140665630Sdcs if ( failed once more ) 140765630Sdcs oldmodulepath restoreenv 140865630Sdcs newmodulepath drop free-memory 140965630Sdcs 1 141065630Sdcs else 141165630Sdcs oldmodulepath nip -1 <> if 141265630Sdcs newmodulepath s" ;" strcat 141365630Sdcs oldmodulepath strcat 141465630Sdcs modulepath setenv 141565630Sdcs newmodulepath drop free-memory 141665630Sdcs oldmodulepath drop free-memory 141765630Sdcs then 141865630Sdcs 0 141965630Sdcs then 142065630Sdcs; 142165630Sdcs 142265630Sdcs\ Try to load a kernel; the kernel name is taken from one of 142365630Sdcs\ the following lists, as ordered: 142465630Sdcs\ 142565641Sdcs\ 1. The "bootfile" environment variable 142665641Sdcs\ 2. The "kernel" environment variable 142765630Sdcs\ 3. The "path" argument 142865630Sdcs\ 142965630Sdcs\ Flags are passed, if provided. 143065630Sdcs\ 143165630Sdcs\ The kernel will be loaded from a directory computed from the 143265630Sdcs\ path given. Two directories will be tried in the following order: 143365630Sdcs\ 143465630Sdcs\ 1. /boot/path 143565630Sdcs\ 2. path 143665630Sdcs\ 143765630Sdcs\ Unless "path" is meant to be kernel name itself. In that case, it 143865630Sdcs\ will first be tried as a full path, and, next, search on the 143965630Sdcs\ directories pointed by module_path. 144065630Sdcs\ 144165630Sdcs\ The module_path variable is overridden if load is succesful, by 144265630Sdcs\ prepending the successful path. 144365630Sdcs 144465630Sdcs: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 144565630Sdcs local args 144665630Sdcs 2local path 144765630Sdcs args 1 = if 0 0 then 144865630Sdcs 2local flags 144965630Sdcs end-locals 145065630Sdcs 145165630Sdcs \ First, assume path is an absolute path to a directory 145265630Sdcs flags path args clip_args load_from_directory 145365630Sdcs dup 0= if exit else drop then 145465630Sdcs 145565630Sdcs \ Next, assume path points to the kernel 145665630Sdcs flags path args try_multiple_kernels 145765630Sdcs; 145865630Sdcs 145944603Sdcs: initialize ( addr len -- ) 146044603Sdcs strdup conf_files .len ! conf_files .addr ! 146144603Sdcs; 146244603Sdcs 146365883Sdcs: kernel_options ( -- addr len 1 | 0 ) 146465630Sdcs s" kernel_options" getenv 146565883Sdcs dup -1 = if drop 0 else 1 then 146665630Sdcs; 146765630Sdcs 146865938Sdcs: standard_kernel_search ( flags 1 | 0 -- flag ) 146965938Sdcs local args 147065938Sdcs args 0= if 0 0 then 147165938Sdcs 2local flags 147265630Sdcs s" kernel" getenv 147365938Sdcs dup -1 = if 0 swap then 147465938Sdcs 2local path 147565938Sdcs end-locals 147665938Sdcs 147765938Sdcs path dup -1 = if ( there isn't a "kernel" environment variable ) 147865938Sdcs 2drop 147965938Sdcs flags args load_a_kernel 148065938Sdcs else 148165938Sdcs flags path args 1+ clip_args load_directory_or_file 148265938Sdcs then 148365630Sdcs; 148465630Sdcs 148544603Sdcs: load_kernel ( -- ) ( throws: abort ) 148665938Sdcs kernel_options standard_kernel_search 148765630Sdcs abort" Unable to load a kernel!" 148844603Sdcs; 148965883Sdcs 149065883Sdcs: set-defaultoptions ( -- ) 149165883Sdcs s" kernel_options" getenv dup -1 = if 149265883Sdcs drop 149365883Sdcs else 149465883Sdcs s" temp_options" setenv 149565883Sdcs then 149665883Sdcs; 149765883Sdcs 149865883Sdcs: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 149965883Sdcs 2dup = if 0 0 exit then 150065883Sdcs dup >r 150165883Sdcs 1+ 2* ( skip N and ui ) 150265883Sdcs pick 150365883Sdcs r> 150465883Sdcs 1+ 2* ( skip N and ai ) 150565883Sdcs pick 150665883Sdcs; 150765883Sdcs 150865883Sdcs: drop-args ( aN uN ... a1 u1 N -- ) 150965883Sdcs 0 ?do 2drop loop 151065883Sdcs; 151165883Sdcs 151265883Sdcs: argc 151365883Sdcs dup 151465883Sdcs; 151565883Sdcs 151665883Sdcs: queue-argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 151765883Sdcs >r 151865883Sdcs over 2* 1+ -roll 151965883Sdcs r> 152065883Sdcs over 2* 1+ -roll 152165883Sdcs 1+ 152265883Sdcs; 152365883Sdcs 152465883Sdcs: unqueue-argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 152565883Sdcs 1- -rot 152665883Sdcs; 152765883Sdcs 152865883Sdcs: strlen(argv) 152965883Sdcs dup 0= if 0 exit then 153065883Sdcs 0 >r \ Size 153165883Sdcs 0 >r \ Index 153265883Sdcs begin 153365883Sdcs argc r@ <> 153465883Sdcs while 153565883Sdcs r@ argv[] 153665883Sdcs nip 153765883Sdcs r> r> rot + 1+ 153865883Sdcs >r 1+ >r 153965883Sdcs repeat 154065883Sdcs r> drop 154165883Sdcs r> 154265883Sdcs; 154365883Sdcs 154465883Sdcs: concat-argv ( aN uN ... a1 u1 N -- a u ) 154565883Sdcs strlen(argv) allocate if out_of_memory throw then 154665883Sdcs 0 2>r 154765883Sdcs 154865883Sdcs begin 154965883Sdcs argc 155065883Sdcs while 155165883Sdcs unqueue-argv 155265883Sdcs 2r> 2swap 155365883Sdcs strcat 155465883Sdcs s" " strcat 155565883Sdcs 2>r 155665883Sdcs repeat 155765883Sdcs drop-args 155865883Sdcs 2r> 155965883Sdcs; 156065883Sdcs 156165883Sdcs: set-tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 156265883Sdcs \ Save the first argument, if it exists and is not a flag 156365883Sdcs argc if 156465883Sdcs 0 argv[] drop c@ [char] - <> if 156565883Sdcs unqueue-argv 2>r \ Filename 156665883Sdcs 1 >r \ Filename present 156765883Sdcs else 156865883Sdcs 0 >r \ Filename not present 156965883Sdcs then 157065883Sdcs else 157165883Sdcs 0 >r \ Filename not present 157265883Sdcs then 157365883Sdcs 157465883Sdcs \ If there are other arguments, assume they are flags 157565883Sdcs ?dup if 157665883Sdcs concat-argv 157765883Sdcs 2dup s" temp_options" setenv 157865883Sdcs drop free if free_error throw then 157965883Sdcs else 158065883Sdcs set-defaultoptions 158165883Sdcs then 158265883Sdcs 158365883Sdcs \ Bring back the filename, if one was provided 158465883Sdcs r> if 2r> 1 else 0 then 158565883Sdcs; 158665883Sdcs 158765883Sdcs: get-arguments ( -- addrN lenN ... addr1 len1 N ) 158865883Sdcs 0 158965883Sdcs begin 159065883Sdcs \ Get next word on the command line 159165883Sdcs parse-word 159265883Sdcs ?dup while 159365883Sdcs queue-argv 159465883Sdcs repeat 159565883Sdcs drop ( empty string ) 159665883Sdcs; 159765883Sdcs 159865938Sdcs: load_conf ( args -- flag ) 159965883Sdcs set-tempoptions 160065883Sdcs argc >r 160165883Sdcs s" temp_options" getenv dup -1 <> if 160265883Sdcs queue-argv 160365883Sdcs else 160465883Sdcs drop 160565883Sdcs then 160665883Sdcs r> if ( a path was passed ) 160765938Sdcs load_directory_or_file 160865883Sdcs else 160965938Sdcs standard_kernel_search 161065883Sdcs then 161165938Sdcs ?dup 0= if ['] load_modules catch then 161265883Sdcs; 161365883Sdcs 161453672Sdcs: read-password { size | buf len -- } 161553672Sdcs size allocate if out_of_memory throw then 161653672Sdcs to buf 161753672Sdcs 0 to len 161853672Sdcs begin 161953672Sdcs key 162053672Sdcs dup backspace = if 162153672Sdcs drop 162253672Sdcs len if 162353672Sdcs backspace emit bl emit backspace emit 162453672Sdcs len 1 - to len 162553672Sdcs else 162653672Sdcs bell emit 162753672Sdcs then 162853672Sdcs else 162953672Sdcs dup <cr> = if cr drop buf len exit then 163053672Sdcs [char] * emit 163153672Sdcs len size < if 163253672Sdcs buf len chars + c! 163353672Sdcs else 163453672Sdcs drop 163553672Sdcs then 163653672Sdcs len 1+ to len 163753672Sdcs then 163853672Sdcs again 163953672Sdcs; 164053672Sdcs 164144603Sdcs\ Go back to straight forth vocabulary 164244603Sdcs 164344603Sdcsonly forth also definitions 164444603Sdcs 1645