support.4th revision 292899
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 292899 2015-12-30 02:15:12Z 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 -- ) 855187143Sluigi \ ." ----- Trying conf " 2dup type cr \ debugging 85644603Sdcs 0 to end_of_file? 85765615Sdcs reset_line_reading 85887636Sjhb O_RDONLY fopen fd ! 859186789Sluigi fd @ -1 = if EOPEN throw then 86044603Sdcs ['] process_conf catch 86144603Sdcs fd @ fclose 86244603Sdcs throw 86344603Sdcs; 86444603Sdcs 865186789Sluigi: print_line line_buffer strtype cr ; 86644603Sdcs 86744603Sdcs: print_syntax_error 868186789Sluigi line_buffer strtype cr 86944603Sdcs line_buffer .addr @ 87044603Sdcs begin 87144603Sdcs line_pointer over <> 87244603Sdcs while 873186789Sluigi bl emit char+ 87444603Sdcs repeat 87544603Sdcs drop 87644603Sdcs ." ^" cr 87744603Sdcs; 87844603Sdcs 879186789Sluigi 880163327Sru\ Debugging support functions 88144603Sdcs 88244603Sdcsonly forth definitions also support-functions 88344603Sdcs 88444603Sdcs: test-file 88544603Sdcs ['] load_conf catch dup . 886186789Sluigi ESYNTAX = if cr print_syntax_error then 88744603Sdcs; 88844603Sdcs 889186789Sluigi\ find a module name, leave addr on the stack (0 if not found) 890186789Sluigi: find-module ( <module> -- ptr | 0 ) 891186789Sluigi bl parse ( addr len ) 892186789Sluigi module_options @ >r ( store current pointer ) 893186789Sluigi begin 894186789Sluigi r@ 895186789Sluigi while 896186789Sluigi 2dup ( addr len addr len ) 897186789Sluigi r@ module.name strget 898186789Sluigi compare 0= if drop drop r> exit then ( found it ) 899186789Sluigi r> module.next @ >r 900186789Sluigi repeat 901186789Sluigi type ." was not found" cr r> 902186789Sluigi; 903186789Sluigi 904186789Sluigi: show-nonempty ( addr len mod -- ) 905186789Sluigi strget dup verbose? or if 906186789Sluigi 2swap type type cr 907186789Sluigi else 908186789Sluigi drop drop drop drop 909186789Sluigi then ; 910186789Sluigi 911186789Sluigi: show-one-module { addr -- addr } 912186789Sluigi ." Name: " addr module.name strtype cr 913186789Sluigi s" Path: " addr module.loadname show-nonempty 914186789Sluigi s" Type: " addr module.type show-nonempty 915186789Sluigi s" Flags: " addr module.args show-nonempty 916186789Sluigi s" Before load: " addr module.beforeload show-nonempty 917186789Sluigi s" After load: " addr module.afterload show-nonempty 918186789Sluigi s" Error: " addr module.loaderror show-nonempty 919186789Sluigi ." Status: " addr module.flag @ if ." Load" else ." Don't load" then cr 920186789Sluigi cr 921186789Sluigi addr 922186789Sluigi; 923186789Sluigi 92444603Sdcs: show-module-options 92544603Sdcs module_options @ 92644603Sdcs begin 92744603Sdcs ?dup 92844603Sdcs while 929186789Sluigi show-one-module 93044603Sdcs module.next @ 93144603Sdcs repeat 93244603Sdcs; 93344603Sdcs 93444603Sdcsonly forth also support-functions definitions 93544603Sdcs 93644603Sdcs\ Variables used for processing multiple conf files 93744603Sdcs 938186789Sluigistring current_file_name_ref \ used to print the file name 93944603Sdcs 94044603Sdcs\ Indicates if any conf file was succesfully read 94144603Sdcs 94244603Sdcs0 value any_conf_read? 94344603Sdcs 94444603Sdcs\ loader_conf_files processing support functions 94544603Sdcs 946185746Sluigi: get_conf_files ( -- addr len ) \ put addr/len on stack, reset var 947187143Sluigi \ ." -- starting on <" conf_files strtype ." >" cr \ debugging 948185746Sluigi conf_files strget 0 0 conf_files strset 94944603Sdcs; 95044603Sdcs 95153672Sdcs: skip_leading_spaces { addr len pos -- addr len pos' } 95244603Sdcs begin 953186789Sluigi pos len = if 0 else addr pos + c@ bl = then 95444603Sdcs while 95553672Sdcs pos char+ to pos 95644603Sdcs repeat 95753672Sdcs addr len pos 95844603Sdcs; 95944603Sdcs 960186789Sluigi\ return the file name at pos, or free the string if nothing left 96153672Sdcs: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 96253672Sdcs pos len = if 96344603Sdcs addr free abort" Fatal error freeing memory" 96444603Sdcs 0 exit 96544603Sdcs then 96653672Sdcs pos >r 96744603Sdcs begin 968186789Sluigi \ stay in the loop until have chars and they are not blank 969186789Sluigi pos len = if 0 else addr pos + c@ bl <> then 97044603Sdcs while 97153672Sdcs pos char+ to pos 97244603Sdcs repeat 97353672Sdcs addr len pos addr r@ + pos r> - 974187143Sluigi \ 2dup ." get_file_name has " type cr \ debugging 97544603Sdcs; 97644603Sdcs 97744603Sdcs: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 97844603Sdcs skip_leading_spaces 97944603Sdcs get_file_name 98044603Sdcs; 98144603Sdcs 98244603Sdcs: print_current_file 983186789Sluigi current_file_name_ref strtype 98444603Sdcs; 98544603Sdcs 98644603Sdcs: process_conf_errors 98744603Sdcs dup 0= if true to any_conf_read? drop exit then 98844603Sdcs >r 2drop r> 989186789Sluigi dup ESYNTAX = if 99044603Sdcs ." Warning: syntax error on file " print_current_file cr 99144603Sdcs print_syntax_error drop exit 99244603Sdcs then 993186789Sluigi dup ESETERROR = if 99444603Sdcs ." Warning: bad definition on file " print_current_file cr 99544603Sdcs print_line drop exit 99644603Sdcs then 997186789Sluigi dup EREAD = if 99844603Sdcs ." Warning: error reading file " print_current_file cr drop exit 99944603Sdcs then 1000186789Sluigi dup EOPEN = if 100144603Sdcs verbose? if ." Warning: unable to open file " print_current_file cr then 100244603Sdcs drop exit 100344603Sdcs then 1004186789Sluigi dup EFREE = abort" Fatal error freeing memory" 1005186789Sluigi dup ENOMEM = abort" Out of memory" 100644603Sdcs throw \ Unknown error -- pass ahead 100744603Sdcs; 100844603Sdcs 100944603Sdcs\ Process loader_conf_files recursively 101044603Sdcs\ Interface to loader_conf_files processing 101144603Sdcs 101244603Sdcs: include_conf_files 1013186789Sluigi get_conf_files 0 ( addr len offset ) 101444603Sdcs begin 1015186789Sluigi get_next_file ?dup ( addr len 1 | 0 ) 101644603Sdcs while 1017186789Sluigi current_file_name_ref strref 101844603Sdcs ['] load_conf catch 101944603Sdcs process_conf_errors 1020185746Sluigi conf_files .addr @ if recurse then 102144603Sdcs repeat 102244603Sdcs; 102344603Sdcs 102497201Sgordon: get_nextboot_conf_file ( -- addr len ) 1025292899Sdteske nextboot_conf_file strget strdup 102697201Sgordon; 102797201Sgordon 102897201Sgordon: rewrite_nextboot_file ( -- ) 102997201Sgordon get_nextboot_conf_file 103097201Sgordon O_WRONLY fopen fd ! 1031186789Sluigi fd @ -1 = if EOPEN throw then 1032292899Sdteske fd @ s' nextboot_enable="NO" ' fwrite ( fd buf len -- nwritten ) drop 103397201Sgordon fd @ fclose 103497201Sgordon; 103597201Sgordon 1036292899Sdteske: include_nextboot_file ( -- ) 103797201Sgordon get_nextboot_conf_file 1038292899Sdteske ['] peek_file catch if 2drop then 103997201Sgordon nextboot? if 104097201Sgordon get_nextboot_conf_file 1041292899Sdteske current_file_name_ref strref 104297201Sgordon ['] load_conf catch 104397201Sgordon process_conf_errors 1044292899Sdteske ['] rewrite_nextboot_file catch if 2drop then 104597201Sgordon then 104697201Sgordon; 104797201Sgordon 104844603Sdcs\ Module loading functions 104944603Sdcs 1050186789Sluigi: load_parameters { addr -- addr addrN lenN ... addr1 len1 N } 1051186789Sluigi addr 1052186789Sluigi addr module.args strget 1053186789Sluigi addr module.loadname .len @ if 1054186789Sluigi addr module.loadname strget 105544603Sdcs else 1056186789Sluigi addr module.name strget 105744603Sdcs then 1058186789Sluigi addr module.type .len @ if 1059186789Sluigi addr module.type strget 106044603Sdcs s" -t " 106144603Sdcs 4 ( -t type name flags ) 106244603Sdcs else 106344603Sdcs 2 ( name flags ) 106444603Sdcs then 106544603Sdcs; 106644603Sdcs 106744603Sdcs: before_load ( addr -- addr ) 106844603Sdcs dup module.beforeload .len @ if 1069186789Sluigi dup module.beforeload strget 1070186789Sluigi ['] evaluate catch if EBEFORELOAD throw then 107144603Sdcs then 107244603Sdcs; 107344603Sdcs 107444603Sdcs: after_load ( addr -- addr ) 107544603Sdcs dup module.afterload .len @ if 1076186789Sluigi dup module.afterload strget 1077186789Sluigi ['] evaluate catch if EAFTERLOAD throw then 107844603Sdcs then 107944603Sdcs; 108044603Sdcs 108144603Sdcs: load_error ( addr -- addr ) 108244603Sdcs dup module.loaderror .len @ if 1083186789Sluigi dup module.loaderror strget 108444603Sdcs evaluate \ This we do not intercept so it can throw errors 108544603Sdcs then 108644603Sdcs; 108744603Sdcs 108844603Sdcs: pre_load_message ( addr -- addr ) 108944603Sdcs verbose? if 1090186789Sluigi dup module.name strtype 109144603Sdcs ." ..." 109244603Sdcs then 109344603Sdcs; 109444603Sdcs 109544603Sdcs: load_error_message verbose? if ." failed!" cr then ; 109644603Sdcs 109744603Sdcs: load_succesful_message verbose? if ." ok" cr then ; 109844603Sdcs 109944603Sdcs: load_module 110044603Sdcs load_parameters load 110144603Sdcs; 110244603Sdcs 110344603Sdcs: process_module ( addr -- addr ) 110444603Sdcs pre_load_message 110544603Sdcs before_load 110644603Sdcs begin 110744603Sdcs ['] load_module catch if 110844603Sdcs dup module.loaderror .len @ if 110944603Sdcs load_error \ Command should return a flag! 111044603Sdcs else 111144603Sdcs load_error_message true \ Do not retry 111244603Sdcs then 111344603Sdcs else 111444603Sdcs after_load 111544603Sdcs load_succesful_message true \ Succesful, do not retry 111644603Sdcs then 111744603Sdcs until 111844603Sdcs; 111944603Sdcs 112044603Sdcs: process_module_errors ( addr ior -- ) 1121186789Sluigi dup EBEFORELOAD = if 112244603Sdcs drop 112344603Sdcs ." Module " 1124186789Sluigi dup module.name strtype 112544603Sdcs dup module.loadname .len @ if 1126186789Sluigi ." (" dup module.loadname strtype ." )" 112744603Sdcs then 112844603Sdcs cr 112944603Sdcs ." Error executing " 1130186789Sluigi dup module.beforeload strtype cr \ XXX there was a typo here 113144603Sdcs abort 113244603Sdcs then 113344603Sdcs 1134186789Sluigi dup EAFTERLOAD = if 113544603Sdcs drop 113644603Sdcs ." Module " 113744603Sdcs dup module.name .addr @ over module.name .len @ type 113844603Sdcs dup module.loadname .len @ if 1139186789Sluigi ." (" dup module.loadname strtype ." )" 114044603Sdcs then 114144603Sdcs cr 114244603Sdcs ." Error executing " 1143186789Sluigi dup module.afterload strtype cr 114444603Sdcs abort 114544603Sdcs then 114644603Sdcs 114744603Sdcs throw \ Don't know what it is all about -- pass ahead 114844603Sdcs; 114944603Sdcs 115044603Sdcs\ Module loading interface 115144603Sdcs 1152186789Sluigi\ scan the list of modules, load enabled ones. 115344603Sdcs: load_modules ( -- ) ( throws: abort & user-defined ) 1154186789Sluigi module_options @ ( list_head ) 115544603Sdcs begin 115644603Sdcs ?dup 115744603Sdcs while 1158186789Sluigi dup module.flag @ if 115944603Sdcs ['] process_module catch 116044603Sdcs process_module_errors 116144603Sdcs then 116244603Sdcs module.next @ 116344603Sdcs repeat 116444603Sdcs; 116544603Sdcs 116665630Sdcs\ h00h00 magic used to try loading either a kernel with a given name, 116765630Sdcs\ or a kernel with the default name in a directory of a given name 116865630Sdcs\ (the pain!) 116944603Sdcs 117065630Sdcs: bootpath s" /boot/" ; 117165630Sdcs: modulepath s" module_path" ; 117265630Sdcs 117365630Sdcs\ Functions used to save and restore module_path's value. 117465630Sdcs: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 117565630Sdcs dup -1 = if 0 swap exit then 117665630Sdcs strdup 117765630Sdcs; 117865630Sdcs: freeenv ( addr len | 0 -1 ) 117965630Sdcs -1 = if drop else free abort" Freeing error" then 118065630Sdcs; 118165630Sdcs: restoreenv ( addr len | 0 -1 -- ) 118265630Sdcs dup -1 = if ( it wasn't set ) 118365630Sdcs 2drop 118465630Sdcs modulepath unsetenv 118565630Sdcs else 118665630Sdcs over >r 118765630Sdcs modulepath setenv 118865630Sdcs r> free abort" Freeing error" 118965630Sdcs then 119065630Sdcs; 119165630Sdcs 119265630Sdcs: clip_args \ Drop second string if only one argument is passed 119365630Sdcs 1 = if 119465630Sdcs 2swap 2drop 119565630Sdcs 1 119665630Sdcs else 119765630Sdcs 2 119865630Sdcs then 119965630Sdcs; 120065630Sdcs 120165630Sdcsalso builtins 120265630Sdcs 1203186789Sluigi\ Parse filename from a semicolon-separated list 120465630Sdcs 1205186789Sluigi\ replacement, not working yet 1206186789Sluigi: newparse-; { addr len | a1 -- a' len-x addr x } 1207186789Sluigi addr len [char] ; strchr dup if ( a1 len1 ) 1208186789Sluigi swap to a1 ( store address ) 1209186789Sluigi 1 - a1 @ 1 + swap ( remove match ) 1210186789Sluigi addr a1 addr - 1211186789Sluigi else 1212186789Sluigi 0 0 addr len 1213186789Sluigi then 1214186789Sluigi; 1215186789Sluigi 121665630Sdcs: parse-; ( addr len -- addr' len-x addr x ) 1217186789Sluigi over 0 2swap ( addr 0 addr len ) 121865630Sdcs begin 1219186789Sluigi dup 0 <> ( addr 0 addr len ) 122065630Sdcs while 1221186789Sluigi over c@ [char] ; <> ( addr 0 addr len flag ) 122265630Sdcs while 122365630Sdcs 1- swap 1+ swap 122465630Sdcs 2swap 1+ 2swap 122565630Sdcs repeat then 122665630Sdcs dup 0 <> if 122765630Sdcs 1- swap 1+ swap 122865630Sdcs then 122965630Sdcs 2swap 123065630Sdcs; 123165630Sdcs 123265630Sdcs\ Try loading one of multiple kernels specified 123365630Sdcs 123465630Sdcs: try_multiple_kernels ( addr len addr' len' args -- flag ) 123565630Sdcs >r 123665630Sdcs begin 123765630Sdcs parse-; 2>r 123865630Sdcs 2over 2r> 123965945Sdcs r@ clip_args 124065945Sdcs s" DEBUG" getenv? if 124165945Sdcs s" echo Module_path: ${module_path}" evaluate 124265945Sdcs ." Kernel : " >r 2dup type r> cr 124365945Sdcs dup 2 = if ." Flags : " >r 2over type r> cr then 124465945Sdcs then 124565945Sdcs 1 load 124665630Sdcs while 124765630Sdcs dup 0= 124865630Sdcs until 124965630Sdcs 1 >r \ Failure 125065630Sdcs else 125165630Sdcs 0 >r \ Success 125265630Sdcs then 125365630Sdcs 2drop 2drop 125465630Sdcs r> 125565630Sdcs r> drop 125665630Sdcs; 125765630Sdcs 125865630Sdcs\ Try to load a kernel; the kernel name is taken from one of 125965630Sdcs\ the following lists, as ordered: 126065630Sdcs\ 126165641Sdcs\ 1. The "bootfile" environment variable 126265641Sdcs\ 2. The "kernel" environment variable 126365630Sdcs\ 126465938Sdcs\ Flags are passed, if available. If not, dummy values must be given. 126565630Sdcs\ 126665630Sdcs\ The kernel gets loaded from the current module_path. 126765630Sdcs 126865938Sdcs: load_a_kernel ( flags len 1 | x x 0 -- flag ) 126965630Sdcs local args 127065630Sdcs 2local flags 127165630Sdcs 0 0 2local kernel 127265630Sdcs end-locals 127365630Sdcs 127465630Sdcs \ Check if a default kernel name exists at all, exits if not 127565641Sdcs s" bootfile" getenv dup -1 <> if 127665630Sdcs to kernel 127765883Sdcs flags kernel args 1+ try_multiple_kernels 127865630Sdcs dup 0= if exit then 127965630Sdcs then 128065630Sdcs drop 128165630Sdcs 128265641Sdcs s" kernel" getenv dup -1 <> if 128365630Sdcs to kernel 128465630Sdcs else 128565630Sdcs drop 128665630Sdcs 1 exit \ Failure 128765630Sdcs then 128865630Sdcs 128965630Sdcs \ Try all default kernel names 129065883Sdcs flags kernel args 1+ try_multiple_kernels 129165630Sdcs; 129265630Sdcs 129365630Sdcs\ Try to load a kernel; the kernel name is taken from one of 129465630Sdcs\ the following lists, as ordered: 129565630Sdcs\ 129665641Sdcs\ 1. The "bootfile" environment variable 129765641Sdcs\ 2. The "kernel" environment variable 129865630Sdcs\ 129965630Sdcs\ Flags are passed, if provided. 130065630Sdcs\ 130165630Sdcs\ The kernel will be loaded from a directory computed from the 130265630Sdcs\ path given. Two directories will be tried in the following order: 130365630Sdcs\ 130465630Sdcs\ 1. /boot/path 130565630Sdcs\ 2. path 130665630Sdcs\ 130765630Sdcs\ The module_path variable is overridden if load is succesful, by 130865630Sdcs\ prepending the successful path. 130965630Sdcs 131065630Sdcs: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 131165630Sdcs local args 131265630Sdcs 2local path 131365630Sdcs args 1 = if 0 0 then 131465630Sdcs 2local flags 1315186789Sluigi 0 0 2local oldmodulepath \ like a string 1316186789Sluigi 0 0 2local newmodulepath \ like a string 131765630Sdcs end-locals 131865630Sdcs 131965630Sdcs \ Set the environment variable module_path, and try loading 132065630Sdcs \ the kernel again. 132165630Sdcs modulepath getenv saveenv to oldmodulepath 132265630Sdcs 132365630Sdcs \ Try prepending /boot/ first 1324186789Sluigi bootpath nip path nip + \ total length 132565630Sdcs oldmodulepath nip dup -1 = if 132665630Sdcs drop 132765630Sdcs else 1328186789Sluigi 1+ + \ add oldpath -- XXX why the 1+ ? 132965630Sdcs then 1330186789Sluigi allocate if ( out of memory ) 1 exit then \ XXX throw ? 133165630Sdcs 133265630Sdcs 0 133365630Sdcs bootpath strcat 133465630Sdcs path strcat 133565630Sdcs 2dup to newmodulepath 133665630Sdcs modulepath setenv 133765630Sdcs 133865630Sdcs \ Try all default kernel names 133965938Sdcs flags args 1- load_a_kernel 134065630Sdcs 0= if ( success ) 134165630Sdcs oldmodulepath nip -1 <> if 134265630Sdcs newmodulepath s" ;" strcat 134365630Sdcs oldmodulepath strcat 134465630Sdcs modulepath setenv 134565630Sdcs newmodulepath drop free-memory 134665630Sdcs oldmodulepath drop free-memory 134765630Sdcs then 134865630Sdcs 0 exit 134965630Sdcs then 135065630Sdcs 135165630Sdcs \ Well, try without the prepended /boot/ 135265630Sdcs path newmodulepath drop swap move 135365883Sdcs newmodulepath drop path nip 135465630Sdcs 2dup to newmodulepath 135565630Sdcs modulepath setenv 135665630Sdcs 135765630Sdcs \ Try all default kernel names 135865938Sdcs flags args 1- load_a_kernel 135965630Sdcs if ( failed once more ) 136065630Sdcs oldmodulepath restoreenv 136165630Sdcs newmodulepath drop free-memory 136265630Sdcs 1 136365630Sdcs else 136465630Sdcs oldmodulepath nip -1 <> if 136565630Sdcs newmodulepath s" ;" strcat 136665630Sdcs oldmodulepath strcat 136765630Sdcs modulepath setenv 136865630Sdcs newmodulepath drop free-memory 136965630Sdcs oldmodulepath drop free-memory 137065630Sdcs then 137165630Sdcs 0 137265630Sdcs then 137365630Sdcs; 137465630Sdcs 137565630Sdcs\ Try to load a kernel; the kernel name is taken from one of 137665630Sdcs\ the following lists, as ordered: 137765630Sdcs\ 137865641Sdcs\ 1. The "bootfile" environment variable 137965641Sdcs\ 2. The "kernel" environment variable 138065630Sdcs\ 3. The "path" argument 138165630Sdcs\ 138265630Sdcs\ Flags are passed, if provided. 138365630Sdcs\ 138465630Sdcs\ The kernel will be loaded from a directory computed from the 138565630Sdcs\ path given. Two directories will be tried in the following order: 138665630Sdcs\ 138765630Sdcs\ 1. /boot/path 138865630Sdcs\ 2. path 138965630Sdcs\ 139065630Sdcs\ Unless "path" is meant to be kernel name itself. In that case, it 139165630Sdcs\ will first be tried as a full path, and, next, search on the 139265630Sdcs\ directories pointed by module_path. 139365630Sdcs\ 139465630Sdcs\ The module_path variable is overridden if load is succesful, by 139565630Sdcs\ prepending the successful path. 139665630Sdcs 139765630Sdcs: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 139865630Sdcs local args 139965630Sdcs 2local path 140065630Sdcs args 1 = if 0 0 then 140165630Sdcs 2local flags 140265630Sdcs end-locals 140365630Sdcs 140465630Sdcs \ First, assume path is an absolute path to a directory 140565630Sdcs flags path args clip_args load_from_directory 140665630Sdcs dup 0= if exit else drop then 140765630Sdcs 140865630Sdcs \ Next, assume path points to the kernel 140965630Sdcs flags path args try_multiple_kernels 141065630Sdcs; 141165630Sdcs 141244603Sdcs: initialize ( addr len -- ) 1413186789Sluigi strdup conf_files strset 141444603Sdcs; 141544603Sdcs 141665883Sdcs: kernel_options ( -- addr len 1 | 0 ) 141765630Sdcs s" kernel_options" getenv 141865883Sdcs dup -1 = if drop 0 else 1 then 141965630Sdcs; 142065630Sdcs 142165938Sdcs: standard_kernel_search ( flags 1 | 0 -- flag ) 142265938Sdcs local args 142365938Sdcs args 0= if 0 0 then 142465938Sdcs 2local flags 142565630Sdcs s" kernel" getenv 142665938Sdcs dup -1 = if 0 swap then 142765938Sdcs 2local path 142865938Sdcs end-locals 142965938Sdcs 143066349Sdcs path nip -1 = if ( there isn't a "kernel" environment variable ) 143165938Sdcs flags args load_a_kernel 143265938Sdcs else 143365938Sdcs flags path args 1+ clip_args load_directory_or_file 143465938Sdcs then 143565630Sdcs; 143665630Sdcs 143744603Sdcs: load_kernel ( -- ) ( throws: abort ) 143865938Sdcs kernel_options standard_kernel_search 143965630Sdcs abort" Unable to load a kernel!" 144044603Sdcs; 144165883Sdcs 1442283933Sdteske: load_xen ( -- flag ) 1443277215Sroyger s" xen_kernel" getenv dup -1 <> if 1444283933Sdteske 1 1 load ( c-addr/u flag N -- flag ) 1445277215Sroyger else 1446277215Sroyger drop 1447283933Sdteske 0 ( -1 -- flag ) 1448277215Sroyger then 1449277215Sroyger; 1450277215Sroyger 1451277215Sroyger: load_xen_throw ( -- ) ( throws: abort ) 1452277215Sroyger load_xen 1453277215Sroyger abort" Unable to load Xen!" 1454277215Sroyger; 1455277215Sroyger 145665949Sdcs: set_defaultoptions ( -- ) 145765883Sdcs s" kernel_options" getenv dup -1 = if 145865883Sdcs drop 145965883Sdcs else 146065883Sdcs s" temp_options" setenv 146165883Sdcs then 146265883Sdcs; 146365883Sdcs 1464186789Sluigi\ pick the i-th argument, i starts at 0 146565883Sdcs: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 1466186789Sluigi 2dup = if 0 0 exit then \ out of range 146765883Sdcs dup >r 146865883Sdcs 1+ 2* ( skip N and ui ) 146965883Sdcs pick 147065883Sdcs r> 147165883Sdcs 1+ 2* ( skip N and ai ) 147265883Sdcs pick 147365883Sdcs; 147465883Sdcs 147565949Sdcs: drop_args ( aN uN ... a1 u1 N -- ) 147665883Sdcs 0 ?do 2drop loop 147765883Sdcs; 147865883Sdcs 147965883Sdcs: argc 148065883Sdcs dup 148165883Sdcs; 148265883Sdcs 148365949Sdcs: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 148465883Sdcs >r 148565883Sdcs over 2* 1+ -roll 148665883Sdcs r> 148765883Sdcs over 2* 1+ -roll 148865883Sdcs 1+ 148965883Sdcs; 149065883Sdcs 149165949Sdcs: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 149265883Sdcs 1- -rot 149365883Sdcs; 149465883Sdcs 1495186789Sluigi\ compute the length of the buffer including the spaces between words 1496186789Sluigi: strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len ) 149765883Sdcs dup 0= if 0 exit then 149865883Sdcs 0 >r \ Size 149965883Sdcs 0 >r \ Index 150065883Sdcs begin 150165883Sdcs argc r@ <> 150265883Sdcs while 150365883Sdcs r@ argv[] 150465883Sdcs nip 150565883Sdcs r> r> rot + 1+ 150665883Sdcs >r 1+ >r 150765883Sdcs repeat 150865883Sdcs r> drop 150965883Sdcs r> 151065883Sdcs; 151165883Sdcs 151265949Sdcs: concat_argv ( aN uN ... a1 u1 N -- a u ) 1513186789Sluigi strlen(argv) allocate if ENOMEM throw then 1514186789Sluigi 0 2>r ( save addr 0 on return stack ) 151565883Sdcs 151665883Sdcs begin 1517186789Sluigi dup 151865883Sdcs while 1519186789Sluigi unqueue_argv ( ... N a1 u1 ) 1520186789Sluigi 2r> 2swap ( old a1 u1 ) 152165883Sdcs strcat 1522186789Sluigi s" " strcat ( append one space ) \ XXX this gives a trailing space 1523186789Sluigi 2>r ( store string on the result stack ) 152465883Sdcs repeat 152565949Sdcs drop_args 152665883Sdcs 2r> 152765883Sdcs; 152865883Sdcs 152965949Sdcs: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 153065883Sdcs \ Save the first argument, if it exists and is not a flag 153165883Sdcs argc if 153265883Sdcs 0 argv[] drop c@ [char] - <> if 153365949Sdcs unqueue_argv 2>r \ Filename 153465883Sdcs 1 >r \ Filename present 153565883Sdcs else 153665883Sdcs 0 >r \ Filename not present 153765883Sdcs then 153865883Sdcs else 153965883Sdcs 0 >r \ Filename not present 154065883Sdcs then 154165883Sdcs 154265883Sdcs \ If there are other arguments, assume they are flags 154365883Sdcs ?dup if 154465949Sdcs concat_argv 154565883Sdcs 2dup s" temp_options" setenv 1546186789Sluigi drop free if EFREE throw then 154765883Sdcs else 154865949Sdcs set_defaultoptions 154965883Sdcs then 155065883Sdcs 155165883Sdcs \ Bring back the filename, if one was provided 155265883Sdcs r> if 2r> 1 else 0 then 155365883Sdcs; 155465883Sdcs 155565949Sdcs: get_arguments ( -- addrN lenN ... addr1 len1 N ) 155665883Sdcs 0 155765883Sdcs begin 155865883Sdcs \ Get next word on the command line 155965883Sdcs parse-word 156065883Sdcs ?dup while 156165949Sdcs queue_argv 156265883Sdcs repeat 156365883Sdcs drop ( empty string ) 156465883Sdcs; 156565883Sdcs 156665945Sdcs: load_kernel_and_modules ( args -- flag ) 156765949Sdcs set_tempoptions 156865883Sdcs argc >r 156965883Sdcs s" temp_options" getenv dup -1 <> if 157065949Sdcs queue_argv 157165883Sdcs else 157265883Sdcs drop 157365883Sdcs then 1574277215Sroyger load_xen 1575277215Sroyger ?dup 0= if ( success ) 1576277215Sroyger r> if ( a path was passed ) 1577277215Sroyger load_directory_or_file 1578277215Sroyger else 1579277215Sroyger standard_kernel_search 1580277215Sroyger then 1581277215Sroyger ?dup 0= if ['] load_modules catch then 158265883Sdcs then 158365883Sdcs; 158465883Sdcs 1585280937Sdteskeonly forth definitions 1586