support.4th revision 186789
144603Sdcs\ Copyright (c) 1999 Daniel C. Sobral <dcs@freebsd.org> 244603Sdcs\ All rights reserved. 344603Sdcs\ 444603Sdcs\ Redistribution and use in source and binary forms, with or without 544603Sdcs\ modification, are permitted provided that the following conditions 644603Sdcs\ are met: 744603Sdcs\ 1. Redistributions of source code must retain the above copyright 844603Sdcs\ notice, this list of conditions and the following disclaimer. 944603Sdcs\ 2. Redistributions in binary form must reproduce the above copyright 1044603Sdcs\ notice, this list of conditions and the following disclaimer in the 1144603Sdcs\ documentation and/or other materials provided with the distribution. 1244603Sdcs\ 1344603Sdcs\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 1444603Sdcs\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 1544603Sdcs\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 1644603Sdcs\ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 1744603Sdcs\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 1844603Sdcs\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 1944603Sdcs\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 2044603Sdcs\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 2144603Sdcs\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 2244603Sdcs\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 2344603Sdcs\ SUCH DAMAGE. 2444603Sdcs\ 2550477Speter\ $FreeBSD: head/sys/boot/forth/support.4th 186789 2009-01-05 20:09:54Z luigi $ 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 5753672Sdcs\ string password password 5844603Sdcs\ cell modules_options pointer to first module information 5944603Sdcs\ value verbose? indicates if user wants a verbose loading 6044603Sdcs\ value any_conf_read? indicates if a conf file was succesfully read 6144603Sdcs\ 6244603Sdcs\ Other exported words: 63186789Sluigi\ note, strlen is internal 6444603Sdcs\ strdup ( addr len -- addr' len) similar to strdup(3) 6544603Sdcs\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3) 6644603Sdcs\ s' ( | string' -- addr len | ) similar to s" 6744603Sdcs\ rudimentary structure support 6844603Sdcs 6944603Sdcs\ Exception values 7044603Sdcs 71186789Sluigi1 constant ESYNTAX 72186789Sluigi2 constant ENOMEM 73186789Sluigi3 constant EFREE 74186789Sluigi4 constant ESETERROR \ error setting environment variable 75186789Sluigi5 constant EREAD \ error reading 76186789Sluigi6 constant EOPEN 77186789Sluigi7 constant EEXEC \ XXX never catched 78186789Sluigi8 constant EBEFORELOAD 79186789Sluigi9 constant EAFTERLOAD 8044603Sdcs 8187636Sjhb\ I/O constants 8287636Sjhb 8387636Sjhb0 constant SEEK_SET 8487636Sjhb1 constant SEEK_CUR 8587636Sjhb2 constant SEEK_END 8687636Sjhb 8787636Sjhb0 constant O_RDONLY 8887636Sjhb1 constant O_WRONLY 8987636Sjhb2 constant O_RDWR 9087636Sjhb 9144603Sdcs\ Crude structure support 9244603Sdcs 9365615Sdcs: structure: 9465615Sdcs create here 0 , ['] drop , 0 9565615Sdcs does> create here swap dup @ allot cell+ @ execute 9665615Sdcs; 9744603Sdcs: member: create dup , over , + does> cell+ @ + ; 9844603Sdcs: ;structure swap ! ; 9965615Sdcs: constructor! >body cell+ ! ; 10065615Sdcs: constructor: over :noname ; 10165615Sdcs: ;constructor postpone ; swap cell+ ! ; immediate 10244603Sdcs: sizeof ' >body @ state @ if postpone literal then ; immediate 10344603Sdcs: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate 10444603Sdcs: ptr 1 cells member: ; 10544603Sdcs: int 1 cells member: ; 10644603Sdcs 10744603Sdcs\ String structure 10844603Sdcs 10944603Sdcsstructure: string 11044603Sdcs ptr .addr 11144603Sdcs int .len 11265615Sdcs constructor: 11365615Sdcs 0 over .addr ! 11465615Sdcs 0 swap .len ! 11565615Sdcs ;constructor 11644603Sdcs;structure 11744603Sdcs 11865615Sdcs 11944603Sdcs\ Module options linked list 12044603Sdcs 12144603Sdcsstructure: module 12244603Sdcs int module.flag 12344603Sdcs sizeof string member: module.name 12444603Sdcs sizeof string member: module.loadname 12544603Sdcs sizeof string member: module.type 12644603Sdcs sizeof string member: module.args 12744603Sdcs sizeof string member: module.beforeload 12844603Sdcs sizeof string member: module.afterload 12944603Sdcs sizeof string member: module.loaderror 13044603Sdcs ptr module.next 13144603Sdcs;structure 13244603Sdcs 133186789Sluigi\ Internal loader structures (preloaded_file, kernel_module, file_metadata) 134186789Sluigi\ must be in sync with the C struct in sys/boot/common/bootstrap.h 13565615Sdcsstructure: preloaded_file 13665615Sdcs ptr pf.name 13765615Sdcs ptr pf.type 13865615Sdcs ptr pf.args 13965615Sdcs ptr pf.metadata \ file_metadata 14065615Sdcs int pf.loader 14165615Sdcs int pf.addr 14265615Sdcs int pf.size 14365615Sdcs ptr pf.modules \ kernel_module 14465615Sdcs ptr pf.next \ preloaded_file 14565615Sdcs;structure 14665615Sdcs 14765615Sdcsstructure: kernel_module 14865615Sdcs ptr km.name 14965615Sdcs \ ptr km.args 15065615Sdcs ptr km.fp \ preloaded_file 15165615Sdcs ptr km.next \ kernel_module 15265615Sdcs;structure 15365615Sdcs 15465615Sdcsstructure: file_metadata 15565615Sdcs int md.size 15665615Sdcs 2 member: md.type \ this is not ANS Forth compatible (XXX) 15765615Sdcs ptr md.next \ file_metadata 15865615Sdcs 0 member: md.data \ variable size 15965615Sdcs;structure 16065615Sdcs 161186789Sluigi\ end of structures 16265615Sdcs 16344603Sdcs\ Global variables 16444603Sdcs 16544603Sdcsstring conf_files 16697201Sgordonstring nextboot_conf_file 16753672Sdcsstring password 16865615Sdcscreate module_options sizeof module.next allot 0 module_options ! 16965615Sdcscreate last_module_option sizeof module.next allot 0 last_module_option ! 17044603Sdcs0 value verbose? 17197201Sgordon0 value nextboot? 17244603Sdcs 17344603Sdcs\ Support string functions 174186789Sluigi: strdup { addr len -- addr' len' } 175186789Sluigi len allocate if ENOMEM throw then 176186789Sluigi addr over len move len 17744603Sdcs; 17844603Sdcs 17944603Sdcs: strcat { addr len addr' len' -- addr len+len' } 18044603Sdcs addr' addr len + len' move 18144603Sdcs addr len len' + 18244603Sdcs; 18344603Sdcs 184186789Sluigi: strchr { addr len c -- addr' len' } 18561373Sdcs begin 186186789Sluigi len 187186789Sluigi while 188186789Sluigi addr c@ c = if addr len exit then 189186789Sluigi addr 1 + to addr 190186789Sluigi len 1 - to len 191186789Sluigi repeat 192186789Sluigi 0 0 19361373Sdcs; 19461373Sdcs 195186789Sluigi: s' \ same as s", allows " in the string 19644603Sdcs [char] ' parse 197186789Sluigi state @ if postpone sliteral then 19844603Sdcs; immediate 19944603Sdcs 20061373Sdcs: 2>r postpone >r postpone >r ; immediate 20161373Sdcs: 2r> postpone r> postpone r> ; immediate 20265883Sdcs: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate 20353672Sdcs 204186789Sluigi: getenv? getenv -1 = if false else drop true then ; 20565938Sdcs 20644603Sdcs\ Private definitions 20744603Sdcs 20844603Sdcsvocabulary support-functions 20944603Sdcsonly forth also support-functions definitions 21044603Sdcs 21144603Sdcs\ Some control characters constants 21244603Sdcs 21353672Sdcs7 constant bell 21453672Sdcs8 constant backspace 21544603Sdcs9 constant tab 21644603Sdcs10 constant lf 21753672Sdcs13 constant <cr> 21844603Sdcs 21944603Sdcs\ Read buffer size 22044603Sdcs 22144603Sdcs80 constant read_buffer_size 22244603Sdcs 22344603Sdcs\ Standard suffixes 22444603Sdcs 225186789Sluigi: load_module_suffix s" _load" ; 226186789Sluigi: module_loadname_suffix s" _name" ; 227186789Sluigi: module_type_suffix s" _type" ; 228186789Sluigi: module_args_suffix s" _flags" ; 229186789Sluigi: module_beforeload_suffix s" _before" ; 230186789Sluigi: module_afterload_suffix s" _after" ; 231186789Sluigi: module_loaderror_suffix s" _error" ; 23244603Sdcs 23344603Sdcs\ Support operators 23444603Sdcs 23544603Sdcs: >= < 0= ; 23644603Sdcs: <= > 0= ; 23744603Sdcs 238186789Sluigi\ Assorted support functions 23944603Sdcs 240186789Sluigi: free-memory free if EFREE throw then ; 24144603Sdcs 242185746Sluigi: strget { var -- addr len } var .addr @ var .len @ ; 243185746Sluigi 244185746Sluigi\ assign addr len to variable. 245186789Sluigi: strset { addr len var -- } addr var .addr ! len var .len ! ; 246185746Sluigi 247185746Sluigi\ free memory and reset fields 248185746Sluigi: strfree { var -- } var .addr @ ?dup if free-memory 0 0 var strset then ; 249185746Sluigi 250185746Sluigi\ free old content, make a copy of the string and assign to variable 251185746Sluigi: string= { addr len var -- } var strfree addr len strdup var strset ; 252185746Sluigi 253186789Sluigi: strtype ( str -- ) strget type ; 254186789Sluigi 255186789Sluigi\ assign a reference to what is on the stack 256186789Sluigi: strref { addr len var -- addr len } 257186789Sluigi addr var .addr ! len var .len ! addr len 258186789Sluigi; 259186789Sluigi 260186789Sluigi\ unquote a string 261186789Sluigi: unquote ( addr len -- addr len ) 262186789Sluigi over c@ [char] " = if 2 chars - swap char+ swap then 263186789Sluigi; 264186789Sluigi 26544603Sdcs\ Assignment data temporary storage 26644603Sdcs 26744603Sdcsstring name_buffer 26844603Sdcsstring value_buffer 26944603Sdcs 27065615Sdcs\ Line by line file reading functions 27165615Sdcs\ 27265615Sdcs\ exported: 27365615Sdcs\ line_buffer 27465615Sdcs\ end_of_file? 27565615Sdcs\ fd 27665615Sdcs\ read_line 27765615Sdcs\ reset_line_reading 27865615Sdcs 27965615Sdcsvocabulary line-reading 28065615Sdcsalso line-reading definitions also 28165615Sdcs 28244603Sdcs\ File data temporary storage 28344603Sdcs 28444603Sdcsstring read_buffer 28544603Sdcs0 value read_buffer_ptr 28644603Sdcs 28744603Sdcs\ File's line reading function 28844603Sdcs 28965615Sdcssupport-functions definitions 29065615Sdcs 29165615Sdcsstring line_buffer 29244603Sdcs0 value end_of_file? 29344603Sdcsvariable fd 29444603Sdcs 29565615Sdcsline-reading definitions 29665615Sdcs 29744603Sdcs: skip_newlines 29844603Sdcs begin 29944603Sdcs read_buffer .len @ read_buffer_ptr > 30044603Sdcs while 30144603Sdcs read_buffer .addr @ read_buffer_ptr + c@ lf = if 30244603Sdcs read_buffer_ptr char+ to read_buffer_ptr 30344603Sdcs else 30444603Sdcs exit 30544603Sdcs then 30644603Sdcs repeat 30744603Sdcs; 30844603Sdcs 30944603Sdcs: scan_buffer ( -- addr len ) 31044603Sdcs read_buffer_ptr >r 31144603Sdcs begin 31244603Sdcs read_buffer .len @ r@ > 31344603Sdcs while 31444603Sdcs read_buffer .addr @ r@ + c@ lf = if 31544603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 31644603Sdcs r@ read_buffer_ptr - ( -- len ) 31744603Sdcs r> to read_buffer_ptr 31844603Sdcs exit 31944603Sdcs then 32044603Sdcs r> char+ >r 32144603Sdcs repeat 32244603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 32344603Sdcs r@ read_buffer_ptr - ( -- len ) 32444603Sdcs r> to read_buffer_ptr 32544603Sdcs; 32644603Sdcs 32744603Sdcs: line_buffer_resize ( len -- len ) 32844603Sdcs >r 32944603Sdcs line_buffer .len @ if 33044603Sdcs line_buffer .addr @ 33144603Sdcs line_buffer .len @ r@ + 332186789Sluigi resize if ENOMEM throw then 33344603Sdcs else 334186789Sluigi r@ allocate if ENOMEM throw then 33544603Sdcs then 33644603Sdcs line_buffer .addr ! 33744603Sdcs r> 33844603Sdcs; 33944603Sdcs 34044603Sdcs: append_to_line_buffer ( addr len -- ) 341186789Sluigi line_buffer strget 34244603Sdcs 2swap strcat 34344603Sdcs line_buffer .len ! 34444603Sdcs drop 34544603Sdcs; 34644603Sdcs 34744603Sdcs: read_from_buffer 34844603Sdcs scan_buffer ( -- addr len ) 34944603Sdcs line_buffer_resize ( len -- len ) 35044603Sdcs append_to_line_buffer ( addr len -- ) 35144603Sdcs; 35244603Sdcs 35344603Sdcs: refill_required? 35444603Sdcs read_buffer .len @ read_buffer_ptr = 35544603Sdcs end_of_file? 0= and 35644603Sdcs; 35744603Sdcs 35844603Sdcs: refill_buffer 35944603Sdcs 0 to read_buffer_ptr 36044603Sdcs read_buffer .addr @ 0= if 361186789Sluigi read_buffer_size allocate if ENOMEM throw then 36244603Sdcs read_buffer .addr ! 36344603Sdcs then 36444603Sdcs fd @ read_buffer .addr @ read_buffer_size fread 365186789Sluigi dup -1 = if EREAD throw then 36644603Sdcs dup 0= if true to end_of_file? then 36744603Sdcs read_buffer .len ! 36844603Sdcs; 36944603Sdcs 37065615Sdcssupport-functions definitions 37165615Sdcs 37265615Sdcs: reset_line_reading 37365615Sdcs 0 to read_buffer_ptr 37465615Sdcs; 37565615Sdcs 37644603Sdcs: read_line 377186789Sluigi line_buffer strfree 37844603Sdcs skip_newlines 37944603Sdcs begin 38044603Sdcs read_from_buffer 38144603Sdcs refill_required? 38244603Sdcs while 38344603Sdcs refill_buffer 38444603Sdcs repeat 38544603Sdcs; 38644603Sdcs 38765615Sdcsonly forth also support-functions definitions 38865615Sdcs 38944603Sdcs\ Conf file line parser: 39044603Sdcs\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 39144603Sdcs\ <spaces>[<comment>] 39244603Sdcs\ <name> ::= <letter>{<letter>|<digit>|'_'} 39344603Sdcs\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 39444603Sdcs\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 39544603Sdcs\ <comment> ::= '#'{<anything>} 39665615Sdcs\ 39765615Sdcs\ exported: 39865615Sdcs\ line_pointer 39965615Sdcs\ process_conf 40044603Sdcs 40165615Sdcs0 value line_pointer 40265615Sdcs 40365615Sdcsvocabulary file-processing 40465615Sdcsalso file-processing definitions 40565615Sdcs 40665615Sdcs\ parser functions 40765615Sdcs\ 40865615Sdcs\ exported: 40965615Sdcs\ get_assignment 41065615Sdcs 41165615Sdcsvocabulary parser 41265615Sdcsalso parser definitions also 41365615Sdcs 41444603Sdcs0 value parsing_function 41544603Sdcs0 value end_of_line 41644603Sdcs 417186789Sluigi: end_of_line? line_pointer end_of_line = ; 41844603Sdcs 419186789Sluigi\ classifiers for various character classes in the input line 420186789Sluigi 42144603Sdcs: letter? 42244603Sdcs line_pointer c@ >r 42344603Sdcs r@ [char] A >= 42444603Sdcs r@ [char] Z <= and 42544603Sdcs r@ [char] a >= 42644603Sdcs r> [char] z <= and 42744603Sdcs or 42844603Sdcs; 42944603Sdcs 43044603Sdcs: digit? 43144603Sdcs line_pointer c@ >r 432174777Sambrisko r@ [char] - = 43344603Sdcs r@ [char] 0 >= 43444603Sdcs r> [char] 9 <= and 435174777Sambrisko or 43644603Sdcs; 43744603Sdcs 438186789Sluigi: quote? line_pointer c@ [char] " = ; 43944603Sdcs 440186789Sluigi: assignment_sign? line_pointer c@ [char] = = ; 44144603Sdcs 442186789Sluigi: comment? line_pointer c@ [char] # = ; 44344603Sdcs 444186789Sluigi: space? line_pointer c@ bl = line_pointer c@ tab = or ; 44544603Sdcs 446186789Sluigi: backslash? line_pointer c@ [char] \ = ; 44744603Sdcs 448186789Sluigi: underscore? line_pointer c@ [char] _ = ; 44944603Sdcs 450186789Sluigi: dot? line_pointer c@ [char] . = ; 45144603Sdcs 452186789Sluigi\ manipulation of input line 453186789Sluigi: skip_character line_pointer char+ to line_pointer ; 45444603Sdcs 455186789Sluigi: skip_to_end_of_line end_of_line to line_pointer ; 45644603Sdcs 45744603Sdcs: eat_space 45844603Sdcs begin 459186789Sluigi end_of_line? if 0 else space? then 46044603Sdcs while 46144603Sdcs skip_character 46244603Sdcs repeat 46344603Sdcs; 46444603Sdcs 46544603Sdcs: parse_name ( -- addr len ) 46644603Sdcs line_pointer 46744603Sdcs begin 468186789Sluigi end_of_line? if 0 else letter? digit? underscore? dot? or or or then 46944603Sdcs while 47044603Sdcs skip_character 47144603Sdcs repeat 47244603Sdcs line_pointer over - 47344603Sdcs strdup 47444603Sdcs; 47544603Sdcs 47644603Sdcs: remove_backslashes { addr len | addr' len' -- addr' len' } 477186789Sluigi len allocate if ENOMEM throw then 47844603Sdcs to addr' 47944603Sdcs addr >r 48044603Sdcs begin 48144603Sdcs addr c@ [char] \ <> if 48244603Sdcs addr c@ addr' len' + c! 48344603Sdcs len' char+ to len' 48444603Sdcs then 48544603Sdcs addr char+ to addr 48644603Sdcs r@ len + addr = 48744603Sdcs until 48844603Sdcs r> drop 48944603Sdcs addr' len' 49044603Sdcs; 49144603Sdcs 49244603Sdcs: parse_quote ( -- addr len ) 49344603Sdcs line_pointer 49444603Sdcs skip_character 495186789Sluigi end_of_line? if ESYNTAX throw then 49644603Sdcs begin 49744603Sdcs quote? 0= 49844603Sdcs while 49944603Sdcs backslash? if 50044603Sdcs skip_character 501186789Sluigi end_of_line? if ESYNTAX throw then 50244603Sdcs then 50344603Sdcs skip_character 504186789Sluigi end_of_line? if ESYNTAX throw then 50544603Sdcs repeat 50644603Sdcs skip_character 50744603Sdcs line_pointer over - 50844603Sdcs remove_backslashes 50944603Sdcs; 51044603Sdcs 51144603Sdcs: read_name 51244603Sdcs parse_name ( -- addr len ) 513186789Sluigi name_buffer strset 51444603Sdcs; 51544603Sdcs 51644603Sdcs: read_value 51744603Sdcs quote? if 51844603Sdcs parse_quote ( -- addr len ) 51944603Sdcs else 52044603Sdcs parse_name ( -- addr len ) 52144603Sdcs then 522186789Sluigi value_buffer strset 52344603Sdcs; 52444603Sdcs 52544603Sdcs: comment 52644603Sdcs skip_to_end_of_line 52744603Sdcs; 52844603Sdcs 52944603Sdcs: white_space_4 53044603Sdcs eat_space 53144603Sdcs comment? if ['] comment to parsing_function exit then 532186789Sluigi end_of_line? 0= if ESYNTAX throw then 53344603Sdcs; 53444603Sdcs 53544603Sdcs: variable_value 53644603Sdcs read_value 53744603Sdcs ['] white_space_4 to parsing_function 53844603Sdcs; 53944603Sdcs 54044603Sdcs: white_space_3 54144603Sdcs eat_space 54244603Sdcs letter? digit? quote? or or if 54344603Sdcs ['] variable_value to parsing_function exit 54444603Sdcs then 545186789Sluigi ESYNTAX throw 54644603Sdcs; 54744603Sdcs 54844603Sdcs: assignment_sign 54944603Sdcs skip_character 55044603Sdcs ['] white_space_3 to parsing_function 55144603Sdcs; 55244603Sdcs 55344603Sdcs: white_space_2 55444603Sdcs eat_space 55544603Sdcs assignment_sign? if ['] assignment_sign to parsing_function exit then 556186789Sluigi ESYNTAX throw 55744603Sdcs; 55844603Sdcs 55944603Sdcs: variable_name 56044603Sdcs read_name 56144603Sdcs ['] white_space_2 to parsing_function 56244603Sdcs; 56344603Sdcs 56444603Sdcs: white_space_1 56544603Sdcs eat_space 56644603Sdcs letter? if ['] variable_name to parsing_function exit then 56744603Sdcs comment? if ['] comment to parsing_function exit then 568186789Sluigi end_of_line? 0= if ESYNTAX throw then 56944603Sdcs; 57044603Sdcs 57165615Sdcsfile-processing definitions 57265615Sdcs 57344603Sdcs: get_assignment 574186789Sluigi line_buffer strget + to end_of_line 57544603Sdcs line_buffer .addr @ to line_pointer 57644603Sdcs ['] white_space_1 to parsing_function 57744603Sdcs begin 57844603Sdcs end_of_line? 0= 57944603Sdcs while 58044603Sdcs parsing_function execute 58144603Sdcs repeat 58244603Sdcs parsing_function ['] comment = 58344603Sdcs parsing_function ['] white_space_1 = 58444603Sdcs parsing_function ['] white_space_4 = 585186789Sluigi or or 0= if ESYNTAX throw then 58644603Sdcs; 58744603Sdcs 58865615Sdcsonly forth also support-functions also file-processing definitions also 58965615Sdcs 59044603Sdcs\ Process line 59144603Sdcs 59244603Sdcs: assignment_type? ( addr len -- flag ) 593186789Sluigi name_buffer strget 59444603Sdcs compare 0= 59544603Sdcs; 59644603Sdcs 59744603Sdcs: suffix_type? ( addr len -- flag ) 59844603Sdcs name_buffer .len @ over <= if 2drop false exit then 59944603Sdcs name_buffer .len @ over - name_buffer .addr @ + 60044603Sdcs over compare 0= 60144603Sdcs; 60244603Sdcs 603186789Sluigi: loader_conf_files? s" loader_conf_files" assignment_type? ; 60444603Sdcs 605186789Sluigi: nextboot_flag? s" nextboot_enable" assignment_type? ; 60697201Sgordon 607186789Sluigi: nextboot_conf? s" nextboot_conf" assignment_type? ; 60897201Sgordon 609186789Sluigi: verbose_flag? s" verbose_loading" assignment_type? ; 61044603Sdcs 611186789Sluigi: execute? s" exec" assignment_type? ; 61244603Sdcs 613186789Sluigi: password? s" password" assignment_type? ; 61453672Sdcs 615186789Sluigi: module_load? load_module_suffix suffix_type? ; 61644603Sdcs 617186789Sluigi: module_loadname? module_loadname_suffix suffix_type? ; 61844603Sdcs 619186789Sluigi: module_type? module_type_suffix suffix_type? ; 62044603Sdcs 621186789Sluigi: module_args? module_args_suffix suffix_type? ; 62244603Sdcs 623186789Sluigi: module_beforeload? module_beforeload_suffix suffix_type? ; 62444603Sdcs 625186789Sluigi: module_afterload? module_afterload_suffix suffix_type? ; 62644603Sdcs 627186789Sluigi: module_loaderror? module_loaderror_suffix suffix_type? ; 62844603Sdcs 629186789Sluigi\ build a 'set' statement and execute it 630186789Sluigi: set_environment_variable 631186789Sluigi name_buffer .len @ value_buffer .len @ + 5 chars + \ size of result string 632186789Sluigi allocate if ENOMEM throw then 633186789Sluigi dup 0 \ start with an empty string and append the pieces 634186789Sluigi s" set " strcat 635186789Sluigi name_buffer strget strcat 636186789Sluigi s" =" strcat 637186789Sluigi value_buffer strget strcat 638186789Sluigi ['] evaluate catch if 639186789Sluigi 2drop free drop 640186789Sluigi ESETERROR throw 641186789Sluigi else 64297201Sgordon free-memory 64397201Sgordon then 64497201Sgordon; 64597201Sgordon 646186789Sluigi: set_conf_files 647186789Sluigi set_environment_variable 648186789Sluigi s" loader_conf_files" getenv conf_files string= 649186789Sluigi; 650186789Sluigi 651186789Sluigi: set_nextboot_conf \ XXX maybe do as set_conf_files ? 652186789Sluigi value_buffer strget unquote nextboot_conf_file string= 653186789Sluigi; 654186789Sluigi 65544603Sdcs: append_to_module_options_list ( addr -- ) 65644603Sdcs module_options @ 0= if 65744603Sdcs dup module_options ! 65844603Sdcs last_module_option ! 65944603Sdcs else 66044603Sdcs dup last_module_option @ module.next ! 66144603Sdcs last_module_option ! 66244603Sdcs then 66344603Sdcs; 66444603Sdcs 665186789Sluigi: set_module_name { addr -- } \ check leaks 666186789Sluigi name_buffer strget addr module.name string= 66744603Sdcs; 66844603Sdcs 66944603Sdcs: yes_value? 670186789Sluigi value_buffer strget \ XXX could use unquote 67144603Sdcs 2dup s' "YES"' compare >r 67244603Sdcs 2dup s' "yes"' compare >r 67344603Sdcs 2dup s" YES" compare >r 67444603Sdcs s" yes" compare r> r> r> and and and 0= 67544603Sdcs; 67644603Sdcs 677186789Sluigi: find_module_option ( -- addr | 0 ) \ return ptr to entry matching name_buffer 67844603Sdcs module_options @ 67944603Sdcs begin 68044603Sdcs dup 68144603Sdcs while 682186789Sluigi dup module.name strget 683186789Sluigi name_buffer strget 68444603Sdcs compare 0= if exit then 68544603Sdcs module.next @ 68644603Sdcs repeat 68744603Sdcs; 68844603Sdcs 68944603Sdcs: new_module_option ( -- addr ) 690186789Sluigi sizeof module allocate if ENOMEM throw then 69144603Sdcs dup sizeof module erase 69244603Sdcs dup append_to_module_options_list 69344603Sdcs dup set_module_name 69444603Sdcs; 69544603Sdcs 69644603Sdcs: get_module_option ( -- addr ) 69744603Sdcs find_module_option 69844603Sdcs ?dup 0= if new_module_option then 69944603Sdcs; 70044603Sdcs 70144603Sdcs: set_module_flag 70244603Sdcs name_buffer .len @ load_module_suffix nip - name_buffer .len ! 70344603Sdcs yes_value? get_module_option module.flag ! 70444603Sdcs; 70544603Sdcs 70644603Sdcs: set_module_args 70744603Sdcs name_buffer .len @ module_args_suffix nip - name_buffer .len ! 708186789Sluigi value_buffer strget unquote 709186789Sluigi get_module_option module.args string= 71044603Sdcs; 71144603Sdcs 71244603Sdcs: set_module_loadname 71344603Sdcs name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 714186789Sluigi value_buffer strget unquote 715186789Sluigi get_module_option module.loadname string= 71644603Sdcs; 71744603Sdcs 71844603Sdcs: set_module_type 71944603Sdcs name_buffer .len @ module_type_suffix nip - name_buffer .len ! 720186789Sluigi value_buffer strget unquote 721186789Sluigi get_module_option module.type string= 72244603Sdcs; 72344603Sdcs 72444603Sdcs: set_module_beforeload 72544603Sdcs name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 726186789Sluigi value_buffer strget unquote 727186789Sluigi get_module_option module.beforeload string= 72844603Sdcs; 72944603Sdcs 73044603Sdcs: set_module_afterload 73144603Sdcs name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 732186789Sluigi value_buffer strget unquote 733186789Sluigi get_module_option module.afterload string= 73444603Sdcs; 73544603Sdcs 73644603Sdcs: set_module_loaderror 73744603Sdcs name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 738186789Sluigi value_buffer strget unquote 739186789Sluigi get_module_option module.loaderror string= 74044603Sdcs; 74144603Sdcs 74297201Sgordon: set_nextboot_flag 74397201Sgordon yes_value? to nextboot? 74497201Sgordon; 74597201Sgordon 74644603Sdcs: set_verbose 74744603Sdcs yes_value? to verbose? 74844603Sdcs; 74944603Sdcs 75044603Sdcs: execute_command 751186789Sluigi value_buffer strget unquote 752186789Sluigi ['] evaluate catch if EEXEC throw then 75344603Sdcs; 75444603Sdcs 75553672Sdcs: set_password 756186789Sluigi value_buffer strget unquote password string= 75753672Sdcs; 75853672Sdcs 75944603Sdcs: process_assignment 76044603Sdcs name_buffer .len @ 0= if exit then 76144603Sdcs loader_conf_files? if set_conf_files exit then 76297201Sgordon nextboot_flag? if set_nextboot_flag exit then 76397201Sgordon nextboot_conf? if set_nextboot_conf exit then 76444603Sdcs verbose_flag? if set_verbose exit then 76544603Sdcs execute? if execute_command exit then 76653672Sdcs password? if set_password exit then 76744603Sdcs module_load? if set_module_flag exit then 76844603Sdcs module_loadname? if set_module_loadname exit then 76944603Sdcs module_type? if set_module_type exit then 77044603Sdcs module_args? if set_module_args exit then 77144603Sdcs module_beforeload? if set_module_beforeload exit then 77244603Sdcs module_afterload? if set_module_afterload exit then 77344603Sdcs module_loaderror? if set_module_loaderror exit then 77444603Sdcs set_environment_variable 77544603Sdcs; 77644603Sdcs 77753672Sdcs\ free_buffer ( -- ) 77853672Sdcs\ 77953672Sdcs\ Free some pointers if needed. The code then tests for errors 78053672Sdcs\ in freeing, and throws an exception if needed. If a pointer is 78153672Sdcs\ not allocated, it's value (0) is used as flag. 78253672Sdcs 78344603Sdcs: free_buffers 784186789Sluigi name_buffer strfree 785186789Sluigi value_buffer strfree 78644603Sdcs; 78744603Sdcs 78844603Sdcs\ Higher level file processing 78944603Sdcs 79065615Sdcssupport-functions definitions 79165615Sdcs 79244603Sdcs: process_conf 79344603Sdcs begin 79444603Sdcs end_of_file? 0= 79544603Sdcs while 796186789Sluigi free_buffers 79744603Sdcs read_line 79844603Sdcs get_assignment 79944603Sdcs ['] process_assignment catch 80044603Sdcs ['] free_buffers catch 80144603Sdcs swap throw throw 80244603Sdcs repeat 80344603Sdcs; 80444603Sdcs 80597201Sgordon: peek_file 80697201Sgordon 0 to end_of_file? 80797201Sgordon reset_line_reading 80897201Sgordon O_RDONLY fopen fd ! 809186789Sluigi fd @ -1 = if EOPEN throw then 810186789Sluigi free_buffers 81197201Sgordon read_line 81297201Sgordon get_assignment 81397201Sgordon ['] process_assignment catch 81497201Sgordon ['] free_buffers catch 81597201Sgordon fd @ fclose 81697201Sgordon; 81797201Sgordon 81865615Sdcsonly forth also support-functions definitions 81965615Sdcs 82044603Sdcs\ Interface to loading conf files 82144603Sdcs 82244603Sdcs: load_conf ( addr len -- ) 823186789Sluigi ." ----- Trying conf " 2dup type cr 82444603Sdcs 0 to end_of_file? 82565615Sdcs reset_line_reading 82687636Sjhb O_RDONLY fopen fd ! 827186789Sluigi fd @ -1 = if EOPEN throw then 82844603Sdcs ['] process_conf catch 82944603Sdcs fd @ fclose 83044603Sdcs throw 83144603Sdcs; 83244603Sdcs 833186789Sluigi: print_line line_buffer strtype cr ; 83444603Sdcs 83544603Sdcs: print_syntax_error 836186789Sluigi line_buffer strtype cr 83744603Sdcs line_buffer .addr @ 83844603Sdcs begin 83944603Sdcs line_pointer over <> 84044603Sdcs while 841186789Sluigi bl emit char+ 84244603Sdcs repeat 84344603Sdcs drop 84444603Sdcs ." ^" cr 84544603Sdcs; 84644603Sdcs 847186789Sluigi 848163327Sru\ Debugging support functions 84944603Sdcs 85044603Sdcsonly forth definitions also support-functions 85144603Sdcs 85244603Sdcs: test-file 85344603Sdcs ['] load_conf catch dup . 854186789Sluigi ESYNTAX = if cr print_syntax_error then 85544603Sdcs; 85644603Sdcs 857186789Sluigi\ find a module name, leave addr on the stack (0 if not found) 858186789Sluigi: find-module ( <module> -- ptr | 0 ) 859186789Sluigi bl parse ( addr len ) 860186789Sluigi module_options @ >r ( store current pointer ) 861186789Sluigi begin 862186789Sluigi r@ 863186789Sluigi while 864186789Sluigi 2dup ( addr len addr len ) 865186789Sluigi r@ module.name strget 866186789Sluigi compare 0= if drop drop r> exit then ( found it ) 867186789Sluigi r> module.next @ >r 868186789Sluigi repeat 869186789Sluigi type ." was not found" cr r> 870186789Sluigi; 871186789Sluigi 872186789Sluigi: show-nonempty ( addr len mod -- ) 873186789Sluigi strget dup verbose? or if 874186789Sluigi 2swap type type cr 875186789Sluigi else 876186789Sluigi drop drop drop drop 877186789Sluigi then ; 878186789Sluigi 879186789Sluigi: show-one-module { addr -- addr } 880186789Sluigi ." Name: " addr module.name strtype cr 881186789Sluigi s" Path: " addr module.loadname show-nonempty 882186789Sluigi s" Type: " addr module.type show-nonempty 883186789Sluigi s" Flags: " addr module.args show-nonempty 884186789Sluigi s" Before load: " addr module.beforeload show-nonempty 885186789Sluigi s" After load: " addr module.afterload show-nonempty 886186789Sluigi s" Error: " addr module.loaderror show-nonempty 887186789Sluigi ." Status: " addr module.flag @ if ." Load" else ." Don't load" then cr 888186789Sluigi cr 889186789Sluigi addr 890186789Sluigi; 891186789Sluigi 89244603Sdcs: show-module-options 89344603Sdcs module_options @ 89444603Sdcs begin 89544603Sdcs ?dup 89644603Sdcs while 897186789Sluigi show-one-module 89844603Sdcs module.next @ 89944603Sdcs repeat 90044603Sdcs; 90144603Sdcs 90244603Sdcsonly forth also support-functions definitions 90344603Sdcs 90444603Sdcs\ Variables used for processing multiple conf files 90544603Sdcs 906186789Sluigistring current_file_name_ref \ used to print the file name 90744603Sdcs 90844603Sdcs\ Indicates if any conf file was succesfully read 90944603Sdcs 91044603Sdcs0 value any_conf_read? 91144603Sdcs 91244603Sdcs\ loader_conf_files processing support functions 91344603Sdcs 914185746Sluigi: get_conf_files ( -- addr len ) \ put addr/len on stack, reset var 915186789Sluigi ." -- starting on <" conf_files strtype ." >" cr 916185746Sluigi conf_files strget 0 0 conf_files strset 91744603Sdcs; 91844603Sdcs 91953672Sdcs: skip_leading_spaces { addr len pos -- addr len pos' } 92044603Sdcs begin 921186789Sluigi pos len = if 0 else addr pos + c@ bl = then 92244603Sdcs while 92353672Sdcs pos char+ to pos 92444603Sdcs repeat 92553672Sdcs addr len pos 92644603Sdcs; 92744603Sdcs 928186789Sluigi\ return the file name at pos, or free the string if nothing left 92953672Sdcs: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 93053672Sdcs pos len = if 93144603Sdcs addr free abort" Fatal error freeing memory" 93244603Sdcs 0 exit 93344603Sdcs then 93453672Sdcs pos >r 93544603Sdcs begin 936186789Sluigi \ stay in the loop until have chars and they are not blank 937186789Sluigi pos len = if 0 else addr pos + c@ bl <> then 93844603Sdcs while 93953672Sdcs pos char+ to pos 94044603Sdcs repeat 94153672Sdcs addr len pos addr r@ + pos r> - 942186789Sluigi 2dup 943186789Sluigi ." get_file_name has " type cr 94444603Sdcs; 94544603Sdcs 94644603Sdcs: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 94744603Sdcs skip_leading_spaces 94844603Sdcs get_file_name 94944603Sdcs; 95044603Sdcs 95144603Sdcs: print_current_file 952186789Sluigi current_file_name_ref strtype 95344603Sdcs; 95444603Sdcs 95544603Sdcs: process_conf_errors 95644603Sdcs dup 0= if true to any_conf_read? drop exit then 95744603Sdcs >r 2drop r> 958186789Sluigi dup ESYNTAX = if 95944603Sdcs ." Warning: syntax error on file " print_current_file cr 96044603Sdcs print_syntax_error drop exit 96144603Sdcs then 962186789Sluigi dup ESETERROR = if 96344603Sdcs ." Warning: bad definition on file " print_current_file cr 96444603Sdcs print_line drop exit 96544603Sdcs then 966186789Sluigi dup EREAD = if 96744603Sdcs ." Warning: error reading file " print_current_file cr drop exit 96844603Sdcs then 969186789Sluigi dup EOPEN = if 97044603Sdcs verbose? if ." Warning: unable to open file " print_current_file cr then 97144603Sdcs drop exit 97244603Sdcs then 973186789Sluigi dup EFREE = abort" Fatal error freeing memory" 974186789Sluigi dup ENOMEM = abort" Out of memory" 97544603Sdcs throw \ Unknown error -- pass ahead 97644603Sdcs; 97744603Sdcs 97844603Sdcs\ Process loader_conf_files recursively 97944603Sdcs\ Interface to loader_conf_files processing 98044603Sdcs 98144603Sdcs: include_conf_files 982186789Sluigi get_conf_files 0 ( addr len offset ) 98344603Sdcs begin 984186789Sluigi get_next_file ?dup ( addr len 1 | 0 ) 98544603Sdcs while 986186789Sluigi current_file_name_ref strref 98744603Sdcs ['] load_conf catch 98844603Sdcs process_conf_errors 989185746Sluigi conf_files .addr @ if recurse then 99044603Sdcs repeat 99144603Sdcs; 99244603Sdcs 99397201Sgordon: get_nextboot_conf_file ( -- addr len ) 994186789Sluigi nextboot_conf_file strget strdup \ XXX is the strdup a leak ? 99597201Sgordon; 99697201Sgordon 99797201Sgordon: rewrite_nextboot_file ( -- ) 99897201Sgordon get_nextboot_conf_file 99997201Sgordon O_WRONLY fopen fd ! 1000186789Sluigi fd @ -1 = if EOPEN throw then 100197201Sgordon fd @ s' nextboot_enable="NO" ' fwrite 100297201Sgordon fd @ fclose 100397201Sgordon; 100497201Sgordon 100597201Sgordon: include_nextboot_file 100697201Sgordon get_nextboot_conf_file 100797201Sgordon ['] peek_file catch 100897201Sgordon nextboot? if 100997201Sgordon get_nextboot_conf_file 101097201Sgordon ['] load_conf catch 101197201Sgordon process_conf_errors 101297201Sgordon ['] rewrite_nextboot_file catch 101397201Sgordon then 101497201Sgordon; 101597201Sgordon 101644603Sdcs\ Module loading functions 101744603Sdcs 1018186789Sluigi: load_parameters { addr -- addr addrN lenN ... addr1 len1 N } 1019186789Sluigi addr 1020186789Sluigi addr module.args strget 1021186789Sluigi addr module.loadname .len @ if 1022186789Sluigi addr module.loadname strget 102344603Sdcs else 1024186789Sluigi addr module.name strget 102544603Sdcs then 1026186789Sluigi addr module.type .len @ if 1027186789Sluigi addr module.type strget 102844603Sdcs s" -t " 102944603Sdcs 4 ( -t type name flags ) 103044603Sdcs else 103144603Sdcs 2 ( name flags ) 103244603Sdcs then 103344603Sdcs; 103444603Sdcs 103544603Sdcs: before_load ( addr -- addr ) 103644603Sdcs dup module.beforeload .len @ if 1037186789Sluigi dup module.beforeload strget 1038186789Sluigi ['] evaluate catch if EBEFORELOAD throw then 103944603Sdcs then 104044603Sdcs; 104144603Sdcs 104244603Sdcs: after_load ( addr -- addr ) 104344603Sdcs dup module.afterload .len @ if 1044186789Sluigi dup module.afterload strget 1045186789Sluigi ['] evaluate catch if EAFTERLOAD throw then 104644603Sdcs then 104744603Sdcs; 104844603Sdcs 104944603Sdcs: load_error ( addr -- addr ) 105044603Sdcs dup module.loaderror .len @ if 1051186789Sluigi dup module.loaderror strget 105244603Sdcs evaluate \ This we do not intercept so it can throw errors 105344603Sdcs then 105444603Sdcs; 105544603Sdcs 105644603Sdcs: pre_load_message ( addr -- addr ) 105744603Sdcs verbose? if 1058186789Sluigi dup module.name strtype 105944603Sdcs ." ..." 106044603Sdcs then 106144603Sdcs; 106244603Sdcs 106344603Sdcs: load_error_message verbose? if ." failed!" cr then ; 106444603Sdcs 106544603Sdcs: load_succesful_message verbose? if ." ok" cr then ; 106644603Sdcs 106744603Sdcs: load_module 106844603Sdcs load_parameters load 106944603Sdcs; 107044603Sdcs 107144603Sdcs: process_module ( addr -- addr ) 107244603Sdcs pre_load_message 107344603Sdcs before_load 107444603Sdcs begin 107544603Sdcs ['] load_module catch if 107644603Sdcs dup module.loaderror .len @ if 107744603Sdcs load_error \ Command should return a flag! 107844603Sdcs else 107944603Sdcs load_error_message true \ Do not retry 108044603Sdcs then 108144603Sdcs else 108244603Sdcs after_load 108344603Sdcs load_succesful_message true \ Succesful, do not retry 108444603Sdcs then 108544603Sdcs until 108644603Sdcs; 108744603Sdcs 108844603Sdcs: process_module_errors ( addr ior -- ) 1089186789Sluigi dup EBEFORELOAD = if 109044603Sdcs drop 109144603Sdcs ." Module " 1092186789Sluigi dup module.name strtype 109344603Sdcs dup module.loadname .len @ if 1094186789Sluigi ." (" dup module.loadname strtype ." )" 109544603Sdcs then 109644603Sdcs cr 109744603Sdcs ." Error executing " 1098186789Sluigi dup module.beforeload strtype cr \ XXX there was a typo here 109944603Sdcs abort 110044603Sdcs then 110144603Sdcs 1102186789Sluigi dup EAFTERLOAD = if 110344603Sdcs drop 110444603Sdcs ." Module " 110544603Sdcs dup module.name .addr @ over module.name .len @ type 110644603Sdcs dup module.loadname .len @ if 1107186789Sluigi ." (" dup module.loadname strtype ." )" 110844603Sdcs then 110944603Sdcs cr 111044603Sdcs ." Error executing " 1111186789Sluigi dup module.afterload strtype cr 111244603Sdcs abort 111344603Sdcs then 111444603Sdcs 111544603Sdcs throw \ Don't know what it is all about -- pass ahead 111644603Sdcs; 111744603Sdcs 111844603Sdcs\ Module loading interface 111944603Sdcs 1120186789Sluigi\ scan the list of modules, load enabled ones. 112144603Sdcs: load_modules ( -- ) ( throws: abort & user-defined ) 1122186789Sluigi module_options @ ( list_head ) 112344603Sdcs begin 112444603Sdcs ?dup 112544603Sdcs while 1126186789Sluigi dup module.flag @ if 112744603Sdcs ['] process_module catch 112844603Sdcs process_module_errors 112944603Sdcs then 113044603Sdcs module.next @ 113144603Sdcs repeat 113244603Sdcs; 113344603Sdcs 113465630Sdcs\ h00h00 magic used to try loading either a kernel with a given name, 113565630Sdcs\ or a kernel with the default name in a directory of a given name 113665630Sdcs\ (the pain!) 113744603Sdcs 113865630Sdcs: bootpath s" /boot/" ; 113965630Sdcs: modulepath s" module_path" ; 114065630Sdcs 114165630Sdcs\ Functions used to save and restore module_path's value. 114265630Sdcs: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 114365630Sdcs dup -1 = if 0 swap exit then 114465630Sdcs strdup 114565630Sdcs; 114665630Sdcs: freeenv ( addr len | 0 -1 ) 114765630Sdcs -1 = if drop else free abort" Freeing error" then 114865630Sdcs; 114965630Sdcs: restoreenv ( addr len | 0 -1 -- ) 115065630Sdcs dup -1 = if ( it wasn't set ) 115165630Sdcs 2drop 115265630Sdcs modulepath unsetenv 115365630Sdcs else 115465630Sdcs over >r 115565630Sdcs modulepath setenv 115665630Sdcs r> free abort" Freeing error" 115765630Sdcs then 115865630Sdcs; 115965630Sdcs 116065630Sdcs: clip_args \ Drop second string if only one argument is passed 116165630Sdcs 1 = if 116265630Sdcs 2swap 2drop 116365630Sdcs 1 116465630Sdcs else 116565630Sdcs 2 116665630Sdcs then 116765630Sdcs; 116865630Sdcs 116965630Sdcsalso builtins 117065630Sdcs 1171186789Sluigi\ Parse filename from a semicolon-separated list 117265630Sdcs 1173186789Sluigi\ replacement, not working yet 1174186789Sluigi: newparse-; { addr len | a1 -- a' len-x addr x } 1175186789Sluigi addr len [char] ; strchr dup if ( a1 len1 ) 1176186789Sluigi swap to a1 ( store address ) 1177186789Sluigi 1 - a1 @ 1 + swap ( remove match ) 1178186789Sluigi addr a1 addr - 1179186789Sluigi else 1180186789Sluigi 0 0 addr len 1181186789Sluigi then 1182186789Sluigi; 1183186789Sluigi 118465630Sdcs: parse-; ( addr len -- addr' len-x addr x ) 1185186789Sluigi over 0 2swap ( addr 0 addr len ) 118665630Sdcs begin 1187186789Sluigi dup 0 <> ( addr 0 addr len ) 118865630Sdcs while 1189186789Sluigi over c@ [char] ; <> ( addr 0 addr len flag ) 119065630Sdcs while 119165630Sdcs 1- swap 1+ swap 119265630Sdcs 2swap 1+ 2swap 119365630Sdcs repeat then 119465630Sdcs dup 0 <> if 119565630Sdcs 1- swap 1+ swap 119665630Sdcs then 119765630Sdcs 2swap 119865630Sdcs; 119965630Sdcs 120065630Sdcs\ Try loading one of multiple kernels specified 120165630Sdcs 120265630Sdcs: try_multiple_kernels ( addr len addr' len' args -- flag ) 120365630Sdcs >r 120465630Sdcs begin 120565630Sdcs parse-; 2>r 120665630Sdcs 2over 2r> 120765945Sdcs r@ clip_args 120865945Sdcs s" DEBUG" getenv? if 120965945Sdcs s" echo Module_path: ${module_path}" evaluate 121065945Sdcs ." Kernel : " >r 2dup type r> cr 121165945Sdcs dup 2 = if ." Flags : " >r 2over type r> cr then 121265945Sdcs then 121365945Sdcs 1 load 121465630Sdcs while 121565630Sdcs dup 0= 121665630Sdcs until 121765630Sdcs 1 >r \ Failure 121865630Sdcs else 121965630Sdcs 0 >r \ Success 122065630Sdcs then 122165630Sdcs 2drop 2drop 122265630Sdcs r> 122365630Sdcs r> drop 122465630Sdcs; 122565630Sdcs 122665630Sdcs\ Try to load a kernel; the kernel name is taken from one of 122765630Sdcs\ the following lists, as ordered: 122865630Sdcs\ 122965641Sdcs\ 1. The "bootfile" environment variable 123065641Sdcs\ 2. The "kernel" environment variable 123165630Sdcs\ 123265938Sdcs\ Flags are passed, if available. If not, dummy values must be given. 123365630Sdcs\ 123465630Sdcs\ The kernel gets loaded from the current module_path. 123565630Sdcs 123665938Sdcs: load_a_kernel ( flags len 1 | x x 0 -- flag ) 123765630Sdcs local args 123865630Sdcs 2local flags 123965630Sdcs 0 0 2local kernel 124065630Sdcs end-locals 124165630Sdcs 124265630Sdcs \ Check if a default kernel name exists at all, exits if not 124365641Sdcs s" bootfile" getenv dup -1 <> if 124465630Sdcs to kernel 124565883Sdcs flags kernel args 1+ try_multiple_kernels 124665630Sdcs dup 0= if exit then 124765630Sdcs then 124865630Sdcs drop 124965630Sdcs 125065641Sdcs s" kernel" getenv dup -1 <> if 125165630Sdcs to kernel 125265630Sdcs else 125365630Sdcs drop 125465630Sdcs 1 exit \ Failure 125565630Sdcs then 125665630Sdcs 125765630Sdcs \ Try all default kernel names 125865883Sdcs flags kernel args 1+ try_multiple_kernels 125965630Sdcs; 126065630Sdcs 126165630Sdcs\ Try to load a kernel; the kernel name is taken from one of 126265630Sdcs\ the following lists, as ordered: 126365630Sdcs\ 126465641Sdcs\ 1. The "bootfile" environment variable 126565641Sdcs\ 2. The "kernel" environment variable 126665630Sdcs\ 126765630Sdcs\ Flags are passed, if provided. 126865630Sdcs\ 126965630Sdcs\ The kernel will be loaded from a directory computed from the 127065630Sdcs\ path given. Two directories will be tried in the following order: 127165630Sdcs\ 127265630Sdcs\ 1. /boot/path 127365630Sdcs\ 2. path 127465630Sdcs\ 127565630Sdcs\ The module_path variable is overridden if load is succesful, by 127665630Sdcs\ prepending the successful path. 127765630Sdcs 127865630Sdcs: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 127965630Sdcs local args 128065630Sdcs 2local path 128165630Sdcs args 1 = if 0 0 then 128265630Sdcs 2local flags 1283186789Sluigi 0 0 2local oldmodulepath \ like a string 1284186789Sluigi 0 0 2local newmodulepath \ like a string 128565630Sdcs end-locals 128665630Sdcs 128765630Sdcs \ Set the environment variable module_path, and try loading 128865630Sdcs \ the kernel again. 128965630Sdcs modulepath getenv saveenv to oldmodulepath 129065630Sdcs 129165630Sdcs \ Try prepending /boot/ first 1292186789Sluigi bootpath nip path nip + \ total length 129365630Sdcs oldmodulepath nip dup -1 = if 129465630Sdcs drop 129565630Sdcs else 1296186789Sluigi 1+ + \ add oldpath -- XXX why the 1+ ? 129765630Sdcs then 1298186789Sluigi allocate if ( out of memory ) 1 exit then \ XXX throw ? 129965630Sdcs 130065630Sdcs 0 130165630Sdcs bootpath strcat 130265630Sdcs path strcat 130365630Sdcs 2dup to newmodulepath 130465630Sdcs modulepath setenv 130565630Sdcs 130665630Sdcs \ Try all default kernel names 130765938Sdcs flags args 1- load_a_kernel 130865630Sdcs 0= if ( success ) 130965630Sdcs oldmodulepath nip -1 <> if 131065630Sdcs newmodulepath s" ;" strcat 131165630Sdcs oldmodulepath strcat 131265630Sdcs modulepath setenv 131365630Sdcs newmodulepath drop free-memory 131465630Sdcs oldmodulepath drop free-memory 131565630Sdcs then 131665630Sdcs 0 exit 131765630Sdcs then 131865630Sdcs 131965630Sdcs \ Well, try without the prepended /boot/ 132065630Sdcs path newmodulepath drop swap move 132165883Sdcs newmodulepath drop path nip 132265630Sdcs 2dup to newmodulepath 132365630Sdcs modulepath setenv 132465630Sdcs 132565630Sdcs \ Try all default kernel names 132665938Sdcs flags args 1- load_a_kernel 132765630Sdcs if ( failed once more ) 132865630Sdcs oldmodulepath restoreenv 132965630Sdcs newmodulepath drop free-memory 133065630Sdcs 1 133165630Sdcs else 133265630Sdcs oldmodulepath nip -1 <> if 133365630Sdcs newmodulepath s" ;" strcat 133465630Sdcs oldmodulepath strcat 133565630Sdcs modulepath setenv 133665630Sdcs newmodulepath drop free-memory 133765630Sdcs oldmodulepath drop free-memory 133865630Sdcs then 133965630Sdcs 0 134065630Sdcs then 134165630Sdcs; 134265630Sdcs 134365630Sdcs\ Try to load a kernel; the kernel name is taken from one of 134465630Sdcs\ the following lists, as ordered: 134565630Sdcs\ 134665641Sdcs\ 1. The "bootfile" environment variable 134765641Sdcs\ 2. The "kernel" environment variable 134865630Sdcs\ 3. The "path" argument 134965630Sdcs\ 135065630Sdcs\ Flags are passed, if provided. 135165630Sdcs\ 135265630Sdcs\ The kernel will be loaded from a directory computed from the 135365630Sdcs\ path given. Two directories will be tried in the following order: 135465630Sdcs\ 135565630Sdcs\ 1. /boot/path 135665630Sdcs\ 2. path 135765630Sdcs\ 135865630Sdcs\ Unless "path" is meant to be kernel name itself. In that case, it 135965630Sdcs\ will first be tried as a full path, and, next, search on the 136065630Sdcs\ directories pointed by module_path. 136165630Sdcs\ 136265630Sdcs\ The module_path variable is overridden if load is succesful, by 136365630Sdcs\ prepending the successful path. 136465630Sdcs 136565630Sdcs: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 136665630Sdcs local args 136765630Sdcs 2local path 136865630Sdcs args 1 = if 0 0 then 136965630Sdcs 2local flags 137065630Sdcs end-locals 137165630Sdcs 137265630Sdcs \ First, assume path is an absolute path to a directory 137365630Sdcs flags path args clip_args load_from_directory 137465630Sdcs dup 0= if exit else drop then 137565630Sdcs 137665630Sdcs \ Next, assume path points to the kernel 137765630Sdcs flags path args try_multiple_kernels 137865630Sdcs; 137965630Sdcs 138044603Sdcs: initialize ( addr len -- ) 1381186789Sluigi strdup conf_files strset 138244603Sdcs; 138344603Sdcs 138465883Sdcs: kernel_options ( -- addr len 1 | 0 ) 138565630Sdcs s" kernel_options" getenv 138665883Sdcs dup -1 = if drop 0 else 1 then 138765630Sdcs; 138865630Sdcs 138965938Sdcs: standard_kernel_search ( flags 1 | 0 -- flag ) 139065938Sdcs local args 139165938Sdcs args 0= if 0 0 then 139265938Sdcs 2local flags 139365630Sdcs s" kernel" getenv 139465938Sdcs dup -1 = if 0 swap then 139565938Sdcs 2local path 139665938Sdcs end-locals 139765938Sdcs 139866349Sdcs path nip -1 = if ( there isn't a "kernel" environment variable ) 139965938Sdcs flags args load_a_kernel 140065938Sdcs else 140165938Sdcs flags path args 1+ clip_args load_directory_or_file 140265938Sdcs then 140365630Sdcs; 140465630Sdcs 140544603Sdcs: load_kernel ( -- ) ( throws: abort ) 140665938Sdcs kernel_options standard_kernel_search 140765630Sdcs abort" Unable to load a kernel!" 140844603Sdcs; 140965883Sdcs 141065949Sdcs: set_defaultoptions ( -- ) 141165883Sdcs s" kernel_options" getenv dup -1 = if 141265883Sdcs drop 141365883Sdcs else 141465883Sdcs s" temp_options" setenv 141565883Sdcs then 141665883Sdcs; 141765883Sdcs 1418186789Sluigi\ pick the i-th argument, i starts at 0 141965883Sdcs: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 1420186789Sluigi 2dup = if 0 0 exit then \ out of range 142165883Sdcs dup >r 142265883Sdcs 1+ 2* ( skip N and ui ) 142365883Sdcs pick 142465883Sdcs r> 142565883Sdcs 1+ 2* ( skip N and ai ) 142665883Sdcs pick 142765883Sdcs; 142865883Sdcs 142965949Sdcs: drop_args ( aN uN ... a1 u1 N -- ) 143065883Sdcs 0 ?do 2drop loop 143165883Sdcs; 143265883Sdcs 143365883Sdcs: argc 143465883Sdcs dup 143565883Sdcs; 143665883Sdcs 143765949Sdcs: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 143865883Sdcs >r 143965883Sdcs over 2* 1+ -roll 144065883Sdcs r> 144165883Sdcs over 2* 1+ -roll 144265883Sdcs 1+ 144365883Sdcs; 144465883Sdcs 144565949Sdcs: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 144665883Sdcs 1- -rot 144765883Sdcs; 144865883Sdcs 1449186789Sluigi\ compute the length of the buffer including the spaces between words 1450186789Sluigi: strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len ) 145165883Sdcs dup 0= if 0 exit then 145265883Sdcs 0 >r \ Size 145365883Sdcs 0 >r \ Index 145465883Sdcs begin 145565883Sdcs argc r@ <> 145665883Sdcs while 145765883Sdcs r@ argv[] 145865883Sdcs nip 145965883Sdcs r> r> rot + 1+ 146065883Sdcs >r 1+ >r 146165883Sdcs repeat 146265883Sdcs r> drop 146365883Sdcs r> 146465883Sdcs; 146565883Sdcs 146665949Sdcs: concat_argv ( aN uN ... a1 u1 N -- a u ) 1467186789Sluigi strlen(argv) allocate if ENOMEM throw then 1468186789Sluigi 0 2>r ( save addr 0 on return stack ) 146965883Sdcs 147065883Sdcs begin 1471186789Sluigi dup 147265883Sdcs while 1473186789Sluigi unqueue_argv ( ... N a1 u1 ) 1474186789Sluigi 2r> 2swap ( old a1 u1 ) 147565883Sdcs strcat 1476186789Sluigi s" " strcat ( append one space ) \ XXX this gives a trailing space 1477186789Sluigi 2>r ( store string on the result stack ) 147865883Sdcs repeat 147965949Sdcs drop_args 148065883Sdcs 2r> 148165883Sdcs; 148265883Sdcs 148365949Sdcs: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 148465883Sdcs \ Save the first argument, if it exists and is not a flag 148565883Sdcs argc if 148665883Sdcs 0 argv[] drop c@ [char] - <> if 148765949Sdcs unqueue_argv 2>r \ Filename 148865883Sdcs 1 >r \ Filename present 148965883Sdcs else 149065883Sdcs 0 >r \ Filename not present 149165883Sdcs then 149265883Sdcs else 149365883Sdcs 0 >r \ Filename not present 149465883Sdcs then 149565883Sdcs 149665883Sdcs \ If there are other arguments, assume they are flags 149765883Sdcs ?dup if 149865949Sdcs concat_argv 149965883Sdcs 2dup s" temp_options" setenv 1500186789Sluigi drop free if EFREE throw then 150165883Sdcs else 150265949Sdcs set_defaultoptions 150365883Sdcs then 150465883Sdcs 150565883Sdcs \ Bring back the filename, if one was provided 150665883Sdcs r> if 2r> 1 else 0 then 150765883Sdcs; 150865883Sdcs 150965949Sdcs: get_arguments ( -- addrN lenN ... addr1 len1 N ) 151065883Sdcs 0 151165883Sdcs begin 151265883Sdcs \ Get next word on the command line 151365883Sdcs parse-word 151465883Sdcs ?dup while 151565949Sdcs queue_argv 151665883Sdcs repeat 151765883Sdcs drop ( empty string ) 151865883Sdcs; 151965883Sdcs 152065945Sdcs: load_kernel_and_modules ( args -- flag ) 152165949Sdcs set_tempoptions 152265883Sdcs argc >r 152365883Sdcs s" temp_options" getenv dup -1 <> if 152465949Sdcs queue_argv 152565883Sdcs else 152665883Sdcs drop 152765883Sdcs then 152865883Sdcs r> if ( a path was passed ) 152965938Sdcs load_directory_or_file 153065883Sdcs else 153165938Sdcs standard_kernel_search 153265883Sdcs then 153365938Sdcs ?dup 0= if ['] load_modules catch then 153465883Sdcs; 153565883Sdcs 1536186789Sluigi\ read and store only as many bytes as we need, drop the extra 153753672Sdcs: read-password { size | buf len -- } 1538186789Sluigi size allocate if ENOMEM throw then 153953672Sdcs to buf 154053672Sdcs 0 to len 154153672Sdcs begin 154253672Sdcs key 154353672Sdcs dup backspace = if 154453672Sdcs drop 154553672Sdcs len if 154653672Sdcs backspace emit bl emit backspace emit 154753672Sdcs len 1 - to len 154853672Sdcs else 154953672Sdcs bell emit 155053672Sdcs then 155153672Sdcs else 155253672Sdcs dup <cr> = if cr drop buf len exit then 155353672Sdcs [char] * emit 1554186789Sluigi len size < if buf len chars + c! else drop then 155553672Sdcs len 1+ to len 155653672Sdcs then 155753672Sdcs again 155853672Sdcs; 155953672Sdcs 156044603Sdcs\ Go back to straight forth vocabulary 156144603Sdcs 156244603Sdcsonly forth also definitions 156344603Sdcs 1564