support.4th revision 65938
1157642Sps\ Copyright (c) 1999 Daniel C. Sobral <dcs@freebsd.org> 2265917Sdavidcs\ All rights reserved. 3157642Sps\ 4157642Sps\ Redistribution and use in source and binary forms, with or without 5157642Sps\ modification, are permitted provided that the following conditions 6157642Sps\ are met: 7157642Sps\ 1. Redistributions of source code must retain the above copyright 8157642Sps\ notice, this list of conditions and the following disclaimer. 9157642Sps\ 2. Redistributions in binary form must reproduce the above copyright 10157642Sps\ notice, this list of conditions and the following disclaimer in the 11157642Sps\ documentation and/or other materials provided with the distribution. 12157642Sps\ 13157642Sps\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 14157642Sps\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 15157642Sps\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 16157642Sps\ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 17157642Sps\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 18157642Sps\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 19157642Sps\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 20157642Sps\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 21157642Sps\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 22157642Sps\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 23157642Sps\ SUCH DAMAGE. 24157642Sps\ 25157642Sps\ $FreeBSD: head/sys/boot/forth/support.4th 65938 2000-09-16 19:49:52Z dcs $ 26157642Sps 27157642Sps\ Loader.rc support functions: 28157642Sps\ 29157642Sps\ initialize_support ( -- ) initialize global variables 30265917Sdavidcs\ initialize ( addr len -- ) as above, plus load_conf_files 31157642Sps\ load_conf ( addr len -- ) load conf file given 32157642Sps\ include_conf_files ( -- ) load all conf files in load_conf_files 33218529Sdavidch\ print_syntax_error ( -- ) print line and marker of where a syntax 34218529Sdavidch\ error was detected 35157642Sps\ print_line ( -- ) print last line processed 36157642Sps\ load_kernel ( -- ) load kernel 37218529Sdavidch\ load_modules ( -- ) load modules flagged 38218529Sdavidch\ 39218529Sdavidch\ Exported structures: 40218529Sdavidch\ 41218529Sdavidch\ string counted string structure 42218529Sdavidch\ cell .addr string address 43218529Sdavidch\ cell .len string length 44218529Sdavidch\ module module loading information structure 45218529Sdavidch\ cell module.flag should we load it? 46218529Sdavidch\ string module.name module's name 47218529Sdavidch\ string module.loadname name to be used in loading the module 48218529Sdavidch\ string module.type module's type 49218529Sdavidch\ string module.args flags to be passed during load 50218529Sdavidch\ string module.beforeload command to be executed before load 51218529Sdavidch\ string module.afterload command to be executed after load 52218529Sdavidch\ string module.loaderror command to be executed if load fails 53218529Sdavidch\ cell module.next list chain 54218529Sdavidch\ 55218529Sdavidch\ Exported global variables; 56251142Smarius\ 57218529Sdavidch\ string conf_files configuration files to be loaded 58218529Sdavidch\ string password password 59218529Sdavidch\ cell modules_options pointer to first module information 60218529Sdavidch\ value verbose? indicates if user wants a verbose loading 61218529Sdavidch\ value any_conf_read? indicates if a conf file was succesfully read 62218529Sdavidch\ 63218529Sdavidch\ Other exported words: 64218529Sdavidch\ 65218529Sdavidch\ strdup ( addr len -- addr' len) similar to strdup(3) 66218529Sdavidch\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3) 67218529Sdavidch\ strlen ( addr -- len ) similar to strlen(3) 68218529Sdavidch\ s' ( | string' -- addr len | ) similar to s" 69218529Sdavidch\ rudimentary structure support 70218529Sdavidch 71218529Sdavidch\ Exception values 72218529Sdavidch 73218529Sdavidch1 constant syntax_error 74218529Sdavidch2 constant out_of_memory 75218529Sdavidch3 constant free_error 76218529Sdavidch4 constant set_error 77218529Sdavidch5 constant read_error 78218529Sdavidch6 constant open_error 79218529Sdavidch7 constant exec_error 80218529Sdavidch8 constant before_load_error 81218529Sdavidch9 constant after_load_error 82218529Sdavidch 83218529Sdavidch\ Crude structure support 84218529Sdavidch 85218529Sdavidch: structure: 86218529Sdavidch create here 0 , ['] drop , 0 87218529Sdavidch does> create here swap dup @ allot cell+ @ execute 88218529Sdavidch; 89218529Sdavidch: member: create dup , over , + does> cell+ @ + ; 90218529Sdavidch: ;structure swap ! ; 91218529Sdavidch: constructor! >body cell+ ! ; 92218529Sdavidch: constructor: over :noname ; 93218529Sdavidch: ;constructor postpone ; swap cell+ ! ; immediate 94218529Sdavidch: sizeof ' >body @ state @ if postpone literal then ; immediate 95218529Sdavidch: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate 96218529Sdavidch: ptr 1 cells member: ; 97218529Sdavidch: int 1 cells member: ; 98218529Sdavidch 99218529Sdavidch\ String structure 100218529Sdavidch 101218529Sdavidchstructure: string 102218529Sdavidch ptr .addr 103218529Sdavidch int .len 104218529Sdavidch constructor: 105218529Sdavidch 0 over .addr ! 106218529Sdavidch 0 swap .len ! 107218529Sdavidch ;constructor 108218529Sdavidch;structure 109218529Sdavidch 110218529Sdavidch 111218529Sdavidch\ Module options linked list 112218529Sdavidch 113218529Sdavidchstructure: module 114218529Sdavidch int module.flag 115218529Sdavidch sizeof string member: module.name 116218529Sdavidch sizeof string member: module.loadname 117218529Sdavidch sizeof string member: module.type 118218529Sdavidch sizeof string member: module.args 119218529Sdavidch sizeof string member: module.beforeload 120218529Sdavidch sizeof string member: module.afterload 121218529Sdavidch sizeof string member: module.loaderror 122218529Sdavidch ptr module.next 123218529Sdavidch;structure 124218529Sdavidch 125218529Sdavidch\ Internal loader structures 126218529Sdavidchstructure: preloaded_file 127218529Sdavidch ptr pf.name 128218529Sdavidch ptr pf.type 129218529Sdavidch ptr pf.args 130218529Sdavidch ptr pf.metadata \ file_metadata 131218529Sdavidch int pf.loader 132218529Sdavidch int pf.addr 133218529Sdavidch int pf.size 134218529Sdavidch ptr pf.modules \ kernel_module 135218529Sdavidch ptr pf.next \ preloaded_file 136218529Sdavidch;structure 137218529Sdavidch 138218529Sdavidchstructure: kernel_module 139218529Sdavidch ptr km.name 140218529Sdavidch \ ptr km.args 141218529Sdavidch ptr km.fp \ preloaded_file 142218529Sdavidch ptr km.next \ kernel_module 143218529Sdavidch;structure 144218529Sdavidch 145218529Sdavidchstructure: file_metadata 146218529Sdavidch int md.size 147218529Sdavidch 2 member: md.type \ this is not ANS Forth compatible (XXX) 148218529Sdavidch ptr md.next \ file_metadata 149218529Sdavidch 0 member: md.data \ variable size 150218529Sdavidch;structure 151218529Sdavidch 152218529Sdavidchstructure: config_resource 153218529Sdavidch ptr cf.name 154218529Sdavidch int cf.type 155218529Sdavidch0 constant RES_INT 156218529Sdavidch1 constant RES_STRING 157218529Sdavidch2 constant RES_LONG 158218529Sdavidch 2 cells member: u 159218529Sdavidch;structure 160218529Sdavidch 161218529Sdavidchstructure: config_device 162218529Sdavidch ptr cd.name 163218529Sdavidch int cd.unit 164218529Sdavidch int cd.resource_count 165218529Sdavidch ptr cd.resources \ config_resource 166218529Sdavidch;structure 167218529Sdavidch 168218529Sdavidchstructure: STAILQ_HEAD 169218529Sdavidch ptr stqh_first \ type* 170218529Sdavidch ptr stqh_last \ type** 171218529Sdavidch;structure 172218529Sdavidch 173218529Sdavidchstructure: STAILQ_ENTRY 174218529Sdavidch ptr stqe_next \ type* 175218529Sdavidch;structure 176218529Sdavidch 177218529Sdavidchstructure: pnphandler 178218529Sdavidch ptr pnph.name 179218529Sdavidch ptr pnph.enumerate 180218529Sdavidch;structure 181218529Sdavidch 182218529Sdavidchstructure: pnpident 183218529Sdavidch ptr pnpid.ident \ char* 184218529Sdavidch sizeof STAILQ_ENTRY cells member: pnpid.link \ pnpident 185218529Sdavidch;structure 186218529Sdavidch 187218529Sdavidchstructure: pnpinfo 188218529Sdavidch ptr pnpi.desc 189218529Sdavidch int pnpi.revision 190218529Sdavidch ptr pnpi.module \ (char*) module args 191218529Sdavidch int pnpi.argc 192218529Sdavidch ptr pnpi.argv 193218529Sdavidch ptr pnpi.handler \ pnphandler 194218529Sdavidch sizeof STAILQ_HEAD member: pnpi.ident \ pnpident 195218529Sdavidch sizeof STAILQ_ENTRY member: pnpi.link \ pnpinfo 196218529Sdavidch;structure 197218529Sdavidch 198218529Sdavidch\ Global variables 199218529Sdavidch 200218529Sdavidchstring conf_files 201218529Sdavidchstring password 202218529Sdavidchcreate module_options sizeof module.next allot 0 module_options ! 203218529Sdavidchcreate last_module_option sizeof module.next allot 0 last_module_option ! 204218529Sdavidch0 value verbose? 205218529Sdavidch 206218529Sdavidch\ Support string functions 207218529Sdavidch 208218529Sdavidch: strdup ( addr len -- addr' len ) 209218529Sdavidch >r r@ allocate if out_of_memory throw then 210218529Sdavidch tuck r@ move 211218529Sdavidch r> 212218529Sdavidch; 213218529Sdavidch 214218529Sdavidch: strcat { addr len addr' len' -- addr len+len' } 215218529Sdavidch addr' addr len + len' move 216218529Sdavidch addr len len' + 217218529Sdavidch; 218218529Sdavidch 219218529Sdavidch: strlen ( addr -- len ) 220218529Sdavidch 0 >r 221218529Sdavidch begin 222218529Sdavidch dup c@ while 223218529Sdavidch 1+ r> 1+ >r repeat 224218529Sdavidch drop r> 225218529Sdavidch; 226218529Sdavidch 227218529Sdavidch: s' 228218529Sdavidch [char] ' parse 229218529Sdavidch state @ if 230218529Sdavidch postpone sliteral 231218529Sdavidch then 232218529Sdavidch; immediate 233218529Sdavidch 234218529Sdavidch: 2>r postpone >r postpone >r ; immediate 235218529Sdavidch: 2r> postpone r> postpone r> ; immediate 236218529Sdavidch: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate 237218529Sdavidch 238218529Sdavidch: getenv? 239218529Sdavidch getenv 240218529Sdavidch -1 = if false else drop true then 241218529Sdavidch; 242218529Sdavidch 243218529Sdavidch\ Private definitions 244218529Sdavidch 245218529Sdavidchvocabulary support-functions 246218529Sdavidchonly forth also support-functions definitions 247218529Sdavidch 248218529Sdavidch\ Some control characters constants 249218529Sdavidch 250218529Sdavidch7 constant bell 251218529Sdavidch8 constant backspace 252218529Sdavidch9 constant tab 253218529Sdavidch10 constant lf 254218529Sdavidch13 constant <cr> 255218529Sdavidch 256218529Sdavidch\ Read buffer size 257218529Sdavidch 258218529Sdavidch80 constant read_buffer_size 259218529Sdavidch 260218529Sdavidch\ Standard suffixes 261218529Sdavidch 262218529Sdavidch: load_module_suffix s" _load" ; 263218529Sdavidch: module_loadname_suffix s" _name" ; 264218529Sdavidch: module_type_suffix s" _type" ; 265218529Sdavidch: module_args_suffix s" _flags" ; 266218529Sdavidch: module_beforeload_suffix s" _before" ; 267218529Sdavidch: module_afterload_suffix s" _after" ; 268218529Sdavidch: module_loaderror_suffix s" _error" ; 269218529Sdavidch 270218529Sdavidch\ Support operators 271218529Sdavidch 272218529Sdavidch: >= < 0= ; 273218529Sdavidch: <= > 0= ; 274218529Sdavidch 275218529Sdavidch\ Assorted support funcitons 276218529Sdavidch 277218529Sdavidch: free-memory free if free_error throw then ; 278218529Sdavidch 279218529Sdavidch\ Assignment data temporary storage 280218529Sdavidch 281218529Sdavidchstring name_buffer 282218529Sdavidchstring value_buffer 283218529Sdavidch 284218529Sdavidch\ Line by line file reading functions 285218529Sdavidch\ 286218529Sdavidch\ exported: 287218529Sdavidch\ line_buffer 288218529Sdavidch\ end_of_file? 289218529Sdavidch\ fd 290218529Sdavidch\ read_line 291218529Sdavidch\ reset_line_reading 292218529Sdavidch 293218529Sdavidchvocabulary line-reading 294218529Sdavidchalso line-reading definitions also 295218529Sdavidch 296218529Sdavidch\ File data temporary storage 297218529Sdavidch 298218529Sdavidchstring read_buffer 299218529Sdavidch0 value read_buffer_ptr 300218529Sdavidch 301218529Sdavidch\ File's line reading function 302218529Sdavidch 303218529Sdavidchsupport-functions definitions 304218529Sdavidch 305218529Sdavidchstring line_buffer 306218529Sdavidch0 value end_of_file? 307218529Sdavidchvariable fd 308218529Sdavidch 309218529Sdavidchline-reading definitions 310218529Sdavidch 311218529Sdavidch: skip_newlines 312218529Sdavidch begin 313218529Sdavidch read_buffer .len @ read_buffer_ptr > 314218529Sdavidch while 315218529Sdavidch read_buffer .addr @ read_buffer_ptr + c@ lf = if 316218529Sdavidch read_buffer_ptr char+ to read_buffer_ptr 317218529Sdavidch else 318218529Sdavidch exit 319218529Sdavidch then 320218529Sdavidch repeat 321218529Sdavidch; 322218529Sdavidch 323218529Sdavidch: scan_buffer ( -- addr len ) 324218529Sdavidch read_buffer_ptr >r 325218529Sdavidch begin 326218529Sdavidch read_buffer .len @ r@ > 327218529Sdavidch while 328218529Sdavidch read_buffer .addr @ r@ + c@ lf = if 329218529Sdavidch read_buffer .addr @ read_buffer_ptr + ( -- addr ) 330218529Sdavidch r@ read_buffer_ptr - ( -- len ) 331218529Sdavidch r> to read_buffer_ptr 332218529Sdavidch exit 333218529Sdavidch then 334218529Sdavidch r> char+ >r 335218529Sdavidch repeat 336218529Sdavidch read_buffer .addr @ read_buffer_ptr + ( -- addr ) 337218529Sdavidch r@ read_buffer_ptr - ( -- len ) 338218529Sdavidch r> to read_buffer_ptr 339218529Sdavidch; 340218529Sdavidch 341218529Sdavidch: line_buffer_resize ( len -- len ) 342218529Sdavidch >r 343218529Sdavidch line_buffer .len @ if 344218529Sdavidch line_buffer .addr @ 345218529Sdavidch line_buffer .len @ r@ + 346218529Sdavidch resize if out_of_memory throw then 347218529Sdavidch else 348218529Sdavidch r@ allocate if out_of_memory throw then 349218529Sdavidch then 350218529Sdavidch line_buffer .addr ! 351218529Sdavidch r> 352218529Sdavidch; 353218529Sdavidch 354218529Sdavidch: append_to_line_buffer ( addr len -- ) 355218529Sdavidch line_buffer .addr @ line_buffer .len @ 356218529Sdavidch 2swap strcat 357218529Sdavidch line_buffer .len ! 358218529Sdavidch drop 359218529Sdavidch; 360218529Sdavidch 361218529Sdavidch: read_from_buffer 362218529Sdavidch scan_buffer ( -- addr len ) 363218529Sdavidch line_buffer_resize ( len -- len ) 364218529Sdavidch append_to_line_buffer ( addr len -- ) 365218529Sdavidch; 366218529Sdavidch 367218529Sdavidch: refill_required? 368218529Sdavidch read_buffer .len @ read_buffer_ptr = 369218529Sdavidch end_of_file? 0= and 370218529Sdavidch; 371218529Sdavidch 372218529Sdavidch: refill_buffer 373218529Sdavidch 0 to read_buffer_ptr 374218529Sdavidch read_buffer .addr @ 0= if 375218529Sdavidch read_buffer_size allocate if out_of_memory throw then 376218529Sdavidch read_buffer .addr ! 377218529Sdavidch then 378218529Sdavidch fd @ read_buffer .addr @ read_buffer_size fread 379218529Sdavidch dup -1 = if read_error throw then 380218529Sdavidch dup 0= if true to end_of_file? then 381218529Sdavidch read_buffer .len ! 382218529Sdavidch; 383218529Sdavidch 384218529Sdavidch: reset_line_buffer 385218529Sdavidch line_buffer .addr @ ?dup if 386218529Sdavidch free-memory 387218529Sdavidch then 388218529Sdavidch 0 line_buffer .addr ! 389218529Sdavidch 0 line_buffer .len ! 390218529Sdavidch; 391218529Sdavidch 392218529Sdavidchsupport-functions definitions 393218529Sdavidch 394218529Sdavidch: reset_line_reading 395218529Sdavidch 0 to read_buffer_ptr 396218529Sdavidch; 397218529Sdavidch 398218529Sdavidch: read_line 399218529Sdavidch reset_line_buffer 400218529Sdavidch skip_newlines 401218529Sdavidch begin 402218529Sdavidch read_from_buffer 403218529Sdavidch refill_required? 404218529Sdavidch while 405218529Sdavidch refill_buffer 406218529Sdavidch repeat 407218529Sdavidch; 408218529Sdavidch 409218529Sdavidchonly forth also support-functions definitions 410218529Sdavidch 411218529Sdavidch\ Conf file line parser: 412218529Sdavidch\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 413218529Sdavidch\ <spaces>[<comment>] 414218529Sdavidch\ <name> ::= <letter>{<letter>|<digit>|'_'} 415218529Sdavidch\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 416218529Sdavidch\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 417218529Sdavidch\ <comment> ::= '#'{<anything>} 418218529Sdavidch\ 419218529Sdavidch\ exported: 420218529Sdavidch\ line_pointer 421218529Sdavidch\ process_conf 422218529Sdavidch 423218529Sdavidch0 value line_pointer 424218529Sdavidch 425218529Sdavidchvocabulary file-processing 426218529Sdavidchalso file-processing definitions 427218529Sdavidch 428218529Sdavidch\ parser functions 429218529Sdavidch\ 430218529Sdavidch\ exported: 431218529Sdavidch\ get_assignment 432218529Sdavidch 433218529Sdavidchvocabulary parser 434218529Sdavidchalso parser definitions also 435218529Sdavidch 436218529Sdavidch0 value parsing_function 437218529Sdavidch0 value end_of_line 438218529Sdavidch 439218529Sdavidch: end_of_line? 440218529Sdavidch line_pointer end_of_line = 441218529Sdavidch; 442218529Sdavidch 443218529Sdavidch: letter? 444218529Sdavidch line_pointer c@ >r 445218529Sdavidch r@ [char] A >= 446218529Sdavidch r@ [char] Z <= and 447218529Sdavidch r@ [char] a >= 448218529Sdavidch r> [char] z <= and 449218529Sdavidch or 450218529Sdavidch; 451218529Sdavidch 452218529Sdavidch: digit? 453218529Sdavidch line_pointer c@ >r 454218529Sdavidch r@ [char] 0 >= 455218529Sdavidch r> [char] 9 <= and 456218529Sdavidch; 457218529Sdavidch 458218529Sdavidch: quote? 459218529Sdavidch line_pointer c@ [char] " = 460218529Sdavidch; 461218529Sdavidch 462218529Sdavidch: assignment_sign? 463218529Sdavidch line_pointer c@ [char] = = 464218529Sdavidch; 465218529Sdavidch 466218529Sdavidch: comment? 467218529Sdavidch line_pointer c@ [char] # = 468218529Sdavidch; 469218529Sdavidch 470218529Sdavidch: space? 471218529Sdavidch line_pointer c@ bl = 472218529Sdavidch line_pointer c@ tab = or 473218529Sdavidch; 474218529Sdavidch 475218529Sdavidch: backslash? 476218529Sdavidch line_pointer c@ [char] \ = 477218529Sdavidch; 478218529Sdavidch 479218529Sdavidch: underscore? 480218529Sdavidch line_pointer c@ [char] _ = 481218529Sdavidch; 482218529Sdavidch 483218529Sdavidch: dot? 484218529Sdavidch line_pointer c@ [char] . = 485218529Sdavidch; 486218529Sdavidch 487218529Sdavidch: skip_character 488218529Sdavidch line_pointer char+ to line_pointer 489218529Sdavidch; 490218529Sdavidch 491218529Sdavidch: skip_to_end_of_line 492218529Sdavidch end_of_line to line_pointer 493218529Sdavidch; 494218529Sdavidch 495218529Sdavidch: eat_space 496218529Sdavidch begin 497218529Sdavidch space? 498218529Sdavidch while 499218529Sdavidch skip_character 500218529Sdavidch end_of_line? if exit then 501218529Sdavidch repeat 502218529Sdavidch; 503218529Sdavidch 504218529Sdavidch: parse_name ( -- addr len ) 505218529Sdavidch line_pointer 506218529Sdavidch begin 507218529Sdavidch letter? digit? underscore? dot? or or or 508218529Sdavidch while 509218529Sdavidch skip_character 510218529Sdavidch end_of_line? if 511218529Sdavidch line_pointer over - 512218529Sdavidch strdup 513218529Sdavidch exit 514218529Sdavidch then 515218529Sdavidch repeat 516218529Sdavidch line_pointer over - 517218529Sdavidch strdup 518218529Sdavidch; 519218529Sdavidch 520218529Sdavidch: remove_backslashes { addr len | addr' len' -- addr' len' } 521218529Sdavidch len allocate if out_of_memory throw then 522218529Sdavidch to addr' 523218529Sdavidch addr >r 524218529Sdavidch begin 525218529Sdavidch addr c@ [char] \ <> if 526218529Sdavidch addr c@ addr' len' + c! 527218529Sdavidch len' char+ to len' 528218529Sdavidch then 529218529Sdavidch addr char+ to addr 530218529Sdavidch r@ len + addr = 531218529Sdavidch until 532218529Sdavidch r> drop 533218529Sdavidch addr' len' 534218529Sdavidch; 535218529Sdavidch 536218529Sdavidch: parse_quote ( -- addr len ) 537218529Sdavidch line_pointer 538218529Sdavidch skip_character 539218529Sdavidch end_of_line? if syntax_error throw then 540218529Sdavidch begin 541218529Sdavidch quote? 0= 542218529Sdavidch while 543218529Sdavidch backslash? if 544218529Sdavidch skip_character 545218529Sdavidch end_of_line? if syntax_error throw then 546218529Sdavidch then 547218529Sdavidch skip_character 548218529Sdavidch end_of_line? if syntax_error throw then 549218529Sdavidch repeat 550218529Sdavidch skip_character 551218529Sdavidch line_pointer over - 552218529Sdavidch remove_backslashes 553218529Sdavidch; 554218529Sdavidch 555218529Sdavidch: read_name 556218529Sdavidch parse_name ( -- addr len ) 557218529Sdavidch name_buffer .len ! 558218529Sdavidch name_buffer .addr ! 559218529Sdavidch; 560218529Sdavidch 561218529Sdavidch: read_value 562218529Sdavidch quote? if 563218529Sdavidch parse_quote ( -- addr len ) 564218529Sdavidch else 565218529Sdavidch parse_name ( -- addr len ) 566218529Sdavidch then 567218529Sdavidch value_buffer .len ! 568218529Sdavidch value_buffer .addr ! 569218529Sdavidch; 570218529Sdavidch 571218529Sdavidch: comment 572218529Sdavidch skip_to_end_of_line 573218529Sdavidch; 574218529Sdavidch 575218529Sdavidch: white_space_4 576218529Sdavidch eat_space 577218529Sdavidch comment? if ['] comment to parsing_function exit then 578218529Sdavidch end_of_line? 0= if syntax_error throw then 579218529Sdavidch; 580218529Sdavidch 581218529Sdavidch: variable_value 582218529Sdavidch read_value 583218529Sdavidch ['] white_space_4 to parsing_function 584218529Sdavidch; 585218529Sdavidch 586218529Sdavidch: white_space_3 587218529Sdavidch eat_space 588218529Sdavidch letter? digit? quote? or or if 589218529Sdavidch ['] variable_value to parsing_function exit 590218529Sdavidch then 591218529Sdavidch syntax_error throw 592218529Sdavidch; 593218529Sdavidch 594218529Sdavidch: assignment_sign 595218529Sdavidch skip_character 596218529Sdavidch ['] white_space_3 to parsing_function 597218529Sdavidch; 598218529Sdavidch 599218529Sdavidch: white_space_2 600218529Sdavidch eat_space 601218529Sdavidch assignment_sign? if ['] assignment_sign to parsing_function exit then 602218529Sdavidch syntax_error throw 603218529Sdavidch; 604218529Sdavidch 605218529Sdavidch: variable_name 606218529Sdavidch read_name 607218529Sdavidch ['] white_space_2 to parsing_function 608218529Sdavidch; 609218529Sdavidch 610218529Sdavidch: white_space_1 611218529Sdavidch eat_space 612218529Sdavidch letter? if ['] variable_name to parsing_function exit then 613218529Sdavidch comment? if ['] comment to parsing_function exit then 614218529Sdavidch end_of_line? 0= if syntax_error throw then 615218529Sdavidch; 616218529Sdavidch 617218529Sdavidchfile-processing definitions 618218529Sdavidch 619218529Sdavidch: get_assignment 620218529Sdavidch line_buffer .addr @ line_buffer .len @ + to end_of_line 621218529Sdavidch line_buffer .addr @ to line_pointer 622218529Sdavidch ['] white_space_1 to parsing_function 623218529Sdavidch begin 624218529Sdavidch end_of_line? 0= 625218529Sdavidch while 626218529Sdavidch parsing_function execute 627218529Sdavidch repeat 628218529Sdavidch parsing_function ['] comment = 629218529Sdavidch parsing_function ['] white_space_1 = 630218529Sdavidch parsing_function ['] white_space_4 = 631218529Sdavidch or or 0= if syntax_error throw then 632218529Sdavidch; 633218529Sdavidch 634218529Sdavidchonly forth also support-functions also file-processing definitions also 635218529Sdavidch 636218529Sdavidch\ Process line 637218529Sdavidch 638218529Sdavidch: assignment_type? ( addr len -- flag ) 639218529Sdavidch name_buffer .addr @ name_buffer .len @ 640218529Sdavidch compare 0= 641218529Sdavidch; 642218529Sdavidch 643218529Sdavidch: suffix_type? ( addr len -- flag ) 644218529Sdavidch name_buffer .len @ over <= if 2drop false exit then 645218529Sdavidch name_buffer .len @ over - name_buffer .addr @ + 646218529Sdavidch over compare 0= 647218529Sdavidch; 648218529Sdavidch 649218529Sdavidch: loader_conf_files? 650218529Sdavidch s" loader_conf_files" assignment_type? 651218529Sdavidch; 652218529Sdavidch 653218529Sdavidch: verbose_flag? 654218529Sdavidch s" verbose_loading" assignment_type? 655218529Sdavidch; 656218529Sdavidch 657218529Sdavidch: execute? 658218529Sdavidch s" exec" assignment_type? 659218529Sdavidch; 660218529Sdavidch 661218529Sdavidch: password? 662218529Sdavidch s" password" assignment_type? 663218529Sdavidch; 664218529Sdavidch 665218529Sdavidch: module_load? 666218529Sdavidch load_module_suffix suffix_type? 667218529Sdavidch; 668218529Sdavidch 669218529Sdavidch: module_loadname? 670218529Sdavidch module_loadname_suffix suffix_type? 671218529Sdavidch; 672218529Sdavidch 673218529Sdavidch: module_type? 674218529Sdavidch module_type_suffix suffix_type? 675218529Sdavidch; 676218529Sdavidch 677218529Sdavidch: module_args? 678218529Sdavidch module_args_suffix suffix_type? 679218529Sdavidch; 680218529Sdavidch 681218529Sdavidch: module_beforeload? 682218529Sdavidch module_beforeload_suffix suffix_type? 683218529Sdavidch; 684218529Sdavidch 685218529Sdavidch: module_afterload? 686218529Sdavidch module_afterload_suffix suffix_type? 687218529Sdavidch; 688218529Sdavidch 689218529Sdavidch: module_loaderror? 690218529Sdavidch module_loaderror_suffix suffix_type? 691218529Sdavidch; 692218529Sdavidch 693218529Sdavidch: set_conf_files 694218529Sdavidch conf_files .addr @ ?dup if 695218529Sdavidch free-memory 696218529Sdavidch then 697218529Sdavidch value_buffer .addr @ c@ [char] " = if 698218529Sdavidch value_buffer .addr @ char+ value_buffer .len @ 2 chars - 699218529Sdavidch else 700218529Sdavidch value_buffer .addr @ value_buffer .len @ 701218529Sdavidch then 702218529Sdavidch strdup 703218529Sdavidch conf_files .len ! conf_files .addr ! 704218529Sdavidch; 705218529Sdavidch 706218529Sdavidch: append_to_module_options_list ( addr -- ) 707218529Sdavidch module_options @ 0= if 708218529Sdavidch dup module_options ! 709218529Sdavidch last_module_option ! 710218529Sdavidch else 711218529Sdavidch dup last_module_option @ module.next ! 712218529Sdavidch last_module_option ! 713218529Sdavidch then 714218529Sdavidch; 715218529Sdavidch 716218529Sdavidch: set_module_name ( addr -- ) 717218529Sdavidch name_buffer .addr @ name_buffer .len @ 718218529Sdavidch strdup 719218529Sdavidch >r over module.name .addr ! 720218529Sdavidch r> swap module.name .len ! 721218529Sdavidch; 722218529Sdavidch 723218529Sdavidch: yes_value? 724218529Sdavidch value_buffer .addr @ value_buffer .len @ 725218529Sdavidch 2dup s' "YES"' compare >r 726218529Sdavidch 2dup s' "yes"' compare >r 727218529Sdavidch 2dup s" YES" compare >r 728218529Sdavidch s" yes" compare r> r> r> and and and 0= 729218529Sdavidch; 730218529Sdavidch 731218529Sdavidch: find_module_option ( -- addr | 0 ) 732218529Sdavidch module_options @ 733218529Sdavidch begin 734218529Sdavidch dup 735218529Sdavidch while 736218529Sdavidch dup module.name dup .addr @ swap .len @ 737218529Sdavidch name_buffer .addr @ name_buffer .len @ 738218529Sdavidch compare 0= if exit then 739218529Sdavidch module.next @ 740218529Sdavidch repeat 741218529Sdavidch; 742218529Sdavidch 743218529Sdavidch: new_module_option ( -- addr ) 744218529Sdavidch sizeof module allocate if out_of_memory throw then 745218529Sdavidch dup sizeof module erase 746218529Sdavidch dup append_to_module_options_list 747218529Sdavidch dup set_module_name 748218529Sdavidch; 749218529Sdavidch 750218529Sdavidch: get_module_option ( -- addr ) 751218529Sdavidch find_module_option 752218529Sdavidch ?dup 0= if new_module_option then 753218529Sdavidch; 754218529Sdavidch 755218529Sdavidch: set_module_flag 756218529Sdavidch name_buffer .len @ load_module_suffix nip - name_buffer .len ! 757218529Sdavidch yes_value? get_module_option module.flag ! 758218529Sdavidch; 759218529Sdavidch 760218529Sdavidch: set_module_args 761218529Sdavidch name_buffer .len @ module_args_suffix nip - name_buffer .len ! 762218529Sdavidch get_module_option module.args 763218529Sdavidch dup .addr @ ?dup if free-memory then 764218529Sdavidch value_buffer .addr @ value_buffer .len @ 765218529Sdavidch over c@ [char] " = if 766218529Sdavidch 2 chars - swap char+ swap 767218529Sdavidch then 768218529Sdavidch strdup 769218529Sdavidch >r over .addr ! 770218529Sdavidch r> swap .len ! 771218529Sdavidch; 772218529Sdavidch 773218529Sdavidch: set_module_loadname 774218529Sdavidch name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 775218529Sdavidch get_module_option module.loadname 776218529Sdavidch dup .addr @ ?dup if free-memory then 777218529Sdavidch value_buffer .addr @ value_buffer .len @ 778218529Sdavidch over c@ [char] " = if 779218529Sdavidch 2 chars - swap char+ swap 780218529Sdavidch then 781218529Sdavidch strdup 782218529Sdavidch >r over .addr ! 783218529Sdavidch r> swap .len ! 784218529Sdavidch; 785218529Sdavidch 786218529Sdavidch: set_module_type 787218529Sdavidch name_buffer .len @ module_type_suffix nip - name_buffer .len ! 788218529Sdavidch get_module_option module.type 789218529Sdavidch dup .addr @ ?dup if free-memory then 790218529Sdavidch value_buffer .addr @ value_buffer .len @ 791218529Sdavidch over c@ [char] " = if 792218529Sdavidch 2 chars - swap char+ swap 793218529Sdavidch then 794218529Sdavidch strdup 795218529Sdavidch >r over .addr ! 796218529Sdavidch r> swap .len ! 797218529Sdavidch; 798218529Sdavidch 799218529Sdavidch: set_module_beforeload 800218529Sdavidch name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 801218529Sdavidch get_module_option module.beforeload 802218529Sdavidch dup .addr @ ?dup if free-memory then 803218529Sdavidch value_buffer .addr @ value_buffer .len @ 804218529Sdavidch over c@ [char] " = if 805218529Sdavidch 2 chars - swap char+ swap 806218529Sdavidch then 807218529Sdavidch strdup 808218529Sdavidch >r over .addr ! 809218529Sdavidch r> swap .len ! 810218529Sdavidch; 811218529Sdavidch 812218529Sdavidch: set_module_afterload 813218529Sdavidch name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 814218529Sdavidch get_module_option module.afterload 815218529Sdavidch dup .addr @ ?dup if free-memory then 816218529Sdavidch value_buffer .addr @ value_buffer .len @ 817218529Sdavidch over c@ [char] " = if 818218529Sdavidch 2 chars - swap char+ swap 819218529Sdavidch then 820218529Sdavidch strdup 821218529Sdavidch >r over .addr ! 822218529Sdavidch r> swap .len ! 823218529Sdavidch; 824218529Sdavidch 825218529Sdavidch: set_module_loaderror 826218529Sdavidch name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 827218529Sdavidch get_module_option module.loaderror 828218529Sdavidch dup .addr @ ?dup if free-memory then 829218529Sdavidch value_buffer .addr @ value_buffer .len @ 830218529Sdavidch over c@ [char] " = if 831218529Sdavidch 2 chars - swap char+ swap 832218529Sdavidch then 833218529Sdavidch strdup 834218529Sdavidch >r over .addr ! 835218529Sdavidch r> swap .len ! 836218529Sdavidch; 837218529Sdavidch 838218529Sdavidch: set_environment_variable 839218529Sdavidch name_buffer .len @ 840218529Sdavidch value_buffer .len @ + 841218529Sdavidch 5 chars + 842218529Sdavidch allocate if out_of_memory throw then 843218529Sdavidch dup 0 ( addr -- addr addr len ) 844218529Sdavidch s" set " strcat 845218529Sdavidch name_buffer .addr @ name_buffer .len @ strcat 846218529Sdavidch s" =" strcat 847218529Sdavidch value_buffer .addr @ value_buffer .len @ strcat 848218529Sdavidch ['] evaluate catch if 849218529Sdavidch 2drop free drop 850218529Sdavidch set_error throw 851218529Sdavidch else 852218529Sdavidch free-memory 853218529Sdavidch then 854218529Sdavidch; 855218529Sdavidch 856218529Sdavidch: set_verbose 857218529Sdavidch yes_value? to verbose? 858218529Sdavidch; 859218529Sdavidch 860218529Sdavidch: execute_command 861218529Sdavidch value_buffer .addr @ value_buffer .len @ 862218529Sdavidch over c@ [char] " = if 863218529Sdavidch 2 - swap char+ swap 864218529Sdavidch then 865218529Sdavidch ['] evaluate catch if exec_error throw then 866218529Sdavidch; 867218529Sdavidch 868218529Sdavidch: set_password 869218529Sdavidch password .addr @ ?dup if free if free_error throw then then 870218529Sdavidch value_buffer .addr @ c@ [char] " = if 871218529Sdavidch value_buffer .addr @ char+ value_buffer .len @ 2 - strdup 872218529Sdavidch value_buffer .addr @ free if free_error throw then 873218529Sdavidch else 874218529Sdavidch value_buffer .addr @ value_buffer .len @ 875218529Sdavidch then 876218529Sdavidch password .len ! password .addr ! 877218529Sdavidch 0 value_buffer .addr ! 878218529Sdavidch; 879218529Sdavidch 880218529Sdavidch: process_assignment 881218529Sdavidch name_buffer .len @ 0= if exit then 882218529Sdavidch loader_conf_files? if set_conf_files exit then 883218529Sdavidch verbose_flag? if set_verbose exit then 884218529Sdavidch execute? if execute_command exit then 885218529Sdavidch password? if set_password exit then 886218529Sdavidch module_load? if set_module_flag exit then 887218529Sdavidch module_loadname? if set_module_loadname exit then 888218529Sdavidch module_type? if set_module_type exit then 889218529Sdavidch module_args? if set_module_args exit then 890218529Sdavidch module_beforeload? if set_module_beforeload exit then 891218529Sdavidch module_afterload? if set_module_afterload exit then 892218529Sdavidch module_loaderror? if set_module_loaderror exit then 893218529Sdavidch set_environment_variable 894218529Sdavidch; 895218529Sdavidch 896218529Sdavidch\ free_buffer ( -- ) 897218529Sdavidch\ 898218529Sdavidch\ Free some pointers if needed. The code then tests for errors 899218529Sdavidch\ in freeing, and throws an exception if needed. If a pointer is 900218529Sdavidch\ not allocated, it's value (0) is used as flag. 901218529Sdavidch 902218529Sdavidch: free_buffers 903218529Sdavidch name_buffer .addr @ dup if free then 904218529Sdavidch value_buffer .addr @ dup if free then 905218529Sdavidch or if free_error throw then 906218529Sdavidch; 907218529Sdavidch 908218529Sdavidch: reset_assignment_buffers 909218529Sdavidch 0 name_buffer .addr ! 910218529Sdavidch 0 name_buffer .len ! 911218529Sdavidch 0 value_buffer .addr ! 912218529Sdavidch 0 value_buffer .len ! 913218529Sdavidch; 914218529Sdavidch 915218529Sdavidch\ Higher level file processing 916218529Sdavidch 917218529Sdavidchsupport-functions definitions 918218529Sdavidch 919218529Sdavidch: process_conf 920218529Sdavidch begin 921218529Sdavidch end_of_file? 0= 922218529Sdavidch while 923218529Sdavidch reset_assignment_buffers 924218529Sdavidch read_line 925218529Sdavidch get_assignment 926218529Sdavidch ['] process_assignment catch 927218529Sdavidch ['] free_buffers catch 928218529Sdavidch swap throw throw 929218529Sdavidch repeat 930218529Sdavidch; 931218529Sdavidch 932218529Sdavidchonly forth also support-functions definitions 933218529Sdavidch 934218529Sdavidch: create_null_terminated_string { addr len -- addr' len } 935218529Sdavidch len char+ allocate if out_of_memory throw then 936218529Sdavidch >r 937218529Sdavidch addr r@ len move 938218529Sdavidch 0 r@ len + c! 939218529Sdavidch r> len 940218529Sdavidch; 941218529Sdavidch 942218529Sdavidch\ Interface to loading conf files 943218529Sdavidch 944218529Sdavidch: load_conf ( addr len -- ) 945218529Sdavidch 0 to end_of_file? 946218529Sdavidch reset_line_reading 947218529Sdavidch create_null_terminated_string 948218529Sdavidch over >r 949218529Sdavidch fopen fd ! 950218529Sdavidch r> free-memory 951218529Sdavidch fd @ -1 = if open_error throw then 952218529Sdavidch ['] process_conf catch 953218529Sdavidch fd @ fclose 954218529Sdavidch throw 955218529Sdavidch; 956218529Sdavidch 957218529Sdavidch: print_line 958218529Sdavidch line_buffer .addr @ line_buffer .len @ type cr 959218529Sdavidch; 960218529Sdavidch 961218529Sdavidch: print_syntax_error 962218529Sdavidch line_buffer .addr @ line_buffer .len @ type cr 963218529Sdavidch line_buffer .addr @ 964218529Sdavidch begin 965218529Sdavidch line_pointer over <> 966218529Sdavidch while 967218529Sdavidch bl emit 968218529Sdavidch char+ 969218529Sdavidch repeat 970218529Sdavidch drop 971218529Sdavidch ." ^" cr 972218529Sdavidch; 973218529Sdavidch 974218529Sdavidch\ Depuration support functions 975218529Sdavidch 976218529Sdavidchonly forth definitions also support-functions 977218529Sdavidch 978218529Sdavidch: test-file 979218529Sdavidch ['] load_conf catch dup . 980218529Sdavidch syntax_error = if cr print_syntax_error then 981218529Sdavidch; 982218529Sdavidch 983218529Sdavidch: show-module-options 984218529Sdavidch module_options @ 985218529Sdavidch begin 986218529Sdavidch ?dup 987218529Sdavidch while 988218529Sdavidch ." Name: " dup module.name dup .addr @ swap .len @ type cr 989218529Sdavidch ." Path: " dup module.loadname dup .addr @ swap .len @ type cr 990218529Sdavidch ." Type: " dup module.type dup .addr @ swap .len @ type cr 991218529Sdavidch ." Flags: " dup module.args dup .addr @ swap .len @ type cr 992218529Sdavidch ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr 993218529Sdavidch ." After load: " dup module.afterload dup .addr @ swap .len @ type cr 994218529Sdavidch ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr 995218529Sdavidch ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr 996218529Sdavidch module.next @ 997218529Sdavidch repeat 998218529Sdavidch; 999218529Sdavidch 1000218529Sdavidchonly forth also support-functions definitions 1001218529Sdavidch 1002218529Sdavidch\ Variables used for processing multiple conf files 1003218529Sdavidch 1004218529Sdavidchstring current_file_name 1005218529Sdavidchvariable current_conf_files 1006218529Sdavidch 1007218529Sdavidch\ Indicates if any conf file was succesfully read 1008218529Sdavidch 1009218529Sdavidch0 value any_conf_read? 1010218529Sdavidch 1011218529Sdavidch\ loader_conf_files processing support functions 1012218529Sdavidch 1013218529Sdavidch: set_current_conf_files 1014218529Sdavidch conf_files .addr @ current_conf_files ! 1015218529Sdavidch; 1016218529Sdavidch 1017218529Sdavidch: get_conf_files 1018218529Sdavidch conf_files .addr @ conf_files .len @ strdup 1019218529Sdavidch; 1020218529Sdavidch 1021218529Sdavidch: recurse_on_conf_files? 1022218529Sdavidch current_conf_files @ conf_files .addr @ <> 1023218529Sdavidch; 1024218529Sdavidch 1025218529Sdavidch: skip_leading_spaces { addr len pos -- addr len pos' } 1026218529Sdavidch begin 1027218529Sdavidch pos len = if addr len pos exit then 1028218529Sdavidch addr pos + c@ bl = 1029218529Sdavidch while 1030218529Sdavidch pos char+ to pos 1031218529Sdavidch repeat 1032218529Sdavidch addr len pos 1033218529Sdavidch; 1034218529Sdavidch 1035218529Sdavidch: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 1036218529Sdavidch pos len = if 1037218529Sdavidch addr free abort" Fatal error freeing memory" 1038218529Sdavidch 0 exit 1039218529Sdavidch then 1040218529Sdavidch pos >r 1041218529Sdavidch begin 1042218529Sdavidch addr pos + c@ bl <> 1043218529Sdavidch while 1044218529Sdavidch pos char+ to pos 1045218529Sdavidch pos len = if 1046218529Sdavidch addr len pos addr r@ + pos r> - exit 1047218529Sdavidch then 1048218529Sdavidch repeat 1049218529Sdavidch addr len pos addr r@ + pos r> - 1050218529Sdavidch; 1051218529Sdavidch 1052218529Sdavidch: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 1053218529Sdavidch skip_leading_spaces 1054218529Sdavidch get_file_name 1055218529Sdavidch; 1056218529Sdavidch 1057218529Sdavidch: set_current_file_name 1058218529Sdavidch over current_file_name .addr ! 1059218529Sdavidch dup current_file_name .len ! 1060218529Sdavidch; 1061218529Sdavidch 1062218529Sdavidch: print_current_file 1063218529Sdavidch current_file_name .addr @ current_file_name .len @ type 1064218529Sdavidch; 1065218529Sdavidch 1066218529Sdavidch: process_conf_errors 1067218529Sdavidch dup 0= if true to any_conf_read? drop exit then 1068218529Sdavidch >r 2drop r> 1069218529Sdavidch dup syntax_error = if 1070218529Sdavidch ." Warning: syntax error on file " print_current_file cr 1071218529Sdavidch print_syntax_error drop exit 1072218529Sdavidch then 1073218529Sdavidch dup set_error = if 1074218529Sdavidch ." Warning: bad definition on file " print_current_file cr 1075218529Sdavidch print_line drop exit 1076218529Sdavidch then 1077218529Sdavidch dup read_error = if 1078218529Sdavidch ." Warning: error reading file " print_current_file cr drop exit 1079218529Sdavidch then 1080218529Sdavidch dup open_error = if 1081218529Sdavidch verbose? if ." Warning: unable to open file " print_current_file cr then 1082218529Sdavidch drop exit 1083218529Sdavidch then 1084218529Sdavidch dup free_error = abort" Fatal error freeing memory" 1085218529Sdavidch dup out_of_memory = abort" Out of memory" 1086218529Sdavidch throw \ Unknown error -- pass ahead 1087218529Sdavidch; 1088218529Sdavidch 1089218529Sdavidch\ Process loader_conf_files recursively 1090218529Sdavidch\ Interface to loader_conf_files processing 1091218529Sdavidch 1092218529Sdavidch: include_conf_files 1093218529Sdavidch set_current_conf_files 1094218529Sdavidch get_conf_files 0 1095218529Sdavidch begin 1096218529Sdavidch get_next_file ?dup 1097218529Sdavidch while 1098218529Sdavidch set_current_file_name 1099218529Sdavidch ['] load_conf catch 1100218529Sdavidch process_conf_errors 1101218529Sdavidch recurse_on_conf_files? if recurse then 1102218529Sdavidch repeat 1103218529Sdavidch; 1104218529Sdavidch 1105218529Sdavidch\ Module loading functions 1106218529Sdavidch 1107218529Sdavidch: load_module? 1108218529Sdavidch module.flag @ 1109218529Sdavidch; 1110218529Sdavidch 1111218529Sdavidch: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N ) 1112218529Sdavidch dup >r 1113218529Sdavidch r@ module.args .addr @ r@ module.args .len @ 1114218529Sdavidch r@ module.loadname .len @ if 1115218529Sdavidch r@ module.loadname .addr @ r@ module.loadname .len @ 1116218529Sdavidch else 1117218529Sdavidch r@ module.name .addr @ r@ module.name .len @ 1118218529Sdavidch then 1119218529Sdavidch r@ module.type .len @ if 1120218529Sdavidch r@ module.type .addr @ r@ module.type .len @ 1121218529Sdavidch s" -t " 1122218529Sdavidch 4 ( -t type name flags ) 1123218529Sdavidch else 1124218529Sdavidch 2 ( name flags ) 1125218529Sdavidch then 1126218529Sdavidch r> drop 1127218529Sdavidch; 1128218529Sdavidch 1129218529Sdavidch: before_load ( addr -- addr ) 1130218529Sdavidch dup module.beforeload .len @ if 1131218529Sdavidch dup module.beforeload .addr @ over module.beforeload .len @ 1132218529Sdavidch ['] evaluate catch if before_load_error throw then 1133218529Sdavidch then 1134218529Sdavidch; 1135218529Sdavidch 1136218529Sdavidch: after_load ( addr -- addr ) 1137218529Sdavidch dup module.afterload .len @ if 1138218529Sdavidch dup module.afterload .addr @ over module.afterload .len @ 1139218529Sdavidch ['] evaluate catch if after_load_error throw then 1140218529Sdavidch then 1141218529Sdavidch; 1142218529Sdavidch 1143218529Sdavidch: load_error ( addr -- addr ) 1144218529Sdavidch dup module.loaderror .len @ if 1145218529Sdavidch dup module.loaderror .addr @ over module.loaderror .len @ 1146218529Sdavidch evaluate \ This we do not intercept so it can throw errors 1147218529Sdavidch then 1148218529Sdavidch; 1149218529Sdavidch 1150218529Sdavidch: pre_load_message ( addr -- addr ) 1151218529Sdavidch verbose? if 1152218529Sdavidch dup module.name .addr @ over module.name .len @ type 1153218529Sdavidch ." ..." 1154218529Sdavidch then 1155218529Sdavidch; 1156218529Sdavidch 1157218529Sdavidch: load_error_message verbose? if ." failed!" cr then ; 1158218529Sdavidch 1159218529Sdavidch: load_succesful_message verbose? if ." ok" cr then ; 1160218529Sdavidch 1161218529Sdavidch: load_module 1162218529Sdavidch load_parameters load 1163218529Sdavidch; 1164218529Sdavidch 1165218529Sdavidch: process_module ( addr -- addr ) 1166218529Sdavidch pre_load_message 1167218529Sdavidch before_load 1168218529Sdavidch begin 1169218529Sdavidch ['] load_module catch if 1170218529Sdavidch dup module.loaderror .len @ if 1171218529Sdavidch load_error \ Command should return a flag! 1172218529Sdavidch else 1173218529Sdavidch load_error_message true \ Do not retry 1174218529Sdavidch then 1175218529Sdavidch else 1176218529Sdavidch after_load 1177218529Sdavidch load_succesful_message true \ Succesful, do not retry 1178218529Sdavidch then 1179218529Sdavidch until 1180218529Sdavidch; 1181218529Sdavidch 1182218529Sdavidch: process_module_errors ( addr ior -- ) 1183218529Sdavidch dup before_load_error = if 1184218529Sdavidch drop 1185218529Sdavidch ." Module " 1186218529Sdavidch dup module.name .addr @ over module.name .len @ type 1187218529Sdavidch dup module.loadname .len @ if 1188218529Sdavidch ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 1189218529Sdavidch then 1190218529Sdavidch cr 1191218529Sdavidch ." Error executing " 1192218529Sdavidch dup module.beforeload .addr @ over module.afterload .len @ type cr 1193218529Sdavidch abort 1194218529Sdavidch then 1195218529Sdavidch 1196218529Sdavidch dup after_load_error = if 1197218529Sdavidch drop 1198218529Sdavidch ." Module " 1199218529Sdavidch dup module.name .addr @ over module.name .len @ type 1200218529Sdavidch dup module.loadname .len @ if 1201218529Sdavidch ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 1202218529Sdavidch then 1203218529Sdavidch cr 1204218529Sdavidch ." Error executing " 1205218529Sdavidch dup module.afterload .addr @ over module.afterload .len @ type cr 1206218529Sdavidch abort 1207218529Sdavidch then 1208218529Sdavidch 1209218529Sdavidch throw \ Don't know what it is all about -- pass ahead 1210218529Sdavidch; 1211218529Sdavidch 1212218529Sdavidch\ Module loading interface 1213218529Sdavidch 1214218529Sdavidch: load_modules ( -- ) ( throws: abort & user-defined ) 1215218529Sdavidch module_options @ 1216218529Sdavidch begin 1217218529Sdavidch ?dup 1218218529Sdavidch while 1219218529Sdavidch dup load_module? if 1220218529Sdavidch ['] process_module catch 1221218529Sdavidch process_module_errors 1222218529Sdavidch then 1223218529Sdavidch module.next @ 1224218529Sdavidch repeat 1225218529Sdavidch; 1226218529Sdavidch 1227218529Sdavidch\ h00h00 magic used to try loading either a kernel with a given name, 1228218529Sdavidch\ or a kernel with the default name in a directory of a given name 1229218529Sdavidch\ (the pain!) 1230218529Sdavidch 1231218529Sdavidch: bootpath s" /boot/" ; 1232218529Sdavidch: modulepath s" module_path" ; 1233218529Sdavidch 1234218529Sdavidch\ Functions used to save and restore module_path's value. 1235218529Sdavidch: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 1236218529Sdavidch dup -1 = if 0 swap exit then 1237218529Sdavidch strdup 1238218529Sdavidch; 1239218529Sdavidch: freeenv ( addr len | 0 -1 ) 1240218529Sdavidch -1 = if drop else free abort" Freeing error" then 1241218529Sdavidch; 1242218529Sdavidch: restoreenv ( addr len | 0 -1 -- ) 1243218529Sdavidch dup -1 = if ( it wasn't set ) 1244218529Sdavidch 2drop 1245218529Sdavidch modulepath unsetenv 1246218529Sdavidch else 1247218529Sdavidch over >r 1248251142Smarius modulepath setenv 1249251142Smarius r> free abort" Freeing error" 1250218529Sdavidch then 1251218529Sdavidch; 1252189325Sdavidch 1253251142Smarius: clip_args \ Drop second string if only one argument is passed 1254251142Smarius 1 = if 1255251142Smarius 2swap 2drop 1256178132Sdavidch 1 1257189325Sdavidch else 1258218529Sdavidch 2 1259218529Sdavidch then 1260218529Sdavidch; 1261218529Sdavidch 1262218529Sdavidchalso builtins 1263218529Sdavidch 1264218529Sdavidch\ Parse filename from a comma-separated list 1265218529Sdavidch 1266218529Sdavidch: parse-; ( addr len -- addr' len-x addr x ) 1267218529Sdavidch over 0 2swap 1268218529Sdavidch begin 1269218529Sdavidch dup 0 <> 1270218529Sdavidch while 1271218529Sdavidch over c@ [char] ; <> 1272218529Sdavidch while 1273218529Sdavidch 1- swap 1+ swap 1274251142Smarius 2swap 1+ 2swap 1275218529Sdavidch repeat then 1276218529Sdavidch dup 0 <> if 1277218529Sdavidch 1- swap 1+ swap 1278189325Sdavidch then 1279189325Sdavidch 2swap 1280189325Sdavidch; 1281189325Sdavidch 1282189325Sdavidch\ Try loading one of multiple kernels specified 1283189325Sdavidch 1284189325Sdavidch: try_multiple_kernels ( addr len addr' len' args -- flag ) 1285189325Sdavidch >r 1286189325Sdavidch begin 1287189325Sdavidch parse-; 2>r 1288189325Sdavidch 2over 2r> 1289189325Sdavidch r@ clip_args 1 load 1290189325Sdavidch while 1291189325Sdavidch dup 0= 1292189325Sdavidch until 1293189325Sdavidch 1 >r \ Failure 1294189325Sdavidch else 1295189325Sdavidch 0 >r \ Success 1296189325Sdavidch then 1297189325Sdavidch 2drop 2drop 1298189325Sdavidch r> 1299189325Sdavidch r> drop 1300189325Sdavidch; 1301189325Sdavidch 1302189325Sdavidch\ Try to load a kernel; the kernel name is taken from one of 1303189325Sdavidch\ the following lists, as ordered: 1304189325Sdavidch\ 1305189325Sdavidch\ 1. The "bootfile" environment variable 1306189325Sdavidch\ 2. The "kernel" environment variable 1307189325Sdavidch\ 1308189325Sdavidch\ Flags are passed, if available. If not, dummy values must be given. 1309189325Sdavidch\ 1310189325Sdavidch\ The kernel gets loaded from the current module_path. 1311189325Sdavidch 1312189325Sdavidch: load_a_kernel ( flags len 1 | x x 0 -- flag ) 1313189325Sdavidch local args 1314189325Sdavidch 2local flags 1315189325Sdavidch 0 0 2local kernel 1316189325Sdavidch end-locals 1317189325Sdavidch 1318189325Sdavidch \ Check if a default kernel name exists at all, exits if not 1319189325Sdavidch s" bootfile" getenv dup -1 <> if 1320189325Sdavidch to kernel 1321189325Sdavidch flags kernel args 1+ try_multiple_kernels 1322189325Sdavidch dup 0= if exit then 1323189325Sdavidch then 1324189325Sdavidch drop 1325189325Sdavidch 1326189325Sdavidch s" kernel" getenv dup -1 <> if 1327189325Sdavidch to kernel 1328189325Sdavidch else 1329189325Sdavidch drop 1330189325Sdavidch 1 exit \ Failure 1331189325Sdavidch then 1332189325Sdavidch 1333189325Sdavidch \ Try all default kernel names 1334189325Sdavidch flags kernel args 1+ try_multiple_kernels 1335189325Sdavidch; 1336189325Sdavidch 1337189325Sdavidch\ Try to load a kernel; the kernel name is taken from one of 1338189325Sdavidch\ the following lists, as ordered: 1339189325Sdavidch\ 1340189325Sdavidch\ 1. The "bootfile" environment variable 1341189325Sdavidch\ 2. The "kernel" environment variable 1342189325Sdavidch\ 1343189325Sdavidch\ Flags are passed, if provided. 1344189325Sdavidch\ 1345189325Sdavidch\ The kernel will be loaded from a directory computed from the 1346189325Sdavidch\ path given. Two directories will be tried in the following order: 1347189325Sdavidch\ 1348189325Sdavidch\ 1. /boot/path 1349189325Sdavidch\ 2. path 1350189325Sdavidch\ 1351189325Sdavidch\ The module_path variable is overridden if load is succesful, by 1352189325Sdavidch\ prepending the successful path. 1353189325Sdavidch 1354189325Sdavidch: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 1355189325Sdavidch local args 1356189325Sdavidch 2local path 1357189325Sdavidch args 1 = if 0 0 then 1358189325Sdavidch 2local flags 1359189325Sdavidch 0 0 2local oldmodulepath 1360189325Sdavidch 0 0 2local newmodulepath 1361189325Sdavidch end-locals 1362189325Sdavidch 1363189325Sdavidch \ Set the environment variable module_path, and try loading 1364189325Sdavidch \ the kernel again. 1365189325Sdavidch modulepath getenv saveenv to oldmodulepath 1366189325Sdavidch 1367189325Sdavidch \ Try prepending /boot/ first 1368189325Sdavidch bootpath nip path nip + 1369189325Sdavidch oldmodulepath nip dup -1 = if 1370189325Sdavidch drop 1371189325Sdavidch else 1372189325Sdavidch 1+ + 1373189325Sdavidch then 1374189325Sdavidch allocate 1375189325Sdavidch if ( out of memory ) 1376189325Sdavidch 1 exit 1377189325Sdavidch then 1378189325Sdavidch 1379189325Sdavidch 0 1380189325Sdavidch bootpath strcat 1381189325Sdavidch path strcat 1382189325Sdavidch 2dup to newmodulepath 1383189325Sdavidch modulepath setenv 1384189325Sdavidch 1385189325Sdavidch \ Try all default kernel names 1386189325Sdavidch flags args 1- load_a_kernel 1387189325Sdavidch 0= if ( success ) 1388189325Sdavidch oldmodulepath nip -1 <> if 1389189325Sdavidch newmodulepath s" ;" strcat 1390189325Sdavidch oldmodulepath strcat 1391189325Sdavidch modulepath setenv 1392189325Sdavidch newmodulepath drop free-memory 1393189325Sdavidch oldmodulepath drop free-memory 1394189325Sdavidch then 1395189325Sdavidch 0 exit 1396189325Sdavidch then 1397189325Sdavidch 1398189325Sdavidch \ Well, try without the prepended /boot/ 1399189325Sdavidch path newmodulepath drop swap move 1400189325Sdavidch newmodulepath drop path nip 1401189325Sdavidch 2dup to newmodulepath 1402189325Sdavidch modulepath setenv 1403189325Sdavidch 1404189325Sdavidch \ Try all default kernel names 1405189325Sdavidch flags args 1- load_a_kernel 1406189325Sdavidch if ( failed once more ) 1407189325Sdavidch oldmodulepath restoreenv 1408189325Sdavidch newmodulepath drop free-memory 1409189325Sdavidch 1 1410189325Sdavidch else 1411189325Sdavidch oldmodulepath nip -1 <> if 1412189325Sdavidch newmodulepath s" ;" strcat 1413189325Sdavidch oldmodulepath strcat 1414189325Sdavidch modulepath setenv 1415189325Sdavidch newmodulepath drop free-memory 1416189325Sdavidch oldmodulepath drop free-memory 1417189325Sdavidch then 1418189325Sdavidch 0 1419189325Sdavidch then 1420189325Sdavidch; 1421189325Sdavidch 1422189325Sdavidch\ Try to load a kernel; the kernel name is taken from one of 1423189325Sdavidch\ the following lists, as ordered: 1424189325Sdavidch\ 1425189325Sdavidch\ 1. The "bootfile" environment variable 1426189325Sdavidch\ 2. The "kernel" environment variable 1427189325Sdavidch\ 3. The "path" argument 1428189325Sdavidch\ 1429189325Sdavidch\ Flags are passed, if provided. 1430189325Sdavidch\ 1431189325Sdavidch\ The kernel will be loaded from a directory computed from the 1432189325Sdavidch\ path given. Two directories will be tried in the following order: 1433189325Sdavidch\ 1434189325Sdavidch\ 1. /boot/path 1435189325Sdavidch\ 2. path 1436189325Sdavidch\ 1437189325Sdavidch\ Unless "path" is meant to be kernel name itself. In that case, it 1438189325Sdavidch\ will first be tried as a full path, and, next, search on the 1439189325Sdavidch\ directories pointed by module_path. 1440189325Sdavidch\ 1441189325Sdavidch\ The module_path variable is overridden if load is succesful, by 1442189325Sdavidch\ prepending the successful path. 1443189325Sdavidch 1444189325Sdavidch: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 1445189325Sdavidch local args 1446189325Sdavidch 2local path 1447189325Sdavidch args 1 = if 0 0 then 1448189325Sdavidch 2local flags 1449189325Sdavidch end-locals 1450189325Sdavidch 1451189325Sdavidch \ First, assume path is an absolute path to a directory 1452189325Sdavidch flags path args clip_args load_from_directory 1453189325Sdavidch dup 0= if exit else drop then 1454189325Sdavidch 1455189325Sdavidch \ Next, assume path points to the kernel 1456189325Sdavidch flags path args try_multiple_kernels 1457189325Sdavidch; 1458189325Sdavidch 1459189325Sdavidch: initialize ( addr len -- ) 1460189325Sdavidch strdup conf_files .len ! conf_files .addr ! 1461189325Sdavidch; 1462189325Sdavidch 1463189325Sdavidch: kernel_options ( -- addr len 1 | 0 ) 1464189325Sdavidch s" kernel_options" getenv 1465189325Sdavidch dup -1 = if drop 0 else 1 then 1466189325Sdavidch; 1467189325Sdavidch 1468189325Sdavidch: standard_kernel_search ( flags 1 | 0 -- flag ) 1469189325Sdavidch local args 1470189325Sdavidch args 0= if 0 0 then 1471189325Sdavidch 2local flags 1472189325Sdavidch s" kernel" getenv 1473189325Sdavidch dup -1 = if 0 swap then 1474189325Sdavidch 2local path 1475189325Sdavidch end-locals 1476189325Sdavidch 1477189325Sdavidch path dup -1 = if ( there isn't a "kernel" environment variable ) 1478189325Sdavidch 2drop 1479189325Sdavidch flags args load_a_kernel 1480189325Sdavidch else 1481189325Sdavidch flags path args 1+ clip_args load_directory_or_file 1482189325Sdavidch then 1483189325Sdavidch; 1484189325Sdavidch 1485189325Sdavidch: load_kernel ( -- ) ( throws: abort ) 1486189325Sdavidch kernel_options standard_kernel_search 1487189325Sdavidch abort" Unable to load a kernel!" 1488189325Sdavidch; 1489189325Sdavidch 1490189325Sdavidch: set-defaultoptions ( -- ) 1491189325Sdavidch s" kernel_options" getenv dup -1 = if 1492189325Sdavidch drop 1493189325Sdavidch else 1494189325Sdavidch s" temp_options" setenv 1495189325Sdavidch then 1496189325Sdavidch; 1497189325Sdavidch 1498189325Sdavidch: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 1499189325Sdavidch 2dup = if 0 0 exit then 1500189325Sdavidch dup >r 1501189325Sdavidch 1+ 2* ( skip N and ui ) 1502189325Sdavidch pick 1503189325Sdavidch r> 1504189325Sdavidch 1+ 2* ( skip N and ai ) 1505189325Sdavidch pick 1506189325Sdavidch; 1507189325Sdavidch 1508189325Sdavidch: drop-args ( aN uN ... a1 u1 N -- ) 1509189325Sdavidch 0 ?do 2drop loop 1510189325Sdavidch; 1511189325Sdavidch 1512189325Sdavidch: argc 1513189325Sdavidch dup 1514189325Sdavidch; 1515189325Sdavidch 1516189325Sdavidch: queue-argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 1517189325Sdavidch >r 1518189325Sdavidch over 2* 1+ -roll 1519189325Sdavidch r> 1520189325Sdavidch over 2* 1+ -roll 1521189325Sdavidch 1+ 1522189325Sdavidch; 1523189325Sdavidch 1524189325Sdavidch: unqueue-argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 1525189325Sdavidch 1- -rot 1526189325Sdavidch; 1527189325Sdavidch 1528189325Sdavidch: strlen(argv) 1529189325Sdavidch dup 0= if 0 exit then 1530189325Sdavidch 0 >r \ Size 1531189325Sdavidch 0 >r \ Index 1532189325Sdavidch begin 1533189325Sdavidch argc r@ <> 1534189325Sdavidch while 1535189325Sdavidch r@ argv[] 1536189325Sdavidch nip 1537189325Sdavidch r> r> rot + 1+ 1538189325Sdavidch >r 1+ >r 1539189325Sdavidch repeat 1540189325Sdavidch r> drop 1541189325Sdavidch r> 1542189325Sdavidch; 1543189325Sdavidch 1544189325Sdavidch: concat-argv ( aN uN ... a1 u1 N -- a u ) 1545189325Sdavidch strlen(argv) allocate if out_of_memory throw then 1546189325Sdavidch 0 2>r 1547189325Sdavidch 1548189325Sdavidch begin 1549189325Sdavidch argc 1550189325Sdavidch while 1551189325Sdavidch unqueue-argv 1552189325Sdavidch 2r> 2swap 1553189325Sdavidch strcat 1554189325Sdavidch s" " strcat 1555189325Sdavidch 2>r 1556189325Sdavidch repeat 1557189325Sdavidch drop-args 1558189325Sdavidch 2r> 1559189325Sdavidch; 1560189325Sdavidch 1561189325Sdavidch: set-tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 1562189325Sdavidch \ Save the first argument, if it exists and is not a flag 1563189325Sdavidch argc if 1564189325Sdavidch 0 argv[] drop c@ [char] - <> if 1565189325Sdavidch unqueue-argv 2>r \ Filename 1566189325Sdavidch 1 >r \ Filename present 1567189325Sdavidch else 1568189325Sdavidch 0 >r \ Filename not present 1569189325Sdavidch then 1570189325Sdavidch else 1571189325Sdavidch 0 >r \ Filename not present 1572189325Sdavidch then 1573189325Sdavidch 1574189325Sdavidch \ If there are other arguments, assume they are flags 1575189325Sdavidch ?dup if 1576189325Sdavidch concat-argv 1577189325Sdavidch 2dup s" temp_options" setenv 1578189325Sdavidch drop free if free_error throw then 1579189325Sdavidch else 1580189325Sdavidch set-defaultoptions 1581189325Sdavidch then 1582189325Sdavidch 1583189325Sdavidch \ Bring back the filename, if one was provided 1584189325Sdavidch r> if 2r> 1 else 0 then 1585189325Sdavidch; 1586189325Sdavidch 1587189325Sdavidch: get-arguments ( -- addrN lenN ... addr1 len1 N ) 1588189325Sdavidch 0 1589189325Sdavidch begin 1590189325Sdavidch \ Get next word on the command line 1591189325Sdavidch parse-word 1592189325Sdavidch ?dup while 1593189325Sdavidch queue-argv 1594189325Sdavidch repeat 1595189325Sdavidch drop ( empty string ) 1596189325Sdavidch; 1597189325Sdavidch 1598189325Sdavidch: load_conf ( args -- flag ) 1599189325Sdavidch set-tempoptions 1600189325Sdavidch argc >r 1601189325Sdavidch s" temp_options" getenv dup -1 <> if 1602189325Sdavidch queue-argv 1603189325Sdavidch else 1604189325Sdavidch drop 1605189325Sdavidch then 1606189325Sdavidch r> if ( a path was passed ) 1607189325Sdavidch load_directory_or_file 1608189325Sdavidch else 1609189325Sdavidch standard_kernel_search 1610189325Sdavidch then 1611189325Sdavidch ?dup 0= if ['] load_modules catch then 1612189325Sdavidch; 1613189325Sdavidch 1614189325Sdavidch: read-password { size | buf len -- } 1615189325Sdavidch size allocate if out_of_memory throw then 1616189325Sdavidch to buf 1617189325Sdavidch 0 to len 1618189325Sdavidch begin 1619189325Sdavidch key 1620189325Sdavidch dup backspace = if 1621189325Sdavidch drop 1622189325Sdavidch len if 1623189325Sdavidch backspace emit bl emit backspace emit 1624189325Sdavidch len 1 - to len 1625189325Sdavidch else 1626189325Sdavidch bell emit 1627189325Sdavidch then 1628189325Sdavidch else 1629189325Sdavidch dup <cr> = if cr drop buf len exit then 1630189325Sdavidch [char] * emit 1631189325Sdavidch len size < if 1632189325Sdavidch buf len chars + c! 1633189325Sdavidch else 1634189325Sdavidch drop 1635189325Sdavidch then 1636189325Sdavidch len 1+ to len 1637189325Sdavidch then 1638189325Sdavidch again 1639189325Sdavidch; 1640189325Sdavidch 1641189325Sdavidch\ Go back to straight forth vocabulary 1642189325Sdavidch 1643189325Sdavidchonly forth also definitions 1644189325Sdavidch 1645189325Sdavidch