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