support.4th revision 65883
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 65883 2000-09-15 08:05:52Z dcs $ 2644603Sdcs 2744603Sdcs\ Loader.rc support functions: 2844603Sdcs\ 2944603Sdcs\ initialize_support ( -- ) initialize global variables 3044603Sdcs\ initialize ( addr len -- ) as above, plus load_conf_files 3144603Sdcs\ load_conf ( addr len -- ) load conf file given 3244603Sdcs\ include_conf_files ( -- ) load all conf files in load_conf_files 3344603Sdcs\ print_syntax_error ( -- ) print line and marker of where a syntax 3444603Sdcs\ error was detected 3544603Sdcs\ print_line ( -- ) print last line processed 3644603Sdcs\ load_kernel ( -- ) load kernel 3744603Sdcs\ load_modules ( -- ) load modules flagged 3844603Sdcs\ 3944603Sdcs\ Exported structures: 4044603Sdcs\ 4144603Sdcs\ string counted string structure 4244603Sdcs\ cell .addr string address 4344603Sdcs\ cell .len string length 4444603Sdcs\ module module loading information structure 4544603Sdcs\ cell module.flag should we load it? 4644603Sdcs\ string module.name module's name 4744603Sdcs\ string module.loadname name to be used in loading the module 4844603Sdcs\ string module.type module's type 4944603Sdcs\ string module.args flags to be passed during load 5044603Sdcs\ string module.beforeload command to be executed before load 5144603Sdcs\ string module.afterload command to be executed after load 5244603Sdcs\ string module.loaderror command to be executed if load fails 5344603Sdcs\ cell module.next list chain 5444603Sdcs\ 5544603Sdcs\ Exported global variables; 5644603Sdcs\ 5744603Sdcs\ string conf_files configuration files to be loaded 5844603Sdcs\ string password password 5944603Sdcs\ cell modules_options pointer to first module information 6044603Sdcs\ value verbose? indicates if user wants a verbose loading 6144603Sdcs\ value any_conf_read? indicates if a conf file was succesfully read 62186789Sluigi\ 6344603Sdcs\ Other exported words: 6444603Sdcs\ 6544603Sdcs\ strdup ( addr len -- addr' len) similar to strdup(3) 6644603Sdcs\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3) 6744603Sdcs\ strlen ( addr -- len ) similar to strlen(3) 6844603Sdcs\ s' ( | string' -- addr len | ) similar to s" 6944603Sdcs\ rudimentary structure support 70186789Sluigi 71186789Sluigi\ Exception values 72186789Sluigi 73186789Sluigi1 constant syntax_error 74186789Sluigi2 constant out_of_memory 75186789Sluigi3 constant free_error 76186789Sluigi4 constant set_error 77186789Sluigi5 constant read_error 78186789Sluigi6 constant open_error 7944603Sdcs7 constant exec_error 8087636Sjhb8 constant before_load_error 8187636Sjhb9 constant after_load_error 8287636Sjhb 8387636Sjhb\ Crude structure support 8487636Sjhb 8587636Sjhb: structure: 8687636Sjhb create here 0 , ['] drop , 0 8787636Sjhb does> create here swap dup @ allot cell+ @ execute 8887636Sjhb; 8987636Sjhb: member: create dup , over , + does> cell+ @ + ; 9044603Sdcs: ;structure swap ! ; 9144603Sdcs: constructor! >body cell+ ! ; 9265615Sdcs: constructor: over :noname ; 9365615Sdcs: ;constructor postpone ; swap cell+ ! ; immediate 9465615Sdcs: sizeof ' >body @ state @ if postpone literal then ; immediate 9565615Sdcs: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate 9644603Sdcs: ptr 1 cells member: ; 9744603Sdcs: int 1 cells member: ; 9865615Sdcs 9965615Sdcs\ String structure 10065615Sdcs 10144603Sdcsstructure: string 10244603Sdcs ptr .addr 10344603Sdcs int .len 10444603Sdcs constructor: 10544603Sdcs 0 over .addr ! 10644603Sdcs 0 swap .len ! 10744603Sdcs ;constructor 10844603Sdcs;structure 10944603Sdcs 11044603Sdcs 11165615Sdcs\ Module options linked list 11265615Sdcs 11365615Sdcsstructure: module 11465615Sdcs int module.flag 11544603Sdcs sizeof string member: module.name 11644603Sdcs sizeof string member: module.loadname 11765615Sdcs sizeof string member: module.type 11844603Sdcs sizeof string member: module.args 11944603Sdcs sizeof string member: module.beforeload 12044603Sdcs sizeof string member: module.afterload 12144603Sdcs sizeof string member: module.loaderror 12244603Sdcs ptr module.next 12344603Sdcs;structure 12444603Sdcs 12544603Sdcs\ Internal loader structures 12644603Sdcsstructure: preloaded_file 12744603Sdcs ptr pf.name 12844603Sdcs ptr pf.type 12944603Sdcs ptr pf.args 13044603Sdcs ptr pf.metadata \ file_metadata 13144603Sdcs int pf.loader 132186789Sluigi int pf.addr 133186789Sluigi int pf.size 13465615Sdcs ptr pf.modules \ kernel_module 13565615Sdcs ptr pf.next \ preloaded_file 13665615Sdcs;structure 13765615Sdcs 13865615Sdcsstructure: kernel_module 13965615Sdcs ptr km.name 14065615Sdcs \ ptr km.args 14165615Sdcs ptr km.fp \ preloaded_file 14265615Sdcs ptr km.next \ kernel_module 14365615Sdcs;structure 14465615Sdcs 14565615Sdcsstructure: file_metadata 14665615Sdcs int md.size 14765615Sdcs 2 member: md.type \ this is not ANS Forth compatible (XXX) 14865615Sdcs ptr md.next \ file_metadata 14965615Sdcs 0 member: md.data \ variable size 15065615Sdcs;structure 15165615Sdcs 15265615Sdcsstructure: config_resource 15365615Sdcs ptr cf.name 15465615Sdcs int cf.type 15565615Sdcs0 constant RES_INT 15665615Sdcs1 constant RES_STRING 15765615Sdcs2 constant RES_LONG 15865615Sdcs 2 cells member: u 15965615Sdcs;structure 160186789Sluigi 16165615Sdcsstructure: config_device 16244603Sdcs ptr cd.name 16344603Sdcs int cd.unit 16444603Sdcs int cd.resource_count 16597201Sgordon ptr cd.resources \ config_resource 16665615Sdcs;structure 16765615Sdcs 16844603Sdcsstructure: STAILQ_HEAD 16997201Sgordon ptr stqh_first \ type* 17044603Sdcs ptr stqh_last \ type** 17144603Sdcs;structure 172186789Sluigi 173186789Sluigistructure: STAILQ_ENTRY 174186789Sluigi ptr stqe_next \ type* 17544603Sdcs;structure 17644603Sdcs 17744603Sdcsstructure: pnphandler 17844603Sdcs ptr pnph.name 17944603Sdcs ptr pnph.enumerate 18044603Sdcs;structure 18144603Sdcs 182186789Sluigistructure: pnpident 18361373Sdcs ptr pnpid.ident \ char* 184186789Sluigi sizeof STAILQ_ENTRY cells member: pnpid.link \ pnpident 185186789Sluigi;structure 186186789Sluigi 187186789Sluigistructure: pnpinfo 188186789Sluigi ptr pnpi.desc 189186789Sluigi int pnpi.revision 190186789Sluigi ptr pnpi.module \ (char*) module args 19161373Sdcs int pnpi.argc 19261373Sdcs ptr pnpi.argv 193186789Sluigi ptr pnpi.handler \ pnphandler 19444603Sdcs sizeof STAILQ_HEAD member: pnpi.ident \ pnpident 195186789Sluigi sizeof STAILQ_ENTRY member: pnpi.link \ pnpinfo 19644603Sdcs;structure 19744603Sdcs 19861373Sdcs\ Global variables 19961373Sdcs 20065883Sdcsstring conf_files 20153672Sdcsstring password 202186789Sluigicreate module_options sizeof module.next allot 0 module_options ! 20365938Sdcscreate last_module_option sizeof module.next allot 0 last_module_option ! 204244048Sdteske0 value verbose? 205244048Sdteske 206244048Sdteske\ Support string functions 207244048Sdteske 208244048Sdteske: strdup ( addr len -- addr' len ) 209244048Sdteske >r r@ allocate if out_of_memory throw then 210244089Sdteske tuck r@ move 211244089Sdteske r> 212244048Sdteske; 213244048Sdteske 214244048Sdteske: strcat { addr len addr' len' -- addr len+len' } 215244048Sdteske addr' addr len + len' move 216244048Sdteske addr len len' + 217244048Sdteske; 218244089Sdteske 219244048Sdteske: strlen ( addr -- len ) 220244048Sdteske 0 >r 221244089Sdteske begin 222244089Sdteske dup c@ while 223244089Sdteske 1+ r> 1+ >r repeat 224244048Sdteske drop r> 225244048Sdteske; 226244048Sdteske 227244048Sdteske: s' 228244048Sdteske [char] ' parse 229244048Sdteske state @ if 230244048Sdteske postpone sliteral 231244048Sdteske then 232244048Sdteske; immediate 233244048Sdteske 234244048Sdteske: 2>r postpone >r postpone >r ; immediate 235244048Sdteske: 2r> postpone r> postpone r> ; immediate 236244048Sdteske: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate 237244048Sdteske 238244048Sdteske\ Private definitions 239244048Sdteske 240244048Sdteskevocabulary support-functions 241244048Sdteskeonly forth also support-functions definitions 242244048Sdteske 243244048Sdteske\ Some control characters constants 24444603Sdcs 24544603Sdcs7 constant bell 24644603Sdcs8 constant backspace 24744603Sdcs9 constant tab 24844603Sdcs10 constant lf 24944603Sdcs13 constant <cr> 25044603Sdcs 25153672Sdcs\ Read buffer size 25253672Sdcs 25344603Sdcs80 constant read_buffer_size 25444603Sdcs 25553672Sdcs\ Standard suffixes 25644603Sdcs 25744603Sdcs: load_module_suffix s" _load" ; 25844603Sdcs: module_loadname_suffix s" _name" ; 25944603Sdcs: module_type_suffix s" _type" ; 26044603Sdcs: module_args_suffix s" _flags" ; 26144603Sdcs: module_beforeload_suffix s" _before" ; 26244603Sdcs: module_afterload_suffix s" _after" ; 263186789Sluigi: module_loaderror_suffix s" _error" ; 264186789Sluigi 265186789Sluigi\ Support operators 266186789Sluigi 267186789Sluigi: >= < 0= ; 268186789Sluigi: <= > 0= ; 269186789Sluigi 27044603Sdcs\ Assorted support funcitons 27144603Sdcs 27244603Sdcs: free-memory free if free_error throw then ; 27344603Sdcs 27444603Sdcs\ Assignment data temporary storage 27544603Sdcs 276186789Sluigistring name_buffer 27744603Sdcsstring value_buffer 278186789Sluigi 27944603Sdcs\ Line by line file reading functions 280185746Sluigi\ 281185746Sluigi\ exported: 282185746Sluigi\ line_buffer 283186789Sluigi\ end_of_file? 284185746Sluigi\ fd 285185746Sluigi\ read_line 286185746Sluigi\ reset_line_reading 287185746Sluigi 288185746Sluigivocabulary line-reading 289185746Sluigialso line-reading definitions also 290185746Sluigi 291186789Sluigi\ File data temporary storage 292186789Sluigi 293186789Sluigistring read_buffer 294186789Sluigi0 value read_buffer_ptr 295186789Sluigi 296186789Sluigi\ File's line reading function 297186789Sluigi 298186789Sluigisupport-functions definitions 299186789Sluigi 300186789Sluigistring line_buffer 301186789Sluigi0 value end_of_file? 302186789Sluigivariable fd 30344603Sdcs 30444603Sdcsline-reading definitions 30544603Sdcs 30644603Sdcs: skip_newlines 30744603Sdcs begin 30865615Sdcs read_buffer .len @ read_buffer_ptr > 30965615Sdcs while 31065615Sdcs read_buffer .addr @ read_buffer_ptr + c@ lf = if 31165615Sdcs read_buffer_ptr char+ to read_buffer_ptr 31265615Sdcs else 31365615Sdcs exit 31465615Sdcs then 31565615Sdcs repeat 31665615Sdcs; 31765615Sdcs 318280937Sdteske: scan_buffer ( -- addr len ) 31965615Sdcs read_buffer_ptr >r 32044603Sdcs begin 32144603Sdcs read_buffer .len @ r@ > 32244603Sdcs while 32344603Sdcs read_buffer .addr @ r@ + c@ lf = if 32444603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 32544603Sdcs r@ read_buffer_ptr - ( -- len ) 32644603Sdcs r> to read_buffer_ptr 327280937Sdteske exit 32865615Sdcs then 32965615Sdcs r> char+ >r 33044603Sdcs repeat 33144603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 33244603Sdcs r@ read_buffer_ptr - ( -- len ) 333280937Sdteske r> to read_buffer_ptr 33465615Sdcs; 33544603Sdcs 33644603Sdcs: line_buffer_resize ( len -- len ) 33744603Sdcs >r 33844603Sdcs line_buffer .len @ if 33944603Sdcs line_buffer .addr @ 34044603Sdcs line_buffer .len @ r@ + 34144603Sdcs resize if out_of_memory throw then 34244603Sdcs else 34344603Sdcs r@ allocate if out_of_memory throw then 34444603Sdcs then 34544603Sdcs line_buffer .addr ! 34644603Sdcs r> 34744603Sdcs; 34844603Sdcs 34944603Sdcs: append_to_line_buffer ( addr len -- ) 35044603Sdcs line_buffer .addr @ line_buffer .len @ 35144603Sdcs 2swap strcat 35244603Sdcs line_buffer .len ! 35344603Sdcs drop 35444603Sdcs; 35544603Sdcs 35644603Sdcs: read_from_buffer 35744603Sdcs scan_buffer ( -- addr len ) 35844603Sdcs line_buffer_resize ( len -- len ) 35944603Sdcs append_to_line_buffer ( addr len -- ) 36044603Sdcs; 36144603Sdcs 36244603Sdcs: refill_required? 36344603Sdcs read_buffer .len @ read_buffer_ptr = 36444603Sdcs end_of_file? 0= and 36544603Sdcs; 36644603Sdcs 36744603Sdcs: refill_buffer 36844603Sdcs 0 to read_buffer_ptr 36944603Sdcs read_buffer .addr @ 0= if 370186789Sluigi read_buffer_size allocate if out_of_memory throw then 37144603Sdcs read_buffer .addr ! 372186789Sluigi then 37344603Sdcs fd @ read_buffer .addr @ read_buffer_size fread 37444603Sdcs dup -1 = if read_error throw then 37544603Sdcs dup 0= if true to end_of_file? then 37644603Sdcs read_buffer .len ! 37744603Sdcs; 37844603Sdcs 379186789Sluigi: reset_line_buffer 38044603Sdcs line_buffer .addr @ ?dup if 38144603Sdcs free-memory 38244603Sdcs then 38344603Sdcs 0 line_buffer .addr ! 38444603Sdcs 0 line_buffer .len ! 38544603Sdcs; 38644603Sdcs 38744603Sdcssupport-functions definitions 38844603Sdcs 38944603Sdcs: reset_line_reading 39044603Sdcs 0 to read_buffer_ptr 39144603Sdcs; 39244603Sdcs 39344603Sdcs: read_line 39444603Sdcs reset_line_buffer 39544603Sdcs skip_newlines 39644603Sdcs begin 39744603Sdcs read_from_buffer 39844603Sdcs refill_required? 399186789Sluigi while 40044603Sdcs refill_buffer 40144603Sdcs repeat 40244603Sdcs; 403186789Sluigi 40444603Sdcsonly forth also support-functions definitions 40544603Sdcs 40644603Sdcs\ Conf file line parser: 40744603Sdcs\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 408280937Sdteske\ <spaces>[<comment>] 40965615Sdcs\ <name> ::= <letter>{<letter>|<digit>|'_'} 41065615Sdcs\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 41165615Sdcs\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 41265615Sdcs\ <comment> ::= '#'{<anything>} 41365615Sdcs\ 41444603Sdcs\ exported: 415186789Sluigi\ line_pointer 41644603Sdcs\ process_conf 41744603Sdcs 41844603Sdcs0 value line_pointer 41944603Sdcs 42044603Sdcsvocabulary file-processing 42144603Sdcsalso file-processing definitions 42244603Sdcs 42344603Sdcs\ parser functions 42444603Sdcs\ 42565615Sdcs\ exported: 42665615Sdcs\ get_assignment 42744603Sdcs 42844603Sdcsvocabulary parser 42944603Sdcsalso parser definitions also 43044603Sdcs 43144603Sdcs0 value parsing_function 43244603Sdcs0 value end_of_line 43344603Sdcs 43465615Sdcs: end_of_line? 43565615Sdcs line_pointer end_of_line = 43665615Sdcs; 43765615Sdcs 43844603Sdcs: letter? 43965615Sdcs line_pointer c@ >r 44065615Sdcs r@ [char] A >= 44165615Sdcs r@ [char] Z <= and 44265615Sdcs r@ [char] a >= 44365615Sdcs r> [char] z <= and 44465615Sdcs or 44565615Sdcs; 44665615Sdcs 44765615Sdcs: digit? 44865615Sdcs line_pointer c@ >r 44965615Sdcs r@ [char] 0 >= 450280937Sdteske r> [char] 9 <= and 45165615Sdcs; 45244603Sdcs 45344603Sdcs: quote? 45444603Sdcs line_pointer c@ [char] " = 455186789Sluigi; 45644603Sdcs 457186789Sluigi: assignment_sign? 458186789Sluigi line_pointer c@ [char] = = 45944603Sdcs; 46044603Sdcs 46144603Sdcs: comment? 46244603Sdcs line_pointer c@ [char] # = 46344603Sdcs; 46444603Sdcs 46544603Sdcs: space? 46644603Sdcs line_pointer c@ bl = 46744603Sdcs line_pointer c@ tab = or 46844603Sdcs; 46944603Sdcs 470174777Sambrisko: backslash? 47144603Sdcs line_pointer c@ [char] \ = 47244603Sdcs; 473174777Sambrisko 47444603Sdcs: underscore? 47544603Sdcs line_pointer c@ [char] _ = 476186789Sluigi; 47744603Sdcs 478186789Sluigi: dot? 47944603Sdcs line_pointer c@ [char] . = 480186789Sluigi; 48144603Sdcs 482186789Sluigi: skip_character 48344603Sdcs line_pointer char+ to line_pointer 484186789Sluigi; 48544603Sdcs 486186789Sluigi: skip_to_end_of_line 48744603Sdcs end_of_line to line_pointer 488186789Sluigi; 48944603Sdcs 490186789Sluigi: eat_space 491186789Sluigi begin 49244603Sdcs space? 493186789Sluigi while 49444603Sdcs skip_character 49544603Sdcs end_of_line? if exit then 49644603Sdcs repeat 497186789Sluigi; 49844603Sdcs 49944603Sdcs: parse_name ( -- addr len ) 50044603Sdcs line_pointer 50144603Sdcs begin 50244603Sdcs letter? digit? underscore? dot? or or or 50344603Sdcs while 50444603Sdcs skip_character 50544603Sdcs end_of_line? if 506186789Sluigi line_pointer over - 50744603Sdcs strdup 50844603Sdcs exit 50944603Sdcs then 51044603Sdcs repeat 51144603Sdcs line_pointer over - 51244603Sdcs strdup 51344603Sdcs; 51444603Sdcs 515186789Sluigi: remove_backslashes { addr len | addr' len' -- addr' len' } 51644603Sdcs len allocate if out_of_memory throw then 51744603Sdcs to addr' 51844603Sdcs addr >r 51944603Sdcs begin 52044603Sdcs addr c@ [char] \ <> if 52144603Sdcs addr c@ addr' len' + c! 52244603Sdcs len' char+ to len' 52344603Sdcs then 52444603Sdcs addr char+ to addr 52544603Sdcs r@ len + addr = 52644603Sdcs until 52744603Sdcs r> drop 52844603Sdcs addr' len' 52944603Sdcs; 53044603Sdcs 53144603Sdcs: parse_quote ( -- addr len ) 53244603Sdcs line_pointer 533186789Sluigi skip_character 53444603Sdcs end_of_line? if syntax_error throw then 53544603Sdcs begin 53644603Sdcs quote? 0= 53744603Sdcs while 53844603Sdcs backslash? if 539186789Sluigi skip_character 54044603Sdcs end_of_line? if syntax_error throw then 54144603Sdcs then 542186789Sluigi skip_character 54344603Sdcs end_of_line? if syntax_error throw then 54444603Sdcs repeat 54544603Sdcs skip_character 54644603Sdcs line_pointer over - 54744603Sdcs remove_backslashes 54844603Sdcs; 54944603Sdcs 55044603Sdcs: read_name 551186789Sluigi parse_name ( -- addr len ) 55244603Sdcs name_buffer .len ! 55344603Sdcs name_buffer .addr ! 55444603Sdcs; 55544603Sdcs 55644603Sdcs: read_value 55744603Sdcs quote? if 55844603Sdcs parse_quote ( -- addr len ) 55944603Sdcs else 560186789Sluigi parse_name ( -- addr len ) 56144603Sdcs then 56244603Sdcs value_buffer .len ! 56344603Sdcs value_buffer .addr ! 56444603Sdcs; 56544603Sdcs 56644603Sdcs: comment 56744603Sdcs skip_to_end_of_line 56844603Sdcs; 56944603Sdcs 570186789Sluigi: white_space_4 57144603Sdcs eat_space 57244603Sdcs comment? if ['] comment to parsing_function exit then 57344603Sdcs end_of_line? 0= if syntax_error throw then 57444603Sdcs; 57544603Sdcs 57644603Sdcs: variable_value 57744603Sdcs read_value 57844603Sdcs ['] white_space_4 to parsing_function 57944603Sdcs; 58044603Sdcs 58144603Sdcs: white_space_3 58244603Sdcs eat_space 583186789Sluigi letter? digit? quote? or or if 58444603Sdcs ['] variable_value to parsing_function exit 58544603Sdcs then 58644603Sdcs syntax_error throw 58744603Sdcs; 58844603Sdcs 58944603Sdcs: assignment_sign 59044603Sdcs skip_character 59144603Sdcs ['] white_space_3 to parsing_function 59244603Sdcs; 59344603Sdcs 594186789Sluigi: white_space_2 59544603Sdcs eat_space 59644603Sdcs assignment_sign? if ['] assignment_sign to parsing_function exit then 59744603Sdcs syntax_error throw 59844603Sdcs; 59944603Sdcs 60044603Sdcs: variable_name 60144603Sdcs read_name 60244603Sdcs ['] white_space_2 to parsing_function 60344603Sdcs; 60444603Sdcs 60544603Sdcs: white_space_1 606186789Sluigi eat_space 60744603Sdcs letter? if ['] variable_name to parsing_function exit then 60844603Sdcs comment? if ['] comment to parsing_function exit then 609280937Sdteske end_of_line? 0= if syntax_error throw then 61065615Sdcs; 61144603Sdcs 612186789Sluigifile-processing definitions 61344603Sdcs 61444603Sdcs: get_assignment 61544603Sdcs line_buffer .addr @ line_buffer .len @ + to end_of_line 61644603Sdcs line_buffer .addr @ to line_pointer 61744603Sdcs ['] white_space_1 to parsing_function 61844603Sdcs begin 61944603Sdcs end_of_line? 0= 62044603Sdcs while 62144603Sdcs parsing_function execute 62244603Sdcs repeat 623186789Sluigi parsing_function ['] comment = 62444603Sdcs parsing_function ['] white_space_1 = 62544603Sdcs parsing_function ['] white_space_4 = 626280937Sdteske or or 0= if syntax_error throw then 62765615Sdcs; 62844603Sdcs 62944603Sdcsonly forth also support-functions also file-processing definitions also 63044603Sdcs 631186789Sluigi\ Process line 63244603Sdcs 63344603Sdcs: assignment_type? ( addr len -- flag ) 63444603Sdcs name_buffer .addr @ name_buffer .len @ 63544603Sdcs compare 0= 63644603Sdcs; 63744603Sdcs 63844603Sdcs: suffix_type? ( addr len -- flag ) 63944603Sdcs name_buffer .len @ over <= if 2drop false exit then 64044603Sdcs name_buffer .len @ over - name_buffer .addr @ + 641186789Sluigi over compare 0= 64244603Sdcs; 643186789Sluigi 64497201Sgordon: loader_conf_files? 645186789Sluigi s" loader_conf_files" assignment_type? 64697201Sgordon; 647186789Sluigi 64844603Sdcs: verbose_flag? 649186789Sluigi s" verbose_loading" assignment_type? 65044603Sdcs; 651186789Sluigi 65244603Sdcs: execute? 653186789Sluigi s" exec" assignment_type? 65444603Sdcs; 655186789Sluigi 65644603Sdcs: password? 657186789Sluigi s" password" assignment_type? 65844603Sdcs; 659186789Sluigi 66044603Sdcs: module_load? 661186789Sluigi load_module_suffix suffix_type? 66244603Sdcs; 663186789Sluigi 66444603Sdcs: module_loadname? 665186789Sluigi module_loadname_suffix suffix_type? 666186789Sluigi; 667186789Sluigi 668186789Sluigi: module_type? 669186789Sluigi module_type_suffix suffix_type? 670186789Sluigi; 671186789Sluigi 672186789Sluigi: module_args? 673186789Sluigi module_args_suffix suffix_type? 674186789Sluigi; 675186789Sluigi 676186789Sluigi: module_beforeload? 677186789Sluigi module_beforeload_suffix suffix_type? 67897201Sgordon; 67997201Sgordon 68097201Sgordon: module_afterload? 68197201Sgordon module_afterload_suffix suffix_type? 682186789Sluigi; 683186789Sluigi 684186789Sluigi: module_loaderror? 685186789Sluigi module_loaderror_suffix suffix_type? 686186789Sluigi; 687186789Sluigi 688186789Sluigi: set_conf_files 689186789Sluigi conf_files .addr @ ?dup if 690186789Sluigi free-memory 69144603Sdcs then 69244603Sdcs value_buffer .addr @ c@ [char] " = if 69344603Sdcs value_buffer .addr @ char+ value_buffer .len @ 2 chars - 69444603Sdcs else 69544603Sdcs value_buffer .addr @ value_buffer .len @ 69644603Sdcs then 69744603Sdcs strdup 69844603Sdcs conf_files .len ! conf_files .addr ! 69944603Sdcs; 70044603Sdcs 701186789Sluigi: append_to_module_options_list ( addr -- ) 702186789Sluigi module_options @ 0= if 70344603Sdcs dup module_options ! 70444603Sdcs last_module_option ! 70544603Sdcs else 706186789Sluigi dup last_module_option @ module.next ! 70744603Sdcs last_module_option ! 70844603Sdcs then 70944603Sdcs; 71044603Sdcs 71144603Sdcs: set_module_name ( addr -- ) 71244603Sdcs name_buffer .addr @ name_buffer .len @ 713186789Sluigi strdup 71444603Sdcs >r over module.name .addr ! 71544603Sdcs r> swap module.name .len ! 71644603Sdcs; 71744603Sdcs 718186789Sluigi: yes_value? 719186789Sluigi value_buffer .addr @ value_buffer .len @ 72044603Sdcs 2dup s' "YES"' compare >r 72144603Sdcs 2dup s' "yes"' compare >r 72244603Sdcs 2dup s" YES" compare >r 72344603Sdcs s" yes" compare r> r> r> and and and 0= 72444603Sdcs; 72544603Sdcs 726186789Sluigi: find_module_option ( -- addr | 0 ) 72744603Sdcs module_options @ 72844603Sdcs begin 72944603Sdcs dup 73044603Sdcs while 73144603Sdcs dup module.name dup .addr @ swap .len @ 73244603Sdcs name_buffer .addr @ name_buffer .len @ 73344603Sdcs compare 0= if exit then 73444603Sdcs module.next @ 73544603Sdcs repeat 73644603Sdcs; 73744603Sdcs 73844603Sdcs: new_module_option ( -- addr ) 73944603Sdcs sizeof module allocate if out_of_memory throw then 74044603Sdcs dup sizeof module erase 74144603Sdcs dup append_to_module_options_list 74244603Sdcs dup set_module_name 74344603Sdcs; 744186789Sluigi 745186789Sluigi: get_module_option ( -- addr ) 74644603Sdcs find_module_option 74744603Sdcs ?dup 0= if new_module_option then 74844603Sdcs; 74944603Sdcs 750186789Sluigi: set_module_flag 751186789Sluigi name_buffer .len @ load_module_suffix nip - name_buffer .len ! 75244603Sdcs yes_value? get_module_option module.flag ! 75344603Sdcs; 75444603Sdcs 75544603Sdcs: set_module_args 756186789Sluigi name_buffer .len @ module_args_suffix nip - name_buffer .len ! 757186789Sluigi get_module_option module.args 75844603Sdcs dup .addr @ ?dup if free-memory then 75944603Sdcs value_buffer .addr @ value_buffer .len @ 76044603Sdcs over c@ [char] " = if 76144603Sdcs 2 chars - swap char+ swap 762186789Sluigi then 763186789Sluigi strdup 76444603Sdcs >r over .addr ! 76544603Sdcs r> swap .len ! 76644603Sdcs; 76744603Sdcs 768186789Sluigi: set_module_loadname 769186789Sluigi name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 77044603Sdcs get_module_option module.loadname 77144603Sdcs dup .addr @ ?dup if free-memory then 77244603Sdcs value_buffer .addr @ value_buffer .len @ 77344603Sdcs over c@ [char] " = if 774186789Sluigi 2 chars - swap char+ swap 775186789Sluigi then 77644603Sdcs strdup 77744603Sdcs >r over .addr ! 77897201Sgordon r> swap .len ! 77997201Sgordon; 78097201Sgordon 78197201Sgordon: set_module_type 78244603Sdcs name_buffer .len @ module_type_suffix nip - name_buffer .len ! 78344603Sdcs get_module_option module.type 78444603Sdcs dup .addr @ ?dup if free-memory then 78544603Sdcs value_buffer .addr @ value_buffer .len @ 78644603Sdcs over c@ [char] " = if 787186789Sluigi 2 chars - swap char+ swap 788186789Sluigi then 78944603Sdcs strdup 79044603Sdcs >r over .addr ! 79144603Sdcs r> swap .len ! 79244603Sdcs; 79344603Sdcs 79497201Sgordon: set_module_beforeload 79597201Sgordon name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 79644603Sdcs get_module_option module.beforeload 79744603Sdcs dup .addr @ ?dup if free-memory then 79844603Sdcs value_buffer .addr @ value_buffer .len @ 79944603Sdcs over c@ [char] " = if 80044603Sdcs 2 chars - swap char+ swap 80144603Sdcs then 80244603Sdcs strdup 80344603Sdcs >r over .addr ! 80444603Sdcs r> swap .len ! 80544603Sdcs; 80644603Sdcs 80744603Sdcs: set_module_afterload 80853672Sdcs name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 80953672Sdcs get_module_option module.afterload 81053672Sdcs dup .addr @ ?dup if free-memory then 81153672Sdcs value_buffer .addr @ value_buffer .len @ 81253672Sdcs over c@ [char] " = if 81353672Sdcs 2 chars - swap char+ swap 81444603Sdcs then 815186789Sluigi strdup 816186789Sluigi >r over .addr ! 81744603Sdcs r> swap .len ! 81844603Sdcs; 81944603Sdcs 82044603Sdcs: set_module_loaderror 821280937Sdteske name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 82265615Sdcs get_module_option module.loaderror 82344603Sdcs dup .addr @ ?dup if free-memory then 82444603Sdcs value_buffer .addr @ value_buffer .len @ 82544603Sdcs over c@ [char] " = if 82644603Sdcs 2 chars - swap char+ swap 827186789Sluigi then 82844603Sdcs strdup 82944603Sdcs >r over .addr ! 83044603Sdcs r> swap .len ! 83144603Sdcs; 83244603Sdcs 83344603Sdcs: set_environment_variable 83444603Sdcs name_buffer .len @ 83544603Sdcs value_buffer .len @ + 83697201Sgordon 5 chars + 83797201Sgordon allocate if out_of_memory throw then 83897201Sgordon dup 0 ( addr -- addr addr len ) 83997201Sgordon s" set " strcat 840186789Sluigi name_buffer .addr @ name_buffer .len @ strcat 841186789Sluigi s" =" strcat 84297201Sgordon value_buffer .addr @ value_buffer .len @ strcat 84397201Sgordon ['] evaluate catch if 84497201Sgordon 2drop free drop 84597201Sgordon set_error throw 84697201Sgordon else 84797201Sgordon free-memory 84897201Sgordon then 84965615Sdcs; 85065615Sdcs 85144603Sdcs: set_verbose 85244603Sdcs yes_value? to verbose? 85344603Sdcs; 854187143Sluigi 85544603Sdcs: execute_command 85665615Sdcs value_buffer .addr @ value_buffer .len @ 85787636Sjhb over c@ [char] " = if 858186789Sluigi 2 - swap char+ swap 85944603Sdcs then 86044603Sdcs ['] evaluate catch if exec_error throw then 86144603Sdcs; 86244603Sdcs 86344603Sdcs: set_password 864186789Sluigi password .addr @ ?dup if free if free_error throw then then 86544603Sdcs value_buffer .addr @ c@ [char] " = if 86644603Sdcs value_buffer .addr @ char+ value_buffer .len @ 2 - strdup 867186789Sluigi value_buffer .addr @ free if free_error throw then 86844603Sdcs else 86944603Sdcs value_buffer .addr @ value_buffer .len @ 87044603Sdcs then 87144603Sdcs password .len ! password .addr ! 872186789Sluigi 0 value_buffer .addr ! 87344603Sdcs; 87444603Sdcs 87544603Sdcs: process_assignment 87644603Sdcs name_buffer .len @ 0= if exit then 87744603Sdcs loader_conf_files? if set_conf_files exit then 878186789Sluigi verbose_flag? if set_verbose exit then 879163327Sru execute? if execute_command exit then 88044603Sdcs password? if set_password exit then 88144603Sdcs module_load? if set_module_flag exit then 88244603Sdcs module_loadname? if set_module_loadname exit then 88344603Sdcs module_type? if set_module_type exit then 88444603Sdcs module_args? if set_module_args exit then 885186789Sluigi module_beforeload? if set_module_beforeload exit then 88644603Sdcs module_afterload? if set_module_afterload exit then 88744603Sdcs module_loaderror? if set_module_loaderror exit then 888186789Sluigi set_environment_variable 889186789Sluigi; 890186789Sluigi 891186789Sluigi\ free_buffer ( -- ) 892186789Sluigi\ 893186789Sluigi\ Free some pointers if needed. The code then tests for errors 894186789Sluigi\ in freeing, and throws an exception if needed. If a pointer is 895186789Sluigi\ not allocated, it's value (0) is used as flag. 896186789Sluigi 897186789Sluigi: free_buffers 898186789Sluigi name_buffer .addr @ dup if free then 899186789Sluigi value_buffer .addr @ dup if free then 900186789Sluigi or if free_error throw then 901186789Sluigi; 902186789Sluigi 903186789Sluigi: reset_assignment_buffers 904186789Sluigi 0 name_buffer .addr ! 905186789Sluigi 0 name_buffer .len ! 906186789Sluigi 0 value_buffer .addr ! 907186789Sluigi 0 value_buffer .len ! 908186789Sluigi; 909186789Sluigi 910186789Sluigi\ Higher level file processing 911186789Sluigi 912186789Sluigisupport-functions definitions 913186789Sluigi 914186789Sluigi: process_conf 915186789Sluigi begin 916186789Sluigi end_of_file? 0= 917186789Sluigi while 918186789Sluigi reset_assignment_buffers 919186789Sluigi read_line 920186789Sluigi get_assignment 921186789Sluigi ['] process_assignment catch 922186789Sluigi ['] free_buffers catch 92344603Sdcs swap throw throw 92444603Sdcs repeat 92544603Sdcs; 92644603Sdcs 92744603Sdcsonly forth also support-functions definitions 928186789Sluigi 92944603Sdcs: create_null_terminated_string { addr len -- addr' len } 93044603Sdcs len char+ allocate if out_of_memory throw then 93144603Sdcs >r 93244603Sdcs addr r@ len move 93344603Sdcs 0 r@ len + c! 93444603Sdcs r> len 93544603Sdcs; 93644603Sdcs 937186789Sluigi\ Interface to loading conf files 93844603Sdcs 93944603Sdcs: load_conf ( addr len -- ) 94044603Sdcs 0 to end_of_file? 94144603Sdcs reset_line_reading 94244603Sdcs create_null_terminated_string 94344603Sdcs over >r 94444603Sdcs fopen fd ! 945185746Sluigi r> free-memory 946187143Sluigi fd @ -1 = if open_error throw then 947185746Sluigi ['] process_conf catch 94844603Sdcs fd @ fclose 94944603Sdcs throw 95053672Sdcs; 95144603Sdcs 952186789Sluigi: print_line 95344603Sdcs line_buffer .addr @ line_buffer .len @ type cr 95453672Sdcs; 95544603Sdcs 95653672Sdcs: print_syntax_error 95744603Sdcs line_buffer .addr @ line_buffer .len @ type cr 95844603Sdcs line_buffer .addr @ 959186789Sluigi begin 96053672Sdcs line_pointer over <> 96153672Sdcs while 96244603Sdcs bl emit 96344603Sdcs char+ 96444603Sdcs repeat 96553672Sdcs drop 96644603Sdcs ." ^" cr 967186789Sluigi; 968186789Sluigi 96944603Sdcs\ Depuration support functions 97053672Sdcs 97144603Sdcsonly forth definitions also support-functions 97253672Sdcs 973187143Sluigi: test-file 97444603Sdcs ['] load_conf catch dup . 97544603Sdcs syntax_error = if cr print_syntax_error then 97644603Sdcs; 97744603Sdcs 97844603Sdcs: show-module-options 97944603Sdcs module_options @ 98044603Sdcs begin 98144603Sdcs ?dup 982186789Sluigi while 98344603Sdcs ." Name: " dup module.name dup .addr @ swap .len @ type cr 98444603Sdcs ." Path: " dup module.loadname dup .addr @ swap .len @ type cr 98544603Sdcs ." Type: " dup module.type dup .addr @ swap .len @ type cr 98644603Sdcs ." Flags: " dup module.args dup .addr @ swap .len @ type cr 98744603Sdcs ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr 988186789Sluigi ." After load: " dup module.afterload dup .addr @ swap .len @ type cr 98944603Sdcs ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr 99044603Sdcs ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr 99144603Sdcs module.next @ 992186789Sluigi repeat 99344603Sdcs; 99444603Sdcs 99544603Sdcsonly forth also support-functions definitions 996186789Sluigi 99744603Sdcs\ Variables used for processing multiple conf files 99844603Sdcs 999186789Sluigistring current_file_name 100044603Sdcsvariable current_conf_files 100144603Sdcs 100244603Sdcs\ Indicates if any conf file was succesfully read 1003186789Sluigi 1004186789Sluigi0 value any_conf_read? 100544603Sdcs 100644603Sdcs\ loader_conf_files processing support functions 100744603Sdcs 100844603Sdcs: set_current_conf_files 100944603Sdcs conf_files .addr @ current_conf_files ! 101044603Sdcs; 101144603Sdcs 1012186789Sluigi: get_conf_files 101344603Sdcs conf_files .addr @ conf_files .len @ strdup 1014186789Sluigi; 101544603Sdcs 1016186789Sluigi: recurse_on_conf_files? 101744603Sdcs current_conf_files @ conf_files .addr @ <> 101844603Sdcs; 1019185746Sluigi 102044603Sdcs: skip_leading_spaces { addr len pos -- addr len pos' } 102144603Sdcs begin 102244603Sdcs pos len = if addr len pos exit then 102397201Sgordon addr pos + c@ bl = 1024186789Sluigi while 102597201Sgordon pos char+ to pos 102697201Sgordon repeat 102797201Sgordon addr len pos 102897201Sgordon; 102997201Sgordon 1030186789Sluigi: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 103197201Sgordon pos len = if 103297201Sgordon addr free abort" Fatal error freeing memory" 103397201Sgordon 0 exit 103497201Sgordon then 103597201Sgordon pos >r 103697201Sgordon begin 103797201Sgordon addr pos + c@ bl <> 103897201Sgordon while 103997201Sgordon pos char+ to pos 104097201Sgordon pos len = if 104197201Sgordon addr len pos addr r@ + pos r> - exit 104297201Sgordon then 104397201Sgordon repeat 104497201Sgordon addr len pos addr r@ + pos r> - 104597201Sgordon; 104644603Sdcs 104744603Sdcs: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 1048186789Sluigi skip_leading_spaces 1049186789Sluigi get_file_name 1050186789Sluigi; 1051186789Sluigi 1052186789Sluigi: set_current_file_name 105344603Sdcs over current_file_name .addr ! 1054186789Sluigi dup current_file_name .len ! 105544603Sdcs; 1056186789Sluigi 1057186789Sluigi: print_current_file 105844603Sdcs current_file_name .addr @ current_file_name .len @ type 105944603Sdcs; 106044603Sdcs 106144603Sdcs: process_conf_errors 106244603Sdcs dup 0= if true to any_conf_read? drop exit then 106344603Sdcs >r 2drop r> 106444603Sdcs dup syntax_error = if 106544603Sdcs ." Warning: syntax error on file " print_current_file cr 106644603Sdcs print_syntax_error drop exit 1067186789Sluigi then 1068186789Sluigi dup set_error = if 106944603Sdcs ." Warning: bad definition on file " print_current_file cr 107044603Sdcs print_line drop exit 107144603Sdcs then 107244603Sdcs dup read_error = if 107344603Sdcs ." Warning: error reading file " print_current_file cr drop exit 1074186789Sluigi then 1075186789Sluigi dup open_error = if 107644603Sdcs verbose? if ." Warning: unable to open file " print_current_file cr then 107744603Sdcs drop exit 107844603Sdcs then 107944603Sdcs dup free_error = abort" Fatal error freeing memory" 108044603Sdcs dup out_of_memory = abort" Out of memory" 1081186789Sluigi throw \ Unknown error -- pass ahead 108244603Sdcs; 108344603Sdcs 108444603Sdcs\ Process loader_conf_files recursively 108544603Sdcs\ Interface to loader_conf_files processing 108644603Sdcs 108744603Sdcs: include_conf_files 1088186789Sluigi set_current_conf_files 108944603Sdcs get_conf_files 0 109044603Sdcs begin 109144603Sdcs get_next_file ?dup 109244603Sdcs while 109344603Sdcs set_current_file_name 109444603Sdcs ['] load_conf catch 109544603Sdcs process_conf_errors 109644603Sdcs recurse_on_conf_files? if recurse then 109744603Sdcs repeat 109844603Sdcs; 109944603Sdcs 110044603Sdcs\ Module loading functions 110144603Sdcs 110244603Sdcs: load_module? 110344603Sdcs module.flag @ 110444603Sdcs; 110544603Sdcs 110644603Sdcs: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N ) 110744603Sdcs dup >r 110844603Sdcs r@ module.args .addr @ r@ module.args .len @ 110944603Sdcs r@ module.loadname .len @ if 111044603Sdcs r@ module.loadname .addr @ r@ module.loadname .len @ 111144603Sdcs else 111244603Sdcs r@ module.name .addr @ r@ module.name .len @ 111344603Sdcs then 111444603Sdcs r@ module.type .len @ if 111544603Sdcs r@ module.type .addr @ r@ module.type .len @ 111644603Sdcs s" -t " 111744603Sdcs 4 ( -t type name flags ) 111844603Sdcs else 1119186789Sluigi 2 ( name flags ) 112044603Sdcs then 112144603Sdcs r> drop 1122186789Sluigi; 112344603Sdcs 1124186789Sluigi: before_load ( addr -- addr ) 112544603Sdcs dup module.beforeload .len @ if 112644603Sdcs dup module.beforeload .addr @ over module.beforeload .len @ 112744603Sdcs ['] evaluate catch if before_load_error throw then 1128186789Sluigi then 112944603Sdcs; 113044603Sdcs 113144603Sdcs: after_load ( addr -- addr ) 1132186789Sluigi dup module.afterload .len @ if 113344603Sdcs dup module.afterload .addr @ over module.afterload .len @ 113444603Sdcs ['] evaluate catch if after_load_error throw then 113544603Sdcs then 113644603Sdcs; 1137186789Sluigi 113844603Sdcs: load_error ( addr -- addr ) 113944603Sdcs dup module.loaderror .len @ if 114044603Sdcs dup module.loaderror .addr @ over module.loaderror .len @ 1141186789Sluigi evaluate \ This we do not intercept so it can throw errors 114244603Sdcs then 114344603Sdcs; 114444603Sdcs 114544603Sdcs: pre_load_message ( addr -- addr ) 114644603Sdcs verbose? if 114744603Sdcs dup module.name .addr @ over module.name .len @ type 114844603Sdcs ." ..." 114944603Sdcs then 1150186789Sluigi; 115144603Sdcs 1152186789Sluigi: load_error_message verbose? if ." failed!" cr then ; 115344603Sdcs 115444603Sdcs: load_succesful_message verbose? if ." ok" cr then ; 115544603Sdcs 1156186789Sluigi: load_module 115744603Sdcs load_parameters load 115844603Sdcs; 115944603Sdcs 116044603Sdcs: process_module ( addr -- addr ) 116144603Sdcs pre_load_message 116244603Sdcs before_load 116344603Sdcs begin 116465630Sdcs ['] load_module catch if 116565630Sdcs dup module.loaderror .len @ if 116665630Sdcs load_error \ Command should return a flag! 116744603Sdcs else 116865630Sdcs load_error_message true \ Do not retry 116965630Sdcs then 117065630Sdcs else 117165630Sdcs after_load 117265630Sdcs load_succesful_message true \ Succesful, do not retry 117365630Sdcs then 117465630Sdcs until 117565630Sdcs; 117665630Sdcs 117765630Sdcs: process_module_errors ( addr ior -- ) 117865630Sdcs dup before_load_error = if 117965630Sdcs drop 118065630Sdcs ." Module " 118165630Sdcs dup module.name .addr @ over module.name .len @ type 118265630Sdcs dup module.loadname .len @ if 118365630Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 118465630Sdcs then 118565630Sdcs cr 118665630Sdcs ." Error executing " 118765630Sdcs dup module.beforeload .addr @ over module.afterload .len @ type cr 118865630Sdcs abort 118965630Sdcs then 119065630Sdcs 119165630Sdcs dup after_load_error = if 119265630Sdcs drop 119365630Sdcs ." Module " 119465630Sdcs dup module.name .addr @ over module.name .len @ type 119565630Sdcs dup module.loadname .len @ if 119665630Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 119765630Sdcs then 119865630Sdcs cr 119965630Sdcs ." Error executing " 120065630Sdcs dup module.afterload .addr @ over module.afterload .len @ type cr 1201186789Sluigi abort 120265630Sdcs then 1203186789Sluigi 1204186789Sluigi throw \ Don't know what it is all about -- pass ahead 1205186789Sluigi; 1206186789Sluigi 1207186789Sluigi\ Module loading interface 1208186789Sluigi 1209186789Sluigi: load_modules ( -- ) ( throws: abort & user-defined ) 1210186789Sluigi module_options @ 1211186789Sluigi begin 1212186789Sluigi ?dup 1213186789Sluigi while 121465630Sdcs dup load_module? if 1215186789Sluigi ['] process_module catch 121665630Sdcs process_module_errors 1217186789Sluigi then 121865630Sdcs module.next @ 1219186789Sluigi repeat 122065630Sdcs; 122165630Sdcs 122265630Sdcs\ h00h00 magic used to try loading either a kernel with a given name, 122365630Sdcs\ or a kernel with the default name in a directory of a given name 122465630Sdcs\ (the pain!) 122565630Sdcs 122665630Sdcs: bootpath s" /boot/" ; 122765630Sdcs: modulepath s" module_path" ; 122865630Sdcs 122965630Sdcs\ Functions used to save and restore module_path's value. 123065630Sdcs: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 123165630Sdcs dup -1 = if 0 swap exit then 123265630Sdcs strdup 123365630Sdcs; 123465630Sdcs: freeenv ( addr len | 0 -1 ) 123565630Sdcs -1 = if drop else free abort" Freeing error" then 123665630Sdcs; 123765945Sdcs: restoreenv ( addr len | 0 -1 -- ) 123865945Sdcs dup -1 = if ( it wasn't set ) 123965945Sdcs 2drop 124065945Sdcs modulepath unsetenv 124165945Sdcs else 124265945Sdcs over >r 124365945Sdcs modulepath setenv 124465630Sdcs r> free abort" Freeing error" 124565630Sdcs then 124665630Sdcs; 124765630Sdcs 124865630Sdcs: clip_args \ Drop second string if only one argument is passed 124965630Sdcs 1 = if 125065630Sdcs 2swap 2drop 125165630Sdcs 1 125265630Sdcs else 125365630Sdcs 2 125465630Sdcs then 125565630Sdcs; 125665630Sdcs 125765630Sdcsalso builtins 125865630Sdcs 125965641Sdcs\ Parse filename from a comma-separated list 126065641Sdcs 126165630Sdcs: parse-; ( addr len -- addr' len-x addr x ) 126265938Sdcs over 0 2swap 126365630Sdcs begin 126465630Sdcs dup 0 <> 126565630Sdcs while 126665938Sdcs over c@ [char] ; <> 126765630Sdcs while 126865630Sdcs 1- swap 1+ swap 126965630Sdcs 2swap 1+ 2swap 127065630Sdcs repeat then 127165630Sdcs dup 0 <> if 127265630Sdcs 1- swap 1+ swap 127365641Sdcs then 127465630Sdcs 2swap 127565883Sdcs; 127665630Sdcs 127765630Sdcs\ Try loading one of multiple kernels specified 127865630Sdcs 127965630Sdcs: try_multiple_kernels ( addr len addr' len' args -- flag ) 128065641Sdcs >r 128165630Sdcs begin 128265630Sdcs parse-; 2>r 128365630Sdcs 2over 2r> 128465630Sdcs r@ clip_args 1 load 128565630Sdcs while 128665630Sdcs dup 0= 128765630Sdcs until 128865883Sdcs 1 >r \ Failure 128965630Sdcs else 129065630Sdcs 0 >r \ Success 129165630Sdcs then 129265630Sdcs 2drop 2drop 129365630Sdcs r> 129465641Sdcs r> drop 129565641Sdcs; 129665630Sdcs 129765630Sdcs\ Try to load a kernel; the kernel name is taken from one of 129865630Sdcs\ the following lists, as ordered: 129965630Sdcs\ 130065630Sdcs\ 1. The "bootfile" environment variable 130165630Sdcs\ 2. The "kernel" environment variable 130265630Sdcs\ 130365630Sdcs\ Flags are passed, if available. 130465630Sdcs\ 130565630Sdcs\ The kernel gets loaded from the current module_path. 130665630Sdcs 130765630Sdcs: load_a_kernel ( flags len 1 | 0 -- flag ) 130865630Sdcs local args 130965630Sdcs args 0= if 0 0 then 131065630Sdcs 2local flags 131165630Sdcs 0 0 2local kernel 131265630Sdcs end-locals 1313186789Sluigi 1314186789Sluigi \ Check if a default kernel name exists at all, exits if not 131565630Sdcs s" bootfile" getenv dup -1 <> if 131665630Sdcs to kernel 131765630Sdcs flags kernel args 1+ try_multiple_kernels 131865630Sdcs dup 0= if exit then 131965630Sdcs then 132065630Sdcs drop 132165630Sdcs 1322186789Sluigi s" kernel" getenv dup -1 <> if 132365630Sdcs to kernel 132465630Sdcs else 132565630Sdcs drop 1326186789Sluigi 1 exit \ Failure 132765630Sdcs then 1328186789Sluigi 132965630Sdcs \ Try all default kernel names 133065630Sdcs flags kernel args 1+ try_multiple_kernels 133165630Sdcs; 133265630Sdcs 133365630Sdcs\ Try to load a kernel; the kernel name is taken from one of 133465630Sdcs\ the following lists, as ordered: 133565630Sdcs\ 133665630Sdcs\ 1. The "bootfile" environment variable 133765938Sdcs\ 2. The "kernel" environment variable 133865630Sdcs\ 133965630Sdcs\ Flags are passed, if provided. 134065630Sdcs\ 134165630Sdcs\ The kernel will be loaded from a directory computed from the 134265630Sdcs\ path given. Two directories will be tried in the following order: 134365630Sdcs\ 134465630Sdcs\ 1. /boot/path 134565630Sdcs\ 2. path 134665630Sdcs\ 134765630Sdcs\ The module_path variable is overridden if load is succesful, by 134865630Sdcs\ prepending the successful path. 134965630Sdcs 135065630Sdcs: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 135165883Sdcs local args 135265630Sdcs 2local path 135365630Sdcs args 1 = if 0 0 then 135465630Sdcs 2local flags 135565630Sdcs 0 0 2local oldmodulepath 135665938Sdcs 0 0 2local newmodulepath 135765630Sdcs end-locals 135865630Sdcs 135965630Sdcs \ Set the environment variable module_path, and try loading 136065630Sdcs \ the kernel again. 136165630Sdcs modulepath getenv saveenv to oldmodulepath 136265630Sdcs 136365630Sdcs \ Try prepending /boot/ first 136465630Sdcs bootpath nip path nip + 136565630Sdcs oldmodulepath nip dup -1 = if 136665630Sdcs drop 136765630Sdcs else 136865630Sdcs 1+ + 136965630Sdcs then 137065630Sdcs allocate 137165630Sdcs if ( out of memory ) 137265630Sdcs 1 exit 137365630Sdcs then 137465630Sdcs 137565630Sdcs 0 137665641Sdcs bootpath strcat 137765641Sdcs path strcat 137865630Sdcs 2dup to newmodulepath 137965630Sdcs modulepath setenv 138065630Sdcs 138165630Sdcs \ Try all default kernel names 138265630Sdcs args 2 = if flags 1 else 0 then 138365630Sdcs load_a_kernel 138465630Sdcs 0= if ( success ) 138565630Sdcs oldmodulepath nip -1 <> if 138665630Sdcs newmodulepath s" ;" strcat 138765630Sdcs oldmodulepath strcat 138865630Sdcs modulepath setenv 138965630Sdcs newmodulepath drop free-memory 139065630Sdcs oldmodulepath drop free-memory 139165630Sdcs then 139265630Sdcs 0 exit 139365630Sdcs then 139465630Sdcs 139565630Sdcs \ Well, try without the prepended /boot/ 139665630Sdcs path newmodulepath drop swap move 139765630Sdcs newmodulepath drop path nip 139865630Sdcs 2dup to newmodulepath 139965630Sdcs modulepath setenv 140065630Sdcs 140165630Sdcs \ Try all default kernel names 140265630Sdcs args 2 = if flags 1 else 0 then 140365630Sdcs load_a_kernel 140465630Sdcs if ( failed once more ) 140565630Sdcs oldmodulepath restoreenv 140665630Sdcs newmodulepath drop free-memory 140765630Sdcs 1 140865630Sdcs else 140965630Sdcs oldmodulepath nip -1 <> if 141044603Sdcs newmodulepath s" ;" strcat 1411186789Sluigi oldmodulepath strcat 141244603Sdcs modulepath setenv 141344603Sdcs newmodulepath drop free-memory 141465883Sdcs oldmodulepath drop free-memory 141565630Sdcs then 141665883Sdcs 0 141765630Sdcs then 141865630Sdcs; 141965938Sdcs 142065938Sdcs\ Try to load a kernel; the kernel name is taken from one of 142165938Sdcs\ the following lists, as ordered: 142265938Sdcs\ 142365630Sdcs\ 1. The "bootfile" environment variable 142465938Sdcs\ 2. The "kernel" environment variable 142565938Sdcs\ 3. The "path" argument 142665938Sdcs\ 142765938Sdcs\ Flags are passed, if provided. 142866349Sdcs\ 142965938Sdcs\ The kernel will be loaded from a directory computed from the 143065938Sdcs\ path given. Two directories will be tried in the following order: 143165938Sdcs\ 143265938Sdcs\ 1. /boot/path 143365630Sdcs\ 2. path 143465630Sdcs\ 143544603Sdcs\ Unless "path" is meant to be kernel name itself. In that case, it 143665938Sdcs\ will first be tried as a full path, and, next, search on the 143765630Sdcs\ directories pointed by module_path. 143844603Sdcs\ 143965883Sdcs\ The module_path variable is overridden if load is succesful, by 1440283933Sdteske\ prepending the successful path. 1441277215Sroyger 1442283933Sdteske: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 1443277215Sroyger local args 1444277215Sroyger 2local path 1445283933Sdteske args 1 = if 0 0 then 1446277215Sroyger 2local flags 1447277215Sroyger end-locals 1448277215Sroyger 1449277215Sroyger \ First, assume path is an absolute path to a directory 1450277215Sroyger flags path args clip_args load_from_directory 1451277215Sroyger dup 0= if exit else drop then 1452277215Sroyger 1453277215Sroyger \ Next, assume path points to the kernel 145465949Sdcs flags path args try_multiple_kernels 145565883Sdcs; 145665883Sdcs 145765883Sdcs: load_kernel_and_modules ( flags len path len' 2 | path len' 1 -- flag ) 145865883Sdcs load_directory_or_file 145965883Sdcs ?dup 0= if ['] load_modules catch then 146065883Sdcs; 146165883Sdcs 1462186789Sluigi: initialize ( addr len -- ) 146365883Sdcs strdup conf_files .len ! conf_files .addr ! 1464186789Sluigi; 146565883Sdcs 146665883Sdcs: kernel_options ( -- addr len 1 | 0 ) 146765883Sdcs s" kernel_options" getenv 146865883Sdcs dup -1 = if drop 0 else 1 then 146965883Sdcs; 147065883Sdcs 147165883Sdcs: kernel_and_options ( a u 1 | 0 -- a u a' u' 2 | a' u' 1 ) 147265883Sdcs kernel_options 147365949Sdcs s" kernel" getenv 147465883Sdcs rot 1+ 147565883Sdcs; 147665883Sdcs 147765883Sdcs: load_kernel ( -- ) ( throws: abort ) 147865883Sdcs s" kernel" getenv 147965883Sdcs dup -1 = if ( there isn't a "kernel" environment variable, try bootfile ) 148065883Sdcs drop 148165949Sdcs kernel_options load_a_kernel 148265883Sdcs else ( try finding a kernel using ${kernel} in various ways ) 148365883Sdcs kernel_options >r 2swap r> clip_args load_from_directory 148465883Sdcs dup if 148565883Sdcs drop 148665883Sdcs kernel_and_options try_multiple_kernels 148765883Sdcs then 148865883Sdcs then 148965949Sdcs abort" Unable to load a kernel!" 149065883Sdcs; 149165883Sdcs 149265883Sdcs: set-defaultoptions ( -- ) 1493186789Sluigi s" kernel_options" getenv dup -1 = if 1494186789Sluigi drop 149565883Sdcs else 149665883Sdcs s" temp_options" setenv 149765883Sdcs then 149865883Sdcs; 149965883Sdcs 150065883Sdcs: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 150165883Sdcs 2dup = if 0 0 exit then 150265883Sdcs dup >r 150365883Sdcs 1+ 2* ( skip N and ui ) 150465883Sdcs pick 150565883Sdcs r> 150665883Sdcs 1+ 2* ( skip N and ai ) 150765883Sdcs pick 150865883Sdcs; 150965883Sdcs 151065949Sdcs: drop-args ( aN uN ... a1 u1 N -- ) 1511186789Sluigi 0 ?do 2drop loop 1512186789Sluigi; 151365883Sdcs 151465883Sdcs: argc 1515186789Sluigi dup 151665883Sdcs; 1517186789Sluigi 1518186789Sluigi: queue-argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 151965883Sdcs >r 1520186789Sluigi over 2* 1+ -roll 1521186789Sluigi r> 152265883Sdcs over 2* 1+ -roll 152365949Sdcs 1+ 152465883Sdcs; 152565883Sdcs 152665883Sdcs: unqueue-argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 152765949Sdcs 1- -rot 152865883Sdcs; 152965883Sdcs 153065883Sdcs: strlen(argv) 153165949Sdcs dup 0= if 0 exit then 153265883Sdcs 0 >r \ Size 153365883Sdcs 0 >r \ Index 153465883Sdcs begin 153565883Sdcs argc r@ <> 153665883Sdcs while 153765883Sdcs r@ argv[] 153865883Sdcs nip 153965883Sdcs r> r> rot + 1+ 154065883Sdcs >r 1+ >r 154165883Sdcs repeat 154265949Sdcs r> drop 154365883Sdcs r> 1544186789Sluigi; 154565883Sdcs 154665949Sdcs: concat-argv ( aN uN ... a1 u1 N -- a u ) 154765883Sdcs strlen(argv) allocate if out_of_memory throw then 154865883Sdcs 0 2>r 154965883Sdcs 155065883Sdcs begin 155165883Sdcs argc 155265883Sdcs while 155365949Sdcs unqueue-argv 155465883Sdcs 2r> 2swap 155565883Sdcs strcat 155665883Sdcs s" " strcat 155765883Sdcs 2>r 155865883Sdcs repeat 155965949Sdcs drop-args 156065883Sdcs 2r> 156165883Sdcs; 156265883Sdcs 156365883Sdcs: set-tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 156465945Sdcs \ Save the first argument, if it exists and is not a flag 156565949Sdcs argc if 156665883Sdcs 0 argv[] drop c@ [char] - <> if 156765883Sdcs unqueue-argv 2>r \ Filename 156865949Sdcs 1 >r \ Filename present 156965883Sdcs else 157065883Sdcs 0 >r \ Filename not present 157165883Sdcs then 1572277215Sroyger else 1573277215Sroyger 0 >r \ Filename not present 1574277215Sroyger then 1575277215Sroyger 1576277215Sroyger \ If there are other arguments, assume they are flags 1577277215Sroyger ?dup if 1578277215Sroyger concat-argv 1579277215Sroyger 2dup s" temp_options" setenv 158065883Sdcs drop free if free_error throw then 158165883Sdcs else 158265883Sdcs set-defaultoptions 1583280937Sdteske then 1584 1585 \ Bring back the filename, if one was provided 1586 r> if 2r> 1 else 0 then 1587; 1588 1589: get-arguments ( -- addrN lenN ... addr1 len1 N ) 1590 0 1591 begin 1592 \ Get next word on the command line 1593 parse-word 1594 ?dup while 1595 queue-argv 1596 repeat 1597 drop ( empty string ) 1598; 1599 1600: load-conf ( args -- flag ) 1601 set-tempoptions 1602 argc >r 1603 s" temp_options" getenv dup -1 <> if 1604 queue-argv 1605 else 1606 drop 1607 then 1608 r> if ( a path was passed ) 1609 load_kernel_and_modules 1610 else 1611 load_a_kernel 1612 ?dup 0= if ['] load_modules catch then 1613 then 1614; 1615 1616: read-password { size | buf len -- } 1617 size allocate if out_of_memory throw then 1618 to buf 1619 0 to len 1620 begin 1621 key 1622 dup backspace = if 1623 drop 1624 len if 1625 backspace emit bl emit backspace emit 1626 len 1 - to len 1627 else 1628 bell emit 1629 then 1630 else 1631 dup <cr> = if cr drop buf len exit then 1632 [char] * emit 1633 len size < if 1634 buf len chars + c! 1635 else 1636 drop 1637 then 1638 len 1+ to len 1639 then 1640 again 1641; 1642 1643\ Go back to straight forth vocabulary 1644 1645only forth also definitions 1646 1647