support.4th revision 292999
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 292999 2015-12-31 19:33:17Z 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 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 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 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 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 946185746Sluigi conf_files strget 0 0 conf_files strset 94744603Sdcs; 94844603Sdcs 94953672Sdcs: skip_leading_spaces { addr len pos -- addr len pos' } 95044603Sdcs begin 951186789Sluigi pos len = if 0 else addr pos + c@ bl = then 95244603Sdcs while 95353672Sdcs pos char+ to pos 95444603Sdcs repeat 95553672Sdcs addr len pos 95644603Sdcs; 95744603Sdcs 958186789Sluigi\ return the file name at pos, or free the string if nothing left 95953672Sdcs: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 96053672Sdcs pos len = if 96144603Sdcs addr free abort" Fatal error freeing memory" 96244603Sdcs 0 exit 96344603Sdcs then 96453672Sdcs pos >r 96544603Sdcs begin 966186789Sluigi \ stay in the loop until have chars and they are not blank 967186789Sluigi pos len = if 0 else addr pos + c@ bl <> then 96844603Sdcs while 96953672Sdcs pos char+ to pos 97044603Sdcs repeat 97153672Sdcs addr len pos addr r@ + pos r> - 97244603Sdcs; 97344603Sdcs 97444603Sdcs: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 97544603Sdcs skip_leading_spaces 97644603Sdcs get_file_name 97744603Sdcs; 97844603Sdcs 97944603Sdcs: print_current_file 980186789Sluigi current_file_name_ref strtype 98144603Sdcs; 98244603Sdcs 98344603Sdcs: process_conf_errors 98444603Sdcs dup 0= if true to any_conf_read? drop exit then 98544603Sdcs >r 2drop r> 986186789Sluigi dup ESYNTAX = if 98744603Sdcs ." Warning: syntax error on file " print_current_file cr 98844603Sdcs print_syntax_error drop exit 98944603Sdcs then 990186789Sluigi dup ESETERROR = if 99144603Sdcs ." Warning: bad definition on file " print_current_file cr 99244603Sdcs print_line drop exit 99344603Sdcs then 994186789Sluigi dup EREAD = if 99544603Sdcs ." Warning: error reading file " print_current_file cr drop exit 99644603Sdcs then 997186789Sluigi dup EOPEN = if 99844603Sdcs verbose? if ." Warning: unable to open file " print_current_file cr then 99944603Sdcs drop exit 100044603Sdcs then 1001186789Sluigi dup EFREE = abort" Fatal error freeing memory" 1002186789Sluigi dup ENOMEM = abort" Out of memory" 100344603Sdcs throw \ Unknown error -- pass ahead 100444603Sdcs; 100544603Sdcs 100644603Sdcs\ Process loader_conf_files recursively 100744603Sdcs\ Interface to loader_conf_files processing 100844603Sdcs 100944603Sdcs: include_conf_files 1010186789Sluigi get_conf_files 0 ( addr len offset ) 101144603Sdcs begin 1012186789Sluigi get_next_file ?dup ( addr len 1 | 0 ) 101344603Sdcs while 1014186789Sluigi current_file_name_ref strref 101544603Sdcs ['] load_conf catch 101644603Sdcs process_conf_errors 1017185746Sluigi conf_files .addr @ if recurse then 101844603Sdcs repeat 101944603Sdcs; 102044603Sdcs 102197201Sgordon: get_nextboot_conf_file ( -- addr len ) 1022292999Sdteske nextboot_conf_file strget 102397201Sgordon; 102497201Sgordon 102597201Sgordon: rewrite_nextboot_file ( -- ) 102697201Sgordon get_nextboot_conf_file 102797201Sgordon O_WRONLY fopen fd ! 1028186789Sluigi fd @ -1 = if EOPEN throw then 1029292899Sdteske fd @ s' nextboot_enable="NO" ' fwrite ( fd buf len -- nwritten ) drop 103097201Sgordon fd @ fclose 103197201Sgordon; 103297201Sgordon 1033292899Sdteske: include_nextboot_file ( -- ) 103497201Sgordon get_nextboot_conf_file 1035292899Sdteske ['] peek_file catch if 2drop then 103697201Sgordon nextboot? if 103797201Sgordon get_nextboot_conf_file 1038292899Sdteske current_file_name_ref strref 103997201Sgordon ['] load_conf catch 104097201Sgordon process_conf_errors 1041292899Sdteske ['] rewrite_nextboot_file catch if 2drop then 104297201Sgordon then 104397201Sgordon; 104497201Sgordon 104544603Sdcs\ Module loading functions 104644603Sdcs 1047186789Sluigi: load_parameters { addr -- addr addrN lenN ... addr1 len1 N } 1048186789Sluigi addr 1049186789Sluigi addr module.args strget 1050186789Sluigi addr module.loadname .len @ if 1051186789Sluigi addr module.loadname strget 105244603Sdcs else 1053186789Sluigi addr module.name strget 105444603Sdcs then 1055186789Sluigi addr module.type .len @ if 1056186789Sluigi addr module.type strget 105744603Sdcs s" -t " 105844603Sdcs 4 ( -t type name flags ) 105944603Sdcs else 106044603Sdcs 2 ( name flags ) 106144603Sdcs then 106244603Sdcs; 106344603Sdcs 106444603Sdcs: before_load ( addr -- addr ) 106544603Sdcs dup module.beforeload .len @ if 1066186789Sluigi dup module.beforeload strget 1067186789Sluigi ['] evaluate catch if EBEFORELOAD throw then 106844603Sdcs then 106944603Sdcs; 107044603Sdcs 107144603Sdcs: after_load ( addr -- addr ) 107244603Sdcs dup module.afterload .len @ if 1073186789Sluigi dup module.afterload strget 1074186789Sluigi ['] evaluate catch if EAFTERLOAD throw then 107544603Sdcs then 107644603Sdcs; 107744603Sdcs 107844603Sdcs: load_error ( addr -- addr ) 107944603Sdcs dup module.loaderror .len @ if 1080186789Sluigi dup module.loaderror strget 108144603Sdcs evaluate \ This we do not intercept so it can throw errors 108244603Sdcs then 108344603Sdcs; 108444603Sdcs 108544603Sdcs: pre_load_message ( addr -- addr ) 108644603Sdcs verbose? if 1087186789Sluigi dup module.name strtype 108844603Sdcs ." ..." 108944603Sdcs then 109044603Sdcs; 109144603Sdcs 109244603Sdcs: load_error_message verbose? if ." failed!" cr then ; 109344603Sdcs 109444603Sdcs: load_succesful_message verbose? if ." ok" cr then ; 109544603Sdcs 109644603Sdcs: load_module 109744603Sdcs load_parameters load 109844603Sdcs; 109944603Sdcs 110044603Sdcs: process_module ( addr -- addr ) 110144603Sdcs pre_load_message 110244603Sdcs before_load 110344603Sdcs begin 110444603Sdcs ['] load_module catch if 110544603Sdcs dup module.loaderror .len @ if 110644603Sdcs load_error \ Command should return a flag! 110744603Sdcs else 110844603Sdcs load_error_message true \ Do not retry 110944603Sdcs then 111044603Sdcs else 111144603Sdcs after_load 111244603Sdcs load_succesful_message true \ Succesful, do not retry 111344603Sdcs then 111444603Sdcs until 111544603Sdcs; 111644603Sdcs 111744603Sdcs: process_module_errors ( addr ior -- ) 1118186789Sluigi dup EBEFORELOAD = if 111944603Sdcs drop 112044603Sdcs ." Module " 1121186789Sluigi dup module.name strtype 112244603Sdcs dup module.loadname .len @ if 1123186789Sluigi ." (" dup module.loadname strtype ." )" 112444603Sdcs then 112544603Sdcs cr 112644603Sdcs ." Error executing " 1127186789Sluigi dup module.beforeload strtype cr \ XXX there was a typo here 112844603Sdcs abort 112944603Sdcs then 113044603Sdcs 1131186789Sluigi dup EAFTERLOAD = if 113244603Sdcs drop 113344603Sdcs ." Module " 113444603Sdcs dup module.name .addr @ over module.name .len @ type 113544603Sdcs dup module.loadname .len @ if 1136186789Sluigi ." (" dup module.loadname strtype ." )" 113744603Sdcs then 113844603Sdcs cr 113944603Sdcs ." Error executing " 1140186789Sluigi dup module.afterload strtype cr 114144603Sdcs abort 114244603Sdcs then 114344603Sdcs 114444603Sdcs throw \ Don't know what it is all about -- pass ahead 114544603Sdcs; 114644603Sdcs 114744603Sdcs\ Module loading interface 114844603Sdcs 1149186789Sluigi\ scan the list of modules, load enabled ones. 115044603Sdcs: load_modules ( -- ) ( throws: abort & user-defined ) 1151186789Sluigi module_options @ ( list_head ) 115244603Sdcs begin 115344603Sdcs ?dup 115444603Sdcs while 1155186789Sluigi dup module.flag @ if 115644603Sdcs ['] process_module catch 115744603Sdcs process_module_errors 115844603Sdcs then 115944603Sdcs module.next @ 116044603Sdcs repeat 116144603Sdcs; 116244603Sdcs 116365630Sdcs\ h00h00 magic used to try loading either a kernel with a given name, 116465630Sdcs\ or a kernel with the default name in a directory of a given name 116565630Sdcs\ (the pain!) 116644603Sdcs 116765630Sdcs: bootpath s" /boot/" ; 116865630Sdcs: modulepath s" module_path" ; 116965630Sdcs 117065630Sdcs\ Functions used to save and restore module_path's value. 117165630Sdcs: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 117265630Sdcs dup -1 = if 0 swap exit then 117365630Sdcs strdup 117465630Sdcs; 117565630Sdcs: freeenv ( addr len | 0 -1 ) 117665630Sdcs -1 = if drop else free abort" Freeing error" then 117765630Sdcs; 117865630Sdcs: restoreenv ( addr len | 0 -1 -- ) 117965630Sdcs dup -1 = if ( it wasn't set ) 118065630Sdcs 2drop 118165630Sdcs modulepath unsetenv 118265630Sdcs else 118365630Sdcs over >r 118465630Sdcs modulepath setenv 118565630Sdcs r> free abort" Freeing error" 118665630Sdcs then 118765630Sdcs; 118865630Sdcs 118965630Sdcs: clip_args \ Drop second string if only one argument is passed 119065630Sdcs 1 = if 119165630Sdcs 2swap 2drop 119265630Sdcs 1 119365630Sdcs else 119465630Sdcs 2 119565630Sdcs then 119665630Sdcs; 119765630Sdcs 119865630Sdcsalso builtins 119965630Sdcs 1200186789Sluigi\ Parse filename from a semicolon-separated list 120165630Sdcs 1202186789Sluigi\ replacement, not working yet 1203186789Sluigi: newparse-; { addr len | a1 -- a' len-x addr x } 1204186789Sluigi addr len [char] ; strchr dup if ( a1 len1 ) 1205186789Sluigi swap to a1 ( store address ) 1206186789Sluigi 1 - a1 @ 1 + swap ( remove match ) 1207186789Sluigi addr a1 addr - 1208186789Sluigi else 1209186789Sluigi 0 0 addr len 1210186789Sluigi then 1211186789Sluigi; 1212186789Sluigi 121365630Sdcs: parse-; ( addr len -- addr' len-x addr x ) 1214186789Sluigi over 0 2swap ( addr 0 addr len ) 121565630Sdcs begin 1216186789Sluigi dup 0 <> ( addr 0 addr len ) 121765630Sdcs while 1218186789Sluigi over c@ [char] ; <> ( addr 0 addr len flag ) 121965630Sdcs while 122065630Sdcs 1- swap 1+ swap 122165630Sdcs 2swap 1+ 2swap 122265630Sdcs repeat then 122365630Sdcs dup 0 <> if 122465630Sdcs 1- swap 1+ swap 122565630Sdcs then 122665630Sdcs 2swap 122765630Sdcs; 122865630Sdcs 122965630Sdcs\ Try loading one of multiple kernels specified 123065630Sdcs 123165630Sdcs: try_multiple_kernels ( addr len addr' len' args -- flag ) 123265630Sdcs >r 123365630Sdcs begin 123465630Sdcs parse-; 2>r 123565630Sdcs 2over 2r> 123665945Sdcs r@ clip_args 123765945Sdcs s" DEBUG" getenv? if 123865945Sdcs s" echo Module_path: ${module_path}" evaluate 123965945Sdcs ." Kernel : " >r 2dup type r> cr 124065945Sdcs dup 2 = if ." Flags : " >r 2over type r> cr then 124165945Sdcs then 124265945Sdcs 1 load 124365630Sdcs while 124465630Sdcs dup 0= 124565630Sdcs until 124665630Sdcs 1 >r \ Failure 124765630Sdcs else 124865630Sdcs 0 >r \ Success 124965630Sdcs then 125065630Sdcs 2drop 2drop 125165630Sdcs r> 125265630Sdcs r> drop 125365630Sdcs; 125465630Sdcs 125565630Sdcs\ Try to load a kernel; the kernel name is taken from one of 125665630Sdcs\ the following lists, as ordered: 125765630Sdcs\ 125865641Sdcs\ 1. The "bootfile" environment variable 125965641Sdcs\ 2. The "kernel" environment variable 126065630Sdcs\ 126165938Sdcs\ Flags are passed, if available. If not, dummy values must be given. 126265630Sdcs\ 126365630Sdcs\ The kernel gets loaded from the current module_path. 126465630Sdcs 126565938Sdcs: load_a_kernel ( flags len 1 | x x 0 -- flag ) 126665630Sdcs local args 126765630Sdcs 2local flags 126865630Sdcs 0 0 2local kernel 126965630Sdcs end-locals 127065630Sdcs 127165630Sdcs \ Check if a default kernel name exists at all, exits if not 127265641Sdcs s" bootfile" getenv dup -1 <> if 127365630Sdcs to kernel 127465883Sdcs flags kernel args 1+ try_multiple_kernels 127565630Sdcs dup 0= if exit then 127665630Sdcs then 127765630Sdcs drop 127865630Sdcs 127965641Sdcs s" kernel" getenv dup -1 <> if 128065630Sdcs to kernel 128165630Sdcs else 128265630Sdcs drop 128365630Sdcs 1 exit \ Failure 128465630Sdcs then 128565630Sdcs 128665630Sdcs \ Try all default kernel names 128765883Sdcs flags kernel args 1+ try_multiple_kernels 128865630Sdcs; 128965630Sdcs 129065630Sdcs\ Try to load a kernel; the kernel name is taken from one of 129165630Sdcs\ the following lists, as ordered: 129265630Sdcs\ 129365641Sdcs\ 1. The "bootfile" environment variable 129465641Sdcs\ 2. The "kernel" environment variable 129565630Sdcs\ 129665630Sdcs\ Flags are passed, if provided. 129765630Sdcs\ 129865630Sdcs\ The kernel will be loaded from a directory computed from the 129965630Sdcs\ path given. Two directories will be tried in the following order: 130065630Sdcs\ 130165630Sdcs\ 1. /boot/path 130265630Sdcs\ 2. path 130365630Sdcs\ 130465630Sdcs\ The module_path variable is overridden if load is succesful, by 130565630Sdcs\ prepending the successful path. 130665630Sdcs 130765630Sdcs: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 130865630Sdcs local args 130965630Sdcs 2local path 131065630Sdcs args 1 = if 0 0 then 131165630Sdcs 2local flags 1312186789Sluigi 0 0 2local oldmodulepath \ like a string 1313186789Sluigi 0 0 2local newmodulepath \ like a string 131465630Sdcs end-locals 131565630Sdcs 131665630Sdcs \ Set the environment variable module_path, and try loading 131765630Sdcs \ the kernel again. 131865630Sdcs modulepath getenv saveenv to oldmodulepath 131965630Sdcs 132065630Sdcs \ Try prepending /boot/ first 1321186789Sluigi bootpath nip path nip + \ total length 132265630Sdcs oldmodulepath nip dup -1 = if 132365630Sdcs drop 132465630Sdcs else 1325186789Sluigi 1+ + \ add oldpath -- XXX why the 1+ ? 132665630Sdcs then 1327186789Sluigi allocate if ( out of memory ) 1 exit then \ XXX throw ? 132865630Sdcs 132965630Sdcs 0 133065630Sdcs bootpath strcat 133165630Sdcs path strcat 133265630Sdcs 2dup to newmodulepath 133365630Sdcs modulepath setenv 133465630Sdcs 133565630Sdcs \ Try all default kernel names 133665938Sdcs flags args 1- load_a_kernel 133765630Sdcs 0= if ( success ) 133865630Sdcs oldmodulepath nip -1 <> if 133965630Sdcs newmodulepath s" ;" strcat 134065630Sdcs oldmodulepath strcat 134165630Sdcs modulepath setenv 134265630Sdcs newmodulepath drop free-memory 134365630Sdcs oldmodulepath drop free-memory 134465630Sdcs then 134565630Sdcs 0 exit 134665630Sdcs then 134765630Sdcs 134865630Sdcs \ Well, try without the prepended /boot/ 134965630Sdcs path newmodulepath drop swap move 135065883Sdcs newmodulepath drop path nip 135165630Sdcs 2dup to newmodulepath 135265630Sdcs modulepath setenv 135365630Sdcs 135465630Sdcs \ Try all default kernel names 135565938Sdcs flags args 1- load_a_kernel 135665630Sdcs if ( failed once more ) 135765630Sdcs oldmodulepath restoreenv 135865630Sdcs newmodulepath drop free-memory 135965630Sdcs 1 136065630Sdcs else 136165630Sdcs oldmodulepath nip -1 <> if 136265630Sdcs newmodulepath s" ;" strcat 136365630Sdcs oldmodulepath strcat 136465630Sdcs modulepath setenv 136565630Sdcs newmodulepath drop free-memory 136665630Sdcs oldmodulepath drop free-memory 136765630Sdcs then 136865630Sdcs 0 136965630Sdcs then 137065630Sdcs; 137165630Sdcs 137265630Sdcs\ Try to load a kernel; the kernel name is taken from one of 137365630Sdcs\ the following lists, as ordered: 137465630Sdcs\ 137565641Sdcs\ 1. The "bootfile" environment variable 137665641Sdcs\ 2. The "kernel" environment variable 137765630Sdcs\ 3. The "path" argument 137865630Sdcs\ 137965630Sdcs\ Flags are passed, if provided. 138065630Sdcs\ 138165630Sdcs\ The kernel will be loaded from a directory computed from the 138265630Sdcs\ path given. Two directories will be tried in the following order: 138365630Sdcs\ 138465630Sdcs\ 1. /boot/path 138565630Sdcs\ 2. path 138665630Sdcs\ 138765630Sdcs\ Unless "path" is meant to be kernel name itself. In that case, it 138865630Sdcs\ will first be tried as a full path, and, next, search on the 138965630Sdcs\ directories pointed by module_path. 139065630Sdcs\ 139165630Sdcs\ The module_path variable is overridden if load is succesful, by 139265630Sdcs\ prepending the successful path. 139365630Sdcs 139465630Sdcs: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 139565630Sdcs local args 139665630Sdcs 2local path 139765630Sdcs args 1 = if 0 0 then 139865630Sdcs 2local flags 139965630Sdcs end-locals 140065630Sdcs 140165630Sdcs \ First, assume path is an absolute path to a directory 140265630Sdcs flags path args clip_args load_from_directory 140365630Sdcs dup 0= if exit else drop then 140465630Sdcs 140565630Sdcs \ Next, assume path points to the kernel 140665630Sdcs flags path args try_multiple_kernels 140765630Sdcs; 140865630Sdcs 140944603Sdcs: initialize ( addr len -- ) 1410186789Sluigi strdup conf_files strset 141144603Sdcs; 141244603Sdcs 141365883Sdcs: kernel_options ( -- addr len 1 | 0 ) 141465630Sdcs s" kernel_options" getenv 141565883Sdcs dup -1 = if drop 0 else 1 then 141665630Sdcs; 141765630Sdcs 141865938Sdcs: standard_kernel_search ( flags 1 | 0 -- flag ) 141965938Sdcs local args 142065938Sdcs args 0= if 0 0 then 142165938Sdcs 2local flags 142265630Sdcs s" kernel" getenv 142365938Sdcs dup -1 = if 0 swap then 142465938Sdcs 2local path 142565938Sdcs end-locals 142665938Sdcs 142766349Sdcs path nip -1 = if ( there isn't a "kernel" environment variable ) 142865938Sdcs flags args load_a_kernel 142965938Sdcs else 143065938Sdcs flags path args 1+ clip_args load_directory_or_file 143165938Sdcs then 143265630Sdcs; 143365630Sdcs 143444603Sdcs: load_kernel ( -- ) ( throws: abort ) 143565938Sdcs kernel_options standard_kernel_search 143665630Sdcs abort" Unable to load a kernel!" 143744603Sdcs; 143865883Sdcs 1439283933Sdteske: load_xen ( -- flag ) 1440277215Sroyger s" xen_kernel" getenv dup -1 <> if 1441283933Sdteske 1 1 load ( c-addr/u flag N -- flag ) 1442277215Sroyger else 1443277215Sroyger drop 1444283933Sdteske 0 ( -1 -- flag ) 1445277215Sroyger then 1446277215Sroyger; 1447277215Sroyger 1448277215Sroyger: load_xen_throw ( -- ) ( throws: abort ) 1449277215Sroyger load_xen 1450277215Sroyger abort" Unable to load Xen!" 1451277215Sroyger; 1452277215Sroyger 145365949Sdcs: set_defaultoptions ( -- ) 145465883Sdcs s" kernel_options" getenv dup -1 = if 145565883Sdcs drop 145665883Sdcs else 145765883Sdcs s" temp_options" setenv 145865883Sdcs then 145965883Sdcs; 146065883Sdcs 1461186789Sluigi\ pick the i-th argument, i starts at 0 146265883Sdcs: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 1463186789Sluigi 2dup = if 0 0 exit then \ out of range 146465883Sdcs dup >r 146565883Sdcs 1+ 2* ( skip N and ui ) 146665883Sdcs pick 146765883Sdcs r> 146865883Sdcs 1+ 2* ( skip N and ai ) 146965883Sdcs pick 147065883Sdcs; 147165883Sdcs 147265949Sdcs: drop_args ( aN uN ... a1 u1 N -- ) 147365883Sdcs 0 ?do 2drop loop 147465883Sdcs; 147565883Sdcs 147665883Sdcs: argc 147765883Sdcs dup 147865883Sdcs; 147965883Sdcs 148065949Sdcs: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 148165883Sdcs >r 148265883Sdcs over 2* 1+ -roll 148365883Sdcs r> 148465883Sdcs over 2* 1+ -roll 148565883Sdcs 1+ 148665883Sdcs; 148765883Sdcs 148865949Sdcs: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 148965883Sdcs 1- -rot 149065883Sdcs; 149165883Sdcs 1492186789Sluigi\ compute the length of the buffer including the spaces between words 1493186789Sluigi: strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len ) 149465883Sdcs dup 0= if 0 exit then 149565883Sdcs 0 >r \ Size 149665883Sdcs 0 >r \ Index 149765883Sdcs begin 149865883Sdcs argc r@ <> 149965883Sdcs while 150065883Sdcs r@ argv[] 150165883Sdcs nip 150265883Sdcs r> r> rot + 1+ 150365883Sdcs >r 1+ >r 150465883Sdcs repeat 150565883Sdcs r> drop 150665883Sdcs r> 150765883Sdcs; 150865883Sdcs 150965949Sdcs: concat_argv ( aN uN ... a1 u1 N -- a u ) 1510186789Sluigi strlen(argv) allocate if ENOMEM throw then 1511186789Sluigi 0 2>r ( save addr 0 on return stack ) 151265883Sdcs 151365883Sdcs begin 1514186789Sluigi dup 151565883Sdcs while 1516186789Sluigi unqueue_argv ( ... N a1 u1 ) 1517186789Sluigi 2r> 2swap ( old a1 u1 ) 151865883Sdcs strcat 1519186789Sluigi s" " strcat ( append one space ) \ XXX this gives a trailing space 1520186789Sluigi 2>r ( store string on the result stack ) 152165883Sdcs repeat 152265949Sdcs drop_args 152365883Sdcs 2r> 152465883Sdcs; 152565883Sdcs 152665949Sdcs: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 152765883Sdcs \ Save the first argument, if it exists and is not a flag 152865883Sdcs argc if 152965883Sdcs 0 argv[] drop c@ [char] - <> if 153065949Sdcs unqueue_argv 2>r \ Filename 153165883Sdcs 1 >r \ Filename present 153265883Sdcs else 153365883Sdcs 0 >r \ Filename not present 153465883Sdcs then 153565883Sdcs else 153665883Sdcs 0 >r \ Filename not present 153765883Sdcs then 153865883Sdcs 153965883Sdcs \ If there are other arguments, assume they are flags 154065883Sdcs ?dup if 154165949Sdcs concat_argv 154265883Sdcs 2dup s" temp_options" setenv 1543186789Sluigi drop free if EFREE throw then 154465883Sdcs else 154565949Sdcs set_defaultoptions 154665883Sdcs then 154765883Sdcs 154865883Sdcs \ Bring back the filename, if one was provided 154965883Sdcs r> if 2r> 1 else 0 then 155065883Sdcs; 155165883Sdcs 155265949Sdcs: get_arguments ( -- addrN lenN ... addr1 len1 N ) 155365883Sdcs 0 155465883Sdcs begin 155565883Sdcs \ Get next word on the command line 155665883Sdcs parse-word 155765883Sdcs ?dup while 155865949Sdcs queue_argv 155965883Sdcs repeat 156065883Sdcs drop ( empty string ) 156165883Sdcs; 156265883Sdcs 156365945Sdcs: load_kernel_and_modules ( args -- flag ) 156465949Sdcs set_tempoptions 156565883Sdcs argc >r 156665883Sdcs s" temp_options" getenv dup -1 <> if 156765949Sdcs queue_argv 156865883Sdcs else 156965883Sdcs drop 157065883Sdcs then 1571277215Sroyger load_xen 1572277215Sroyger ?dup 0= if ( success ) 1573277215Sroyger r> if ( a path was passed ) 1574277215Sroyger load_directory_or_file 1575277215Sroyger else 1576277215Sroyger standard_kernel_search 1577277215Sroyger then 1578277215Sroyger ?dup 0= if ['] load_modules catch then 157965883Sdcs then 158065883Sdcs; 158165883Sdcs 1582280937Sdteskeonly forth definitions 1583