support.4th revision 44603
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\ 2544603Sdcs\ $Id$ 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\ 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: 6344603Sdcs\ 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 7144603Sdcs1 constant syntax_error 7244603Sdcs2 constant out_of_memory 7344603Sdcs3 constant free_error 7444603Sdcs4 constant set_error 7544603Sdcs5 constant read_error 7644603Sdcs6 constant open_error 7744603Sdcs7 constant exec_error 7844603Sdcs8 constant before_load_error 7944603Sdcs9 constant after_load_error 8044603Sdcs 8144603Sdcs\ Crude structure support 8244603Sdcs 8344603Sdcs: structure: create here 0 , 0 does> create @ allot ; 8444603Sdcs: member: create dup , over , + does> cell+ @ + ; 8544603Sdcs: ;structure swap ! ; 8644603Sdcs: sizeof ' >body @ state @ if postpone literal then ; immediate 8744603Sdcs: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate 8844603Sdcs: ptr 1 cells member: ; 8944603Sdcs: int 1 cells member: ; 9044603Sdcs 9144603Sdcs\ String structure 9244603Sdcs 9344603Sdcsstructure: string 9444603Sdcs ptr .addr 9544603Sdcs int .len 9644603Sdcs;structure 9744603Sdcs 9844603Sdcs\ Module options linked list 9944603Sdcs 10044603Sdcsstructure: module 10144603Sdcs int module.flag 10244603Sdcs sizeof string member: module.name 10344603Sdcs sizeof string member: module.loadname 10444603Sdcs sizeof string member: module.type 10544603Sdcs sizeof string member: module.args 10644603Sdcs sizeof string member: module.beforeload 10744603Sdcs sizeof string member: module.afterload 10844603Sdcs sizeof string member: module.loaderror 10944603Sdcs ptr module.next 11044603Sdcs;structure 11144603Sdcs 11244603Sdcs\ Global variables 11344603Sdcs 11444603Sdcsstring conf_files 11544603Sdcscreate module_options sizeof module.next allot 11644603Sdcscreate last_module_option sizeof module.next allot 11744603Sdcs0 value verbose? 11844603Sdcs 11944603Sdcs\ Support string functions 12044603Sdcs 12144603Sdcs: strdup ( addr len -- addr' len ) 12244603Sdcs >r r@ allocate if out_of_memory throw then 12344603Sdcs tuck r@ move 12444603Sdcs r> 12544603Sdcs; 12644603Sdcs 12744603Sdcs: strcat { addr len addr' len' -- addr len+len' } 12844603Sdcs addr' addr len + len' move 12944603Sdcs addr len len' + 13044603Sdcs; 13144603Sdcs 13244603Sdcs: s' 13344603Sdcs [char] ' parse 13444603Sdcs state @ if 13544603Sdcs postpone sliteral 13644603Sdcs then 13744603Sdcs; immediate 13844603Sdcs 13944603Sdcs\ Private definitions 14044603Sdcs 14144603Sdcsvocabulary support-functions 14244603Sdcsonly forth also support-functions definitions 14344603Sdcs 14444603Sdcs\ Some control characters constants 14544603Sdcs 14644603Sdcs9 constant tab 14744603Sdcs10 constant lf 14844603Sdcs 14944603Sdcs\ Read buffer size 15044603Sdcs 15144603Sdcs80 constant read_buffer_size 15244603Sdcs 15344603Sdcs\ Standard suffixes 15444603Sdcs 15544603Sdcs: load_module_suffix s" _load" ; 15644603Sdcs: module_loadname_suffix s" _name" ; 15744603Sdcs: module_type_suffix s" _type" ; 15844603Sdcs: module_args_suffix s" _flags" ; 15944603Sdcs: module_beforeload_suffix s" _before" ; 16044603Sdcs: module_afterload_suffix s" _after" ; 16144603Sdcs: module_loaderror_suffix s" _error" ; 16244603Sdcs 16344603Sdcs\ Support operators 16444603Sdcs 16544603Sdcs: >= < 0= ; 16644603Sdcs: <= > 0= ; 16744603Sdcs 16844603Sdcs\ Assorted support funcitons 16944603Sdcs 17044603Sdcs: free-memory free if free_error throw then ; 17144603Sdcs 17244603Sdcs\ Assignment data temporary storage 17344603Sdcs 17444603Sdcsstring name_buffer 17544603Sdcsstring value_buffer 17644603Sdcs 17744603Sdcs\ File data temporary storage 17844603Sdcs 17944603Sdcsstring line_buffer 18044603Sdcsstring read_buffer 18144603Sdcs0 value read_buffer_ptr 18244603Sdcs 18344603Sdcs\ File's line reading function 18444603Sdcs 18544603Sdcs0 value end_of_file? 18644603Sdcsvariable fd 18744603Sdcs 18844603Sdcs: skip_newlines 18944603Sdcs begin 19044603Sdcs read_buffer .len @ read_buffer_ptr > 19144603Sdcs while 19244603Sdcs read_buffer .addr @ read_buffer_ptr + c@ lf = if 19344603Sdcs read_buffer_ptr char+ to read_buffer_ptr 19444603Sdcs else 19544603Sdcs exit 19644603Sdcs then 19744603Sdcs repeat 19844603Sdcs; 19944603Sdcs 20044603Sdcs: scan_buffer ( -- addr len ) 20144603Sdcs read_buffer_ptr >r 20244603Sdcs begin 20344603Sdcs read_buffer .len @ r@ > 20444603Sdcs while 20544603Sdcs read_buffer .addr @ r@ + c@ lf = if 20644603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 20744603Sdcs r@ read_buffer_ptr - ( -- len ) 20844603Sdcs r> to read_buffer_ptr 20944603Sdcs exit 21044603Sdcs then 21144603Sdcs r> char+ >r 21244603Sdcs repeat 21344603Sdcs read_buffer .addr @ read_buffer_ptr + ( -- addr ) 21444603Sdcs r@ read_buffer_ptr - ( -- len ) 21544603Sdcs r> to read_buffer_ptr 21644603Sdcs; 21744603Sdcs 21844603Sdcs: line_buffer_resize ( len -- len ) 21944603Sdcs >r 22044603Sdcs line_buffer .len @ if 22144603Sdcs line_buffer .addr @ 22244603Sdcs line_buffer .len @ r@ + 22344603Sdcs resize if out_of_memory throw then 22444603Sdcs else 22544603Sdcs r@ allocate if out_of_memory throw then 22644603Sdcs then 22744603Sdcs line_buffer .addr ! 22844603Sdcs r> 22944603Sdcs; 23044603Sdcs 23144603Sdcs: append_to_line_buffer ( addr len -- ) 23244603Sdcs line_buffer .addr @ line_buffer .len @ 23344603Sdcs 2swap strcat 23444603Sdcs line_buffer .len ! 23544603Sdcs drop 23644603Sdcs; 23744603Sdcs 23844603Sdcs: read_from_buffer 23944603Sdcs scan_buffer ( -- addr len ) 24044603Sdcs line_buffer_resize ( len -- len ) 24144603Sdcs append_to_line_buffer ( addr len -- ) 24244603Sdcs; 24344603Sdcs 24444603Sdcs: refill_required? 24544603Sdcs read_buffer .len @ read_buffer_ptr = 24644603Sdcs end_of_file? 0= and 24744603Sdcs; 24844603Sdcs 24944603Sdcs: refill_buffer 25044603Sdcs 0 to read_buffer_ptr 25144603Sdcs read_buffer .addr @ 0= if 25244603Sdcs read_buffer_size allocate if out_of_memory throw then 25344603Sdcs read_buffer .addr ! 25444603Sdcs then 25544603Sdcs fd @ read_buffer .addr @ read_buffer_size fread 25644603Sdcs dup -1 = if read_error throw then 25744603Sdcs dup 0= if true to end_of_file? then 25844603Sdcs read_buffer .len ! 25944603Sdcs; 26044603Sdcs 26144603Sdcs: reset_line_buffer 26244603Sdcs 0 line_buffer .addr ! 26344603Sdcs 0 line_buffer .len ! 26444603Sdcs; 26544603Sdcs 26644603Sdcs: read_line 26744603Sdcs reset_line_buffer 26844603Sdcs skip_newlines 26944603Sdcs begin 27044603Sdcs read_from_buffer 27144603Sdcs refill_required? 27244603Sdcs while 27344603Sdcs refill_buffer 27444603Sdcs repeat 27544603Sdcs; 27644603Sdcs 27744603Sdcs\ Conf file line parser: 27844603Sdcs\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 27944603Sdcs\ <spaces>[<comment>] 28044603Sdcs\ <name> ::= <letter>{<letter>|<digit>|'_'} 28144603Sdcs\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 28244603Sdcs\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 28344603Sdcs\ <comment> ::= '#'{<anything>} 28444603Sdcs 28544603Sdcs0 value parsing_function 28644603Sdcs 28744603Sdcs0 value end_of_line 28844603Sdcs0 value line_pointer 28944603Sdcs 29044603Sdcs: end_of_line? 29144603Sdcs line_pointer end_of_line = 29244603Sdcs; 29344603Sdcs 29444603Sdcs: letter? 29544603Sdcs line_pointer c@ >r 29644603Sdcs r@ [char] A >= 29744603Sdcs r@ [char] Z <= and 29844603Sdcs r@ [char] a >= 29944603Sdcs r> [char] z <= and 30044603Sdcs or 30144603Sdcs; 30244603Sdcs 30344603Sdcs: digit? 30444603Sdcs line_pointer c@ >r 30544603Sdcs r@ [char] 0 >= 30644603Sdcs r> [char] 9 <= and 30744603Sdcs; 30844603Sdcs 30944603Sdcs: quote? 31044603Sdcs line_pointer c@ [char] " = 31144603Sdcs; 31244603Sdcs 31344603Sdcs: assignment_sign? 31444603Sdcs line_pointer c@ [char] = = 31544603Sdcs; 31644603Sdcs 31744603Sdcs: comment? 31844603Sdcs line_pointer c@ [char] # = 31944603Sdcs; 32044603Sdcs 32144603Sdcs: space? 32244603Sdcs line_pointer c@ bl = 32344603Sdcs line_pointer c@ tab = or 32444603Sdcs; 32544603Sdcs 32644603Sdcs: backslash? 32744603Sdcs line_pointer c@ [char] \ = 32844603Sdcs; 32944603Sdcs 33044603Sdcs: underscore? 33144603Sdcs line_pointer c@ [char] _ = 33244603Sdcs; 33344603Sdcs 33444603Sdcs: dot? 33544603Sdcs line_pointer c@ [char] . = 33644603Sdcs; 33744603Sdcs 33844603Sdcs: skip_character 33944603Sdcs line_pointer char+ to line_pointer 34044603Sdcs; 34144603Sdcs 34244603Sdcs: skip_to_end_of_line 34344603Sdcs end_of_line to line_pointer 34444603Sdcs; 34544603Sdcs 34644603Sdcs: eat_space 34744603Sdcs begin 34844603Sdcs space? 34944603Sdcs while 35044603Sdcs skip_character 35144603Sdcs end_of_line? if exit then 35244603Sdcs repeat 35344603Sdcs; 35444603Sdcs 35544603Sdcs: parse_name ( -- addr len ) 35644603Sdcs line_pointer 35744603Sdcs begin 35844603Sdcs letter? digit? underscore? dot? or or or 35944603Sdcs while 36044603Sdcs skip_character 36144603Sdcs end_of_line? if 36244603Sdcs line_pointer over - 36344603Sdcs strdup 36444603Sdcs exit 36544603Sdcs then 36644603Sdcs repeat 36744603Sdcs line_pointer over - 36844603Sdcs strdup 36944603Sdcs; 37044603Sdcs 37144603Sdcs: remove_backslashes { addr len | addr' len' -- addr' len' } 37244603Sdcs len allocate if out_of_memory throw then 37344603Sdcs to addr' 37444603Sdcs addr >r 37544603Sdcs begin 37644603Sdcs addr c@ [char] \ <> if 37744603Sdcs addr c@ addr' len' + c! 37844603Sdcs len' char+ to len' 37944603Sdcs then 38044603Sdcs addr char+ to addr 38144603Sdcs r@ len + addr = 38244603Sdcs until 38344603Sdcs r> drop 38444603Sdcs addr' len' 38544603Sdcs; 38644603Sdcs 38744603Sdcs: parse_quote ( -- addr len ) 38844603Sdcs line_pointer 38944603Sdcs skip_character 39044603Sdcs end_of_line? if syntax_error throw then 39144603Sdcs begin 39244603Sdcs quote? 0= 39344603Sdcs while 39444603Sdcs backslash? if 39544603Sdcs skip_character 39644603Sdcs end_of_line? if syntax_error throw then 39744603Sdcs then 39844603Sdcs skip_character 39944603Sdcs end_of_line? if syntax_error throw then 40044603Sdcs repeat 40144603Sdcs skip_character 40244603Sdcs line_pointer over - 40344603Sdcs remove_backslashes 40444603Sdcs; 40544603Sdcs 40644603Sdcs: read_name 40744603Sdcs parse_name ( -- addr len ) 40844603Sdcs name_buffer .len ! 40944603Sdcs name_buffer .addr ! 41044603Sdcs; 41144603Sdcs 41244603Sdcs: read_value 41344603Sdcs quote? if 41444603Sdcs parse_quote ( -- addr len ) 41544603Sdcs else 41644603Sdcs parse_name ( -- addr len ) 41744603Sdcs then 41844603Sdcs value_buffer .len ! 41944603Sdcs value_buffer .addr ! 42044603Sdcs; 42144603Sdcs 42244603Sdcs: comment 42344603Sdcs skip_to_end_of_line 42444603Sdcs; 42544603Sdcs 42644603Sdcs: white_space_4 42744603Sdcs eat_space 42844603Sdcs comment? if ['] comment to parsing_function exit then 42944603Sdcs end_of_line? 0= if syntax_error throw then 43044603Sdcs; 43144603Sdcs 43244603Sdcs: variable_value 43344603Sdcs read_value 43444603Sdcs ['] white_space_4 to parsing_function 43544603Sdcs; 43644603Sdcs 43744603Sdcs: white_space_3 43844603Sdcs eat_space 43944603Sdcs letter? digit? quote? or or if 44044603Sdcs ['] variable_value to parsing_function exit 44144603Sdcs then 44244603Sdcs syntax_error throw 44344603Sdcs; 44444603Sdcs 44544603Sdcs: assignment_sign 44644603Sdcs skip_character 44744603Sdcs ['] white_space_3 to parsing_function 44844603Sdcs; 44944603Sdcs 45044603Sdcs: white_space_2 45144603Sdcs eat_space 45244603Sdcs assignment_sign? if ['] assignment_sign to parsing_function exit then 45344603Sdcs syntax_error throw 45444603Sdcs; 45544603Sdcs 45644603Sdcs: variable_name 45744603Sdcs read_name 45844603Sdcs ['] white_space_2 to parsing_function 45944603Sdcs; 46044603Sdcs 46144603Sdcs: white_space_1 46244603Sdcs eat_space 46344603Sdcs letter? if ['] variable_name to parsing_function exit then 46444603Sdcs comment? if ['] comment to parsing_function exit then 46544603Sdcs end_of_line? 0= if syntax_error throw then 46644603Sdcs; 46744603Sdcs 46844603Sdcs: get_assignment 46944603Sdcs line_buffer .addr @ line_buffer .len @ + to end_of_line 47044603Sdcs line_buffer .addr @ to line_pointer 47144603Sdcs ['] white_space_1 to parsing_function 47244603Sdcs begin 47344603Sdcs end_of_line? 0= 47444603Sdcs while 47544603Sdcs parsing_function execute 47644603Sdcs repeat 47744603Sdcs parsing_function ['] comment = 47844603Sdcs parsing_function ['] white_space_1 = 47944603Sdcs parsing_function ['] white_space_4 = 48044603Sdcs or or 0= if syntax_error throw then 48144603Sdcs; 48244603Sdcs 48344603Sdcs\ Process line 48444603Sdcs 48544603Sdcs: assignment_type? ( addr len -- flag ) 48644603Sdcs name_buffer .addr @ name_buffer .len @ 48744603Sdcs compare 0= 48844603Sdcs; 48944603Sdcs 49044603Sdcs: suffix_type? ( addr len -- flag ) 49144603Sdcs name_buffer .len @ over <= if 2drop false exit then 49244603Sdcs name_buffer .len @ over - name_buffer .addr @ + 49344603Sdcs over compare 0= 49444603Sdcs; 49544603Sdcs 49644603Sdcs: loader_conf_files? 49744603Sdcs s" loader_conf_files" assignment_type? 49844603Sdcs; 49944603Sdcs 50044603Sdcs: verbose_flag? 50144603Sdcs s" verbose_loading" assignment_type? 50244603Sdcs; 50344603Sdcs 50444603Sdcs: execute? 50544603Sdcs s" exec" assignment_type? 50644603Sdcs; 50744603Sdcs 50844603Sdcs: module_load? 50944603Sdcs load_module_suffix suffix_type? 51044603Sdcs; 51144603Sdcs 51244603Sdcs: module_loadname? 51344603Sdcs module_loadname_suffix suffix_type? 51444603Sdcs; 51544603Sdcs 51644603Sdcs: module_type? 51744603Sdcs module_type_suffix suffix_type? 51844603Sdcs; 51944603Sdcs 52044603Sdcs: module_args? 52144603Sdcs module_args_suffix suffix_type? 52244603Sdcs; 52344603Sdcs 52444603Sdcs: module_beforeload? 52544603Sdcs module_beforeload_suffix suffix_type? 52644603Sdcs; 52744603Sdcs 52844603Sdcs: module_afterload? 52944603Sdcs module_afterload_suffix suffix_type? 53044603Sdcs; 53144603Sdcs 53244603Sdcs: module_loaderror? 53344603Sdcs module_loaderror_suffix suffix_type? 53444603Sdcs; 53544603Sdcs 53644603Sdcs: set_conf_files 53744603Sdcs conf_files .addr @ ?dup if 53844603Sdcs free-memory 53944603Sdcs then 54044603Sdcs value_buffer .addr @ c@ [char] " = if 54144603Sdcs value_buffer .addr @ char+ value_buffer .len @ 2 chars - 54244603Sdcs else 54344603Sdcs value_buffer .addr @ value_buffer .len @ 54444603Sdcs then 54544603Sdcs strdup 54644603Sdcs conf_files .len ! conf_files .addr ! 54744603Sdcs; 54844603Sdcs 54944603Sdcs: append_to_module_options_list ( addr -- ) 55044603Sdcs module_options @ 0= if 55144603Sdcs dup module_options ! 55244603Sdcs last_module_option ! 55344603Sdcs else 55444603Sdcs dup last_module_option @ module.next ! 55544603Sdcs last_module_option ! 55644603Sdcs then 55744603Sdcs; 55844603Sdcs 55944603Sdcs: set_module_name ( addr -- ) 56044603Sdcs name_buffer .addr @ name_buffer .len @ 56144603Sdcs strdup 56244603Sdcs >r over module.name .addr ! 56344603Sdcs r> swap module.name .len ! 56444603Sdcs; 56544603Sdcs 56644603Sdcs: yes_value? 56744603Sdcs value_buffer .addr @ value_buffer .len @ 56844603Sdcs 2dup s' "YES"' compare >r 56944603Sdcs 2dup s' "yes"' compare >r 57044603Sdcs 2dup s" YES" compare >r 57144603Sdcs s" yes" compare r> r> r> and and and 0= 57244603Sdcs; 57344603Sdcs 57444603Sdcs: find_module_option ( -- addr | 0 ) 57544603Sdcs module_options @ 57644603Sdcs begin 57744603Sdcs dup 57844603Sdcs while 57944603Sdcs dup module.name dup .addr @ swap .len @ 58044603Sdcs name_buffer .addr @ name_buffer .len @ 58144603Sdcs compare 0= if exit then 58244603Sdcs module.next @ 58344603Sdcs repeat 58444603Sdcs; 58544603Sdcs 58644603Sdcs: new_module_option ( -- addr ) 58744603Sdcs sizeof module allocate if out_of_memory throw then 58844603Sdcs dup sizeof module erase 58944603Sdcs dup append_to_module_options_list 59044603Sdcs dup set_module_name 59144603Sdcs; 59244603Sdcs 59344603Sdcs: get_module_option ( -- addr ) 59444603Sdcs find_module_option 59544603Sdcs ?dup 0= if new_module_option then 59644603Sdcs; 59744603Sdcs 59844603Sdcs: set_module_flag 59944603Sdcs name_buffer .len @ load_module_suffix nip - name_buffer .len ! 60044603Sdcs yes_value? get_module_option module.flag ! 60144603Sdcs; 60244603Sdcs 60344603Sdcs: set_module_args 60444603Sdcs name_buffer .len @ module_args_suffix nip - name_buffer .len ! 60544603Sdcs get_module_option module.args 60644603Sdcs dup .addr @ ?dup if free-memory then 60744603Sdcs value_buffer .addr @ value_buffer .len @ 60844603Sdcs over c@ [char] " = if 60944603Sdcs 2 chars - swap char+ swap 61044603Sdcs then 61144603Sdcs strdup 61244603Sdcs >r over .addr ! 61344603Sdcs r> swap .len ! 61444603Sdcs; 61544603Sdcs 61644603Sdcs: set_module_loadname 61744603Sdcs name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 61844603Sdcs get_module_option module.loadname 61944603Sdcs dup .addr @ ?dup if free-memory then 62044603Sdcs value_buffer .addr @ value_buffer .len @ 62144603Sdcs over c@ [char] " = if 62244603Sdcs 2 chars - swap char+ swap 62344603Sdcs then 62444603Sdcs strdup 62544603Sdcs >r over .addr ! 62644603Sdcs r> swap .len ! 62744603Sdcs; 62844603Sdcs 62944603Sdcs: set_module_type 63044603Sdcs name_buffer .len @ module_type_suffix nip - name_buffer .len ! 63144603Sdcs get_module_option module.type 63244603Sdcs dup .addr @ ?dup if free-memory then 63344603Sdcs value_buffer .addr @ value_buffer .len @ 63444603Sdcs over c@ [char] " = if 63544603Sdcs 2 chars - swap char+ swap 63644603Sdcs then 63744603Sdcs strdup 63844603Sdcs >r over .addr ! 63944603Sdcs r> swap .len ! 64044603Sdcs; 64144603Sdcs 64244603Sdcs: set_module_beforeload 64344603Sdcs name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 64444603Sdcs get_module_option module.beforeload 64544603Sdcs dup .addr @ ?dup if free-memory then 64644603Sdcs value_buffer .addr @ value_buffer .len @ 64744603Sdcs over c@ [char] " = if 64844603Sdcs 2 chars - swap char+ swap 64944603Sdcs then 65044603Sdcs strdup 65144603Sdcs >r over .addr ! 65244603Sdcs r> swap .len ! 65344603Sdcs; 65444603Sdcs 65544603Sdcs: set_module_afterload 65644603Sdcs name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 65744603Sdcs get_module_option module.afterload 65844603Sdcs dup .addr @ ?dup if free-memory then 65944603Sdcs value_buffer .addr @ value_buffer .len @ 66044603Sdcs over c@ [char] " = if 66144603Sdcs 2 chars - swap char+ swap 66244603Sdcs then 66344603Sdcs strdup 66444603Sdcs >r over .addr ! 66544603Sdcs r> swap .len ! 66644603Sdcs; 66744603Sdcs 66844603Sdcs: set_module_loaderror 66944603Sdcs name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 67044603Sdcs get_module_option module.loaderror 67144603Sdcs dup .addr @ ?dup if free-memory then 67244603Sdcs value_buffer .addr @ value_buffer .len @ 67344603Sdcs over c@ [char] " = if 67444603Sdcs 2 chars - swap char+ swap 67544603Sdcs then 67644603Sdcs strdup 67744603Sdcs >r over .addr ! 67844603Sdcs r> swap .len ! 67944603Sdcs; 68044603Sdcs 68144603Sdcs: set_environment_variable 68244603Sdcs name_buffer .len @ 68344603Sdcs value_buffer .len @ + 68444603Sdcs 5 chars + 68544603Sdcs allocate if out_of_memory throw then 68644603Sdcs dup 0 ( addr -- addr addr len ) 68744603Sdcs s" set " strcat 68844603Sdcs name_buffer .addr @ name_buffer .len @ strcat 68944603Sdcs s" =" strcat 69044603Sdcs value_buffer .addr @ value_buffer .len @ strcat 69144603Sdcs ['] evaluate catch if 69244603Sdcs 2drop free drop 69344603Sdcs set_error throw 69444603Sdcs else 69544603Sdcs free-memory 69644603Sdcs then 69744603Sdcs; 69844603Sdcs 69944603Sdcs: set_verbose 70044603Sdcs yes_value? to verbose? 70144603Sdcs; 70244603Sdcs 70344603Sdcs: execute_command 70444603Sdcs value_buffer .addr @ value_buffer .len @ 70544603Sdcs over c@ [char] " = if 70644603Sdcs 2 chars - swap char+ swap 70744603Sdcs then 70844603Sdcs ['] evaluate catch if exec_error throw then 70944603Sdcs; 71044603Sdcs 71144603Sdcs: process_assignment 71244603Sdcs name_buffer .len @ 0= if exit then 71344603Sdcs loader_conf_files? if set_conf_files exit then 71444603Sdcs verbose_flag? if set_verbose exit then 71544603Sdcs execute? if execute_command exit then 71644603Sdcs module_load? if set_module_flag exit then 71744603Sdcs module_loadname? if set_module_loadname exit then 71844603Sdcs module_type? if set_module_type exit then 71944603Sdcs module_args? if set_module_args exit then 72044603Sdcs module_beforeload? if set_module_beforeload exit then 72144603Sdcs module_afterload? if set_module_afterload exit then 72244603Sdcs module_loaderror? if set_module_loaderror exit then 72344603Sdcs set_environment_variable 72444603Sdcs; 72544603Sdcs 72644603Sdcs: free_buffers 72744603Sdcs line_buffer .addr @ dup if free then 72844603Sdcs name_buffer .addr @ dup if free then 72944603Sdcs value_buffer .addr @ dup if free then 73044603Sdcs or or if free_error throw then 73144603Sdcs; 73244603Sdcs 73344603Sdcs: reset_assignment_buffers 73444603Sdcs 0 name_buffer .addr ! 73544603Sdcs 0 name_buffer .len ! 73644603Sdcs 0 value_buffer .addr ! 73744603Sdcs 0 value_buffer .len ! 73844603Sdcs; 73944603Sdcs 74044603Sdcs\ Higher level file processing 74144603Sdcs 74244603Sdcs: process_conf 74344603Sdcs begin 74444603Sdcs end_of_file? 0= 74544603Sdcs while 74644603Sdcs reset_assignment_buffers 74744603Sdcs read_line 74844603Sdcs get_assignment 74944603Sdcs ['] process_assignment catch 75044603Sdcs ['] free_buffers catch 75144603Sdcs swap throw throw 75244603Sdcs repeat 75344603Sdcs; 75444603Sdcs 75544603Sdcs: create_null_terminated_string { addr len -- addr' len } 75644603Sdcs len char+ allocate if out_of_memory throw then 75744603Sdcs >r 75844603Sdcs addr r@ len move 75944603Sdcs 0 r@ len + c! 76044603Sdcs r> len 76144603Sdcs; 76244603Sdcs 76344603Sdcs\ Interface to loading conf files 76444603Sdcs 76544603Sdcs: load_conf ( addr len -- ) 76644603Sdcs 0 to end_of_file? 76744603Sdcs 0 to read_buffer_ptr 76844603Sdcs create_null_terminated_string 76944603Sdcs over >r 77044603Sdcs fopen fd ! 77144603Sdcs r> free-memory 77244603Sdcs fd @ -1 = if open_error throw then 77344603Sdcs ['] process_conf catch 77444603Sdcs fd @ fclose 77544603Sdcs throw 77644603Sdcs; 77744603Sdcs 77844603Sdcs: initialize_support 77944603Sdcs 0 read_buffer .addr ! 78044603Sdcs 0 conf_files .addr ! 78144603Sdcs 0 module_options ! 78244603Sdcs 0 last_module_option ! 78344603Sdcs 0 to verbose? 78444603Sdcs; 78544603Sdcs 78644603Sdcs: print_line 78744603Sdcs line_buffer .addr @ line_buffer .len @ type cr 78844603Sdcs; 78944603Sdcs 79044603Sdcs: print_syntax_error 79144603Sdcs line_buffer .addr @ line_buffer .len @ type cr 79244603Sdcs line_buffer .addr @ 79344603Sdcs begin 79444603Sdcs line_pointer over <> 79544603Sdcs while 79644603Sdcs bl emit 79744603Sdcs char+ 79844603Sdcs repeat 79944603Sdcs drop 80044603Sdcs ." ^" cr 80144603Sdcs; 80244603Sdcs 80344603Sdcs\ Depuration support functions 80444603Sdcs 80544603Sdcsonly forth definitions also support-functions 80644603Sdcs 80744603Sdcs: test-file 80844603Sdcs ['] load_conf catch dup . 80944603Sdcs syntax_error = if cr print_syntax_error then 81044603Sdcs; 81144603Sdcs 81244603Sdcs: show-module-options 81344603Sdcs module_options @ 81444603Sdcs begin 81544603Sdcs ?dup 81644603Sdcs while 81744603Sdcs ." Name: " dup module.name dup .addr @ swap .len @ type cr 81844603Sdcs ." Path: " dup module.loadname dup .addr @ swap .len @ type cr 81944603Sdcs ." Type: " dup module.type dup .addr @ swap .len @ type cr 82044603Sdcs ." Flags: " dup module.args dup .addr @ swap .len @ type cr 82144603Sdcs ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr 82244603Sdcs ." After load: " dup module.afterload dup .addr @ swap .len @ type cr 82344603Sdcs ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr 82444603Sdcs ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr 82544603Sdcs module.next @ 82644603Sdcs repeat 82744603Sdcs; 82844603Sdcs 82944603Sdcsonly forth also support-functions definitions 83044603Sdcs 83144603Sdcs\ Variables used for processing multiple conf files 83244603Sdcs 83344603Sdcsstring current_file_name 83444603Sdcsvariable current_conf_files 83544603Sdcs 83644603Sdcs\ Indicates if any conf file was succesfully read 83744603Sdcs 83844603Sdcs0 value any_conf_read? 83944603Sdcs 84044603Sdcs\ loader_conf_files processing support functions 84144603Sdcs 84244603Sdcs: set_current_conf_files 84344603Sdcs conf_files .addr @ current_conf_files ! 84444603Sdcs; 84544603Sdcs 84644603Sdcs: get_conf_files 84744603Sdcs conf_files .addr @ conf_files .len @ strdup 84844603Sdcs; 84944603Sdcs 85044603Sdcs: recurse_on_conf_files? 85144603Sdcs current_conf_files @ conf_files .addr @ <> 85244603Sdcs; 85344603Sdcs 85444603Sdcs: skip_leading_spaces { addr len ptr -- addr len ptr' } 85544603Sdcs begin 85644603Sdcs ptr len = if addr len ptr exit then 85744603Sdcs addr ptr + c@ bl = 85844603Sdcs while 85944603Sdcs ptr char+ to ptr 86044603Sdcs repeat 86144603Sdcs addr len ptr 86244603Sdcs; 86344603Sdcs 86444603Sdcs: get_file_name { addr len ptr -- addr len ptr' addr' len' || 0 } 86544603Sdcs ptr len = if 86644603Sdcs addr free abort" Fatal error freeing memory" 86744603Sdcs 0 exit 86844603Sdcs then 86944603Sdcs ptr >r 87044603Sdcs begin 87144603Sdcs addr ptr + c@ bl <> 87244603Sdcs while 87344603Sdcs ptr char+ to ptr 87444603Sdcs ptr len = if 87544603Sdcs addr len ptr addr r@ + ptr r> - exit 87644603Sdcs then 87744603Sdcs repeat 87844603Sdcs addr len ptr addr r@ + ptr r> - 87944603Sdcs; 88044603Sdcs 88144603Sdcs: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 88244603Sdcs skip_leading_spaces 88344603Sdcs get_file_name 88444603Sdcs; 88544603Sdcs 88644603Sdcs: set_current_file_name 88744603Sdcs over current_file_name .addr ! 88844603Sdcs dup current_file_name .len ! 88944603Sdcs; 89044603Sdcs 89144603Sdcs: print_current_file 89244603Sdcs current_file_name .addr @ current_file_name .len @ type 89344603Sdcs; 89444603Sdcs 89544603Sdcs: process_conf_errors 89644603Sdcs dup 0= if true to any_conf_read? drop exit then 89744603Sdcs >r 2drop r> 89844603Sdcs dup syntax_error = if 89944603Sdcs ." Warning: syntax error on file " print_current_file cr 90044603Sdcs print_syntax_error drop exit 90144603Sdcs then 90244603Sdcs dup set_error = if 90344603Sdcs ." Warning: bad definition on file " print_current_file cr 90444603Sdcs print_line drop exit 90544603Sdcs then 90644603Sdcs dup read_error = if 90744603Sdcs ." Warning: error reading file " print_current_file cr drop exit 90844603Sdcs then 90944603Sdcs dup open_error = if 91044603Sdcs verbose? if ." Warning: unable to open file " print_current_file cr then 91144603Sdcs drop exit 91244603Sdcs then 91344603Sdcs dup free_error = abort" Fatal error freeing memory" 91444603Sdcs dup out_of_memory = abort" Out of memory" 91544603Sdcs throw \ Unknown error -- pass ahead 91644603Sdcs; 91744603Sdcs 91844603Sdcs\ Process loader_conf_files recursively 91944603Sdcs\ Interface to loader_conf_files processing 92044603Sdcs 92144603Sdcs: include_conf_files 92244603Sdcs set_current_conf_files 92344603Sdcs get_conf_files 0 92444603Sdcs begin 92544603Sdcs get_next_file ?dup 92644603Sdcs while 92744603Sdcs set_current_file_name 92844603Sdcs ['] load_conf catch 92944603Sdcs process_conf_errors 93044603Sdcs recurse_on_conf_files? if recurse then 93144603Sdcs repeat 93244603Sdcs; 93344603Sdcs 93444603Sdcs\ Module loading functions 93544603Sdcs 93644603Sdcs: load_module? 93744603Sdcs module.flag @ 93844603Sdcs; 93944603Sdcs 94044603Sdcs: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N ) 94144603Sdcs dup >r 94244603Sdcs r@ module.args .addr @ r@ module.args .len @ 94344603Sdcs r@ module.loadname .len @ if 94444603Sdcs r@ module.loadname .addr @ r@ module.loadname .len @ 94544603Sdcs else 94644603Sdcs r@ module.name .addr @ r@ module.name .len @ 94744603Sdcs then 94844603Sdcs r@ module.type .len @ if 94944603Sdcs r@ module.type .addr @ r@ module.type .len @ 95044603Sdcs s" -t " 95144603Sdcs 4 ( -t type name flags ) 95244603Sdcs else 95344603Sdcs 2 ( name flags ) 95444603Sdcs then 95544603Sdcs r> drop 95644603Sdcs; 95744603Sdcs 95844603Sdcs: before_load ( addr -- addr ) 95944603Sdcs dup module.beforeload .len @ if 96044603Sdcs dup module.beforeload .addr @ over module.beforeload .len @ 96144603Sdcs ['] evaluate catch if before_load_error throw then 96244603Sdcs then 96344603Sdcs; 96444603Sdcs 96544603Sdcs: after_load ( addr -- addr ) 96644603Sdcs dup module.afterload .len @ if 96744603Sdcs dup module.afterload .addr @ over module.afterload .len @ 96844603Sdcs ['] evaluate catch if after_load_error throw then 96944603Sdcs then 97044603Sdcs; 97144603Sdcs 97244603Sdcs: load_error ( addr -- addr ) 97344603Sdcs dup module.loaderror .len @ if 97444603Sdcs dup module.loaderror .addr @ over module.loaderror .len @ 97544603Sdcs evaluate \ This we do not intercept so it can throw errors 97644603Sdcs then 97744603Sdcs; 97844603Sdcs 97944603Sdcs: pre_load_message ( addr -- addr ) 98044603Sdcs verbose? if 98144603Sdcs dup module.name .addr @ over module.name .len @ type 98244603Sdcs ." ..." 98344603Sdcs then 98444603Sdcs; 98544603Sdcs 98644603Sdcs: load_error_message verbose? if ." failed!" cr then ; 98744603Sdcs 98844603Sdcs: load_succesful_message verbose? if ." ok" cr then ; 98944603Sdcs 99044603Sdcs: load_module 99144603Sdcs load_parameters load 99244603Sdcs; 99344603Sdcs 99444603Sdcs: process_module ( addr -- addr ) 99544603Sdcs pre_load_message 99644603Sdcs before_load 99744603Sdcs begin 99844603Sdcs ['] load_module catch if 99944603Sdcs dup module.loaderror .len @ if 100044603Sdcs load_error \ Command should return a flag! 100144603Sdcs else 100244603Sdcs load_error_message true \ Do not retry 100344603Sdcs then 100444603Sdcs else 100544603Sdcs after_load 100644603Sdcs load_succesful_message true \ Succesful, do not retry 100744603Sdcs then 100844603Sdcs until 100944603Sdcs; 101044603Sdcs 101144603Sdcs: process_module_errors ( addr ior -- ) 101244603Sdcs dup before_load_error = if 101344603Sdcs drop 101444603Sdcs ." Module " 101544603Sdcs dup module.name .addr @ over module.name .len @ type 101644603Sdcs dup module.loadname .len @ if 101744603Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 101844603Sdcs then 101944603Sdcs cr 102044603Sdcs ." Error executing " 102144603Sdcs dup module.beforeload .addr @ over module.afterload .len @ type cr 102244603Sdcs abort 102344603Sdcs then 102444603Sdcs 102544603Sdcs dup after_load_error = if 102644603Sdcs drop 102744603Sdcs ." Module " 102844603Sdcs dup module.name .addr @ over module.name .len @ type 102944603Sdcs dup module.loadname .len @ if 103044603Sdcs ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 103144603Sdcs then 103244603Sdcs cr 103344603Sdcs ." Error executing " 103444603Sdcs dup module.afterload .addr @ over module.afterload .len @ type cr 103544603Sdcs abort 103644603Sdcs then 103744603Sdcs 103844603Sdcs throw \ Don't know what it is all about -- pass ahead 103944603Sdcs; 104044603Sdcs 104144603Sdcs\ Module loading interface 104244603Sdcs 104344603Sdcs: load_modules ( -- ) ( throws: abort & user-defined ) 104444603Sdcs module_options @ 104544603Sdcs begin 104644603Sdcs ?dup 104744603Sdcs while 104844603Sdcs dup load_module? if 104944603Sdcs ['] process_module catch 105044603Sdcs process_module_errors 105144603Sdcs then 105244603Sdcs module.next @ 105344603Sdcs repeat 105444603Sdcs; 105544603Sdcs 105644603Sdcs\ Additional functions used in "start" 105744603Sdcs 105844603Sdcs: initialize ( addr len -- ) 105944603Sdcs initialize_support 106044603Sdcs strdup conf_files .len ! conf_files .addr ! 106144603Sdcs; 106244603Sdcs 106344603Sdcs: load_kernel ( -- ) ( throws: abort ) 106444603Sdcs s" load ${kernel} ${kernel_options}" ['] evaluate catch 106544603Sdcs if s" echo Unable to load kernel: ${kernel_name}" evaluate abort then 106644603Sdcs; 106744603Sdcs 106844603Sdcs\ Go back to straight forth vocabulary 106944603Sdcs 107044603Sdcsonly forth also definitions 107144603Sdcs 1072