1\ Copyright (c) 1999 Daniel C. Sobral <dcs@FreeBSD.org> 2\ All rights reserved. 3\ 4\ Redistribution and use in source and binary forms, with or without 5\ modification, are permitted provided that the following conditions 6\ are met: 7\ 1. Redistributions of source code must retain the above copyright 8\ notice, this list of conditions and the following disclaimer. 9\ 2. Redistributions in binary form must reproduce the above copyright 10\ notice, this list of conditions and the following disclaimer in the 11\ documentation and/or other materials provided with the distribution. 12\ 13\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 14\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 15\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 16\ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 17\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 18\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 19\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 20\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 21\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 22\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 23\ SUCH DAMAGE. 24\ 25\ $FreeBSD$ 26 27\ Loader.rc support functions: 28\ 29\ initialize ( addr len -- ) as above, plus load_conf_files 30\ load_conf ( addr len -- ) load conf file given 31\ include_conf_files ( -- ) load all conf files in load_conf_files 32\ print_syntax_error ( -- ) print line and marker of where a syntax 33\ error was detected 34\ print_line ( -- ) print last line processed 35\ load_kernel ( -- ) load kernel 36\ load_modules ( -- ) load modules flagged 37\ 38\ Exported structures: 39\ 40\ string counted string structure 41\ cell .addr string address 42\ cell .len string length 43\ module module loading information structure 44\ cell module.flag should we load it? 45\ string module.name module's name 46\ string module.loadname name to be used in loading the module 47\ string module.type module's type 48\ string module.args flags to be passed during load 49\ string module.beforeload command to be executed before load 50\ string module.afterload command to be executed after load 51\ string module.loaderror command to be executed if load fails 52\ cell module.next list chain 53\ 54\ Exported global variables; 55\ 56\ string conf_files configuration files to be loaded 57\ cell modules_options pointer to first module information 58\ value verbose? indicates if user wants a verbose loading 59\ value any_conf_read? indicates if a conf file was successfully read 60\ 61\ Other exported words: 62\ note, strlen is internal 63\ strdup ( addr len -- addr' len) similar to strdup(3) 64\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3) 65\ s' ( | string' -- addr len | ) similar to s" 66\ rudimentary structure support 67 68\ Exception values 69 701 constant ESYNTAX 712 constant ENOMEM 723 constant EFREE 734 constant ESETERROR \ error setting environment variable 745 constant EREAD \ error reading 756 constant EOPEN 767 constant EEXEC \ XXX never catched 778 constant EBEFORELOAD 789 constant EAFTERLOAD 79 80\ I/O constants 81 820 constant SEEK_SET 831 constant SEEK_CUR 842 constant SEEK_END 85 860 constant O_RDONLY 871 constant O_WRONLY 882 constant O_RDWR 89 90\ Crude structure support 91 92: structure: 93 create here 0 , ['] drop , 0 94 does> create here swap dup @ allot cell+ @ execute 95; 96: member: create dup , over , + does> cell+ @ + ; 97: ;structure swap ! ; 98: constructor! >body cell+ ! ; 99: constructor: over :noname ; 100: ;constructor postpone ; swap cell+ ! ; immediate 101: sizeof ' >body @ state @ if postpone literal then ; immediate 102: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate 103: ptr 1 cells member: ; 104: int 1 cells member: ; 105 106\ String structure 107 108structure: string 109 ptr .addr 110 int .len 111 constructor: 112 0 over .addr ! 113 0 swap .len ! 114 ;constructor 115;structure 116 117 118\ Module options linked list 119 120structure: module 121 int module.flag 122 sizeof string member: module.name 123 sizeof string member: module.loadname 124 sizeof string member: module.type 125 sizeof string member: module.args 126 sizeof string member: module.beforeload 127 sizeof string member: module.afterload 128 sizeof string member: module.loaderror 129 ptr module.next 130;structure 131 132\ Internal loader structures (preloaded_file, kernel_module, file_metadata) 133\ must be in sync with the C struct in stand/common/bootstrap.h 134structure: preloaded_file 135 ptr pf.name 136 ptr pf.type 137 ptr pf.args 138 ptr pf.metadata \ file_metadata 139 int pf.loader 140 int pf.addr 141 int pf.size 142 ptr pf.modules \ kernel_module 143 ptr pf.next \ preloaded_file 144;structure 145 146structure: kernel_module 147 ptr km.name 148 \ ptr km.args 149 ptr km.fp \ preloaded_file 150 ptr km.next \ kernel_module 151;structure 152 153structure: file_metadata 154 int md.size 155 2 member: md.type \ this is not ANS Forth compatible (XXX) 156 ptr md.next \ file_metadata 157 0 member: md.data \ variable size 158;structure 159 160\ end of structures 161 162\ Global variables 163 164string conf_files 165string nextboot_conf_file 166create module_options sizeof module.next allot 0 module_options ! 167create last_module_option sizeof module.next allot 0 last_module_option ! 1680 value verbose? 1690 value nextboot? 170 171\ Support string functions 172: strdup { addr len -- addr' len' } 173 len allocate if ENOMEM throw then 174 addr over len move len 175; 176 177: strcat { addr len addr' len' -- addr len+len' } 178 addr' addr len + len' move 179 addr len len' + 180; 181 182: strchr { addr len c -- addr' len' } 183 begin 184 len 185 while 186 addr c@ c = if addr len exit then 187 addr 1 + to addr 188 len 1 - to len 189 repeat 190 0 0 191; 192 193: strspn { addr len addr1 len1 | paddr plen -- addr' len' } 194 begin 195 len 196 while 197 addr1 to paddr 198 len1 to plen 199 begin 200 plen 201 while 202 addr c@ paddr c@ = if addr len exit then 203 paddr 1+ to paddr 204 plen 1- to plen 205 repeat 206 addr 1 + to addr 207 len 1 - to len 208 repeat 209 0 0 210; 211 212: s' \ same as s", allows " in the string 213 [char] ' parse 214 state @ if postpone sliteral then 215; immediate 216 217: 2>r postpone >r postpone >r ; immediate 218: 2r> postpone r> postpone r> ; immediate 219: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate 220 221: getenv? getenv -1 = if false else drop true then ; 222 223\ execute xt for each device listed in console variable. 224\ this allows us to have device specific output for logos, menu frames etc 225: console-iterate { xt | caddr clen taddr tlen -- } 226 \ get current console and save it 227 s" console" getenv 228 ['] strdup catch if 2drop exit then 229 to clen to caddr 230 231 clen to tlen 232 caddr to taddr 233 begin 234 tlen 235 while 236 taddr tlen s" , " strspn 237 \ we need to handle 3 cases for addr len pairs on stack: 238 \ addr len are 0 0 - there was no comma nor space 239 \ addr len are x 0 - the first char is either comma or space 240 \ addr len are x y. 241 2dup + 0= if 242 \ there was no comma nor space. 243 2drop 244 taddr tlen s" console" setenv 245 xt execute 246 0 to tlen 247 else dup 0= if 248 2drop 249 else 250 dup ( taddr' tlen' tlen' ) 251 tlen swap - dup 252 0= if \ sequence of comma and space? 253 drop 254 else 255 taddr swap s" console" setenv 256 xt execute 257 then 258 to tlen 259 to taddr 260 then then 261 tlen 0> if \ step over separator 262 tlen 1- to tlen 263 taddr 1+ to taddr 264 then 265 repeat 266 caddr clen s" console" setenv \ restore console setup 267 caddr free drop 268; 269 270\ determine if a word appears in a string, case-insensitive 271: contains? ( addr1 len1 addr2 len2 -- 0 | -1 ) 272 2 pick 0= if 2drop 2drop true exit then 273 dup 0= if 2drop 2drop false exit then 274 begin 275 begin 276 swap dup c@ dup 32 = over 9 = or over 10 = or 277 over 13 = or over 44 = or swap drop 278 while 1+ swap 1- repeat 279 swap 2 pick 1- over < 280 while 281 2over 2over drop over compare-insensitive 0= if 282 2 pick over = if 2drop 2drop true exit then 283 2 pick tuck - -rot + swap over c@ dup 32 = 284 over 9 = or over 10 = or over 13 = or over 44 = or 285 swap drop if 2drop 2drop true exit then 286 then begin 287 swap dup c@ dup 32 = over 9 = or over 10 = or 288 over 13 = or over 44 = or swap drop 289 if false else true then 2 pick 0> and 290 while 1+ swap 1- repeat 291 swap 292 repeat 293 2drop 2drop false 294; 295 296: boot_serial? ( -- 0 | -1 ) 297 s" console" getenv dup -1 <> if 298 s" comconsole" 2swap contains? 299 else drop false then 300\ s" boot_serial" getenv dup -1 <> if 301\ swap drop 0> 302\ else drop false then 303\ or \ console contains comconsole ( or ) boot_serial 304\ s" boot_multicons" getenv dup -1 <> if 305\ swap drop 0> 306\ else drop false then 307\ or \ previous boolean ( or ) boot_multicons 308; 309 310: framebuffer? ( -- t ) 311 s" console" getenv 312 2dup s" efi" compare 0<> >r 313 s" vidconsole" compare 0<> r> and if 314 FALSE exit 315 then 316 s" screen.depth" getenv? 317; 318 319\ Private definitions 320 321vocabulary support-functions 322only forth also support-functions definitions 323 324\ Some control characters constants 325 3267 constant bell 3278 constant backspace 3289 constant tab 32910 constant lf 33013 constant <cr> 331 332\ Read buffer size 333 33480 constant read_buffer_size 335 336\ Standard suffixes 337 338: load_module_suffix s" _load" ; 339: module_loadname_suffix s" _name" ; 340: module_type_suffix s" _type" ; 341: module_args_suffix s" _flags" ; 342: module_beforeload_suffix s" _before" ; 343: module_afterload_suffix s" _after" ; 344: module_loaderror_suffix s" _error" ; 345 346\ Support operators 347 348: >= < 0= ; 349: <= > 0= ; 350 351\ Assorted support functions 352 353: free-memory free if EFREE throw then ; 354 355: strget { var -- addr len } var .addr @ var .len @ ; 356 357\ assign addr len to variable. 358: strset { addr len var -- } addr var .addr ! len var .len ! ; 359 360\ free memory and reset fields 361: strfree { var -- } var .addr @ ?dup if free-memory 0 0 var strset then ; 362 363\ free old content, make a copy of the string and assign to variable 364: string= { addr len var -- } var strfree addr len strdup var strset ; 365 366: strtype ( str -- ) strget type ; 367 368\ assign a reference to what is on the stack 369: strref { addr len var -- addr len } 370 addr var .addr ! len var .len ! addr len 371; 372 373\ unquote a string 374: unquote ( addr len -- addr len ) 375 over c@ [char] " = if 2 chars - swap char+ swap then 376; 377 378\ Assignment data temporary storage 379 380string name_buffer 381string value_buffer 382 383\ Line by line file reading functions 384\ 385\ exported: 386\ line_buffer 387\ end_of_file? 388\ fd 389\ read_line 390\ reset_line_reading 391 392vocabulary line-reading 393also line-reading definitions 394 395\ File data temporary storage 396 397string read_buffer 3980 value read_buffer_ptr 399 400\ File's line reading function 401 402get-current ( -- wid ) previous definitions 403 404string line_buffer 4050 value end_of_file? 406variable fd 407 408>search ( wid -- ) definitions 409 410: skip_newlines 411 begin 412 read_buffer .len @ read_buffer_ptr > 413 while 414 read_buffer .addr @ read_buffer_ptr + c@ lf = if 415 read_buffer_ptr char+ to read_buffer_ptr 416 else 417 exit 418 then 419 repeat 420; 421 422: scan_buffer ( -- addr len ) 423 read_buffer_ptr >r 424 begin 425 read_buffer .len @ r@ > 426 while 427 read_buffer .addr @ r@ + c@ lf = if 428 read_buffer .addr @ read_buffer_ptr + ( -- addr ) 429 r@ read_buffer_ptr - ( -- len ) 430 r> to read_buffer_ptr 431 exit 432 then 433 r> char+ >r 434 repeat 435 read_buffer .addr @ read_buffer_ptr + ( -- addr ) 436 r@ read_buffer_ptr - ( -- len ) 437 r> to read_buffer_ptr 438; 439 440: line_buffer_resize ( len -- len ) 441 dup 0= if exit then 442 >r 443 line_buffer .len @ if 444 line_buffer .addr @ 445 line_buffer .len @ r@ + 446 resize if ENOMEM throw then 447 else 448 r@ allocate if ENOMEM throw then 449 then 450 line_buffer .addr ! 451 r> 452; 453 454: append_to_line_buffer ( addr len -- ) 455 dup 0= if 2drop exit then 456 line_buffer strget 457 2swap strcat 458 line_buffer .len ! 459 drop 460; 461 462: read_from_buffer 463 scan_buffer ( -- addr len ) 464 line_buffer_resize ( len -- len ) 465 append_to_line_buffer ( addr len -- ) 466; 467 468: refill_required? 469 read_buffer .len @ read_buffer_ptr = 470 end_of_file? 0= and 471; 472 473: refill_buffer 474 0 to read_buffer_ptr 475 read_buffer .addr @ 0= if 476 read_buffer_size allocate if ENOMEM throw then 477 read_buffer .addr ! 478 then 479 fd @ read_buffer .addr @ read_buffer_size fread 480 dup -1 = if EREAD throw then 481 dup 0= if true to end_of_file? then 482 read_buffer .len ! 483; 484 485get-current ( -- wid ) previous definitions >search ( wid -- ) 486 487: reset_line_reading 488 0 to read_buffer_ptr 489 0 read_buffer .len ! 490; 491 492: read_line 493 line_buffer strfree 494 skip_newlines 495 begin 496 read_from_buffer 497 refill_required? 498 while 499 refill_buffer 500 repeat 501; 502 503only forth also support-functions definitions 504 505\ Conf file line parser: 506\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 507\ <spaces>[<comment>] 508\ <name> ::= <letter>{<letter>|<digit>|'_'} 509\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 510\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 511\ <comment> ::= '#'{<anything>} 512\ 513\ exported: 514\ line_pointer 515\ process_conf 516 5170 value line_pointer 518 519vocabulary file-processing 520also file-processing definitions 521 522\ parser functions 523\ 524\ exported: 525\ get_assignment 526 527vocabulary parser 528also parser definitions 529 5300 value parsing_function 5310 value end_of_line 532 533: end_of_line? line_pointer end_of_line = ; 534 535\ classifiers for various character classes in the input line 536 537: letter? 538 line_pointer c@ >r 539 r@ [char] A >= 540 r@ [char] Z <= and 541 r@ [char] a >= 542 r> [char] z <= and 543 or 544; 545 546: digit? 547 line_pointer c@ >r 548 r@ [char] - = 549 r@ [char] 0 >= 550 r> [char] 9 <= and 551 or 552; 553 554: quote? line_pointer c@ [char] " = ; 555 556: assignment_sign? line_pointer c@ [char] = = ; 557 558: comment? line_pointer c@ [char] # = ; 559 560: space? line_pointer c@ bl = line_pointer c@ tab = or ; 561 562: backslash? line_pointer c@ [char] \ = ; 563 564: underscore? line_pointer c@ [char] _ = ; 565 566: dot? line_pointer c@ [char] . = ; 567 568\ manipulation of input line 569: skip_character line_pointer char+ to line_pointer ; 570 571: skip_to_end_of_line end_of_line to line_pointer ; 572 573: eat_space 574 begin 575 end_of_line? if 0 else space? then 576 while 577 skip_character 578 repeat 579; 580 581: parse_name ( -- addr len ) 582 line_pointer 583 begin 584 end_of_line? if 0 else letter? digit? underscore? dot? or or or then 585 while 586 skip_character 587 repeat 588 line_pointer over - 589 strdup 590; 591 592: remove_backslashes { addr len | addr' len' -- addr' len' } 593 len allocate if ENOMEM throw then 594 to addr' 595 addr >r 596 begin 597 addr c@ [char] \ <> if 598 addr c@ addr' len' + c! 599 len' char+ to len' 600 then 601 addr char+ to addr 602 r@ len + addr = 603 until 604 r> drop 605 addr' len' 606; 607 608: parse_quote ( -- addr len ) 609 line_pointer 610 skip_character 611 end_of_line? if ESYNTAX throw then 612 begin 613 quote? 0= 614 while 615 backslash? if 616 skip_character 617 end_of_line? if ESYNTAX throw then 618 then 619 skip_character 620 end_of_line? if ESYNTAX throw then 621 repeat 622 skip_character 623 line_pointer over - 624 remove_backslashes 625; 626 627: read_name 628 parse_name ( -- addr len ) 629 name_buffer strset 630; 631 632: read_value 633 quote? if 634 parse_quote ( -- addr len ) 635 else 636 parse_name ( -- addr len ) 637 then 638 value_buffer strset 639; 640 641: comment 642 skip_to_end_of_line 643; 644 645: white_space_4 646 eat_space 647 comment? if ['] comment to parsing_function exit then 648 end_of_line? 0= if ESYNTAX throw then 649; 650 651: variable_value 652 read_value 653 ['] white_space_4 to parsing_function 654; 655 656: white_space_3 657 eat_space 658 letter? digit? quote? or or if 659 ['] variable_value to parsing_function exit 660 then 661 ESYNTAX throw 662; 663 664: assignment_sign 665 skip_character 666 ['] white_space_3 to parsing_function 667; 668 669: white_space_2 670 eat_space 671 assignment_sign? if ['] assignment_sign to parsing_function exit then 672 ESYNTAX throw 673; 674 675: variable_name 676 read_name 677 ['] white_space_2 to parsing_function 678; 679 680: white_space_1 681 eat_space 682 letter? if ['] variable_name to parsing_function exit then 683 comment? if ['] comment to parsing_function exit then 684 end_of_line? 0= if ESYNTAX throw then 685; 686 687get-current ( -- wid ) previous definitions >search ( wid -- ) 688 689: get_assignment 690 line_buffer strget + to end_of_line 691 line_buffer .addr @ to line_pointer 692 ['] white_space_1 to parsing_function 693 begin 694 end_of_line? 0= 695 while 696 parsing_function execute 697 repeat 698 parsing_function ['] comment = 699 parsing_function ['] white_space_1 = 700 parsing_function ['] white_space_4 = 701 or or 0= if ESYNTAX throw then 702; 703 704only forth also support-functions also file-processing definitions 705 706\ Process line 707 708: assignment_type? ( addr len -- flag ) 709 name_buffer strget 710 compare 0= 711; 712 713: suffix_type? ( addr len -- flag ) 714 name_buffer .len @ over <= if 2drop false exit then 715 name_buffer .len @ over - name_buffer .addr @ + 716 over compare 0= 717; 718 719: loader_conf_files? s" loader_conf_files" assignment_type? ; 720 721: nextboot_flag? s" nextboot_enable" assignment_type? ; 722 723: nextboot_conf? s" nextboot_conf" assignment_type? ; 724 725: verbose_flag? s" verbose_loading" assignment_type? ; 726 727: execute? s" exec" assignment_type? ; 728 729: module_load? load_module_suffix suffix_type? ; 730 731: module_loadname? module_loadname_suffix suffix_type? ; 732 733: module_type? module_type_suffix suffix_type? ; 734 735: module_args? module_args_suffix suffix_type? ; 736 737: module_beforeload? module_beforeload_suffix suffix_type? ; 738 739: module_afterload? module_afterload_suffix suffix_type? ; 740 741: module_loaderror? module_loaderror_suffix suffix_type? ; 742 743\ build a 'set' statement and execute it 744: set_environment_variable 745 name_buffer .len @ value_buffer .len @ + 5 chars + \ size of result string 746 allocate if ENOMEM throw then 747 dup 0 \ start with an empty string and append the pieces 748 s" set " strcat 749 name_buffer strget strcat 750 s" =" strcat 751 value_buffer strget strcat 752 ['] evaluate catch if 753 2drop free drop 754 ESETERROR throw 755 else 756 free-memory 757 then 758; 759 760: set_conf_files 761 set_environment_variable 762 s" loader_conf_files" getenv conf_files string= 763; 764 765: set_nextboot_conf 766 value_buffer strget unquote nextboot_conf_file string= 767; 768 769: append_to_module_options_list ( addr -- ) 770 module_options @ 0= if 771 dup module_options ! 772 last_module_option ! 773 else 774 dup last_module_option @ module.next ! 775 last_module_option ! 776 then 777; 778 779: set_module_name { addr -- } \ check leaks 780 name_buffer strget addr module.name string= 781; 782 783: yes_value? 784 value_buffer strget \ XXX could use unquote 785 2dup s' "YES"' compare >r 786 2dup s' "yes"' compare >r 787 2dup s" YES" compare >r 788 s" yes" compare r> r> r> and and and 0= 789; 790 791: find_module_option ( -- addr | 0 ) \ return ptr to entry matching name_buffer 792 module_options @ 793 begin 794 dup 795 while 796 dup module.name strget 797 name_buffer strget 798 compare 0= if exit then 799 module.next @ 800 repeat 801; 802 803: new_module_option ( -- addr ) 804 sizeof module allocate if ENOMEM throw then 805 dup sizeof module erase 806 dup append_to_module_options_list 807 dup set_module_name 808; 809 810: get_module_option ( -- addr ) 811 find_module_option 812 ?dup 0= if new_module_option then 813; 814 815: set_module_flag 816 name_buffer .len @ load_module_suffix nip - name_buffer .len ! 817 yes_value? get_module_option module.flag ! 818; 819 820: set_module_args 821 name_buffer .len @ module_args_suffix nip - name_buffer .len ! 822 value_buffer strget unquote 823 get_module_option module.args string= 824; 825 826: set_module_loadname 827 name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 828 value_buffer strget unquote 829 get_module_option module.loadname string= 830; 831 832: set_module_type 833 name_buffer .len @ module_type_suffix nip - name_buffer .len ! 834 value_buffer strget unquote 835 get_module_option module.type string= 836; 837 838: set_module_beforeload 839 name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 840 value_buffer strget unquote 841 get_module_option module.beforeload string= 842; 843 844: set_module_afterload 845 name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 846 value_buffer strget unquote 847 get_module_option module.afterload string= 848; 849 850: set_module_loaderror 851 name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 852 value_buffer strget unquote 853 get_module_option module.loaderror string= 854; 855 856: set_nextboot_flag 857 yes_value? to nextboot? 858; 859 860: set_verbose 861 yes_value? to verbose? 862; 863 864: execute_command 865 value_buffer strget unquote 866 ['] evaluate catch if EEXEC throw then 867; 868 869: process_assignment 870 name_buffer .len @ 0= if exit then 871 loader_conf_files? if set_conf_files exit then 872 nextboot_flag? if set_nextboot_flag exit then 873 nextboot_conf? if set_nextboot_conf exit then 874 verbose_flag? if set_verbose exit then 875 execute? if execute_command exit then 876 module_load? if set_module_flag exit then 877 module_loadname? if set_module_loadname exit then 878 module_type? if set_module_type exit then 879 module_args? if set_module_args exit then 880 module_beforeload? if set_module_beforeload exit then 881 module_afterload? if set_module_afterload exit then 882 module_loaderror? if set_module_loaderror exit then 883 set_environment_variable 884; 885 886\ free_buffer ( -- ) 887\ 888\ Free some pointers if needed. The code then tests for errors 889\ in freeing, and throws an exception if needed. If a pointer is 890\ not allocated, it's value (0) is used as flag. 891 892: free_buffers 893 name_buffer strfree 894 value_buffer strfree 895; 896 897\ Higher level file processing 898 899get-current ( -- wid ) previous definitions >search ( wid -- ) 900 901: process_conf 902 begin 903 end_of_file? 0= 904 while 905 free_buffers 906 read_line 907 get_assignment 908 ['] process_assignment catch 909 ['] free_buffers catch 910 swap throw throw 911 repeat 912; 913 914: peek_file ( addr len -- ) 915 0 to end_of_file? 916 reset_line_reading 917 O_RDONLY fopen fd ! 918 fd @ -1 = if EOPEN throw then 919 free_buffers 920 read_line 921 get_assignment 922 ['] process_assignment catch 923 ['] free_buffers catch 924 fd @ fclose 925 swap throw throw 926; 927 928only forth also support-functions definitions 929 930\ Interface to loading conf files 931 932: load_conf ( addr len -- ) 933 0 to end_of_file? 934 reset_line_reading 935 O_RDONLY fopen fd ! 936 fd @ -1 = if EOPEN throw then 937 ['] process_conf catch 938 fd @ fclose 939 throw 940; 941 942: print_line line_buffer strtype cr ; 943 944: print_syntax_error 945 line_buffer strtype cr 946 line_buffer .addr @ 947 begin 948 line_pointer over <> 949 while 950 bl emit char+ 951 repeat 952 drop 953 ." ^" cr 954; 955 956 957\ Debugging support functions 958 959only forth definitions also support-functions 960 961: test-file 962 ['] load_conf catch dup . 963 ESYNTAX = if cr print_syntax_error then 964; 965 966\ find a module name, leave addr on the stack (0 if not found) 967: find-module ( <module> -- ptr | 0 ) 968 bl parse ( addr len ) 969 module_options @ >r ( store current pointer ) 970 begin 971 r@ 972 while 973 2dup ( addr len addr len ) 974 r@ module.name strget 975 compare 0= if drop drop r> exit then ( found it ) 976 r> module.next @ >r 977 repeat 978 type ." was not found" cr r> 979; 980 981: show-nonempty ( addr len mod -- ) 982 strget dup verbose? or if 983 2swap type type cr 984 else 985 drop drop drop drop 986 then ; 987 988: show-one-module { addr -- addr } 989 ." Name: " addr module.name strtype cr 990 s" Path: " addr module.loadname show-nonempty 991 s" Type: " addr module.type show-nonempty 992 s" Flags: " addr module.args show-nonempty 993 s" Before load: " addr module.beforeload show-nonempty 994 s" After load: " addr module.afterload show-nonempty 995 s" Error: " addr module.loaderror show-nonempty 996 ." Status: " addr module.flag @ if ." Load" else ." Don't load" then cr 997 cr 998 addr 999; 1000 1001: show-module-options 1002 module_options @ 1003 begin 1004 ?dup 1005 while 1006 show-one-module 1007 module.next @ 1008 repeat 1009; 1010 1011: free-one-module { addr -- addr } 1012 addr module.name strfree 1013 addr module.loadname strfree 1014 addr module.type strfree 1015 addr module.args strfree 1016 addr module.beforeload strfree 1017 addr module.afterload strfree 1018 addr module.loaderror strfree 1019 addr 1020; 1021 1022: free-module-options 1023 module_options @ 1024 begin 1025 ?dup 1026 while 1027 free-one-module 1028 dup module.next @ 1029 swap free-memory 1030 repeat 1031 0 module_options ! 1032 0 last_module_option ! 1033; 1034 1035only forth also support-functions definitions 1036 1037\ Variables used for processing multiple conf files 1038 1039string current_file_name_ref \ used to print the file name 1040 1041\ Indicates if any conf file was successfully read 1042 10430 value any_conf_read? 1044 1045\ loader_conf_files processing support functions 1046 1047: get_conf_files ( -- addr len ) \ put addr/len on stack, reset var 1048 conf_files strget 0 0 conf_files strset 1049; 1050 1051: skip_leading_spaces { addr len pos -- addr len pos' } 1052 begin 1053 pos len = if 0 else addr pos + c@ bl = then 1054 while 1055 pos char+ to pos 1056 repeat 1057 addr len pos 1058; 1059 1060\ return the file name at pos, or free the string if nothing left 1061: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 1062 pos len = if 1063 addr free abort" Fatal error freeing memory" 1064 0 exit 1065 then 1066 pos >r 1067 begin 1068 \ stay in the loop until have chars and they are not blank 1069 pos len = if 0 else addr pos + c@ bl <> then 1070 while 1071 pos char+ to pos 1072 repeat 1073 addr len pos addr r@ + pos r> - 1074; 1075 1076: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 1077 skip_leading_spaces 1078 get_file_name 1079; 1080 1081: print_current_file 1082 current_file_name_ref strtype 1083; 1084 1085: process_conf_errors 1086 dup 0= if true to any_conf_read? drop exit then 1087 >r 2drop r> 1088 dup ESYNTAX = if 1089 ." Warning: syntax error on file " print_current_file cr 1090 print_syntax_error drop exit 1091 then 1092 dup ESETERROR = if 1093 ." Warning: bad definition on file " print_current_file cr 1094 print_line drop exit 1095 then 1096 dup EREAD = if 1097 ." Warning: error reading file " print_current_file cr drop exit 1098 then 1099 dup EOPEN = if 1100 verbose? if ." Warning: unable to open file " print_current_file cr then 1101 drop exit 1102 then 1103 dup EFREE = abort" Fatal error freeing memory" 1104 dup ENOMEM = abort" Out of memory" 1105 throw \ Unknown error -- pass ahead 1106; 1107 1108\ Process loader_conf_files recursively 1109\ Interface to loader_conf_files processing 1110 1111: include_conf_files 1112 get_conf_files 0 ( addr len offset ) 1113 begin 1114 get_next_file ?dup ( addr len 1 | 0 ) 1115 while 1116 current_file_name_ref strref 1117 ['] load_conf catch 1118 process_conf_errors 1119 conf_files .addr @ if recurse then 1120 repeat 1121; 1122 1123: get_nextboot_conf_file ( -- addr len ) 1124 nextboot_conf_file strget 1125; 1126 1127: rewrite_nextboot_file ( -- ) 1128 get_nextboot_conf_file 1129 O_WRONLY fopen fd ! 1130 fd @ -1 = if EOPEN throw then 1131 fd @ s' nextboot_enable="NO" ' fwrite ( fd buf len -- nwritten ) drop 1132 fd @ fclose 1133; 1134 1135: include_nextboot_file ( -- ) 1136 s" nextboot_enable" getenv dup -1 <> if 1137 2dup s' "YES"' compare >r 1138 2dup s' "yes"' compare >r 1139 2dup s" YES" compare >r 1140 2dup s" yes" compare r> r> r> and and and 0= to nextboot? 1141 else 1142 drop 1143 get_nextboot_conf_file 1144 ['] peek_file catch if 2drop then 1145 then 1146 nextboot? if 1147 get_nextboot_conf_file 1148 current_file_name_ref strref 1149 ['] load_conf catch 1150 process_conf_errors 1151 ['] rewrite_nextboot_file catch if 2drop then 1152 then 1153 s' "NO"' s" nextboot_enable" setenv 1154; 1155 1156\ Module loading functions 1157 1158: load_parameters { addr -- addr addrN lenN ... addr1 len1 N } 1159 addr 1160 addr module.args strget 1161 addr module.loadname .len @ if 1162 addr module.loadname strget 1163 else 1164 addr module.name strget 1165 then 1166 addr module.type .len @ if 1167 addr module.type strget 1168 s" -t " 1169 4 ( -t type name flags ) 1170 else 1171 2 ( name flags ) 1172 then 1173; 1174 1175: before_load ( addr -- addr ) 1176 dup module.beforeload .len @ if 1177 dup module.beforeload strget 1178 ['] evaluate catch if EBEFORELOAD throw then 1179 then 1180; 1181 1182: after_load ( addr -- addr ) 1183 dup module.afterload .len @ if 1184 dup module.afterload strget 1185 ['] evaluate catch if EAFTERLOAD throw then 1186 then 1187; 1188 1189: load_error ( addr -- addr ) 1190 dup module.loaderror .len @ if 1191 dup module.loaderror strget 1192 evaluate \ This we do not intercept so it can throw errors 1193 then 1194; 1195 1196: pre_load_message ( addr -- addr ) 1197 verbose? if 1198 dup module.name strtype 1199 ." ..." 1200 then 1201; 1202 1203: load_error_message verbose? if ." failed!" cr then ; 1204 1205: load_successful_message verbose? if ." ok" cr then ; 1206 1207: load_module 1208 load_parameters load 1209; 1210 1211: process_module ( addr -- addr ) 1212 pre_load_message 1213 before_load 1214 begin 1215 ['] load_module catch if 1216 dup module.loaderror .len @ if 1217 load_error \ Command should return a flag! 1218 else 1219 load_error_message true \ Do not retry 1220 then 1221 else 1222 after_load 1223 load_successful_message true \ Successful, do not retry 1224 then 1225 until 1226; 1227 1228: process_module_errors ( addr ior -- ) 1229 dup EBEFORELOAD = if 1230 drop 1231 ." Module " 1232 dup module.name strtype 1233 dup module.loadname .len @ if 1234 ." (" dup module.loadname strtype ." )" 1235 then 1236 cr 1237 ." Error executing " 1238 dup module.beforeload strtype cr \ XXX there was a typo here 1239 abort 1240 then 1241 1242 dup EAFTERLOAD = if 1243 drop 1244 ." Module " 1245 dup module.name .addr @ over module.name .len @ type 1246 dup module.loadname .len @ if 1247 ." (" dup module.loadname strtype ." )" 1248 then 1249 cr 1250 ." Error executing " 1251 dup module.afterload strtype cr 1252 abort 1253 then 1254 1255 throw \ Don't know what it is all about -- pass ahead 1256; 1257 1258\ Module loading interface 1259 1260\ scan the list of modules, load enabled ones. 1261: load_modules ( -- ) ( throws: abort & user-defined ) 1262 module_options @ ( list_head ) 1263 begin 1264 ?dup 1265 while 1266 dup module.flag @ if 1267 ['] process_module catch 1268 process_module_errors 1269 then 1270 module.next @ 1271 repeat 1272; 1273 1274\ h00h00 magic used to try loading either a kernel with a given name, 1275\ or a kernel with the default name in a directory of a given name 1276\ (the pain!) 1277 1278: bootpath s" /boot/" ; 1279: modulepath s" module_path" ; 1280 1281\ Functions used to save and restore module_path's value. 1282: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 1283 dup -1 = if 0 swap exit then 1284 strdup 1285; 1286: freeenv ( addr len | 0 -1 ) 1287 -1 = if drop else free abort" Freeing error" then 1288; 1289: restoreenv ( addr len | 0 -1 -- ) 1290 dup -1 = if ( it wasn't set ) 1291 2drop 1292 modulepath unsetenv 1293 else 1294 over >r 1295 modulepath setenv 1296 r> free abort" Freeing error" 1297 then 1298; 1299 1300: clip_args \ Drop second string if only one argument is passed 1301 1 = if 1302 2swap 2drop 1303 1 1304 else 1305 2 1306 then 1307; 1308 1309also builtins 1310 1311\ Parse filename from a semicolon-separated list 1312 1313\ replacement, not working yet 1314: newparse-; { addr len | a1 -- a' len-x addr x } 1315 addr len [char] ; strchr dup if ( a1 len1 ) 1316 swap to a1 ( store address ) 1317 1 - a1 @ 1 + swap ( remove match ) 1318 addr a1 addr - 1319 else 1320 0 0 addr len 1321 then 1322; 1323 1324: parse-; ( addr len -- addr' len-x addr x ) 1325 over 0 2swap ( addr 0 addr len ) 1326 begin 1327 dup 0 <> ( addr 0 addr len ) 1328 while 1329 over c@ [char] ; <> ( addr 0 addr len flag ) 1330 while 1331 1- swap 1+ swap 1332 2swap 1+ 2swap 1333 repeat then 1334 dup 0 <> if 1335 1- swap 1+ swap 1336 then 1337 2swap 1338; 1339 1340\ Try loading one of multiple kernels specified 1341 1342: try_multiple_kernels ( addr len addr' len' args -- flag ) 1343 >r 1344 begin 1345 parse-; 2>r 1346 2over 2r> 1347 r@ clip_args 1348 s" DEBUG" getenv? if 1349 s" echo Module_path: ${module_path}" evaluate 1350 ." Kernel : " >r 2dup type r> cr 1351 dup 2 = if ." Flags : " >r 2over type r> cr then 1352 then 1353 1 load 1354 while 1355 dup 0= 1356 until 1357 1 >r \ Failure 1358 else 1359 0 >r \ Success 1360 then 1361 2drop 2drop 1362 r> 1363 r> drop 1364; 1365 1366\ Try to load a kernel; the kernel name is taken from one of 1367\ the following lists, as ordered: 1368\ 1369\ 1. The "bootfile" environment variable 1370\ 2. The "kernel" environment variable 1371\ 1372\ Flags are passed, if available. If not, dummy values must be given. 1373\ 1374\ The kernel gets loaded from the current module_path. 1375 1376: load_a_kernel ( flags len 1 | x x 0 -- flag ) 1377 local args 1378 2local flags 1379 0 0 2local kernel 1380 end-locals 1381 1382 \ Check if a default kernel name exists at all, exits if not 1383 s" bootfile" getenv dup -1 <> if 1384 to kernel 1385 flags kernel args 1+ try_multiple_kernels 1386 dup 0= if exit then 1387 then 1388 drop 1389 1390 s" kernel" getenv dup -1 <> if 1391 to kernel 1392 else 1393 drop 1394 1 exit \ Failure 1395 then 1396 1397 \ Try all default kernel names 1398 flags kernel args 1+ try_multiple_kernels 1399; 1400 1401\ Try to load a kernel; the kernel name is taken from one of 1402\ the following lists, as ordered: 1403\ 1404\ 1. The "bootfile" environment variable 1405\ 2. The "kernel" environment variable 1406\ 1407\ Flags are passed, if provided. 1408\ 1409\ The kernel will be loaded from a directory computed from the 1410\ path given. Two directories will be tried in the following order: 1411\ 1412\ 1. /boot/path 1413\ 2. path 1414\ 1415\ The module_path variable is overridden if load is successful, by 1416\ prepending the successful path. 1417 1418: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 1419 local args 1420 2local path 1421 args 1 = if 0 0 then 1422 2local flags 1423 0 0 2local oldmodulepath \ like a string 1424 0 0 2local newmodulepath \ like a string 1425 end-locals 1426 1427 \ Set the environment variable module_path, and try loading 1428 \ the kernel again. 1429 modulepath getenv saveenv to oldmodulepath 1430 1431 \ Try prepending /boot/ first 1432 bootpath nip path nip + \ total length 1433 oldmodulepath nip dup -1 = if 1434 drop 1435 else 1436 1+ + \ add oldpath -- XXX why the 1+ ? 1437 then 1438 allocate if ( out of memory ) 1 exit then \ XXX throw ? 1439 1440 0 1441 bootpath strcat 1442 path strcat 1443 2dup to newmodulepath 1444 modulepath setenv 1445 1446 \ Try all default kernel names 1447 flags args 1- load_a_kernel 1448 0= if ( success ) 1449 oldmodulepath nip -1 <> if 1450 newmodulepath s" ;" strcat 1451 oldmodulepath strcat 1452 modulepath setenv 1453 newmodulepath drop free-memory 1454 oldmodulepath drop free-memory 1455 then 1456 0 exit 1457 then 1458 1459 \ Well, try without the prepended /boot/ 1460 path newmodulepath drop swap move 1461 newmodulepath drop path nip 1462 2dup to newmodulepath 1463 modulepath setenv 1464 1465 \ Try all default kernel names 1466 flags args 1- load_a_kernel 1467 if ( failed once more ) 1468 oldmodulepath restoreenv 1469 newmodulepath drop free-memory 1470 1 1471 else 1472 oldmodulepath nip -1 <> if 1473 newmodulepath s" ;" strcat 1474 oldmodulepath strcat 1475 modulepath setenv 1476 newmodulepath drop free-memory 1477 oldmodulepath drop free-memory 1478 then 1479 0 1480 then 1481; 1482 1483\ Try to load a kernel; the kernel name is taken from one of 1484\ the following lists, as ordered: 1485\ 1486\ 1. The "bootfile" environment variable 1487\ 2. The "kernel" environment variable 1488\ 3. The "path" argument 1489\ 1490\ Flags are passed, if provided. 1491\ 1492\ The kernel will be loaded from a directory computed from the 1493\ path given. Two directories will be tried in the following order: 1494\ 1495\ 1. /boot/path 1496\ 2. path 1497\ 1498\ Unless "path" is meant to be kernel name itself. In that case, it 1499\ will first be tried as a full path, and, next, search on the 1500\ directories pointed by module_path. 1501\ 1502\ The module_path variable is overridden if load is successful, by 1503\ prepending the successful path. 1504 1505: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 1506 local args 1507 2local path 1508 args 1 = if 0 0 then 1509 2local flags 1510 end-locals 1511 1512 \ First, assume path is an absolute path to a directory 1513 flags path args clip_args load_from_directory 1514 dup 0= if exit else drop then 1515 1516 \ Next, assume path points to the kernel 1517 flags path args try_multiple_kernels 1518; 1519 1520: initialize ( addr len -- ) 1521 strdup conf_files strset 1522; 1523 1524: kernel_options ( -- addr len 1 | 0 ) 1525 s" kernel_options" getenv 1526 dup -1 = if drop 0 else 1 then 1527; 1528 1529: standard_kernel_search ( flags 1 | 0 -- flag ) 1530 local args 1531 args 0= if 0 0 then 1532 2local flags 1533 s" kernel" getenv 1534 dup -1 = if 0 swap then 1535 2local path 1536 end-locals 1537 1538 path nip -1 = if ( there isn't a "kernel" environment variable ) 1539 flags args load_a_kernel 1540 else 1541 flags path args 1+ clip_args load_directory_or_file 1542 then 1543; 1544 1545: load_kernel ( -- ) ( throws: abort ) 1546 kernel_options standard_kernel_search 1547 abort" Unable to load a kernel!" 1548; 1549 1550: load_xen ( -- flag ) 1551 s" xen_kernel" getenv dup -1 <> if 1552 1 1 load ( c-addr/u flag N -- flag ) 1553 else 1554 drop 1555 0 ( -1 -- flag ) 1556 then 1557; 1558 1559: load_xen_throw ( -- ) ( throws: abort ) 1560 load_xen 1561 abort" Unable to load Xen!" 1562; 1563 1564: set_defaultoptions ( -- ) 1565 s" kernel_options" getenv dup -1 = if 1566 drop 1567 else 1568 s" temp_options" setenv 1569 then 1570; 1571 1572\ pick the i-th argument, i starts at 0 1573: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 1574 2dup = if 0 0 exit then \ out of range 1575 dup >r 1576 1+ 2* ( skip N and ui ) 1577 pick 1578 r> 1579 1+ 2* ( skip N and ai ) 1580 pick 1581; 1582 1583: drop_args ( aN uN ... a1 u1 N -- ) 1584 0 ?do 2drop loop 1585; 1586 1587: argc 1588 dup 1589; 1590 1591: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 1592 >r 1593 over 2* 1+ -roll 1594 r> 1595 over 2* 1+ -roll 1596 1+ 1597; 1598 1599: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 1600 1- -rot 1601; 1602 1603\ compute the length of the buffer including the spaces between words 1604: strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len ) 1605 dup 0= if 0 exit then 1606 0 >r \ Size 1607 0 >r \ Index 1608 begin 1609 argc r@ <> 1610 while 1611 r@ argv[] 1612 nip 1613 r> r> rot + 1+ 1614 >r 1+ >r 1615 repeat 1616 r> drop 1617 r> 1618; 1619 1620: concat_argv ( aN uN ... a1 u1 N -- a u ) 1621 strlen(argv) allocate if ENOMEM throw then 1622 0 2>r ( save addr 0 on return stack ) 1623 1624 begin 1625 dup 1626 while 1627 unqueue_argv ( ... N a1 u1 ) 1628 2r> 2swap ( old a1 u1 ) 1629 strcat 1630 s" " strcat ( append one space ) \ XXX this gives a trailing space 1631 2>r ( store string on the result stack ) 1632 repeat 1633 drop_args 1634 2r> 1635; 1636 1637: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 1638 \ Save the first argument, if it exists and is not a flag 1639 argc if 1640 0 argv[] drop c@ [char] - <> if 1641 unqueue_argv 2>r \ Filename 1642 1 >r \ Filename present 1643 else 1644 0 >r \ Filename not present 1645 then 1646 else 1647 0 >r \ Filename not present 1648 then 1649 1650 \ If there are other arguments, assume they are flags 1651 ?dup if 1652 concat_argv 1653 2dup s" temp_options" setenv 1654 drop free if EFREE throw then 1655 else 1656 set_defaultoptions 1657 then 1658 1659 \ Bring back the filename, if one was provided 1660 r> if 2r> 1 else 0 then 1661; 1662 1663: get_arguments ( -- addrN lenN ... addr1 len1 N ) 1664 0 1665 begin 1666 \ Get next word on the command line 1667 parse-word 1668 ?dup while 1669 queue_argv 1670 repeat 1671 drop ( empty string ) 1672; 1673 1674: load_kernel_and_modules ( args -- flag ) 1675 set_tempoptions 1676 argc >r 1677 s" temp_options" getenv dup -1 <> if 1678 queue_argv 1679 else 1680 drop 1681 then 1682 load_xen 1683 ?dup 0= if ( success ) 1684 r> if ( a path was passed ) 1685 load_directory_or_file 1686 else 1687 standard_kernel_search 1688 then 1689 ?dup 0= if ['] load_modules catch then 1690 then 1691; 1692 1693only forth definitions 1694