support.4th revision 298831
1280924Sdteske\ 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 298831 2016-04-30 02:47:41Z pfg $ 2644603Sdcs 2744603Sdcs\ Loader.rc support functions: 2844603Sdcs\ 2944603Sdcs\ initialize ( addr len -- ) as above, plus load_conf_files 3044603Sdcs\ load_conf ( addr len -- ) load conf file given 3144603Sdcs\ include_conf_files ( -- ) load all conf files in load_conf_files 3244603Sdcs\ print_syntax_error ( -- ) print line and marker of where a syntax 3344603Sdcs\ error was detected 3444603Sdcs\ print_line ( -- ) print last line processed 3544603Sdcs\ load_kernel ( -- ) load kernel 3644603Sdcs\ load_modules ( -- ) load modules flagged 3744603Sdcs\ 3844603Sdcs\ Exported structures: 3944603Sdcs\ 4044603Sdcs\ string counted string structure 4144603Sdcs\ cell .addr string address 4244603Sdcs\ cell .len string length 4344603Sdcs\ module module loading information structure 4444603Sdcs\ cell module.flag should we load it? 4544603Sdcs\ string module.name module's name 4644603Sdcs\ string module.loadname name to be used in loading the module 4744603Sdcs\ string module.type module's type 4844603Sdcs\ string module.args flags to be passed during load 4944603Sdcs\ string module.beforeload command to be executed before load 5044603Sdcs\ string module.afterload command to be executed after load 5144603Sdcs\ string module.loaderror command to be executed if load fails 5244603Sdcs\ cell module.next list chain 5344603Sdcs\ 5444603Sdcs\ Exported global variables; 5544603Sdcs\ 5644603Sdcs\ string conf_files configuration files to be loaded 5744603Sdcs\ cell modules_options pointer to first module information 5844603Sdcs\ value verbose? indicates if user wants a verbose loading 59298831Spfg\ value any_conf_read? indicates if a conf file was successfully read 6044603Sdcs\ 6144603Sdcs\ Other exported words: 62186789Sluigi\ note, strlen is internal 6344603Sdcs\ strdup ( addr len -- addr' len) similar to strdup(3) 6444603Sdcs\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3) 6544603Sdcs\ s' ( | string' -- addr len | ) similar to s" 6644603Sdcs\ rudimentary structure support 6744603Sdcs 6844603Sdcs\ Exception values 6944603Sdcs 70186789Sluigi1 constant ESYNTAX 71186789Sluigi2 constant ENOMEM 72186789Sluigi3 constant EFREE 73186789Sluigi4 constant ESETERROR \ error setting environment variable 74186789Sluigi5 constant EREAD \ error reading 75186789Sluigi6 constant EOPEN 76186789Sluigi7 constant EEXEC \ XXX never catched 77186789Sluigi8 constant EBEFORELOAD 78186789Sluigi9 constant EAFTERLOAD 7944603Sdcs 8087636Sjhb\ I/O constants 8187636Sjhb 8287636Sjhb0 constant SEEK_SET 8387636Sjhb1 constant SEEK_CUR 8487636Sjhb2 constant SEEK_END 8587636Sjhb 8687636Sjhb0 constant O_RDONLY 8787636Sjhb1 constant O_WRONLY 8887636Sjhb2 constant O_RDWR 8987636Sjhb 9044603Sdcs\ Crude structure support 9144603Sdcs 9265615Sdcs: structure: 9365615Sdcs create here 0 , ['] drop , 0 9465615Sdcs does> create here swap dup @ allot cell+ @ execute 9565615Sdcs; 9644603Sdcs: member: create dup , over , + does> cell+ @ + ; 9744603Sdcs: ;structure swap ! ; 9865615Sdcs: constructor! >body cell+ ! ; 9965615Sdcs: constructor: over :noname ; 10065615Sdcs: ;constructor postpone ; swap cell+ ! ; immediate 10144603Sdcs: sizeof ' >body @ state @ if postpone literal then ; immediate 10244603Sdcs: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate 10344603Sdcs: ptr 1 cells member: ; 10444603Sdcs: int 1 cells member: ; 10544603Sdcs 10644603Sdcs\ String structure 10744603Sdcs 10844603Sdcsstructure: string 10944603Sdcs ptr .addr 11044603Sdcs int .len 11165615Sdcs constructor: 11265615Sdcs 0 over .addr ! 11365615Sdcs 0 swap .len ! 11465615Sdcs ;constructor 11544603Sdcs;structure 11644603Sdcs 11765615Sdcs 11844603Sdcs\ Module options linked list 11944603Sdcs 12044603Sdcsstructure: module 12144603Sdcs int module.flag 12244603Sdcs sizeof string member: module.name 12344603Sdcs sizeof string member: module.loadname 12444603Sdcs sizeof string member: module.type 12544603Sdcs sizeof string member: module.args 12644603Sdcs sizeof string member: module.beforeload 12744603Sdcs sizeof string member: module.afterload 12844603Sdcs sizeof string member: module.loaderror 12944603Sdcs ptr module.next 13044603Sdcs;structure 13144603Sdcs 132186789Sluigi\ Internal loader structures (preloaded_file, kernel_module, file_metadata) 133186789Sluigi\ must be in sync with the C struct in sys/boot/common/bootstrap.h 13465615Sdcsstructure: preloaded_file 13565615Sdcs ptr pf.name 13665615Sdcs ptr pf.type 13765615Sdcs ptr pf.args 13865615Sdcs ptr pf.metadata \ file_metadata 13965615Sdcs int pf.loader 14065615Sdcs int pf.addr 14165615Sdcs int pf.size 14265615Sdcs ptr pf.modules \ kernel_module 14365615Sdcs ptr pf.next \ preloaded_file 14465615Sdcs;structure 14565615Sdcs 14665615Sdcsstructure: kernel_module 14765615Sdcs ptr km.name 14865615Sdcs \ ptr km.args 14965615Sdcs ptr km.fp \ preloaded_file 15065615Sdcs ptr km.next \ kernel_module 15165615Sdcs;structure 15265615Sdcs 15365615Sdcsstructure: file_metadata 15465615Sdcs int md.size 15565615Sdcs 2 member: md.type \ this is not ANS Forth compatible (XXX) 15665615Sdcs ptr md.next \ file_metadata 15765615Sdcs 0 member: md.data \ variable size 15865615Sdcs;structure 15965615Sdcs 160186789Sluigi\ end of structures 16165615Sdcs 16244603Sdcs\ Global variables 16344603Sdcs 16444603Sdcsstring conf_files 16597201Sgordonstring nextboot_conf_file 16665615Sdcscreate module_options sizeof module.next allot 0 module_options ! 16765615Sdcscreate last_module_option sizeof module.next allot 0 last_module_option ! 16844603Sdcs0 value verbose? 16997201Sgordon0 value nextboot? 17044603Sdcs 17144603Sdcs\ Support string functions 172186789Sluigi: strdup { addr len -- addr' len' } 173186789Sluigi len allocate if ENOMEM throw then 174186789Sluigi addr over len move len 17544603Sdcs; 17644603Sdcs 17744603Sdcs: strcat { addr len addr' len' -- addr len+len' } 17844603Sdcs addr' addr len + len' move 17944603Sdcs addr len len' + 18044603Sdcs; 18144603Sdcs 182186789Sluigi: strchr { addr len c -- addr' len' } 18361373Sdcs begin 184186789Sluigi len 185186789Sluigi while 186186789Sluigi addr c@ c = if addr len exit then 187186789Sluigi addr 1 + to addr 188186789Sluigi len 1 - to len 189186789Sluigi repeat 190186789Sluigi 0 0 19161373Sdcs; 19261373Sdcs 193186789Sluigi: s' \ same as s", allows " in the string 19444603Sdcs [char] ' parse 195186789Sluigi state @ if postpone sliteral then 19644603Sdcs; immediate 19744603Sdcs 19861373Sdcs: 2>r postpone >r postpone >r ; immediate 19961373Sdcs: 2r> postpone r> postpone r> ; immediate 20065883Sdcs: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate 20153672Sdcs 202186789Sluigi: getenv? getenv -1 = if false else drop true then ; 20365938Sdcs 204244048Sdteske\ determine if a word appears in a string, case-insensitive 205244048Sdteske: contains? ( addr1 len1 addr2 len2 -- 0 | -1 ) 206244048Sdteske 2 pick 0= if 2drop 2drop true exit then 207244048Sdteske dup 0= if 2drop 2drop false exit then 208244048Sdteske begin 209244048Sdteske begin 210244089Sdteske swap dup c@ dup 32 = over 9 = or over 10 = or 211244089Sdteske over 13 = or over 44 = or swap drop 212244048Sdteske while 1+ swap 1- repeat 213244048Sdteske swap 2 pick 1- over < 214244048Sdteske while 215244048Sdteske 2over 2over drop over compare-insensitive 0= if 216244048Sdteske 2 pick over = if 2drop 2drop true exit then 217244048Sdteske 2 pick tuck - -rot + swap over c@ dup 32 = 218244089Sdteske over 9 = or over 10 = or over 13 = or over 44 = or 219244048Sdteske swap drop if 2drop 2drop true exit then 220244048Sdteske then begin 221244089Sdteske swap dup c@ dup 32 = over 9 = or over 10 = or 222244089Sdteske over 13 = or over 44 = or swap drop 223244089Sdteske if false else true then 2 pick 0> and 224244048Sdteske while 1+ swap 1- repeat 225244048Sdteske swap 226244048Sdteske repeat 227244048Sdteske 2drop 2drop false 228244048Sdteske; 229244048Sdteske 230244048Sdteske: boot_serial? ( -- 0 | -1 ) 231244048Sdteske s" console" getenv dup -1 <> if 232244048Sdteske s" comconsole" 2swap contains? 233244048Sdteske else drop false then 234244048Sdteske s" boot_serial" getenv dup -1 <> if 235244048Sdteske swap drop 0> 236244048Sdteske else drop false then 237244048Sdteske or \ console contains comconsole ( or ) boot_serial 238244048Sdteske s" boot_multicons" getenv dup -1 <> if 239244048Sdteske swap drop 0> 240244048Sdteske else drop false then 241244048Sdteske or \ previous boolean ( or ) boot_multicons 242244048Sdteske; 243244048Sdteske 24444603Sdcs\ Private definitions 24544603Sdcs 24644603Sdcsvocabulary support-functions 24744603Sdcsonly forth also support-functions definitions 24844603Sdcs 24944603Sdcs\ Some control characters constants 25044603Sdcs 25153672Sdcs7 constant bell 25253672Sdcs8 constant backspace 25344603Sdcs9 constant tab 25444603Sdcs10 constant lf 25553672Sdcs13 constant <cr> 25644603Sdcs 25744603Sdcs\ Read buffer size 25844603Sdcs 25944603Sdcs80 constant read_buffer_size 26044603Sdcs 26144603Sdcs\ Standard suffixes 26244603Sdcs 263186789Sluigi: load_module_suffix s" _load" ; 264186789Sluigi: module_loadname_suffix s" _name" ; 265186789Sluigi: module_type_suffix s" _type" ; 266186789Sluigi: module_args_suffix s" _flags" ; 267186789Sluigi: module_beforeload_suffix s" _before" ; 268186789Sluigi: module_afterload_suffix s" _after" ; 269186789Sluigi: module_loaderror_suffix s" _error" ; 27044603Sdcs 27144603Sdcs\ Support operators 27244603Sdcs 27344603Sdcs: >= < 0= ; 27444603Sdcs: <= > 0= ; 27544603Sdcs 276186789Sluigi\ Assorted support functions 27744603Sdcs 278186789Sluigi: free-memory free if EFREE throw then ; 27944603Sdcs 280185746Sluigi: strget { var -- addr len } var .addr @ var .len @ ; 281185746Sluigi 282185746Sluigi\ assign addr len to variable. 283186789Sluigi: strset { addr len var -- } addr var .addr ! len var .len ! ; 284185746Sluigi 285185746Sluigi\ free memory and reset fields 286185746Sluigi: strfree { var -- } var .addr @ ?dup if free-memory 0 0 var strset then ; 287185746Sluigi 288185746Sluigi\ free old content, make a copy of the string and assign to variable 289185746Sluigi: string= { addr len var -- } var strfree addr len strdup var strset ; 290185746Sluigi 291186789Sluigi: strtype ( str -- ) strget type ; 292186789Sluigi 293186789Sluigi\ assign a reference to what is on the stack 294186789Sluigi: strref { addr len var -- addr len } 295186789Sluigi addr var .addr ! len var .len ! addr len 296186789Sluigi; 297186789Sluigi 298186789Sluigi\ unquote a string 299186789Sluigi: unquote ( addr len -- addr len ) 300186789Sluigi over c@ [char] " = if 2 chars - swap char+ swap then 301186789Sluigi; 302186789Sluigi 30344603Sdcs\ Assignment data temporary storage 30444603Sdcs 30544603Sdcsstring name_buffer 30644603Sdcsstring value_buffer 30744603Sdcs 30865615Sdcs\ Line by line file reading functions 30965615Sdcs\ 31065615Sdcs\ exported: 31165615Sdcs\ line_buffer 31265615Sdcs\ end_of_file? 31365615Sdcs\ fd 31465615Sdcs\ read_line 31565615Sdcs\ reset_line_reading 31665615Sdcs 31765615Sdcsvocabulary line-reading 318280937Sdteskealso line-reading definitions 31965615Sdcs 32044603Sdcs\ File data temporary storage 32144603Sdcs 32244603Sdcsstring read_buffer 32344603Sdcs0 value read_buffer_ptr 32444603Sdcs 32544603Sdcs\ File's line reading function 32644603Sdcs 327280937Sdteskeget-current ( -- wid ) previous definitions 32865615Sdcs 32965615Sdcsstring line_buffer 33044603Sdcs0 value end_of_file? 33144603Sdcsvariable fd 33244603Sdcs 333280937Sdteske>search ( wid -- ) definitions 33465615Sdcs 33544603Sdcs: skip_newlines 33644603Sdcs begin 33744603Sdcs read_buffer .len @ read_buffer_ptr > 33844603Sdcs while 33944603Sdcs read_buffer .addr @ read_buffer_ptr + c@ lf = if 34044603Sdcs read_buffer_ptr char+ to read_buffer_ptr 34144603Sdcs else 34244603Sdcs exit 34344603Sdcs then 34444603Sdcs repeat 34544603Sdcs; 34644603Sdcs 34744603Sdcs: scan_buffer ( -- addr len ) 34844603Sdcs read_buffer_ptr >r 34944603Sdcs begin 35044603Sdcs read_buffer .len @ r@ > 35144603Sdcs while 35244603Sdcs read_buffer .addr @ r@ + c@ lf = if 35344603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 35444603Sdcs r@ read_buffer_ptr - ( -- len ) 35544603Sdcs r> to read_buffer_ptr 35644603Sdcs exit 35744603Sdcs then 35844603Sdcs r> char+ >r 35944603Sdcs repeat 36044603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 36144603Sdcs r@ read_buffer_ptr - ( -- len ) 36244603Sdcs r> to read_buffer_ptr 36344603Sdcs; 36444603Sdcs 36544603Sdcs: line_buffer_resize ( len -- len ) 36644603Sdcs >r 36744603Sdcs line_buffer .len @ if 36844603Sdcs line_buffer .addr @ 36944603Sdcs line_buffer .len @ r@ + 370186789Sluigi resize if ENOMEM throw then 37144603Sdcs else 372186789Sluigi r@ allocate if ENOMEM throw then 37344603Sdcs then 37444603Sdcs line_buffer .addr ! 37544603Sdcs r> 37644603Sdcs; 37744603Sdcs 37844603Sdcs: append_to_line_buffer ( addr len -- ) 379186789Sluigi line_buffer strget 38044603Sdcs 2swap strcat 38144603Sdcs line_buffer .len ! 38244603Sdcs drop 38344603Sdcs; 38444603Sdcs 38544603Sdcs: read_from_buffer 38644603Sdcs scan_buffer ( -- addr len ) 38744603Sdcs line_buffer_resize ( len -- len ) 38844603Sdcs append_to_line_buffer ( addr len -- ) 38944603Sdcs; 39044603Sdcs 39144603Sdcs: refill_required? 39244603Sdcs read_buffer .len @ read_buffer_ptr = 39344603Sdcs end_of_file? 0= and 39444603Sdcs; 39544603Sdcs 39644603Sdcs: refill_buffer 39744603Sdcs 0 to read_buffer_ptr 39844603Sdcs read_buffer .addr @ 0= if 399186789Sluigi read_buffer_size allocate if ENOMEM throw then 40044603Sdcs read_buffer .addr ! 40144603Sdcs then 40244603Sdcs fd @ read_buffer .addr @ read_buffer_size fread 403186789Sluigi dup -1 = if EREAD throw then 40444603Sdcs dup 0= if true to end_of_file? then 40544603Sdcs read_buffer .len ! 40644603Sdcs; 40744603Sdcs 408280937Sdteskeget-current ( -- wid ) previous definitions >search ( wid -- ) 40965615Sdcs 41065615Sdcs: reset_line_reading 41165615Sdcs 0 to read_buffer_ptr 41265615Sdcs; 41365615Sdcs 41444603Sdcs: read_line 415186789Sluigi line_buffer strfree 41644603Sdcs skip_newlines 41744603Sdcs begin 41844603Sdcs read_from_buffer 41944603Sdcs refill_required? 42044603Sdcs while 42144603Sdcs refill_buffer 42244603Sdcs repeat 42344603Sdcs; 42444603Sdcs 42565615Sdcsonly forth also support-functions definitions 42665615Sdcs 42744603Sdcs\ Conf file line parser: 42844603Sdcs\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 42944603Sdcs\ <spaces>[<comment>] 43044603Sdcs\ <name> ::= <letter>{<letter>|<digit>|'_'} 43144603Sdcs\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 43244603Sdcs\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 43344603Sdcs\ <comment> ::= '#'{<anything>} 43465615Sdcs\ 43565615Sdcs\ exported: 43665615Sdcs\ line_pointer 43765615Sdcs\ process_conf 43844603Sdcs 43965615Sdcs0 value line_pointer 44065615Sdcs 44165615Sdcsvocabulary file-processing 44265615Sdcsalso file-processing definitions 44365615Sdcs 44465615Sdcs\ parser functions 44565615Sdcs\ 44665615Sdcs\ exported: 44765615Sdcs\ get_assignment 44865615Sdcs 44965615Sdcsvocabulary parser 450280937Sdteskealso parser definitions 45165615Sdcs 45244603Sdcs0 value parsing_function 45344603Sdcs0 value end_of_line 45444603Sdcs 455186789Sluigi: end_of_line? line_pointer end_of_line = ; 45644603Sdcs 457186789Sluigi\ classifiers for various character classes in the input line 458186789Sluigi 45944603Sdcs: letter? 46044603Sdcs line_pointer c@ >r 46144603Sdcs r@ [char] A >= 46244603Sdcs r@ [char] Z <= and 46344603Sdcs r@ [char] a >= 46444603Sdcs r> [char] z <= and 46544603Sdcs or 46644603Sdcs; 46744603Sdcs 46844603Sdcs: digit? 46944603Sdcs line_pointer c@ >r 470174777Sambrisko r@ [char] - = 47144603Sdcs r@ [char] 0 >= 47244603Sdcs r> [char] 9 <= and 473174777Sambrisko or 47444603Sdcs; 47544603Sdcs 476186789Sluigi: quote? line_pointer c@ [char] " = ; 47744603Sdcs 478186789Sluigi: assignment_sign? line_pointer c@ [char] = = ; 47944603Sdcs 480186789Sluigi: comment? line_pointer c@ [char] # = ; 48144603Sdcs 482186789Sluigi: space? line_pointer c@ bl = line_pointer c@ tab = or ; 48344603Sdcs 484186789Sluigi: backslash? line_pointer c@ [char] \ = ; 48544603Sdcs 486186789Sluigi: underscore? line_pointer c@ [char] _ = ; 48744603Sdcs 488186789Sluigi: dot? line_pointer c@ [char] . = ; 48944603Sdcs 490186789Sluigi\ manipulation of input line 491186789Sluigi: skip_character line_pointer char+ to line_pointer ; 49244603Sdcs 493186789Sluigi: skip_to_end_of_line end_of_line to line_pointer ; 49444603Sdcs 49544603Sdcs: eat_space 49644603Sdcs begin 497186789Sluigi end_of_line? if 0 else space? then 49844603Sdcs while 49944603Sdcs skip_character 50044603Sdcs repeat 50144603Sdcs; 50244603Sdcs 50344603Sdcs: parse_name ( -- addr len ) 50444603Sdcs line_pointer 50544603Sdcs begin 506186789Sluigi end_of_line? if 0 else letter? digit? underscore? dot? or or or then 50744603Sdcs while 50844603Sdcs skip_character 50944603Sdcs repeat 51044603Sdcs line_pointer over - 51144603Sdcs strdup 51244603Sdcs; 51344603Sdcs 51444603Sdcs: remove_backslashes { addr len | addr' len' -- addr' len' } 515186789Sluigi len allocate if ENOMEM throw then 51644603Sdcs to addr' 51744603Sdcs addr >r 51844603Sdcs begin 51944603Sdcs addr c@ [char] \ <> if 52044603Sdcs addr c@ addr' len' + c! 52144603Sdcs len' char+ to len' 52244603Sdcs then 52344603Sdcs addr char+ to addr 52444603Sdcs r@ len + addr = 52544603Sdcs until 52644603Sdcs r> drop 52744603Sdcs addr' len' 52844603Sdcs; 52944603Sdcs 53044603Sdcs: parse_quote ( -- addr len ) 53144603Sdcs line_pointer 53244603Sdcs skip_character 533186789Sluigi end_of_line? if ESYNTAX throw then 53444603Sdcs begin 53544603Sdcs quote? 0= 53644603Sdcs while 53744603Sdcs backslash? if 53844603Sdcs skip_character 539186789Sluigi end_of_line? if ESYNTAX throw then 54044603Sdcs then 54144603Sdcs skip_character 542186789Sluigi end_of_line? if ESYNTAX throw then 54344603Sdcs repeat 54444603Sdcs skip_character 54544603Sdcs line_pointer over - 54644603Sdcs remove_backslashes 54744603Sdcs; 54844603Sdcs 54944603Sdcs: read_name 55044603Sdcs parse_name ( -- addr len ) 551186789Sluigi name_buffer strset 55244603Sdcs; 55344603Sdcs 55444603Sdcs: read_value 55544603Sdcs quote? if 55644603Sdcs parse_quote ( -- addr len ) 55744603Sdcs else 55844603Sdcs parse_name ( -- addr len ) 55944603Sdcs then 560186789Sluigi value_buffer strset 56144603Sdcs; 56244603Sdcs 56344603Sdcs: comment 56444603Sdcs skip_to_end_of_line 56544603Sdcs; 56644603Sdcs 56744603Sdcs: white_space_4 56844603Sdcs eat_space 56944603Sdcs comment? if ['] comment to parsing_function exit then 570186789Sluigi end_of_line? 0= if ESYNTAX throw then 57144603Sdcs; 57244603Sdcs 57344603Sdcs: variable_value 57444603Sdcs read_value 57544603Sdcs ['] white_space_4 to parsing_function 57644603Sdcs; 57744603Sdcs 57844603Sdcs: white_space_3 57944603Sdcs eat_space 58044603Sdcs letter? digit? quote? or or if 58144603Sdcs ['] variable_value to parsing_function exit 58244603Sdcs then 583186789Sluigi ESYNTAX throw 58444603Sdcs; 58544603Sdcs 58644603Sdcs: assignment_sign 58744603Sdcs skip_character 58844603Sdcs ['] white_space_3 to parsing_function 58944603Sdcs; 59044603Sdcs 59144603Sdcs: white_space_2 59244603Sdcs eat_space 59344603Sdcs assignment_sign? if ['] assignment_sign to parsing_function exit then 594186789Sluigi ESYNTAX throw 59544603Sdcs; 59644603Sdcs 59744603Sdcs: variable_name 59844603Sdcs read_name 59944603Sdcs ['] white_space_2 to parsing_function 60044603Sdcs; 60144603Sdcs 60244603Sdcs: white_space_1 60344603Sdcs eat_space 60444603Sdcs letter? if ['] variable_name to parsing_function exit then 60544603Sdcs comment? if ['] comment to parsing_function exit then 606186789Sluigi end_of_line? 0= if ESYNTAX throw then 60744603Sdcs; 60844603Sdcs 609280937Sdteskeget-current ( -- wid ) previous definitions >search ( wid -- ) 61065615Sdcs 61144603Sdcs: get_assignment 612186789Sluigi line_buffer strget + to end_of_line 61344603Sdcs line_buffer .addr @ to line_pointer 61444603Sdcs ['] white_space_1 to parsing_function 61544603Sdcs begin 61644603Sdcs end_of_line? 0= 61744603Sdcs while 61844603Sdcs parsing_function execute 61944603Sdcs repeat 62044603Sdcs parsing_function ['] comment = 62144603Sdcs parsing_function ['] white_space_1 = 62244603Sdcs parsing_function ['] white_space_4 = 623186789Sluigi or or 0= if ESYNTAX throw then 62444603Sdcs; 62544603Sdcs 626280937Sdteskeonly forth also support-functions also file-processing definitions 62765615Sdcs 62844603Sdcs\ Process line 62944603Sdcs 63044603Sdcs: assignment_type? ( addr len -- flag ) 631186789Sluigi name_buffer strget 63244603Sdcs compare 0= 63344603Sdcs; 63444603Sdcs 63544603Sdcs: suffix_type? ( addr len -- flag ) 63644603Sdcs name_buffer .len @ over <= if 2drop false exit then 63744603Sdcs name_buffer .len @ over - name_buffer .addr @ + 63844603Sdcs over compare 0= 63944603Sdcs; 64044603Sdcs 641186789Sluigi: loader_conf_files? s" loader_conf_files" assignment_type? ; 64244603Sdcs 643186789Sluigi: nextboot_flag? s" nextboot_enable" assignment_type? ; 64497201Sgordon 645186789Sluigi: nextboot_conf? s" nextboot_conf" assignment_type? ; 64697201Sgordon 647186789Sluigi: verbose_flag? s" verbose_loading" assignment_type? ; 64844603Sdcs 649186789Sluigi: execute? s" exec" assignment_type? ; 65044603Sdcs 651186789Sluigi: module_load? load_module_suffix suffix_type? ; 65244603Sdcs 653186789Sluigi: module_loadname? module_loadname_suffix suffix_type? ; 65444603Sdcs 655186789Sluigi: module_type? module_type_suffix suffix_type? ; 65644603Sdcs 657186789Sluigi: module_args? module_args_suffix suffix_type? ; 65844603Sdcs 659186789Sluigi: module_beforeload? module_beforeload_suffix suffix_type? ; 66044603Sdcs 661186789Sluigi: module_afterload? module_afterload_suffix suffix_type? ; 66244603Sdcs 663186789Sluigi: module_loaderror? module_loaderror_suffix suffix_type? ; 66444603Sdcs 665186789Sluigi\ build a 'set' statement and execute it 666186789Sluigi: set_environment_variable 667186789Sluigi name_buffer .len @ value_buffer .len @ + 5 chars + \ size of result string 668186789Sluigi allocate if ENOMEM throw then 669186789Sluigi dup 0 \ start with an empty string and append the pieces 670186789Sluigi s" set " strcat 671186789Sluigi name_buffer strget strcat 672186789Sluigi s" =" strcat 673186789Sluigi value_buffer strget strcat 674186789Sluigi ['] evaluate catch if 675186789Sluigi 2drop free drop 676186789Sluigi ESETERROR throw 677186789Sluigi else 67897201Sgordon free-memory 67997201Sgordon then 68097201Sgordon; 68197201Sgordon 682186789Sluigi: set_conf_files 683186789Sluigi set_environment_variable 684186789Sluigi s" loader_conf_files" getenv conf_files string= 685186789Sluigi; 686186789Sluigi 687293000Sdteske: set_nextboot_conf 688186789Sluigi value_buffer strget unquote nextboot_conf_file string= 689186789Sluigi; 690186789Sluigi 69144603Sdcs: append_to_module_options_list ( addr -- ) 69244603Sdcs module_options @ 0= if 69344603Sdcs dup module_options ! 69444603Sdcs last_module_option ! 69544603Sdcs else 69644603Sdcs dup last_module_option @ module.next ! 69744603Sdcs last_module_option ! 69844603Sdcs then 69944603Sdcs; 70044603Sdcs 701186789Sluigi: set_module_name { addr -- } \ check leaks 702186789Sluigi name_buffer strget addr module.name string= 70344603Sdcs; 70444603Sdcs 70544603Sdcs: yes_value? 706186789Sluigi value_buffer strget \ XXX could use unquote 70744603Sdcs 2dup s' "YES"' compare >r 70844603Sdcs 2dup s' "yes"' compare >r 70944603Sdcs 2dup s" YES" compare >r 71044603Sdcs s" yes" compare r> r> r> and and and 0= 71144603Sdcs; 71244603Sdcs 713186789Sluigi: find_module_option ( -- addr | 0 ) \ return ptr to entry matching name_buffer 71444603Sdcs module_options @ 71544603Sdcs begin 71644603Sdcs dup 71744603Sdcs while 718186789Sluigi dup module.name strget 719186789Sluigi name_buffer strget 72044603Sdcs compare 0= if exit then 72144603Sdcs module.next @ 72244603Sdcs repeat 72344603Sdcs; 72444603Sdcs 72544603Sdcs: new_module_option ( -- addr ) 726186789Sluigi sizeof module allocate if ENOMEM throw then 72744603Sdcs dup sizeof module erase 72844603Sdcs dup append_to_module_options_list 72944603Sdcs dup set_module_name 73044603Sdcs; 73144603Sdcs 73244603Sdcs: get_module_option ( -- addr ) 73344603Sdcs find_module_option 73444603Sdcs ?dup 0= if new_module_option then 73544603Sdcs; 73644603Sdcs 73744603Sdcs: set_module_flag 73844603Sdcs name_buffer .len @ load_module_suffix nip - name_buffer .len ! 73944603Sdcs yes_value? get_module_option module.flag ! 74044603Sdcs; 74144603Sdcs 74244603Sdcs: set_module_args 74344603Sdcs name_buffer .len @ module_args_suffix nip - name_buffer .len ! 744186789Sluigi value_buffer strget unquote 745186789Sluigi get_module_option module.args string= 74644603Sdcs; 74744603Sdcs 74844603Sdcs: set_module_loadname 74944603Sdcs name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 750186789Sluigi value_buffer strget unquote 751186789Sluigi get_module_option module.loadname string= 75244603Sdcs; 75344603Sdcs 75444603Sdcs: set_module_type 75544603Sdcs name_buffer .len @ module_type_suffix nip - name_buffer .len ! 756186789Sluigi value_buffer strget unquote 757186789Sluigi get_module_option module.type string= 75844603Sdcs; 75944603Sdcs 76044603Sdcs: set_module_beforeload 76144603Sdcs name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 762186789Sluigi value_buffer strget unquote 763186789Sluigi get_module_option module.beforeload string= 76444603Sdcs; 76544603Sdcs 76644603Sdcs: set_module_afterload 76744603Sdcs name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 768186789Sluigi value_buffer strget unquote 769186789Sluigi get_module_option module.afterload string= 77044603Sdcs; 77144603Sdcs 77244603Sdcs: set_module_loaderror 77344603Sdcs name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 774186789Sluigi value_buffer strget unquote 775186789Sluigi get_module_option module.loaderror string= 77644603Sdcs; 77744603Sdcs 77897201Sgordon: set_nextboot_flag 77997201Sgordon yes_value? to nextboot? 78097201Sgordon; 78197201Sgordon 78244603Sdcs: set_verbose 78344603Sdcs yes_value? to verbose? 78444603Sdcs; 78544603Sdcs 78644603Sdcs: execute_command 787186789Sluigi value_buffer strget unquote 788186789Sluigi ['] evaluate catch if EEXEC throw then 78944603Sdcs; 79044603Sdcs 79144603Sdcs: process_assignment 79244603Sdcs name_buffer .len @ 0= if exit then 79344603Sdcs loader_conf_files? if set_conf_files exit then 79497201Sgordon nextboot_flag? if set_nextboot_flag exit then 79597201Sgordon nextboot_conf? if set_nextboot_conf exit then 79644603Sdcs verbose_flag? if set_verbose exit then 79744603Sdcs execute? if execute_command exit then 79844603Sdcs module_load? if set_module_flag exit then 79944603Sdcs module_loadname? if set_module_loadname exit then 80044603Sdcs module_type? if set_module_type exit then 80144603Sdcs module_args? if set_module_args exit then 80244603Sdcs module_beforeload? if set_module_beforeload exit then 80344603Sdcs module_afterload? if set_module_afterload exit then 80444603Sdcs module_loaderror? if set_module_loaderror exit then 80544603Sdcs set_environment_variable 80644603Sdcs; 80744603Sdcs 80853672Sdcs\ free_buffer ( -- ) 80953672Sdcs\ 81053672Sdcs\ Free some pointers if needed. The code then tests for errors 81153672Sdcs\ in freeing, and throws an exception if needed. If a pointer is 81253672Sdcs\ not allocated, it's value (0) is used as flag. 81353672Sdcs 81444603Sdcs: free_buffers 815186789Sluigi name_buffer strfree 816186789Sluigi value_buffer strfree 81744603Sdcs; 81844603Sdcs 81944603Sdcs\ Higher level file processing 82044603Sdcs 821280937Sdteskeget-current ( -- wid ) previous definitions >search ( wid -- ) 82265615Sdcs 82344603Sdcs: process_conf 82444603Sdcs begin 82544603Sdcs end_of_file? 0= 82644603Sdcs while 827186789Sluigi free_buffers 82844603Sdcs read_line 82944603Sdcs get_assignment 83044603Sdcs ['] process_assignment catch 83144603Sdcs ['] free_buffers catch 83244603Sdcs swap throw throw 83344603Sdcs repeat 83444603Sdcs; 83544603Sdcs 836292899Sdteske: peek_file ( addr len -- ) 83797201Sgordon 0 to end_of_file? 83897201Sgordon reset_line_reading 83997201Sgordon O_RDONLY fopen fd ! 840186789Sluigi fd @ -1 = if EOPEN throw then 841186789Sluigi free_buffers 84297201Sgordon read_line 84397201Sgordon get_assignment 84497201Sgordon ['] process_assignment catch 84597201Sgordon ['] free_buffers catch 84697201Sgordon fd @ fclose 847292899Sdteske swap throw throw 84897201Sgordon; 84997201Sgordon 85065615Sdcsonly forth also support-functions definitions 85165615Sdcs 85244603Sdcs\ Interface to loading conf files 85344603Sdcs 85444603Sdcs: load_conf ( addr len -- ) 85544603Sdcs 0 to end_of_file? 85665615Sdcs reset_line_reading 85787636Sjhb O_RDONLY fopen fd ! 858186789Sluigi fd @ -1 = if EOPEN throw then 85944603Sdcs ['] process_conf catch 86044603Sdcs fd @ fclose 86144603Sdcs throw 86244603Sdcs; 86344603Sdcs 864186789Sluigi: print_line line_buffer strtype cr ; 86544603Sdcs 86644603Sdcs: print_syntax_error 867186789Sluigi line_buffer strtype cr 86844603Sdcs line_buffer .addr @ 86944603Sdcs begin 87044603Sdcs line_pointer over <> 87144603Sdcs while 872186789Sluigi bl emit char+ 87344603Sdcs repeat 87444603Sdcs drop 87544603Sdcs ." ^" cr 87644603Sdcs; 87744603Sdcs 878186789Sluigi 879163327Sru\ Debugging support functions 88044603Sdcs 88144603Sdcsonly forth definitions also support-functions 88244603Sdcs 88344603Sdcs: test-file 88444603Sdcs ['] load_conf catch dup . 885186789Sluigi ESYNTAX = if cr print_syntax_error then 88644603Sdcs; 88744603Sdcs 888186789Sluigi\ find a module name, leave addr on the stack (0 if not found) 889186789Sluigi: find-module ( <module> -- ptr | 0 ) 890186789Sluigi bl parse ( addr len ) 891186789Sluigi module_options @ >r ( store current pointer ) 892186789Sluigi begin 893186789Sluigi r@ 894186789Sluigi while 895186789Sluigi 2dup ( addr len addr len ) 896186789Sluigi r@ module.name strget 897186789Sluigi compare 0= if drop drop r> exit then ( found it ) 898186789Sluigi r> module.next @ >r 899186789Sluigi repeat 900186789Sluigi type ." was not found" cr r> 901186789Sluigi; 902186789Sluigi 903186789Sluigi: show-nonempty ( addr len mod -- ) 904186789Sluigi strget dup verbose? or if 905186789Sluigi 2swap type type cr 906186789Sluigi else 907186789Sluigi drop drop drop drop 908186789Sluigi then ; 909186789Sluigi 910186789Sluigi: show-one-module { addr -- addr } 911186789Sluigi ." Name: " addr module.name strtype cr 912186789Sluigi s" Path: " addr module.loadname show-nonempty 913186789Sluigi s" Type: " addr module.type show-nonempty 914186789Sluigi s" Flags: " addr module.args show-nonempty 915186789Sluigi s" Before load: " addr module.beforeload show-nonempty 916186789Sluigi s" After load: " addr module.afterload show-nonempty 917186789Sluigi s" Error: " addr module.loaderror show-nonempty 918186789Sluigi ." Status: " addr module.flag @ if ." Load" else ." Don't load" then cr 919186789Sluigi cr 920186789Sluigi addr 921186789Sluigi; 922186789Sluigi 92344603Sdcs: show-module-options 92444603Sdcs module_options @ 92544603Sdcs begin 92644603Sdcs ?dup 92744603Sdcs while 928186789Sluigi show-one-module 92944603Sdcs module.next @ 93044603Sdcs repeat 93144603Sdcs; 93244603Sdcs 933293001Sallanjude: free-one-module { addr -- addr } 934293001Sallanjude addr module.name strfree 935293001Sallanjude addr module.loadname strfree 936293001Sallanjude addr module.type strfree 937293001Sallanjude addr module.args strfree 938293001Sallanjude addr module.beforeload strfree 939293001Sallanjude addr module.afterload strfree 940293001Sallanjude addr module.loaderror strfree 941293001Sallanjude addr 942293001Sallanjude; 943293001Sallanjude 944293001Sallanjude: free-module-options 945293001Sallanjude module_options @ 946293001Sallanjude begin 947293001Sallanjude ?dup 948293001Sallanjude while 949293001Sallanjude free-one-module 950293001Sallanjude dup module.next @ 951293001Sallanjude swap free-memory 952293001Sallanjude repeat 953293001Sallanjude 0 module_options ! 954293001Sallanjude 0 last_module_option ! 955293001Sallanjude; 956293001Sallanjude 95744603Sdcsonly forth also support-functions definitions 95844603Sdcs 95944603Sdcs\ Variables used for processing multiple conf files 96044603Sdcs 961186789Sluigistring current_file_name_ref \ used to print the file name 96244603Sdcs 963298831Spfg\ Indicates if any conf file was successfully read 96444603Sdcs 96544603Sdcs0 value any_conf_read? 96644603Sdcs 96744603Sdcs\ loader_conf_files processing support functions 96844603Sdcs 969185746Sluigi: get_conf_files ( -- addr len ) \ put addr/len on stack, reset var 970185746Sluigi conf_files strget 0 0 conf_files strset 97144603Sdcs; 97244603Sdcs 97353672Sdcs: skip_leading_spaces { addr len pos -- addr len pos' } 97444603Sdcs begin 975186789Sluigi pos len = if 0 else addr pos + c@ bl = then 97644603Sdcs while 97753672Sdcs pos char+ to pos 97844603Sdcs repeat 97953672Sdcs addr len pos 98044603Sdcs; 98144603Sdcs 982186789Sluigi\ return the file name at pos, or free the string if nothing left 98353672Sdcs: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 98453672Sdcs pos len = if 98544603Sdcs addr free abort" Fatal error freeing memory" 98644603Sdcs 0 exit 98744603Sdcs then 98853672Sdcs pos >r 98944603Sdcs begin 990186789Sluigi \ stay in the loop until have chars and they are not blank 991186789Sluigi pos len = if 0 else addr pos + c@ bl <> then 99244603Sdcs while 99353672Sdcs pos char+ to pos 99444603Sdcs repeat 99553672Sdcs addr len pos addr r@ + pos r> - 99644603Sdcs; 99744603Sdcs 99844603Sdcs: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 99944603Sdcs skip_leading_spaces 100044603Sdcs get_file_name 100144603Sdcs; 100244603Sdcs 100344603Sdcs: print_current_file 1004186789Sluigi current_file_name_ref strtype 100544603Sdcs; 100644603Sdcs 100744603Sdcs: process_conf_errors 100844603Sdcs dup 0= if true to any_conf_read? drop exit then 100944603Sdcs >r 2drop r> 1010186789Sluigi dup ESYNTAX = if 101144603Sdcs ." Warning: syntax error on file " print_current_file cr 101244603Sdcs print_syntax_error drop exit 101344603Sdcs then 1014186789Sluigi dup ESETERROR = if 101544603Sdcs ." Warning: bad definition on file " print_current_file cr 101644603Sdcs print_line drop exit 101744603Sdcs then 1018186789Sluigi dup EREAD = if 101944603Sdcs ." Warning: error reading file " print_current_file cr drop exit 102044603Sdcs then 1021186789Sluigi dup EOPEN = if 102244603Sdcs verbose? if ." Warning: unable to open file " print_current_file cr then 102344603Sdcs drop exit 102444603Sdcs then 1025186789Sluigi dup EFREE = abort" Fatal error freeing memory" 1026186789Sluigi dup ENOMEM = abort" Out of memory" 102744603Sdcs throw \ Unknown error -- pass ahead 102844603Sdcs; 102944603Sdcs 103044603Sdcs\ Process loader_conf_files recursively 103144603Sdcs\ Interface to loader_conf_files processing 103244603Sdcs 103344603Sdcs: include_conf_files 1034186789Sluigi get_conf_files 0 ( addr len offset ) 103544603Sdcs begin 1036186789Sluigi get_next_file ?dup ( addr len 1 | 0 ) 103744603Sdcs while 1038186789Sluigi current_file_name_ref strref 103944603Sdcs ['] load_conf catch 104044603Sdcs process_conf_errors 1041185746Sluigi conf_files .addr @ if recurse then 104244603Sdcs repeat 104344603Sdcs; 104444603Sdcs 104597201Sgordon: get_nextboot_conf_file ( -- addr len ) 1046292999Sdteske nextboot_conf_file strget 104797201Sgordon; 104897201Sgordon 104997201Sgordon: rewrite_nextboot_file ( -- ) 105097201Sgordon get_nextboot_conf_file 105197201Sgordon O_WRONLY fopen fd ! 1052186789Sluigi fd @ -1 = if EOPEN throw then 1053292899Sdteske fd @ s' nextboot_enable="NO" ' fwrite ( fd buf len -- nwritten ) drop 105497201Sgordon fd @ fclose 105597201Sgordon; 105697201Sgordon 1057292899Sdteske: include_nextboot_file ( -- ) 105897201Sgordon get_nextboot_conf_file 1059292899Sdteske ['] peek_file catch if 2drop then 106097201Sgordon nextboot? if 106197201Sgordon get_nextboot_conf_file 1062292899Sdteske current_file_name_ref strref 106397201Sgordon ['] load_conf catch 106497201Sgordon process_conf_errors 1065292899Sdteske ['] rewrite_nextboot_file catch if 2drop then 106697201Sgordon then 106797201Sgordon; 106897201Sgordon 106944603Sdcs\ Module loading functions 107044603Sdcs 1071186789Sluigi: load_parameters { addr -- addr addrN lenN ... addr1 len1 N } 1072186789Sluigi addr 1073186789Sluigi addr module.args strget 1074186789Sluigi addr module.loadname .len @ if 1075186789Sluigi addr module.loadname strget 107644603Sdcs else 1077186789Sluigi addr module.name strget 107844603Sdcs then 1079186789Sluigi addr module.type .len @ if 1080186789Sluigi addr module.type strget 108144603Sdcs s" -t " 108244603Sdcs 4 ( -t type name flags ) 108344603Sdcs else 108444603Sdcs 2 ( name flags ) 108544603Sdcs then 108644603Sdcs; 108744603Sdcs 108844603Sdcs: before_load ( addr -- addr ) 108944603Sdcs dup module.beforeload .len @ if 1090186789Sluigi dup module.beforeload strget 1091186789Sluigi ['] evaluate catch if EBEFORELOAD throw then 109244603Sdcs then 109344603Sdcs; 109444603Sdcs 109544603Sdcs: after_load ( addr -- addr ) 109644603Sdcs dup module.afterload .len @ if 1097186789Sluigi dup module.afterload strget 1098186789Sluigi ['] evaluate catch if EAFTERLOAD throw then 109944603Sdcs then 110044603Sdcs; 110144603Sdcs 110244603Sdcs: load_error ( addr -- addr ) 110344603Sdcs dup module.loaderror .len @ if 1104186789Sluigi dup module.loaderror strget 110544603Sdcs evaluate \ This we do not intercept so it can throw errors 110644603Sdcs then 110744603Sdcs; 110844603Sdcs 110944603Sdcs: pre_load_message ( addr -- addr ) 111044603Sdcs verbose? if 1111186789Sluigi dup module.name strtype 111244603Sdcs ." ..." 111344603Sdcs then 111444603Sdcs; 111544603Sdcs 111644603Sdcs: load_error_message verbose? if ." failed!" cr then ; 111744603Sdcs 111844603Sdcs: load_succesful_message verbose? if ." ok" cr then ; 111944603Sdcs 112044603Sdcs: load_module 112144603Sdcs load_parameters load 112244603Sdcs; 112344603Sdcs 112444603Sdcs: process_module ( addr -- addr ) 112544603Sdcs pre_load_message 112644603Sdcs before_load 112744603Sdcs begin 112844603Sdcs ['] load_module catch if 112944603Sdcs dup module.loaderror .len @ if 113044603Sdcs load_error \ Command should return a flag! 113144603Sdcs else 113244603Sdcs load_error_message true \ Do not retry 113344603Sdcs then 113444603Sdcs else 113544603Sdcs after_load 1136298831Spfg load_succesful_message true \ Successful, do not retry 113744603Sdcs then 113844603Sdcs until 113944603Sdcs; 114044603Sdcs 114144603Sdcs: process_module_errors ( addr ior -- ) 1142186789Sluigi dup EBEFORELOAD = if 114344603Sdcs drop 114444603Sdcs ." Module " 1145186789Sluigi dup module.name strtype 114644603Sdcs dup module.loadname .len @ if 1147186789Sluigi ." (" dup module.loadname strtype ." )" 114844603Sdcs then 114944603Sdcs cr 115044603Sdcs ." Error executing " 1151186789Sluigi dup module.beforeload strtype cr \ XXX there was a typo here 115244603Sdcs abort 115344603Sdcs then 115444603Sdcs 1155186789Sluigi dup EAFTERLOAD = if 115644603Sdcs drop 115744603Sdcs ." Module " 115844603Sdcs dup module.name .addr @ over module.name .len @ type 115944603Sdcs dup module.loadname .len @ if 1160186789Sluigi ." (" dup module.loadname strtype ." )" 116144603Sdcs then 116244603Sdcs cr 116344603Sdcs ." Error executing " 1164186789Sluigi dup module.afterload strtype cr 116544603Sdcs abort 116644603Sdcs then 116744603Sdcs 116844603Sdcs throw \ Don't know what it is all about -- pass ahead 116944603Sdcs; 117044603Sdcs 117144603Sdcs\ Module loading interface 117244603Sdcs 1173186789Sluigi\ scan the list of modules, load enabled ones. 117444603Sdcs: load_modules ( -- ) ( throws: abort & user-defined ) 1175186789Sluigi module_options @ ( list_head ) 117644603Sdcs begin 117744603Sdcs ?dup 117844603Sdcs while 1179186789Sluigi dup module.flag @ if 118044603Sdcs ['] process_module catch 118144603Sdcs process_module_errors 118244603Sdcs then 118344603Sdcs module.next @ 118444603Sdcs repeat 118544603Sdcs; 118644603Sdcs 118765630Sdcs\ h00h00 magic used to try loading either a kernel with a given name, 118865630Sdcs\ or a kernel with the default name in a directory of a given name 118965630Sdcs\ (the pain!) 119044603Sdcs 119165630Sdcs: bootpath s" /boot/" ; 119265630Sdcs: modulepath s" module_path" ; 119365630Sdcs 119465630Sdcs\ Functions used to save and restore module_path's value. 119565630Sdcs: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 119665630Sdcs dup -1 = if 0 swap exit then 119765630Sdcs strdup 119865630Sdcs; 119965630Sdcs: freeenv ( addr len | 0 -1 ) 120065630Sdcs -1 = if drop else free abort" Freeing error" then 120165630Sdcs; 120265630Sdcs: restoreenv ( addr len | 0 -1 -- ) 120365630Sdcs dup -1 = if ( it wasn't set ) 120465630Sdcs 2drop 120565630Sdcs modulepath unsetenv 120665630Sdcs else 120765630Sdcs over >r 120865630Sdcs modulepath setenv 120965630Sdcs r> free abort" Freeing error" 121065630Sdcs then 121165630Sdcs; 121265630Sdcs 121365630Sdcs: clip_args \ Drop second string if only one argument is passed 121465630Sdcs 1 = if 121565630Sdcs 2swap 2drop 121665630Sdcs 1 121765630Sdcs else 121865630Sdcs 2 121965630Sdcs then 122065630Sdcs; 122165630Sdcs 122265630Sdcsalso builtins 122365630Sdcs 1224186789Sluigi\ Parse filename from a semicolon-separated list 122565630Sdcs 1226186789Sluigi\ replacement, not working yet 1227186789Sluigi: newparse-; { addr len | a1 -- a' len-x addr x } 1228186789Sluigi addr len [char] ; strchr dup if ( a1 len1 ) 1229186789Sluigi swap to a1 ( store address ) 1230186789Sluigi 1 - a1 @ 1 + swap ( remove match ) 1231186789Sluigi addr a1 addr - 1232186789Sluigi else 1233186789Sluigi 0 0 addr len 1234186789Sluigi then 1235186789Sluigi; 1236186789Sluigi 123765630Sdcs: parse-; ( addr len -- addr' len-x addr x ) 1238186789Sluigi over 0 2swap ( addr 0 addr len ) 123965630Sdcs begin 1240186789Sluigi dup 0 <> ( addr 0 addr len ) 124165630Sdcs while 1242186789Sluigi over c@ [char] ; <> ( addr 0 addr len flag ) 124365630Sdcs while 124465630Sdcs 1- swap 1+ swap 124565630Sdcs 2swap 1+ 2swap 124665630Sdcs repeat then 124765630Sdcs dup 0 <> if 124865630Sdcs 1- swap 1+ swap 124965630Sdcs then 125065630Sdcs 2swap 125165630Sdcs; 125265630Sdcs 125365630Sdcs\ Try loading one of multiple kernels specified 125465630Sdcs 125565630Sdcs: try_multiple_kernels ( addr len addr' len' args -- flag ) 125665630Sdcs >r 125765630Sdcs begin 125865630Sdcs parse-; 2>r 125965630Sdcs 2over 2r> 126065945Sdcs r@ clip_args 126165945Sdcs s" DEBUG" getenv? if 126265945Sdcs s" echo Module_path: ${module_path}" evaluate 126365945Sdcs ." Kernel : " >r 2dup type r> cr 126465945Sdcs dup 2 = if ." Flags : " >r 2over type r> cr then 126565945Sdcs then 126665945Sdcs 1 load 126765630Sdcs while 126865630Sdcs dup 0= 126965630Sdcs until 127065630Sdcs 1 >r \ Failure 127165630Sdcs else 127265630Sdcs 0 >r \ Success 127365630Sdcs then 127465630Sdcs 2drop 2drop 127565630Sdcs r> 127665630Sdcs r> drop 127765630Sdcs; 127865630Sdcs 127965630Sdcs\ Try to load a kernel; the kernel name is taken from one of 128065630Sdcs\ the following lists, as ordered: 128165630Sdcs\ 128265641Sdcs\ 1. The "bootfile" environment variable 128365641Sdcs\ 2. The "kernel" environment variable 128465630Sdcs\ 128565938Sdcs\ Flags are passed, if available. If not, dummy values must be given. 128665630Sdcs\ 128765630Sdcs\ The kernel gets loaded from the current module_path. 128865630Sdcs 128965938Sdcs: load_a_kernel ( flags len 1 | x x 0 -- flag ) 129065630Sdcs local args 129165630Sdcs 2local flags 129265630Sdcs 0 0 2local kernel 129365630Sdcs end-locals 129465630Sdcs 129565630Sdcs \ Check if a default kernel name exists at all, exits if not 129665641Sdcs s" bootfile" getenv dup -1 <> if 129765630Sdcs to kernel 129865883Sdcs flags kernel args 1+ try_multiple_kernels 129965630Sdcs dup 0= if exit then 130065630Sdcs then 130165630Sdcs drop 130265630Sdcs 130365641Sdcs s" kernel" getenv dup -1 <> if 130465630Sdcs to kernel 130565630Sdcs else 130665630Sdcs drop 130765630Sdcs 1 exit \ Failure 130865630Sdcs then 130965630Sdcs 131065630Sdcs \ Try all default kernel names 131165883Sdcs flags kernel args 1+ try_multiple_kernels 131265630Sdcs; 131365630Sdcs 131465630Sdcs\ Try to load a kernel; the kernel name is taken from one of 131565630Sdcs\ the following lists, as ordered: 131665630Sdcs\ 131765641Sdcs\ 1. The "bootfile" environment variable 131865641Sdcs\ 2. The "kernel" environment variable 131965630Sdcs\ 132065630Sdcs\ Flags are passed, if provided. 132165630Sdcs\ 132265630Sdcs\ The kernel will be loaded from a directory computed from the 132365630Sdcs\ path given. Two directories will be tried in the following order: 132465630Sdcs\ 132565630Sdcs\ 1. /boot/path 132665630Sdcs\ 2. path 132765630Sdcs\ 1328298831Spfg\ The module_path variable is overridden if load is successful, by 132965630Sdcs\ prepending the successful path. 133065630Sdcs 133165630Sdcs: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 133265630Sdcs local args 133365630Sdcs 2local path 133465630Sdcs args 1 = if 0 0 then 133565630Sdcs 2local flags 1336186789Sluigi 0 0 2local oldmodulepath \ like a string 1337186789Sluigi 0 0 2local newmodulepath \ like a string 133865630Sdcs end-locals 133965630Sdcs 134065630Sdcs \ Set the environment variable module_path, and try loading 134165630Sdcs \ the kernel again. 134265630Sdcs modulepath getenv saveenv to oldmodulepath 134365630Sdcs 134465630Sdcs \ Try prepending /boot/ first 1345186789Sluigi bootpath nip path nip + \ total length 134665630Sdcs oldmodulepath nip dup -1 = if 134765630Sdcs drop 134865630Sdcs else 1349186789Sluigi 1+ + \ add oldpath -- XXX why the 1+ ? 135065630Sdcs then 1351186789Sluigi allocate if ( out of memory ) 1 exit then \ XXX throw ? 135265630Sdcs 135365630Sdcs 0 135465630Sdcs bootpath strcat 135565630Sdcs path strcat 135665630Sdcs 2dup to newmodulepath 135765630Sdcs modulepath setenv 135865630Sdcs 135965630Sdcs \ Try all default kernel names 136065938Sdcs flags args 1- load_a_kernel 136165630Sdcs 0= if ( success ) 136265630Sdcs oldmodulepath nip -1 <> if 136365630Sdcs newmodulepath s" ;" strcat 136465630Sdcs oldmodulepath strcat 136565630Sdcs modulepath setenv 136665630Sdcs newmodulepath drop free-memory 136765630Sdcs oldmodulepath drop free-memory 136865630Sdcs then 136965630Sdcs 0 exit 137065630Sdcs then 137165630Sdcs 137265630Sdcs \ Well, try without the prepended /boot/ 137365630Sdcs path newmodulepath drop swap move 137465883Sdcs newmodulepath drop path nip 137565630Sdcs 2dup to newmodulepath 137665630Sdcs modulepath setenv 137765630Sdcs 137865630Sdcs \ Try all default kernel names 137965938Sdcs flags args 1- load_a_kernel 138065630Sdcs if ( failed once more ) 138165630Sdcs oldmodulepath restoreenv 138265630Sdcs newmodulepath drop free-memory 138365630Sdcs 1 138465630Sdcs else 138565630Sdcs oldmodulepath nip -1 <> if 138665630Sdcs newmodulepath s" ;" strcat 138765630Sdcs oldmodulepath strcat 138865630Sdcs modulepath setenv 138965630Sdcs newmodulepath drop free-memory 139065630Sdcs oldmodulepath drop free-memory 139165630Sdcs then 139265630Sdcs 0 139365630Sdcs then 139465630Sdcs; 139565630Sdcs 139665630Sdcs\ Try to load a kernel; the kernel name is taken from one of 139765630Sdcs\ the following lists, as ordered: 139865630Sdcs\ 139965641Sdcs\ 1. The "bootfile" environment variable 140065641Sdcs\ 2. The "kernel" environment variable 140165630Sdcs\ 3. The "path" argument 140265630Sdcs\ 140365630Sdcs\ Flags are passed, if provided. 140465630Sdcs\ 140565630Sdcs\ The kernel will be loaded from a directory computed from the 140665630Sdcs\ path given. Two directories will be tried in the following order: 140765630Sdcs\ 140865630Sdcs\ 1. /boot/path 140965630Sdcs\ 2. path 141065630Sdcs\ 141165630Sdcs\ Unless "path" is meant to be kernel name itself. In that case, it 141265630Sdcs\ will first be tried as a full path, and, next, search on the 141365630Sdcs\ directories pointed by module_path. 141465630Sdcs\ 1415298831Spfg\ The module_path variable is overridden if load is successful, by 141665630Sdcs\ prepending the successful path. 141765630Sdcs 141865630Sdcs: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 141965630Sdcs local args 142065630Sdcs 2local path 142165630Sdcs args 1 = if 0 0 then 142265630Sdcs 2local flags 142365630Sdcs end-locals 142465630Sdcs 142565630Sdcs \ First, assume path is an absolute path to a directory 142665630Sdcs flags path args clip_args load_from_directory 142765630Sdcs dup 0= if exit else drop then 142865630Sdcs 142965630Sdcs \ Next, assume path points to the kernel 143065630Sdcs flags path args try_multiple_kernels 143165630Sdcs; 143265630Sdcs 143344603Sdcs: initialize ( addr len -- ) 1434186789Sluigi strdup conf_files strset 143544603Sdcs; 143644603Sdcs 143765883Sdcs: kernel_options ( -- addr len 1 | 0 ) 143865630Sdcs s" kernel_options" getenv 143965883Sdcs dup -1 = if drop 0 else 1 then 144065630Sdcs; 144165630Sdcs 144265938Sdcs: standard_kernel_search ( flags 1 | 0 -- flag ) 144365938Sdcs local args 144465938Sdcs args 0= if 0 0 then 144565938Sdcs 2local flags 144665630Sdcs s" kernel" getenv 144765938Sdcs dup -1 = if 0 swap then 144865938Sdcs 2local path 144965938Sdcs end-locals 145065938Sdcs 145166349Sdcs path nip -1 = if ( there isn't a "kernel" environment variable ) 145265938Sdcs flags args load_a_kernel 145365938Sdcs else 145465938Sdcs flags path args 1+ clip_args load_directory_or_file 145565938Sdcs then 145665630Sdcs; 145765630Sdcs 145844603Sdcs: load_kernel ( -- ) ( throws: abort ) 145965938Sdcs kernel_options standard_kernel_search 146065630Sdcs abort" Unable to load a kernel!" 146144603Sdcs; 146265883Sdcs 1463283933Sdteske: load_xen ( -- flag ) 1464277215Sroyger s" xen_kernel" getenv dup -1 <> if 1465283933Sdteske 1 1 load ( c-addr/u flag N -- flag ) 1466277215Sroyger else 1467277215Sroyger drop 1468283933Sdteske 0 ( -1 -- flag ) 1469277215Sroyger then 1470277215Sroyger; 1471277215Sroyger 1472277215Sroyger: load_xen_throw ( -- ) ( throws: abort ) 1473277215Sroyger load_xen 1474277215Sroyger abort" Unable to load Xen!" 1475277215Sroyger; 1476277215Sroyger 147765949Sdcs: set_defaultoptions ( -- ) 147865883Sdcs s" kernel_options" getenv dup -1 = if 147965883Sdcs drop 148065883Sdcs else 148165883Sdcs s" temp_options" setenv 148265883Sdcs then 148365883Sdcs; 148465883Sdcs 1485186789Sluigi\ pick the i-th argument, i starts at 0 148665883Sdcs: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 1487186789Sluigi 2dup = if 0 0 exit then \ out of range 148865883Sdcs dup >r 148965883Sdcs 1+ 2* ( skip N and ui ) 149065883Sdcs pick 149165883Sdcs r> 149265883Sdcs 1+ 2* ( skip N and ai ) 149365883Sdcs pick 149465883Sdcs; 149565883Sdcs 149665949Sdcs: drop_args ( aN uN ... a1 u1 N -- ) 149765883Sdcs 0 ?do 2drop loop 149865883Sdcs; 149965883Sdcs 150065883Sdcs: argc 150165883Sdcs dup 150265883Sdcs; 150365883Sdcs 150465949Sdcs: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 150565883Sdcs >r 150665883Sdcs over 2* 1+ -roll 150765883Sdcs r> 150865883Sdcs over 2* 1+ -roll 150965883Sdcs 1+ 151065883Sdcs; 151165883Sdcs 151265949Sdcs: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 151365883Sdcs 1- -rot 151465883Sdcs; 151565883Sdcs 1516186789Sluigi\ compute the length of the buffer including the spaces between words 1517186789Sluigi: strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len ) 151865883Sdcs dup 0= if 0 exit then 151965883Sdcs 0 >r \ Size 152065883Sdcs 0 >r \ Index 152165883Sdcs begin 152265883Sdcs argc r@ <> 152365883Sdcs while 152465883Sdcs r@ argv[] 152565883Sdcs nip 152665883Sdcs r> r> rot + 1+ 152765883Sdcs >r 1+ >r 152865883Sdcs repeat 152965883Sdcs r> drop 153065883Sdcs r> 153165883Sdcs; 153265883Sdcs 153365949Sdcs: concat_argv ( aN uN ... a1 u1 N -- a u ) 1534186789Sluigi strlen(argv) allocate if ENOMEM throw then 1535186789Sluigi 0 2>r ( save addr 0 on return stack ) 153665883Sdcs 153765883Sdcs begin 1538186789Sluigi dup 153965883Sdcs while 1540186789Sluigi unqueue_argv ( ... N a1 u1 ) 1541186789Sluigi 2r> 2swap ( old a1 u1 ) 154265883Sdcs strcat 1543186789Sluigi s" " strcat ( append one space ) \ XXX this gives a trailing space 1544186789Sluigi 2>r ( store string on the result stack ) 154565883Sdcs repeat 154665949Sdcs drop_args 154765883Sdcs 2r> 154865883Sdcs; 154965883Sdcs 155065949Sdcs: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 155165883Sdcs \ Save the first argument, if it exists and is not a flag 155265883Sdcs argc if 155365883Sdcs 0 argv[] drop c@ [char] - <> if 155465949Sdcs unqueue_argv 2>r \ Filename 155565883Sdcs 1 >r \ Filename present 155665883Sdcs else 155765883Sdcs 0 >r \ Filename not present 155865883Sdcs then 155965883Sdcs else 156065883Sdcs 0 >r \ Filename not present 156165883Sdcs then 156265883Sdcs 156365883Sdcs \ If there are other arguments, assume they are flags 156465883Sdcs ?dup if 156565949Sdcs concat_argv 156665883Sdcs 2dup s" temp_options" setenv 1567186789Sluigi drop free if EFREE throw then 156865883Sdcs else 156965949Sdcs set_defaultoptions 157065883Sdcs then 157165883Sdcs 157265883Sdcs \ Bring back the filename, if one was provided 157365883Sdcs r> if 2r> 1 else 0 then 157465883Sdcs; 157565883Sdcs 157665949Sdcs: get_arguments ( -- addrN lenN ... addr1 len1 N ) 157765883Sdcs 0 157865883Sdcs begin 157965883Sdcs \ Get next word on the command line 158065883Sdcs parse-word 158165883Sdcs ?dup while 158265949Sdcs queue_argv 158365883Sdcs repeat 158465883Sdcs drop ( empty string ) 158565883Sdcs; 158665883Sdcs 158765945Sdcs: load_kernel_and_modules ( args -- flag ) 158865949Sdcs set_tempoptions 158965883Sdcs argc >r 159065883Sdcs s" temp_options" getenv dup -1 <> if 159165949Sdcs queue_argv 159265883Sdcs else 159365883Sdcs drop 159465883Sdcs then 1595277215Sroyger load_xen 1596277215Sroyger ?dup 0= if ( success ) 1597277215Sroyger r> if ( a path was passed ) 1598277215Sroyger load_directory_or_file 1599277215Sroyger else 1600277215Sroyger standard_kernel_search 1601277215Sroyger then 1602277215Sroyger ?dup 0= if ['] load_modules catch then 160365883Sdcs then 160465883Sdcs; 160565883Sdcs 1606280937Sdteskeonly forth definitions 1607