support.4th revision 280924
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 280924 2015-03-31 22:32:35Z dteske $ 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 5944603Sdcs\ value any_conf_read? indicates if a conf file was succesfully 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 31865615Sdcsalso line-reading definitions also 31965615Sdcs 32044603Sdcs\ File data temporary storage 32144603Sdcs 32244603Sdcsstring read_buffer 32344603Sdcs0 value read_buffer_ptr 32444603Sdcs 32544603Sdcs\ File's line reading function 32644603Sdcs 32765615Sdcssupport-functions definitions 32865615Sdcs 32965615Sdcsstring line_buffer 33044603Sdcs0 value end_of_file? 33144603Sdcsvariable fd 33244603Sdcs 33365615Sdcsline-reading 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 40865615Sdcssupport-functions definitions 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 45065615Sdcsalso parser definitions also 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 60965615Sdcsfile-processing definitions 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 62665615Sdcsonly forth also support-functions also file-processing definitions also 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 687186789Sluigi: set_nextboot_conf \ XXX maybe do as set_conf_files ? 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 82165615Sdcssupport-functions definitions 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 83697201Sgordon: peek_file 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 84797201Sgordon; 84897201Sgordon 84965615Sdcsonly forth also support-functions definitions 85065615Sdcs 85144603Sdcs\ Interface to loading conf files 85244603Sdcs 85344603Sdcs: load_conf ( addr len -- ) 854187143Sluigi \ ." ----- Trying conf " 2dup type cr \ debugging 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 93344603Sdcsonly forth also support-functions definitions 93444603Sdcs 93544603Sdcs\ Variables used for processing multiple conf files 93644603Sdcs 937186789Sluigistring current_file_name_ref \ used to print the file name 93844603Sdcs 93944603Sdcs\ Indicates if any conf file was succesfully read 94044603Sdcs 94144603Sdcs0 value any_conf_read? 94244603Sdcs 94344603Sdcs\ loader_conf_files processing support functions 94444603Sdcs 945185746Sluigi: get_conf_files ( -- addr len ) \ put addr/len on stack, reset var 946187143Sluigi \ ." -- starting on <" conf_files strtype ." >" cr \ debugging 947185746Sluigi conf_files strget 0 0 conf_files strset 94844603Sdcs; 94944603Sdcs 95053672Sdcs: skip_leading_spaces { addr len pos -- addr len pos' } 95144603Sdcs begin 952186789Sluigi pos len = if 0 else addr pos + c@ bl = then 95344603Sdcs while 95453672Sdcs pos char+ to pos 95544603Sdcs repeat 95653672Sdcs addr len pos 95744603Sdcs; 95844603Sdcs 959186789Sluigi\ return the file name at pos, or free the string if nothing left 96053672Sdcs: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 96153672Sdcs pos len = if 96244603Sdcs addr free abort" Fatal error freeing memory" 96344603Sdcs 0 exit 96444603Sdcs then 96553672Sdcs pos >r 96644603Sdcs begin 967186789Sluigi \ stay in the loop until have chars and they are not blank 968186789Sluigi pos len = if 0 else addr pos + c@ bl <> then 96944603Sdcs while 97053672Sdcs pos char+ to pos 97144603Sdcs repeat 97253672Sdcs addr len pos addr r@ + pos r> - 973187143Sluigi \ 2dup ." get_file_name has " type cr \ debugging 97444603Sdcs; 97544603Sdcs 97644603Sdcs: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 97744603Sdcs skip_leading_spaces 97844603Sdcs get_file_name 97944603Sdcs; 98044603Sdcs 98144603Sdcs: print_current_file 982186789Sluigi current_file_name_ref strtype 98344603Sdcs; 98444603Sdcs 98544603Sdcs: process_conf_errors 98644603Sdcs dup 0= if true to any_conf_read? drop exit then 98744603Sdcs >r 2drop r> 988186789Sluigi dup ESYNTAX = if 98944603Sdcs ." Warning: syntax error on file " print_current_file cr 99044603Sdcs print_syntax_error drop exit 99144603Sdcs then 992186789Sluigi dup ESETERROR = if 99344603Sdcs ." Warning: bad definition on file " print_current_file cr 99444603Sdcs print_line drop exit 99544603Sdcs then 996186789Sluigi dup EREAD = if 99744603Sdcs ." Warning: error reading file " print_current_file cr drop exit 99844603Sdcs then 999186789Sluigi dup EOPEN = if 100044603Sdcs verbose? if ." Warning: unable to open file " print_current_file cr then 100144603Sdcs drop exit 100244603Sdcs then 1003186789Sluigi dup EFREE = abort" Fatal error freeing memory" 1004186789Sluigi dup ENOMEM = abort" Out of memory" 100544603Sdcs throw \ Unknown error -- pass ahead 100644603Sdcs; 100744603Sdcs 100844603Sdcs\ Process loader_conf_files recursively 100944603Sdcs\ Interface to loader_conf_files processing 101044603Sdcs 101144603Sdcs: include_conf_files 1012186789Sluigi get_conf_files 0 ( addr len offset ) 101344603Sdcs begin 1014186789Sluigi get_next_file ?dup ( addr len 1 | 0 ) 101544603Sdcs while 1016186789Sluigi current_file_name_ref strref 101744603Sdcs ['] load_conf catch 101844603Sdcs process_conf_errors 1019185746Sluigi conf_files .addr @ if recurse then 102044603Sdcs repeat 102144603Sdcs; 102244603Sdcs 102397201Sgordon: get_nextboot_conf_file ( -- addr len ) 1024186789Sluigi nextboot_conf_file strget strdup \ XXX is the strdup a leak ? 102597201Sgordon; 102697201Sgordon 102797201Sgordon: rewrite_nextboot_file ( -- ) 102897201Sgordon get_nextboot_conf_file 102997201Sgordon O_WRONLY fopen fd ! 1030186789Sluigi fd @ -1 = if EOPEN throw then 103197201Sgordon fd @ s' nextboot_enable="NO" ' fwrite 103297201Sgordon fd @ fclose 103397201Sgordon; 103497201Sgordon 103597201Sgordon: include_nextboot_file 103697201Sgordon get_nextboot_conf_file 103797201Sgordon ['] peek_file catch 103897201Sgordon nextboot? if 103997201Sgordon get_nextboot_conf_file 104097201Sgordon ['] load_conf catch 104197201Sgordon process_conf_errors 104297201Sgordon ['] rewrite_nextboot_file catch 104397201Sgordon then 104497201Sgordon; 104597201Sgordon 104644603Sdcs\ Module loading functions 104744603Sdcs 1048186789Sluigi: load_parameters { addr -- addr addrN lenN ... addr1 len1 N } 1049186789Sluigi addr 1050186789Sluigi addr module.args strget 1051186789Sluigi addr module.loadname .len @ if 1052186789Sluigi addr module.loadname strget 105344603Sdcs else 1054186789Sluigi addr module.name strget 105544603Sdcs then 1056186789Sluigi addr module.type .len @ if 1057186789Sluigi addr module.type strget 105844603Sdcs s" -t " 105944603Sdcs 4 ( -t type name flags ) 106044603Sdcs else 106144603Sdcs 2 ( name flags ) 106244603Sdcs then 106344603Sdcs; 106444603Sdcs 106544603Sdcs: before_load ( addr -- addr ) 106644603Sdcs dup module.beforeload .len @ if 1067186789Sluigi dup module.beforeload strget 1068186789Sluigi ['] evaluate catch if EBEFORELOAD throw then 106944603Sdcs then 107044603Sdcs; 107144603Sdcs 107244603Sdcs: after_load ( addr -- addr ) 107344603Sdcs dup module.afterload .len @ if 1074186789Sluigi dup module.afterload strget 1075186789Sluigi ['] evaluate catch if EAFTERLOAD throw then 107644603Sdcs then 107744603Sdcs; 107844603Sdcs 107944603Sdcs: load_error ( addr -- addr ) 108044603Sdcs dup module.loaderror .len @ if 1081186789Sluigi dup module.loaderror strget 108244603Sdcs evaluate \ This we do not intercept so it can throw errors 108344603Sdcs then 108444603Sdcs; 108544603Sdcs 108644603Sdcs: pre_load_message ( addr -- addr ) 108744603Sdcs verbose? if 1088186789Sluigi dup module.name strtype 108944603Sdcs ." ..." 109044603Sdcs then 109144603Sdcs; 109244603Sdcs 109344603Sdcs: load_error_message verbose? if ." failed!" cr then ; 109444603Sdcs 109544603Sdcs: load_succesful_message verbose? if ." ok" cr then ; 109644603Sdcs 109744603Sdcs: load_module 109844603Sdcs load_parameters load 109944603Sdcs; 110044603Sdcs 110144603Sdcs: process_module ( addr -- addr ) 110244603Sdcs pre_load_message 110344603Sdcs before_load 110444603Sdcs begin 110544603Sdcs ['] load_module catch if 110644603Sdcs dup module.loaderror .len @ if 110744603Sdcs load_error \ Command should return a flag! 110844603Sdcs else 110944603Sdcs load_error_message true \ Do not retry 111044603Sdcs then 111144603Sdcs else 111244603Sdcs after_load 111344603Sdcs load_succesful_message true \ Succesful, do not retry 111444603Sdcs then 111544603Sdcs until 111644603Sdcs; 111744603Sdcs 111844603Sdcs: process_module_errors ( addr ior -- ) 1119186789Sluigi dup EBEFORELOAD = if 112044603Sdcs drop 112144603Sdcs ." Module " 1122186789Sluigi dup module.name strtype 112344603Sdcs dup module.loadname .len @ if 1124186789Sluigi ." (" dup module.loadname strtype ." )" 112544603Sdcs then 112644603Sdcs cr 112744603Sdcs ." Error executing " 1128186789Sluigi dup module.beforeload strtype cr \ XXX there was a typo here 112944603Sdcs abort 113044603Sdcs then 113144603Sdcs 1132186789Sluigi dup EAFTERLOAD = if 113344603Sdcs drop 113444603Sdcs ." Module " 113544603Sdcs dup module.name .addr @ over module.name .len @ type 113644603Sdcs dup module.loadname .len @ if 1137186789Sluigi ." (" dup module.loadname strtype ." )" 113844603Sdcs then 113944603Sdcs cr 114044603Sdcs ." Error executing " 1141186789Sluigi dup module.afterload strtype cr 114244603Sdcs abort 114344603Sdcs then 114444603Sdcs 114544603Sdcs throw \ Don't know what it is all about -- pass ahead 114644603Sdcs; 114744603Sdcs 114844603Sdcs\ Module loading interface 114944603Sdcs 1150186789Sluigi\ scan the list of modules, load enabled ones. 115144603Sdcs: load_modules ( -- ) ( throws: abort & user-defined ) 1152186789Sluigi module_options @ ( list_head ) 115344603Sdcs begin 115444603Sdcs ?dup 115544603Sdcs while 1156186789Sluigi dup module.flag @ if 115744603Sdcs ['] process_module catch 115844603Sdcs process_module_errors 115944603Sdcs then 116044603Sdcs module.next @ 116144603Sdcs repeat 116244603Sdcs; 116344603Sdcs 116465630Sdcs\ h00h00 magic used to try loading either a kernel with a given name, 116565630Sdcs\ or a kernel with the default name in a directory of a given name 116665630Sdcs\ (the pain!) 116744603Sdcs 116865630Sdcs: bootpath s" /boot/" ; 116965630Sdcs: modulepath s" module_path" ; 117065630Sdcs 117165630Sdcs\ Functions used to save and restore module_path's value. 117265630Sdcs: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 117365630Sdcs dup -1 = if 0 swap exit then 117465630Sdcs strdup 117565630Sdcs; 117665630Sdcs: freeenv ( addr len | 0 -1 ) 117765630Sdcs -1 = if drop else free abort" Freeing error" then 117865630Sdcs; 117965630Sdcs: restoreenv ( addr len | 0 -1 -- ) 118065630Sdcs dup -1 = if ( it wasn't set ) 118165630Sdcs 2drop 118265630Sdcs modulepath unsetenv 118365630Sdcs else 118465630Sdcs over >r 118565630Sdcs modulepath setenv 118665630Sdcs r> free abort" Freeing error" 118765630Sdcs then 118865630Sdcs; 118965630Sdcs 119065630Sdcs: clip_args \ Drop second string if only one argument is passed 119165630Sdcs 1 = if 119265630Sdcs 2swap 2drop 119365630Sdcs 1 119465630Sdcs else 119565630Sdcs 2 119665630Sdcs then 119765630Sdcs; 119865630Sdcs 119965630Sdcsalso builtins 120065630Sdcs 1201186789Sluigi\ Parse filename from a semicolon-separated list 120265630Sdcs 1203186789Sluigi\ replacement, not working yet 1204186789Sluigi: newparse-; { addr len | a1 -- a' len-x addr x } 1205186789Sluigi addr len [char] ; strchr dup if ( a1 len1 ) 1206186789Sluigi swap to a1 ( store address ) 1207186789Sluigi 1 - a1 @ 1 + swap ( remove match ) 1208186789Sluigi addr a1 addr - 1209186789Sluigi else 1210186789Sluigi 0 0 addr len 1211186789Sluigi then 1212186789Sluigi; 1213186789Sluigi 121465630Sdcs: parse-; ( addr len -- addr' len-x addr x ) 1215186789Sluigi over 0 2swap ( addr 0 addr len ) 121665630Sdcs begin 1217186789Sluigi dup 0 <> ( addr 0 addr len ) 121865630Sdcs while 1219186789Sluigi over c@ [char] ; <> ( addr 0 addr len flag ) 122065630Sdcs while 122165630Sdcs 1- swap 1+ swap 122265630Sdcs 2swap 1+ 2swap 122365630Sdcs repeat then 122465630Sdcs dup 0 <> if 122565630Sdcs 1- swap 1+ swap 122665630Sdcs then 122765630Sdcs 2swap 122865630Sdcs; 122965630Sdcs 123065630Sdcs\ Try loading one of multiple kernels specified 123165630Sdcs 123265630Sdcs: try_multiple_kernels ( addr len addr' len' args -- flag ) 123365630Sdcs >r 123465630Sdcs begin 123565630Sdcs parse-; 2>r 123665630Sdcs 2over 2r> 123765945Sdcs r@ clip_args 123865945Sdcs s" DEBUG" getenv? if 123965945Sdcs s" echo Module_path: ${module_path}" evaluate 124065945Sdcs ." Kernel : " >r 2dup type r> cr 124165945Sdcs dup 2 = if ." Flags : " >r 2over type r> cr then 124265945Sdcs then 124365945Sdcs 1 load 124465630Sdcs while 124565630Sdcs dup 0= 124665630Sdcs until 124765630Sdcs 1 >r \ Failure 124865630Sdcs else 124965630Sdcs 0 >r \ Success 125065630Sdcs then 125165630Sdcs 2drop 2drop 125265630Sdcs r> 125365630Sdcs r> drop 125465630Sdcs; 125565630Sdcs 125665630Sdcs\ Try to load a kernel; the kernel name is taken from one of 125765630Sdcs\ the following lists, as ordered: 125865630Sdcs\ 125965641Sdcs\ 1. The "bootfile" environment variable 126065641Sdcs\ 2. The "kernel" environment variable 126165630Sdcs\ 126265938Sdcs\ Flags are passed, if available. If not, dummy values must be given. 126365630Sdcs\ 126465630Sdcs\ The kernel gets loaded from the current module_path. 126565630Sdcs 126665938Sdcs: load_a_kernel ( flags len 1 | x x 0 -- flag ) 126765630Sdcs local args 126865630Sdcs 2local flags 126965630Sdcs 0 0 2local kernel 127065630Sdcs end-locals 127165630Sdcs 127265630Sdcs \ Check if a default kernel name exists at all, exits if not 127365641Sdcs s" bootfile" getenv dup -1 <> if 127465630Sdcs to kernel 127565883Sdcs flags kernel args 1+ try_multiple_kernels 127665630Sdcs dup 0= if exit then 127765630Sdcs then 127865630Sdcs drop 127965630Sdcs 128065641Sdcs s" kernel" getenv dup -1 <> if 128165630Sdcs to kernel 128265630Sdcs else 128365630Sdcs drop 128465630Sdcs 1 exit \ Failure 128565630Sdcs then 128665630Sdcs 128765630Sdcs \ Try all default kernel names 128865883Sdcs flags kernel args 1+ try_multiple_kernels 128965630Sdcs; 129065630Sdcs 129165630Sdcs\ Try to load a kernel; the kernel name is taken from one of 129265630Sdcs\ the following lists, as ordered: 129365630Sdcs\ 129465641Sdcs\ 1. The "bootfile" environment variable 129565641Sdcs\ 2. The "kernel" environment variable 129665630Sdcs\ 129765630Sdcs\ Flags are passed, if provided. 129865630Sdcs\ 129965630Sdcs\ The kernel will be loaded from a directory computed from the 130065630Sdcs\ path given. Two directories will be tried in the following order: 130165630Sdcs\ 130265630Sdcs\ 1. /boot/path 130365630Sdcs\ 2. path 130465630Sdcs\ 130565630Sdcs\ The module_path variable is overridden if load is succesful, by 130665630Sdcs\ prepending the successful path. 130765630Sdcs 130865630Sdcs: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 130965630Sdcs local args 131065630Sdcs 2local path 131165630Sdcs args 1 = if 0 0 then 131265630Sdcs 2local flags 1313186789Sluigi 0 0 2local oldmodulepath \ like a string 1314186789Sluigi 0 0 2local newmodulepath \ like a string 131565630Sdcs end-locals 131665630Sdcs 131765630Sdcs \ Set the environment variable module_path, and try loading 131865630Sdcs \ the kernel again. 131965630Sdcs modulepath getenv saveenv to oldmodulepath 132065630Sdcs 132165630Sdcs \ Try prepending /boot/ first 1322186789Sluigi bootpath nip path nip + \ total length 132365630Sdcs oldmodulepath nip dup -1 = if 132465630Sdcs drop 132565630Sdcs else 1326186789Sluigi 1+ + \ add oldpath -- XXX why the 1+ ? 132765630Sdcs then 1328186789Sluigi allocate if ( out of memory ) 1 exit then \ XXX throw ? 132965630Sdcs 133065630Sdcs 0 133165630Sdcs bootpath strcat 133265630Sdcs path strcat 133365630Sdcs 2dup to newmodulepath 133465630Sdcs modulepath setenv 133565630Sdcs 133665630Sdcs \ Try all default kernel names 133765938Sdcs flags args 1- load_a_kernel 133865630Sdcs 0= if ( success ) 133965630Sdcs oldmodulepath nip -1 <> if 134065630Sdcs newmodulepath s" ;" strcat 134165630Sdcs oldmodulepath strcat 134265630Sdcs modulepath setenv 134365630Sdcs newmodulepath drop free-memory 134465630Sdcs oldmodulepath drop free-memory 134565630Sdcs then 134665630Sdcs 0 exit 134765630Sdcs then 134865630Sdcs 134965630Sdcs \ Well, try without the prepended /boot/ 135065630Sdcs path newmodulepath drop swap move 135165883Sdcs newmodulepath drop path nip 135265630Sdcs 2dup to newmodulepath 135365630Sdcs modulepath setenv 135465630Sdcs 135565630Sdcs \ Try all default kernel names 135665938Sdcs flags args 1- load_a_kernel 135765630Sdcs if ( failed once more ) 135865630Sdcs oldmodulepath restoreenv 135965630Sdcs newmodulepath drop free-memory 136065630Sdcs 1 136165630Sdcs else 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 137065630Sdcs then 137165630Sdcs; 137265630Sdcs 137365630Sdcs\ Try to load a kernel; the kernel name is taken from one of 137465630Sdcs\ the following lists, as ordered: 137565630Sdcs\ 137665641Sdcs\ 1. The "bootfile" environment variable 137765641Sdcs\ 2. The "kernel" environment variable 137865630Sdcs\ 3. The "path" argument 137965630Sdcs\ 138065630Sdcs\ Flags are passed, if provided. 138165630Sdcs\ 138265630Sdcs\ The kernel will be loaded from a directory computed from the 138365630Sdcs\ path given. Two directories will be tried in the following order: 138465630Sdcs\ 138565630Sdcs\ 1. /boot/path 138665630Sdcs\ 2. path 138765630Sdcs\ 138865630Sdcs\ Unless "path" is meant to be kernel name itself. In that case, it 138965630Sdcs\ will first be tried as a full path, and, next, search on the 139065630Sdcs\ directories pointed by module_path. 139165630Sdcs\ 139265630Sdcs\ The module_path variable is overridden if load is succesful, by 139365630Sdcs\ prepending the successful path. 139465630Sdcs 139565630Sdcs: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 139665630Sdcs local args 139765630Sdcs 2local path 139865630Sdcs args 1 = if 0 0 then 139965630Sdcs 2local flags 140065630Sdcs end-locals 140165630Sdcs 140265630Sdcs \ First, assume path is an absolute path to a directory 140365630Sdcs flags path args clip_args load_from_directory 140465630Sdcs dup 0= if exit else drop then 140565630Sdcs 140665630Sdcs \ Next, assume path points to the kernel 140765630Sdcs flags path args try_multiple_kernels 140865630Sdcs; 140965630Sdcs 141044603Sdcs: initialize ( addr len -- ) 1411186789Sluigi strdup conf_files strset 141244603Sdcs; 141344603Sdcs 141465883Sdcs: kernel_options ( -- addr len 1 | 0 ) 141565630Sdcs s" kernel_options" getenv 141665883Sdcs dup -1 = if drop 0 else 1 then 141765630Sdcs; 141865630Sdcs 141965938Sdcs: standard_kernel_search ( flags 1 | 0 -- flag ) 142065938Sdcs local args 142165938Sdcs args 0= if 0 0 then 142265938Sdcs 2local flags 142365630Sdcs s" kernel" getenv 142465938Sdcs dup -1 = if 0 swap then 142565938Sdcs 2local path 142665938Sdcs end-locals 142765938Sdcs 142866349Sdcs path nip -1 = if ( there isn't a "kernel" environment variable ) 142965938Sdcs flags args load_a_kernel 143065938Sdcs else 143165938Sdcs flags path args 1+ clip_args load_directory_or_file 143265938Sdcs then 143365630Sdcs; 143465630Sdcs 143544603Sdcs: load_kernel ( -- ) ( throws: abort ) 143665938Sdcs kernel_options standard_kernel_search 143765630Sdcs abort" Unable to load a kernel!" 143844603Sdcs; 143965883Sdcs 1440277215Sroyger: load_xen ( -- ) 1441277215Sroyger s" xen_kernel" getenv dup -1 <> if 1442277215Sroyger 1 1 load 1443277215Sroyger else 1444277215Sroyger drop 1445277215Sroyger 0 1446277215Sroyger then 1447277215Sroyger; 1448277215Sroyger 1449277215Sroyger: load_xen_throw ( -- ) ( throws: abort ) 1450277215Sroyger load_xen 1451277215Sroyger abort" Unable to load Xen!" 1452277215Sroyger; 1453277215Sroyger 145465949Sdcs: set_defaultoptions ( -- ) 145565883Sdcs s" kernel_options" getenv dup -1 = if 145665883Sdcs drop 145765883Sdcs else 145865883Sdcs s" temp_options" setenv 145965883Sdcs then 146065883Sdcs; 146165883Sdcs 1462186789Sluigi\ pick the i-th argument, i starts at 0 146365883Sdcs: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 1464186789Sluigi 2dup = if 0 0 exit then \ out of range 146565883Sdcs dup >r 146665883Sdcs 1+ 2* ( skip N and ui ) 146765883Sdcs pick 146865883Sdcs r> 146965883Sdcs 1+ 2* ( skip N and ai ) 147065883Sdcs pick 147165883Sdcs; 147265883Sdcs 147365949Sdcs: drop_args ( aN uN ... a1 u1 N -- ) 147465883Sdcs 0 ?do 2drop loop 147565883Sdcs; 147665883Sdcs 147765883Sdcs: argc 147865883Sdcs dup 147965883Sdcs; 148065883Sdcs 148165949Sdcs: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 148265883Sdcs >r 148365883Sdcs over 2* 1+ -roll 148465883Sdcs r> 148565883Sdcs over 2* 1+ -roll 148665883Sdcs 1+ 148765883Sdcs; 148865883Sdcs 148965949Sdcs: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 149065883Sdcs 1- -rot 149165883Sdcs; 149265883Sdcs 1493186789Sluigi\ compute the length of the buffer including the spaces between words 1494186789Sluigi: strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len ) 149565883Sdcs dup 0= if 0 exit then 149665883Sdcs 0 >r \ Size 149765883Sdcs 0 >r \ Index 149865883Sdcs begin 149965883Sdcs argc r@ <> 150065883Sdcs while 150165883Sdcs r@ argv[] 150265883Sdcs nip 150365883Sdcs r> r> rot + 1+ 150465883Sdcs >r 1+ >r 150565883Sdcs repeat 150665883Sdcs r> drop 150765883Sdcs r> 150865883Sdcs; 150965883Sdcs 151065949Sdcs: concat_argv ( aN uN ... a1 u1 N -- a u ) 1511186789Sluigi strlen(argv) allocate if ENOMEM throw then 1512186789Sluigi 0 2>r ( save addr 0 on return stack ) 151365883Sdcs 151465883Sdcs begin 1515186789Sluigi dup 151665883Sdcs while 1517186789Sluigi unqueue_argv ( ... N a1 u1 ) 1518186789Sluigi 2r> 2swap ( old a1 u1 ) 151965883Sdcs strcat 1520186789Sluigi s" " strcat ( append one space ) \ XXX this gives a trailing space 1521186789Sluigi 2>r ( store string on the result stack ) 152265883Sdcs repeat 152365949Sdcs drop_args 152465883Sdcs 2r> 152565883Sdcs; 152665883Sdcs 152765949Sdcs: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 152865883Sdcs \ Save the first argument, if it exists and is not a flag 152965883Sdcs argc if 153065883Sdcs 0 argv[] drop c@ [char] - <> if 153165949Sdcs unqueue_argv 2>r \ Filename 153265883Sdcs 1 >r \ Filename present 153365883Sdcs else 153465883Sdcs 0 >r \ Filename not present 153565883Sdcs then 153665883Sdcs else 153765883Sdcs 0 >r \ Filename not present 153865883Sdcs then 153965883Sdcs 154065883Sdcs \ If there are other arguments, assume they are flags 154165883Sdcs ?dup if 154265949Sdcs concat_argv 154365883Sdcs 2dup s" temp_options" setenv 1544186789Sluigi drop free if EFREE throw then 154565883Sdcs else 154665949Sdcs set_defaultoptions 154765883Sdcs then 154865883Sdcs 154965883Sdcs \ Bring back the filename, if one was provided 155065883Sdcs r> if 2r> 1 else 0 then 155165883Sdcs; 155265883Sdcs 155365949Sdcs: get_arguments ( -- addrN lenN ... addr1 len1 N ) 155465883Sdcs 0 155565883Sdcs begin 155665883Sdcs \ Get next word on the command line 155765883Sdcs parse-word 155865883Sdcs ?dup while 155965949Sdcs queue_argv 156065883Sdcs repeat 156165883Sdcs drop ( empty string ) 156265883Sdcs; 156365883Sdcs 156465945Sdcs: load_kernel_and_modules ( args -- flag ) 156565949Sdcs set_tempoptions 156665883Sdcs argc >r 156765883Sdcs s" temp_options" getenv dup -1 <> if 156865949Sdcs queue_argv 156965883Sdcs else 157065883Sdcs drop 157165883Sdcs then 1572277215Sroyger load_xen 1573277215Sroyger ?dup 0= if ( success ) 1574277215Sroyger r> if ( a path was passed ) 1575277215Sroyger load_directory_or_file 1576277215Sroyger else 1577277215Sroyger standard_kernel_search 1578277215Sroyger then 1579277215Sroyger ?dup 0= if ['] load_modules catch then 158065883Sdcs then 158165883Sdcs; 158265883Sdcs 158344603Sdcs\ Go back to straight forth vocabulary 158444603Sdcs 158544603Sdcsonly forth also definitions 158644603Sdcs 1587