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