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: s' \ same as s", allows " in the string 194 [char] ' parse 195 state @ if postpone sliteral then 196; immediate 197 198: 2>r postpone >r postpone >r ; immediate 199: 2r> postpone r> postpone r> ; immediate 200: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate 201 202: getenv? getenv -1 = if false else drop true then ; 203 204\ determine if a word appears in a string, case-insensitive 205: contains? ( addr1 len1 addr2 len2 -- 0 | -1 ) 206 2 pick 0= if 2drop 2drop true exit then 207 dup 0= if 2drop 2drop false exit then 208 begin 209 begin 210 swap dup c@ dup 32 = over 9 = or over 10 = or 211 over 13 = or over 44 = or swap drop 212 while 1+ swap 1- repeat 213 swap 2 pick 1- over < 214 while 215 2over 2over drop over compare-insensitive 0= if 216 2 pick over = if 2drop 2drop true exit then 217 2 pick tuck - -rot + swap over c@ dup 32 = 218 over 9 = or over 10 = or over 13 = or over 44 = or 219 swap drop if 2drop 2drop true exit then 220 then begin 221 swap dup c@ dup 32 = over 9 = or over 10 = or 222 over 13 = or over 44 = or swap drop 223 if false else true then 2 pick 0> and 224 while 1+ swap 1- repeat 225 swap 226 repeat 227 2drop 2drop false 228; 229 230: boot_serial? ( -- 0 | -1 ) 231 s" console" getenv dup -1 <> if 232 s" comconsole" 2swap contains? 233 else drop false then 234 s" boot_serial" getenv dup -1 <> if 235 swap drop 0> 236 else drop false then 237 or \ console contains comconsole ( or ) boot_serial 238 s" boot_multicons" getenv dup -1 <> if 239 swap drop 0> 240 else drop false then 241 or \ previous boolean ( or ) boot_multicons 242; 243 244\ Private definitions 245 246vocabulary support-functions 247only forth also support-functions definitions 248 249\ Some control characters constants 250 2517 constant bell 2528 constant backspace 2539 constant tab 25410 constant lf 25513 constant <cr> 256 257\ Read buffer size 258 25980 constant read_buffer_size 260 261\ Standard suffixes 262 263: load_module_suffix s" _load" ; 264: module_loadname_suffix s" _name" ; 265: module_type_suffix s" _type" ; 266: module_args_suffix s" _flags" ; 267: module_beforeload_suffix s" _before" ; 268: module_afterload_suffix s" _after" ; 269: module_loaderror_suffix s" _error" ; 270 271\ Support operators 272 273: >= < 0= ; 274: <= > 0= ; 275 276\ Assorted support functions 277 278: free-memory free if EFREE throw then ; 279 280: strget { var -- addr len } var .addr @ var .len @ ; 281 282\ assign addr len to variable. 283: strset { addr len var -- } addr var .addr ! len var .len ! ; 284 285\ free memory and reset fields 286: strfree { var -- } var .addr @ ?dup if free-memory 0 0 var strset then ; 287 288\ free old content, make a copy of the string and assign to variable 289: string= { addr len var -- } var strfree addr len strdup var strset ; 290 291: strtype ( str -- ) strget type ; 292 293\ assign a reference to what is on the stack 294: strref { addr len var -- addr len } 295 addr var .addr ! len var .len ! addr len 296; 297 298\ unquote a string 299: unquote ( addr len -- addr len ) 300 over c@ [char] " = if 2 chars - swap char+ swap then 301; 302 303\ Assignment data temporary storage 304 305string name_buffer 306string value_buffer 307 308\ Line by line file reading functions 309\ 310\ exported: 311\ line_buffer 312\ end_of_file? 313\ fd 314\ read_line 315\ reset_line_reading 316 317vocabulary line-reading 318also line-reading definitions 319 320\ File data temporary storage 321 322string read_buffer 3230 value read_buffer_ptr 324 325\ File's line reading function 326 327get-current ( -- wid ) previous definitions 328 329string line_buffer 3300 value end_of_file? 331variable fd 332 333>search ( wid -- ) definitions 334 335: skip_newlines 336 begin 337 read_buffer .len @ read_buffer_ptr > 338 while 339 read_buffer .addr @ read_buffer_ptr + c@ lf = if 340 read_buffer_ptr char+ to read_buffer_ptr 341 else 342 exit 343 then 344 repeat 345; 346 347: scan_buffer ( -- addr len ) 348 read_buffer_ptr >r 349 begin 350 read_buffer .len @ r@ > 351 while 352 read_buffer .addr @ r@ + c@ lf = if 353 read_buffer .addr @ read_buffer_ptr + ( -- addr ) 354 r@ read_buffer_ptr - ( -- len ) 355 r> to read_buffer_ptr 356 exit 357 then 358 r> char+ >r 359 repeat 360 read_buffer .addr @ read_buffer_ptr + ( -- addr ) 361 r@ read_buffer_ptr - ( -- len ) 362 r> to read_buffer_ptr 363; 364 365: line_buffer_resize ( len -- len ) 366 >r 367 line_buffer .len @ if 368 line_buffer .addr @ 369 line_buffer .len @ r@ + 370 resize if ENOMEM throw then 371 else 372 r@ allocate if ENOMEM throw then 373 then 374 line_buffer .addr ! 375 r> 376; 377 378: append_to_line_buffer ( addr len -- ) 379 line_buffer strget 380 2swap strcat 381 line_buffer .len ! 382 drop 383; 384 385: read_from_buffer 386 scan_buffer ( -- addr len ) 387 line_buffer_resize ( len -- len ) 388 append_to_line_buffer ( addr len -- ) 389; 390 391: refill_required? 392 read_buffer .len @ read_buffer_ptr = 393 end_of_file? 0= and 394; 395 396: refill_buffer 397 0 to read_buffer_ptr 398 read_buffer .addr @ 0= if 399 read_buffer_size allocate if ENOMEM throw then 400 read_buffer .addr ! 401 then 402 fd @ read_buffer .addr @ read_buffer_size fread 403 dup -1 = if EREAD throw then 404 dup 0= if true to end_of_file? then 405 read_buffer .len ! 406; 407 408get-current ( -- wid ) previous definitions >search ( wid -- ) 409 410: reset_line_reading 411 0 to read_buffer_ptr 412; 413 414: read_line 415 line_buffer strfree 416 skip_newlines 417 begin 418 read_from_buffer 419 refill_required? 420 while 421 refill_buffer 422 repeat 423; 424 425only forth also support-functions definitions 426 427\ Conf file line parser: 428\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 429\ <spaces>[<comment>] 430\ <name> ::= <letter>{<letter>|<digit>|'_'} 431\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 432\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 433\ <comment> ::= '#'{<anything>} 434\ 435\ exported: 436\ line_pointer 437\ process_conf 438 4390 value line_pointer 440 441vocabulary file-processing 442also file-processing definitions 443 444\ parser functions 445\ 446\ exported: 447\ get_assignment 448 449vocabulary parser 450also parser definitions 451 4520 value parsing_function 4530 value end_of_line 454 455: end_of_line? line_pointer end_of_line = ; 456 457\ classifiers for various character classes in the input line 458 459: letter? 460 line_pointer c@ >r 461 r@ [char] A >= 462 r@ [char] Z <= and 463 r@ [char] a >= 464 r> [char] z <= and 465 or 466; 467 468: digit? 469 line_pointer c@ >r 470 r@ [char] - = 471 r@ [char] 0 >= 472 r> [char] 9 <= and 473 or 474; 475 476: quote? line_pointer c@ [char] " = ; 477 478: assignment_sign? line_pointer c@ [char] = = ; 479 480: comment? line_pointer c@ [char] # = ; 481 482: space? line_pointer c@ bl = line_pointer c@ tab = or ; 483 484: backslash? line_pointer c@ [char] \ = ; 485 486: underscore? line_pointer c@ [char] _ = ; 487 488: dot? line_pointer c@ [char] . = ; 489 490\ manipulation of input line 491: skip_character line_pointer char+ to line_pointer ; 492 493: skip_to_end_of_line end_of_line to line_pointer ; 494 495: eat_space 496 begin 497 end_of_line? if 0 else space? then 498 while 499 skip_character 500 repeat 501; 502 503: parse_name ( -- addr len ) 504 line_pointer 505 begin 506 end_of_line? if 0 else letter? digit? underscore? dot? or or or then 507 while 508 skip_character 509 repeat 510 line_pointer over - 511 strdup 512; 513 514: remove_backslashes { addr len | addr' len' -- addr' len' } 515 len allocate if ENOMEM throw then 516 to addr' 517 addr >r 518 begin 519 addr c@ [char] \ <> if 520 addr c@ addr' len' + c! 521 len' char+ to len' 522 then 523 addr char+ to addr 524 r@ len + addr = 525 until 526 r> drop 527 addr' len' 528; 529 530: parse_quote ( -- addr len ) 531 line_pointer 532 skip_character 533 end_of_line? if ESYNTAX throw then 534 begin 535 quote? 0= 536 while 537 backslash? if 538 skip_character 539 end_of_line? if ESYNTAX throw then 540 then 541 skip_character 542 end_of_line? if ESYNTAX throw then 543 repeat 544 skip_character 545 line_pointer over - 546 remove_backslashes 547; 548 549: read_name 550 parse_name ( -- addr len ) 551 name_buffer strset 552; 553 554: read_value 555 quote? if 556 parse_quote ( -- addr len ) 557 else 558 parse_name ( -- addr len ) 559 then 560 value_buffer strset 561; 562 563: comment 564 skip_to_end_of_line 565; 566 567: white_space_4 568 eat_space 569 comment? if ['] comment to parsing_function exit then 570 end_of_line? 0= if ESYNTAX throw then 571; 572 573: variable_value 574 read_value 575 ['] white_space_4 to parsing_function 576; 577 578: white_space_3 579 eat_space 580 letter? digit? quote? or or if 581 ['] variable_value to parsing_function exit 582 then 583 ESYNTAX throw 584; 585 586: assignment_sign 587 skip_character 588 ['] white_space_3 to parsing_function 589; 590 591: white_space_2 592 eat_space 593 assignment_sign? if ['] assignment_sign to parsing_function exit then 594 ESYNTAX throw 595; 596 597: variable_name 598 read_name 599 ['] white_space_2 to parsing_function 600; 601 602: white_space_1 603 eat_space 604 letter? if ['] variable_name to parsing_function exit then 605 comment? if ['] comment to parsing_function exit then 606 end_of_line? 0= if ESYNTAX throw then 607; 608 609get-current ( -- wid ) previous definitions >search ( wid -- ) 610 611: get_assignment 612 line_buffer strget + to end_of_line 613 line_buffer .addr @ to line_pointer 614 ['] white_space_1 to parsing_function 615 begin 616 end_of_line? 0= 617 while 618 parsing_function execute 619 repeat 620 parsing_function ['] comment = 621 parsing_function ['] white_space_1 = 622 parsing_function ['] white_space_4 = 623 or or 0= if ESYNTAX throw then 624; 625 626only forth also support-functions also file-processing definitions 627 628\ Process line 629 630: assignment_type? ( addr len -- flag ) 631 name_buffer strget 632 compare 0= 633; 634 635: suffix_type? ( addr len -- flag ) 636 name_buffer .len @ over <= if 2drop false exit then 637 name_buffer .len @ over - name_buffer .addr @ + 638 over compare 0= 639; 640 641: loader_conf_files? s" loader_conf_files" assignment_type? ; 642 643: nextboot_flag? s" nextboot_enable" assignment_type? ; 644 645: nextboot_conf? s" nextboot_conf" assignment_type? ; 646 647: verbose_flag? s" verbose_loading" assignment_type? ; 648 649: execute? s" exec" assignment_type? ; 650 651: module_load? load_module_suffix suffix_type? ; 652 653: module_loadname? module_loadname_suffix suffix_type? ; 654 655: module_type? module_type_suffix suffix_type? ; 656 657: module_args? module_args_suffix suffix_type? ; 658 659: module_beforeload? module_beforeload_suffix suffix_type? ; 660 661: module_afterload? module_afterload_suffix suffix_type? ; 662 663: module_loaderror? module_loaderror_suffix suffix_type? ; 664 665\ build a 'set' statement and execute it 666: set_environment_variable 667 name_buffer .len @ value_buffer .len @ + 5 chars + \ size of result string 668 allocate if ENOMEM throw then 669 dup 0 \ start with an empty string and append the pieces 670 s" set " strcat 671 name_buffer strget strcat 672 s" =" strcat 673 value_buffer strget strcat 674 ['] evaluate catch if 675 2drop free drop 676 ESETERROR throw 677 else 678 free-memory 679 then 680; 681 682: set_conf_files 683 set_environment_variable 684 s" loader_conf_files" getenv conf_files string= 685; 686 687: set_nextboot_conf 688 value_buffer strget unquote nextboot_conf_file string= 689; 690 691: append_to_module_options_list ( addr -- ) 692 module_options @ 0= if 693 dup module_options ! 694 last_module_option ! 695 else 696 dup last_module_option @ module.next ! 697 last_module_option ! 698 then 699; 700 701: set_module_name { addr -- } \ check leaks 702 name_buffer strget addr module.name string= 703; 704 705: yes_value? 706 value_buffer strget \ XXX could use unquote 707 2dup s' "YES"' compare >r 708 2dup s' "yes"' compare >r 709 2dup s" YES" compare >r 710 s" yes" compare r> r> r> and and and 0= 711; 712 713: find_module_option ( -- addr | 0 ) \ return ptr to entry matching name_buffer 714 module_options @ 715 begin 716 dup 717 while 718 dup module.name strget 719 name_buffer strget 720 compare 0= if exit then 721 module.next @ 722 repeat 723; 724 725: new_module_option ( -- addr ) 726 sizeof module allocate if ENOMEM throw then 727 dup sizeof module erase 728 dup append_to_module_options_list 729 dup set_module_name 730; 731 732: get_module_option ( -- addr ) 733 find_module_option 734 ?dup 0= if new_module_option then 735; 736 737: set_module_flag 738 name_buffer .len @ load_module_suffix nip - name_buffer .len ! 739 yes_value? get_module_option module.flag ! 740; 741 742: set_module_args 743 name_buffer .len @ module_args_suffix nip - name_buffer .len ! 744 value_buffer strget unquote 745 get_module_option module.args string= 746; 747 748: set_module_loadname 749 name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 750 value_buffer strget unquote 751 get_module_option module.loadname string= 752; 753 754: set_module_type 755 name_buffer .len @ module_type_suffix nip - name_buffer .len ! 756 value_buffer strget unquote 757 get_module_option module.type string= 758; 759 760: set_module_beforeload 761 name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 762 value_buffer strget unquote 763 get_module_option module.beforeload string= 764; 765 766: set_module_afterload 767 name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 768 value_buffer strget unquote 769 get_module_option module.afterload string= 770; 771 772: set_module_loaderror 773 name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 774 value_buffer strget unquote 775 get_module_option module.loaderror string= 776; 777 778: set_nextboot_flag 779 yes_value? to nextboot? 780; 781 782: set_verbose 783 yes_value? to verbose? 784; 785 786: execute_command 787 value_buffer strget unquote 788 ['] evaluate catch if EEXEC throw then 789; 790 791: process_assignment 792 name_buffer .len @ 0= if exit then 793 loader_conf_files? if set_conf_files exit then 794 nextboot_flag? if set_nextboot_flag exit then 795 nextboot_conf? if set_nextboot_conf exit then 796 verbose_flag? if set_verbose exit then 797 execute? if execute_command exit then 798 module_load? if set_module_flag exit then 799 module_loadname? if set_module_loadname exit then 800 module_type? if set_module_type exit then 801 module_args? if set_module_args exit then 802 module_beforeload? if set_module_beforeload exit then 803 module_afterload? if set_module_afterload exit then 804 module_loaderror? if set_module_loaderror exit then 805 set_environment_variable 806; 807 808\ free_buffer ( -- ) 809\ 810\ Free some pointers if needed. The code then tests for errors 811\ in freeing, and throws an exception if needed. If a pointer is 812\ not allocated, it's value (0) is used as flag. 813 814: free_buffers 815 name_buffer strfree 816 value_buffer strfree 817; 818 819\ Higher level file processing 820 821get-current ( -- wid ) previous definitions >search ( wid -- ) 822 823: process_conf 824 begin 825 end_of_file? 0= 826 while 827 free_buffers 828 read_line 829 get_assignment 830 ['] process_assignment catch 831 ['] free_buffers catch 832 swap throw throw 833 repeat 834; 835 836: peek_file ( addr len -- ) 837 0 to end_of_file? 838 reset_line_reading 839 O_RDONLY fopen fd ! 840 fd @ -1 = if EOPEN throw then 841 free_buffers 842 read_line 843 get_assignment 844 ['] process_assignment catch 845 ['] free_buffers catch 846 fd @ fclose 847 swap throw throw 848; 849 850only forth also support-functions definitions 851 852\ Interface to loading conf files 853 854: load_conf ( addr len -- ) 855 0 to end_of_file? 856 reset_line_reading 857 O_RDONLY fopen fd ! 858 fd @ -1 = if EOPEN throw then 859 ['] process_conf catch 860 fd @ fclose 861 throw 862; 863 864: print_line line_buffer strtype cr ; 865 866: print_syntax_error 867 line_buffer strtype cr 868 line_buffer .addr @ 869 begin 870 line_pointer over <> 871 while 872 bl emit char+ 873 repeat 874 drop 875 ." ^" cr 876; 877 878 879\ Debugging support functions 880 881only forth definitions also support-functions 882 883: test-file 884 ['] load_conf catch dup . 885 ESYNTAX = if cr print_syntax_error then 886; 887 888\ find a module name, leave addr on the stack (0 if not found) 889: find-module ( <module> -- ptr | 0 ) 890 bl parse ( addr len ) 891 module_options @ >r ( store current pointer ) 892 begin 893 r@ 894 while 895 2dup ( addr len addr len ) 896 r@ module.name strget 897 compare 0= if drop drop r> exit then ( found it ) 898 r> module.next @ >r 899 repeat 900 type ." was not found" cr r> 901; 902 903: show-nonempty ( addr len mod -- ) 904 strget dup verbose? or if 905 2swap type type cr 906 else 907 drop drop drop drop 908 then ; 909 910: show-one-module { addr -- addr } 911 ." Name: " addr module.name strtype cr 912 s" Path: " addr module.loadname show-nonempty 913 s" Type: " addr module.type show-nonempty 914 s" Flags: " addr module.args show-nonempty 915 s" Before load: " addr module.beforeload show-nonempty 916 s" After load: " addr module.afterload show-nonempty 917 s" Error: " addr module.loaderror show-nonempty 918 ." Status: " addr module.flag @ if ." Load" else ." Don't load" then cr 919 cr 920 addr 921; 922 923: show-module-options 924 module_options @ 925 begin 926 ?dup 927 while 928 show-one-module 929 module.next @ 930 repeat 931; 932 933: free-one-module { addr -- addr } 934 addr module.name strfree 935 addr module.loadname strfree 936 addr module.type strfree 937 addr module.args strfree 938 addr module.beforeload strfree 939 addr module.afterload strfree 940 addr module.loaderror strfree 941 addr 942; 943 944: free-module-options 945 module_options @ 946 begin 947 ?dup 948 while 949 free-one-module 950 dup module.next @ 951 swap free-memory 952 repeat 953 0 module_options ! 954 0 last_module_option ! 955; 956 957only forth also support-functions definitions 958 959\ Variables used for processing multiple conf files 960 961string current_file_name_ref \ used to print the file name 962 963\ Indicates if any conf file was successfully read 964 9650 value any_conf_read? 966 967\ loader_conf_files processing support functions 968 969: get_conf_files ( -- addr len ) \ put addr/len on stack, reset var 970 conf_files strget 0 0 conf_files strset 971; 972 973: skip_leading_spaces { addr len pos -- addr len pos' } 974 begin 975 pos len = if 0 else addr pos + c@ bl = then 976 while 977 pos char+ to pos 978 repeat 979 addr len pos 980; 981 982\ return the file name at pos, or free the string if nothing left 983: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 984 pos len = if 985 addr free abort" Fatal error freeing memory" 986 0 exit 987 then 988 pos >r 989 begin 990 \ stay in the loop until have chars and they are not blank 991 pos len = if 0 else addr pos + c@ bl <> then 992 while 993 pos char+ to pos 994 repeat 995 addr len pos addr r@ + pos r> - 996; 997 998: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 999 skip_leading_spaces 1000 get_file_name 1001; 1002 1003: print_current_file 1004 current_file_name_ref strtype 1005; 1006 1007: process_conf_errors 1008 dup 0= if true to any_conf_read? drop exit then 1009 >r 2drop r> 1010 dup ESYNTAX = if 1011 ." Warning: syntax error on file " print_current_file cr 1012 print_syntax_error drop exit 1013 then 1014 dup ESETERROR = if 1015 ." Warning: bad definition on file " print_current_file cr 1016 print_line drop exit 1017 then 1018 dup EREAD = if 1019 ." Warning: error reading file " print_current_file cr drop exit 1020 then 1021 dup EOPEN = if 1022 verbose? if ." Warning: unable to open file " print_current_file cr then 1023 drop exit 1024 then 1025 dup EFREE = abort" Fatal error freeing memory" 1026 dup ENOMEM = abort" Out of memory" 1027 throw \ Unknown error -- pass ahead 1028; 1029 1030\ Process loader_conf_files recursively 1031\ Interface to loader_conf_files processing 1032 1033: include_conf_files 1034 get_conf_files 0 ( addr len offset ) 1035 begin 1036 get_next_file ?dup ( addr len 1 | 0 ) 1037 while 1038 current_file_name_ref strref 1039 ['] load_conf catch 1040 process_conf_errors 1041 conf_files .addr @ if recurse then 1042 repeat 1043; 1044 1045: get_nextboot_conf_file ( -- addr len ) 1046 nextboot_conf_file strget 1047; 1048 1049: rewrite_nextboot_file ( -- ) 1050 get_nextboot_conf_file 1051 O_WRONLY fopen fd ! 1052 fd @ -1 = if EOPEN throw then 1053 fd @ s' nextboot_enable="NO" ' fwrite ( fd buf len -- nwritten ) drop 1054 fd @ fclose 1055; 1056 1057: include_nextboot_file ( -- ) 1058 get_nextboot_conf_file 1059 ['] peek_file catch if 2drop then 1060 nextboot? if 1061 get_nextboot_conf_file 1062 current_file_name_ref strref 1063 ['] load_conf catch 1064 process_conf_errors 1065 ['] rewrite_nextboot_file catch if 2drop then 1066 then 1067; 1068 1069\ Module loading functions 1070 1071: load_parameters { addr -- addr addrN lenN ... addr1 len1 N } 1072 addr 1073 addr module.args strget 1074 addr module.loadname .len @ if 1075 addr module.loadname strget 1076 else 1077 addr module.name strget 1078 then 1079 addr module.type .len @ if 1080 addr module.type strget 1081 s" -t " 1082 4 ( -t type name flags ) 1083 else 1084 2 ( name flags ) 1085 then 1086; 1087 1088: before_load ( addr -- addr ) 1089 dup module.beforeload .len @ if 1090 dup module.beforeload strget 1091 ['] evaluate catch if EBEFORELOAD throw then 1092 then 1093; 1094 1095: after_load ( addr -- addr ) 1096 dup module.afterload .len @ if 1097 dup module.afterload strget 1098 ['] evaluate catch if EAFTERLOAD throw then 1099 then 1100; 1101 1102: load_error ( addr -- addr ) 1103 dup module.loaderror .len @ if 1104 dup module.loaderror strget 1105 evaluate \ This we do not intercept so it can throw errors 1106 then 1107; 1108 1109: pre_load_message ( addr -- addr ) 1110 verbose? if 1111 dup module.name strtype 1112 ." ..." 1113 then 1114; 1115 1116: load_error_message verbose? if ." failed!" cr then ; 1117 1118: load_successful_message verbose? if ." ok" cr then ; 1119 1120: load_module 1121 load_parameters load 1122; 1123 1124: process_module ( addr -- addr ) 1125 pre_load_message 1126 before_load 1127 begin 1128 ['] load_module catch if 1129 dup module.loaderror .len @ if 1130 load_error \ Command should return a flag! 1131 else 1132 load_error_message true \ Do not retry 1133 then 1134 else 1135 after_load 1136 load_successful_message true \ Successful, do not retry 1137 then 1138 until 1139; 1140 1141: process_module_errors ( addr ior -- ) 1142 dup EBEFORELOAD = if 1143 drop 1144 ." Module " 1145 dup module.name strtype 1146 dup module.loadname .len @ if 1147 ." (" dup module.loadname strtype ." )" 1148 then 1149 cr 1150 ." Error executing " 1151 dup module.beforeload strtype cr \ XXX there was a typo here 1152 abort 1153 then 1154 1155 dup EAFTERLOAD = if 1156 drop 1157 ." Module " 1158 dup module.name .addr @ over module.name .len @ type 1159 dup module.loadname .len @ if 1160 ." (" dup module.loadname strtype ." )" 1161 then 1162 cr 1163 ." Error executing " 1164 dup module.afterload strtype cr 1165 abort 1166 then 1167 1168 throw \ Don't know what it is all about -- pass ahead 1169; 1170 1171\ Module loading interface 1172 1173\ scan the list of modules, load enabled ones. 1174: load_modules ( -- ) ( throws: abort & user-defined ) 1175 module_options @ ( list_head ) 1176 begin 1177 ?dup 1178 while 1179 dup module.flag @ if 1180 ['] process_module catch 1181 process_module_errors 1182 then 1183 module.next @ 1184 repeat 1185; 1186 1187\ h00h00 magic used to try loading either a kernel with a given name, 1188\ or a kernel with the default name in a directory of a given name 1189\ (the pain!) 1190 1191: bootpath s" /boot/" ; 1192: modulepath s" module_path" ; 1193 1194\ Functions used to save and restore module_path's value. 1195: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 1196 dup -1 = if 0 swap exit then 1197 strdup 1198; 1199: freeenv ( addr len | 0 -1 ) 1200 -1 = if drop else free abort" Freeing error" then 1201; 1202: restoreenv ( addr len | 0 -1 -- ) 1203 dup -1 = if ( it wasn't set ) 1204 2drop 1205 modulepath unsetenv 1206 else 1207 over >r 1208 modulepath setenv 1209 r> free abort" Freeing error" 1210 then 1211; 1212 1213: clip_args \ Drop second string if only one argument is passed 1214 1 = if 1215 2swap 2drop 1216 1 1217 else 1218 2 1219 then 1220; 1221 1222also builtins 1223 1224\ Parse filename from a semicolon-separated list 1225 1226\ replacement, not working yet 1227: newparse-; { addr len | a1 -- a' len-x addr x } 1228 addr len [char] ; strchr dup if ( a1 len1 ) 1229 swap to a1 ( store address ) 1230 1 - a1 @ 1 + swap ( remove match ) 1231 addr a1 addr - 1232 else 1233 0 0 addr len 1234 then 1235; 1236 1237: parse-; ( addr len -- addr' len-x addr x ) 1238 over 0 2swap ( addr 0 addr len ) 1239 begin 1240 dup 0 <> ( addr 0 addr len ) 1241 while 1242 over c@ [char] ; <> ( addr 0 addr len flag ) 1243 while 1244 1- swap 1+ swap 1245 2swap 1+ 2swap 1246 repeat then 1247 dup 0 <> if 1248 1- swap 1+ swap 1249 then 1250 2swap 1251; 1252 1253\ Try loading one of multiple kernels specified 1254 1255: try_multiple_kernels ( addr len addr' len' args -- flag ) 1256 >r 1257 begin 1258 parse-; 2>r 1259 2over 2r> 1260 r@ clip_args 1261 s" DEBUG" getenv? if 1262 s" echo Module_path: ${module_path}" evaluate 1263 ." Kernel : " >r 2dup type r> cr 1264 dup 2 = if ." Flags : " >r 2over type r> cr then 1265 then 1266 1 load 1267 while 1268 dup 0= 1269 until 1270 1 >r \ Failure 1271 else 1272 0 >r \ Success 1273 then 1274 2drop 2drop 1275 r> 1276 r> drop 1277; 1278 1279\ Try to load a kernel; the kernel name is taken from one of 1280\ the following lists, as ordered: 1281\ 1282\ 1. The "bootfile" environment variable 1283\ 2. The "kernel" environment variable 1284\ 1285\ Flags are passed, if available. If not, dummy values must be given. 1286\ 1287\ The kernel gets loaded from the current module_path. 1288 1289: load_a_kernel ( flags len 1 | x x 0 -- flag ) 1290 local args 1291 2local flags 1292 0 0 2local kernel 1293 end-locals 1294 1295 \ Check if a default kernel name exists at all, exits if not 1296 s" bootfile" getenv dup -1 <> if 1297 to kernel 1298 flags kernel args 1+ try_multiple_kernels 1299 dup 0= if exit then 1300 then 1301 drop 1302 1303 s" kernel" getenv dup -1 <> if 1304 to kernel 1305 else 1306 drop 1307 1 exit \ Failure 1308 then 1309 1310 \ Try all default kernel names 1311 flags kernel args 1+ try_multiple_kernels 1312; 1313 1314\ Try to load a kernel; the kernel name is taken from one of 1315\ the following lists, as ordered: 1316\ 1317\ 1. The "bootfile" environment variable 1318\ 2. The "kernel" environment variable 1319\ 1320\ Flags are passed, if provided. 1321\ 1322\ The kernel will be loaded from a directory computed from the 1323\ path given. Two directories will be tried in the following order: 1324\ 1325\ 1. /boot/path 1326\ 2. path 1327\ 1328\ The module_path variable is overridden if load is successful, by 1329\ prepending the successful path. 1330 1331: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 1332 local args 1333 2local path 1334 args 1 = if 0 0 then 1335 2local flags 1336 0 0 2local oldmodulepath \ like a string 1337 0 0 2local newmodulepath \ like a string 1338 end-locals 1339 1340 \ Set the environment variable module_path, and try loading 1341 \ the kernel again. 1342 modulepath getenv saveenv to oldmodulepath 1343 1344 \ Try prepending /boot/ first 1345 bootpath nip path nip + \ total length 1346 oldmodulepath nip dup -1 = if 1347 drop 1348 else 1349 1+ + \ add oldpath -- XXX why the 1+ ? 1350 then 1351 allocate if ( out of memory ) 1 exit then \ XXX throw ? 1352 1353 0 1354 bootpath strcat 1355 path strcat 1356 2dup to newmodulepath 1357 modulepath setenv 1358 1359 \ Try all default kernel names 1360 flags args 1- load_a_kernel 1361 0= if ( success ) 1362 oldmodulepath nip -1 <> if 1363 newmodulepath s" ;" strcat 1364 oldmodulepath strcat 1365 modulepath setenv 1366 newmodulepath drop free-memory 1367 oldmodulepath drop free-memory 1368 then 1369 0 exit 1370 then 1371 1372 \ Well, try without the prepended /boot/ 1373 path newmodulepath drop swap move 1374 newmodulepath drop path nip 1375 2dup to newmodulepath 1376 modulepath setenv 1377 1378 \ Try all default kernel names 1379 flags args 1- load_a_kernel 1380 if ( failed once more ) 1381 oldmodulepath restoreenv 1382 newmodulepath drop free-memory 1383 1 1384 else 1385 oldmodulepath nip -1 <> if 1386 newmodulepath s" ;" strcat 1387 oldmodulepath strcat 1388 modulepath setenv 1389 newmodulepath drop free-memory 1390 oldmodulepath drop free-memory 1391 then 1392 0 1393 then 1394; 1395 1396\ Try to load a kernel; the kernel name is taken from one of 1397\ the following lists, as ordered: 1398\ 1399\ 1. The "bootfile" environment variable 1400\ 2. The "kernel" environment variable 1401\ 3. The "path" argument 1402\ 1403\ Flags are passed, if provided. 1404\ 1405\ The kernel will be loaded from a directory computed from the 1406\ path given. Two directories will be tried in the following order: 1407\ 1408\ 1. /boot/path 1409\ 2. path 1410\ 1411\ Unless "path" is meant to be kernel name itself. In that case, it 1412\ will first be tried as a full path, and, next, search on the 1413\ directories pointed by module_path. 1414\ 1415\ The module_path variable is overridden if load is successful, by 1416\ prepending the successful path. 1417 1418: load_directory_or_file ( 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 end-locals 1424 1425 \ First, assume path is an absolute path to a directory 1426 flags path args clip_args load_from_directory 1427 dup 0= if exit else drop then 1428 1429 \ Next, assume path points to the kernel 1430 flags path args try_multiple_kernels 1431; 1432 1433: initialize ( addr len -- ) 1434 strdup conf_files strset 1435; 1436 1437: kernel_options ( -- addr len 1 | 0 ) 1438 s" kernel_options" getenv 1439 dup -1 = if drop 0 else 1 then 1440; 1441 1442: standard_kernel_search ( flags 1 | 0 -- flag ) 1443 local args 1444 args 0= if 0 0 then 1445 2local flags 1446 s" kernel" getenv 1447 dup -1 = if 0 swap then 1448 2local path 1449 end-locals 1450 1451 path nip -1 = if ( there isn't a "kernel" environment variable ) 1452 flags args load_a_kernel 1453 else 1454 flags path args 1+ clip_args load_directory_or_file 1455 then 1456; 1457 1458: load_kernel ( -- ) ( throws: abort ) 1459 kernel_options standard_kernel_search 1460 abort" Unable to load a kernel!" 1461; 1462 1463: load_xen ( -- flag ) 1464 s" xen_kernel" getenv dup -1 <> if 1465 1 1 load ( c-addr/u flag N -- flag ) 1466 else 1467 drop 1468 0 ( -1 -- flag ) 1469 then 1470; 1471 1472: load_xen_throw ( -- ) ( throws: abort ) 1473 load_xen 1474 abort" Unable to load Xen!" 1475; 1476 1477: set_defaultoptions ( -- ) 1478 s" kernel_options" getenv dup -1 = if 1479 drop 1480 else 1481 s" temp_options" setenv 1482 then 1483; 1484 1485\ pick the i-th argument, i starts at 0 1486: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 1487 2dup = if 0 0 exit then \ out of range 1488 dup >r 1489 1+ 2* ( skip N and ui ) 1490 pick 1491 r> 1492 1+ 2* ( skip N and ai ) 1493 pick 1494; 1495 1496: drop_args ( aN uN ... a1 u1 N -- ) 1497 0 ?do 2drop loop 1498; 1499 1500: argc 1501 dup 1502; 1503 1504: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 1505 >r 1506 over 2* 1+ -roll 1507 r> 1508 over 2* 1+ -roll 1509 1+ 1510; 1511 1512: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 1513 1- -rot 1514; 1515 1516\ compute the length of the buffer including the spaces between words 1517: strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len ) 1518 dup 0= if 0 exit then 1519 0 >r \ Size 1520 0 >r \ Index 1521 begin 1522 argc r@ <> 1523 while 1524 r@ argv[] 1525 nip 1526 r> r> rot + 1+ 1527 >r 1+ >r 1528 repeat 1529 r> drop 1530 r> 1531; 1532 1533: concat_argv ( aN uN ... a1 u1 N -- a u ) 1534 strlen(argv) allocate if ENOMEM throw then 1535 0 2>r ( save addr 0 on return stack ) 1536 1537 begin 1538 dup 1539 while 1540 unqueue_argv ( ... N a1 u1 ) 1541 2r> 2swap ( old a1 u1 ) 1542 strcat 1543 s" " strcat ( append one space ) \ XXX this gives a trailing space 1544 2>r ( store string on the result stack ) 1545 repeat 1546 drop_args 1547 2r> 1548; 1549 1550: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 1551 \ Save the first argument, if it exists and is not a flag 1552 argc if 1553 0 argv[] drop c@ [char] - <> if 1554 unqueue_argv 2>r \ Filename 1555 1 >r \ Filename present 1556 else 1557 0 >r \ Filename not present 1558 then 1559 else 1560 0 >r \ Filename not present 1561 then 1562 1563 \ If there are other arguments, assume they are flags 1564 ?dup if 1565 concat_argv 1566 2dup s" temp_options" setenv 1567 drop free if EFREE throw then 1568 else 1569 set_defaultoptions 1570 then 1571 1572 \ Bring back the filename, if one was provided 1573 r> if 2r> 1 else 0 then 1574; 1575 1576: get_arguments ( -- addrN lenN ... addr1 len1 N ) 1577 0 1578 begin 1579 \ Get next word on the command line 1580 parse-word 1581 ?dup while 1582 queue_argv 1583 repeat 1584 drop ( empty string ) 1585; 1586 1587: load_kernel_and_modules ( args -- flag ) 1588 set_tempoptions 1589 argc >r 1590 s" temp_options" getenv dup -1 <> if 1591 queue_argv 1592 else 1593 drop 1594 then 1595 load_xen 1596 ?dup 0= if ( success ) 1597 r> if ( a path was passed ) 1598 load_directory_or_file 1599 else 1600 standard_kernel_search 1601 then 1602 ?dup 0= if ['] load_modules catch then 1603 then 1604; 1605 1606only forth definitions 1607