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; 490 491: read_line 492 line_buffer strfree 493 skip_newlines 494 begin 495 read_from_buffer 496 refill_required? 497 while 498 refill_buffer 499 repeat 500; 501 502only forth also support-functions definitions 503 504\ Conf file line parser: 505\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 506\ <spaces>[<comment>] 507\ <name> ::= <letter>{<letter>|<digit>|'_'} 508\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 509\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 510\ <comment> ::= '#'{<anything>} 511\ 512\ exported: 513\ line_pointer 514\ process_conf 515 5160 value line_pointer 517 518vocabulary file-processing 519also file-processing definitions 520 521\ parser functions 522\ 523\ exported: 524\ get_assignment 525 526vocabulary parser 527also parser definitions 528 5290 value parsing_function 5300 value end_of_line 531 532: end_of_line? line_pointer end_of_line = ; 533 534\ classifiers for various character classes in the input line 535 536: letter? 537 line_pointer c@ >r 538 r@ [char] A >= 539 r@ [char] Z <= and 540 r@ [char] a >= 541 r> [char] z <= and 542 or 543; 544 545: digit? 546 line_pointer c@ >r 547 r@ [char] - = 548 r@ [char] 0 >= 549 r> [char] 9 <= and 550 or 551; 552 553: quote? line_pointer c@ [char] " = ; 554 555: assignment_sign? line_pointer c@ [char] = = ; 556 557: comment? line_pointer c@ [char] # = ; 558 559: space? line_pointer c@ bl = line_pointer c@ tab = or ; 560 561: backslash? line_pointer c@ [char] \ = ; 562 563: underscore? line_pointer c@ [char] _ = ; 564 565: dot? line_pointer c@ [char] . = ; 566 567\ manipulation of input line 568: skip_character line_pointer char+ to line_pointer ; 569 570: skip_to_end_of_line end_of_line to line_pointer ; 571 572: eat_space 573 begin 574 end_of_line? if 0 else space? then 575 while 576 skip_character 577 repeat 578; 579 580: parse_name ( -- addr len ) 581 line_pointer 582 begin 583 end_of_line? if 0 else letter? digit? underscore? dot? or or or then 584 while 585 skip_character 586 repeat 587 line_pointer over - 588 strdup 589; 590 591: remove_backslashes { addr len | addr' len' -- addr' len' } 592 len allocate if ENOMEM throw then 593 to addr' 594 addr >r 595 begin 596 addr c@ [char] \ <> if 597 addr c@ addr' len' + c! 598 len' char+ to len' 599 then 600 addr char+ to addr 601 r@ len + addr = 602 until 603 r> drop 604 addr' len' 605; 606 607: parse_quote ( -- addr len ) 608 line_pointer 609 skip_character 610 end_of_line? if ESYNTAX throw then 611 begin 612 quote? 0= 613 while 614 backslash? if 615 skip_character 616 end_of_line? if ESYNTAX throw then 617 then 618 skip_character 619 end_of_line? if ESYNTAX throw then 620 repeat 621 skip_character 622 line_pointer over - 623 remove_backslashes 624; 625 626: read_name 627 parse_name ( -- addr len ) 628 name_buffer strset 629; 630 631: read_value 632 quote? if 633 parse_quote ( -- addr len ) 634 else 635 parse_name ( -- addr len ) 636 then 637 value_buffer strset 638; 639 640: comment 641 skip_to_end_of_line 642; 643 644: white_space_4 645 eat_space 646 comment? if ['] comment to parsing_function exit then 647 end_of_line? 0= if ESYNTAX throw then 648; 649 650: variable_value 651 read_value 652 ['] white_space_4 to parsing_function 653; 654 655: white_space_3 656 eat_space 657 letter? digit? quote? or or if 658 ['] variable_value to parsing_function exit 659 then 660 ESYNTAX throw 661; 662 663: assignment_sign 664 skip_character 665 ['] white_space_3 to parsing_function 666; 667 668: white_space_2 669 eat_space 670 assignment_sign? if ['] assignment_sign to parsing_function exit then 671 ESYNTAX throw 672; 673 674: variable_name 675 read_name 676 ['] white_space_2 to parsing_function 677; 678 679: white_space_1 680 eat_space 681 letter? if ['] variable_name to parsing_function exit then 682 comment? if ['] comment to parsing_function exit then 683 end_of_line? 0= if ESYNTAX throw then 684; 685 686get-current ( -- wid ) previous definitions >search ( wid -- ) 687 688: get_assignment 689 line_buffer strget + to end_of_line 690 line_buffer .addr @ to line_pointer 691 ['] white_space_1 to parsing_function 692 begin 693 end_of_line? 0= 694 while 695 parsing_function execute 696 repeat 697 parsing_function ['] comment = 698 parsing_function ['] white_space_1 = 699 parsing_function ['] white_space_4 = 700 or or 0= if ESYNTAX throw then 701; 702 703only forth also support-functions also file-processing definitions 704 705\ Process line 706 707: assignment_type? ( addr len -- flag ) 708 name_buffer strget 709 compare 0= 710; 711 712: suffix_type? ( addr len -- flag ) 713 name_buffer .len @ over <= if 2drop false exit then 714 name_buffer .len @ over - name_buffer .addr @ + 715 over compare 0= 716; 717 718: loader_conf_files? s" loader_conf_files" assignment_type? ; 719 720: nextboot_flag? s" nextboot_enable" assignment_type? ; 721 722: nextboot_conf? s" nextboot_conf" assignment_type? ; 723 724: verbose_flag? s" verbose_loading" assignment_type? ; 725 726: execute? s" exec" assignment_type? ; 727 728: module_load? load_module_suffix suffix_type? ; 729 730: module_loadname? module_loadname_suffix suffix_type? ; 731 732: module_type? module_type_suffix suffix_type? ; 733 734: module_args? module_args_suffix suffix_type? ; 735 736: module_beforeload? module_beforeload_suffix suffix_type? ; 737 738: module_afterload? module_afterload_suffix suffix_type? ; 739 740: module_loaderror? module_loaderror_suffix suffix_type? ; 741 742\ build a 'set' statement and execute it 743: set_environment_variable 744 name_buffer .len @ value_buffer .len @ + 5 chars + \ size of result string 745 allocate if ENOMEM throw then 746 dup 0 \ start with an empty string and append the pieces 747 s" set " strcat 748 name_buffer strget strcat 749 s" =" strcat 750 value_buffer strget strcat 751 ['] evaluate catch if 752 2drop free drop 753 ESETERROR throw 754 else 755 free-memory 756 then 757; 758 759: set_conf_files 760 set_environment_variable 761 s" loader_conf_files" getenv conf_files string= 762; 763 764: set_nextboot_conf 765 value_buffer strget unquote nextboot_conf_file 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 \ XXX could use unquote 784 2dup s' "YES"' compare >r 785 2dup s' "yes"' compare >r 786 2dup s" YES" compare >r 787 s" yes" compare r> r> r> and and and 0= 788; 789 790: find_module_option ( -- addr | 0 ) \ return ptr to entry matching name_buffer 791 module_options @ 792 begin 793 dup 794 while 795 dup module.name strget 796 name_buffer strget 797 compare 0= if exit then 798 module.next @ 799 repeat 800; 801 802: new_module_option ( -- addr ) 803 sizeof module allocate if ENOMEM throw then 804 dup sizeof module erase 805 dup append_to_module_options_list 806 dup set_module_name 807; 808 809: get_module_option ( -- addr ) 810 find_module_option 811 ?dup 0= if new_module_option then 812; 813 814: set_module_flag 815 name_buffer .len @ load_module_suffix nip - name_buffer .len ! 816 yes_value? get_module_option module.flag ! 817; 818 819: set_module_args 820 name_buffer .len @ module_args_suffix nip - name_buffer .len ! 821 value_buffer strget unquote 822 get_module_option module.args string= 823; 824 825: set_module_loadname 826 name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 827 value_buffer strget unquote 828 get_module_option module.loadname string= 829; 830 831: set_module_type 832 name_buffer .len @ module_type_suffix nip - name_buffer .len ! 833 value_buffer strget unquote 834 get_module_option module.type string= 835; 836 837: set_module_beforeload 838 name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 839 value_buffer strget unquote 840 get_module_option module.beforeload string= 841; 842 843: set_module_afterload 844 name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 845 value_buffer strget unquote 846 get_module_option module.afterload string= 847; 848 849: set_module_loaderror 850 name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 851 value_buffer strget unquote 852 get_module_option module.loaderror string= 853; 854 855: set_nextboot_flag 856 yes_value? to nextboot? 857; 858 859: set_verbose 860 yes_value? to verbose? 861; 862 863: execute_command 864 value_buffer strget unquote 865 ['] evaluate catch if EEXEC throw then 866; 867 868: process_assignment 869 name_buffer .len @ 0= if exit then 870 loader_conf_files? if set_conf_files exit then 871 nextboot_flag? if set_nextboot_flag exit then 872 nextboot_conf? if set_nextboot_conf exit then 873 verbose_flag? if set_verbose exit then 874 execute? if execute_command exit then 875 module_load? if set_module_flag exit then 876 module_loadname? if set_module_loadname exit then 877 module_type? if set_module_type exit then 878 module_args? if set_module_args exit then 879 module_beforeload? if set_module_beforeload exit then 880 module_afterload? if set_module_afterload exit then 881 module_loaderror? if set_module_loaderror exit then 882 set_environment_variable 883; 884 885\ free_buffer ( -- ) 886\ 887\ Free some pointers if needed. The code then tests for errors 888\ in freeing, and throws an exception if needed. If a pointer is 889\ not allocated, it's value (0) is used as flag. 890 891: free_buffers 892 name_buffer strfree 893 value_buffer strfree 894; 895 896\ Higher level file processing 897 898get-current ( -- wid ) previous definitions >search ( wid -- ) 899 900: process_conf 901 begin 902 end_of_file? 0= 903 while 904 free_buffers 905 read_line 906 get_assignment 907 ['] process_assignment catch 908 ['] free_buffers catch 909 swap throw throw 910 repeat 911; 912 913: peek_file ( addr len -- ) 914 0 to end_of_file? 915 reset_line_reading 916 O_RDONLY fopen fd ! 917 fd @ -1 = if EOPEN throw then 918 free_buffers 919 read_line 920 get_assignment 921 ['] process_assignment catch 922 ['] free_buffers catch 923 fd @ fclose 924 swap throw throw 925; 926 927only forth also support-functions definitions 928 929\ Interface to loading conf files 930 931: load_conf ( addr len -- ) 932 0 to end_of_file? 933 reset_line_reading 934 O_RDONLY fopen fd ! 935 fd @ -1 = if EOPEN throw then 936 ['] process_conf catch 937 fd @ fclose 938 throw 939; 940 941: print_line line_buffer strtype cr ; 942 943: print_syntax_error 944 line_buffer strtype cr 945 line_buffer .addr @ 946 begin 947 line_pointer over <> 948 while 949 bl emit char+ 950 repeat 951 drop 952 ." ^" cr 953; 954 955 956\ Debugging support functions 957 958only forth definitions also support-functions 959 960: test-file 961 ['] load_conf catch dup . 962 ESYNTAX = if cr print_syntax_error then 963; 964 965\ find a module name, leave addr on the stack (0 if not found) 966: find-module ( <module> -- ptr | 0 ) 967 bl parse ( addr len ) 968 module_options @ >r ( store current pointer ) 969 begin 970 r@ 971 while 972 2dup ( addr len addr len ) 973 r@ module.name strget 974 compare 0= if drop drop r> exit then ( found it ) 975 r> module.next @ >r 976 repeat 977 type ." was not found" cr r> 978; 979 980: show-nonempty ( addr len mod -- ) 981 strget dup verbose? or if 982 2swap type type cr 983 else 984 drop drop drop drop 985 then ; 986 987: show-one-module { addr -- addr } 988 ." Name: " addr module.name strtype cr 989 s" Path: " addr module.loadname show-nonempty 990 s" Type: " addr module.type show-nonempty 991 s" Flags: " addr module.args show-nonempty 992 s" Before load: " addr module.beforeload show-nonempty 993 s" After load: " addr module.afterload show-nonempty 994 s" Error: " addr module.loaderror show-nonempty 995 ." Status: " addr module.flag @ if ." Load" else ." Don't load" then cr 996 cr 997 addr 998; 999 1000: show-module-options 1001 module_options @ 1002 begin 1003 ?dup 1004 while 1005 show-one-module 1006 module.next @ 1007 repeat 1008; 1009 1010: free-one-module { addr -- addr } 1011 addr module.name strfree 1012 addr module.loadname strfree 1013 addr module.type strfree 1014 addr module.args strfree 1015 addr module.beforeload strfree 1016 addr module.afterload strfree 1017 addr module.loaderror strfree 1018 addr 1019; 1020 1021: free-module-options 1022 module_options @ 1023 begin 1024 ?dup 1025 while 1026 free-one-module 1027 dup module.next @ 1028 swap free-memory 1029 repeat 1030 0 module_options ! 1031 0 last_module_option ! 1032; 1033 1034only forth also support-functions definitions 1035 1036\ Variables used for processing multiple conf files 1037 1038string current_file_name_ref \ used to print the file name 1039 1040\ Indicates if any conf file was successfully read 1041 10420 value any_conf_read? 1043 1044\ loader_conf_files processing support functions 1045 1046: get_conf_files ( -- addr len ) \ put addr/len on stack, reset var 1047 conf_files strget 0 0 conf_files strset 1048; 1049 1050: skip_leading_spaces { addr len pos -- addr len pos' } 1051 begin 1052 pos len = if 0 else addr pos + c@ bl = then 1053 while 1054 pos char+ to pos 1055 repeat 1056 addr len pos 1057; 1058 1059\ return the file name at pos, or free the string if nothing left 1060: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 1061 pos len = if 1062 addr free abort" Fatal error freeing memory" 1063 0 exit 1064 then 1065 pos >r 1066 begin 1067 \ stay in the loop until have chars and they are not blank 1068 pos len = if 0 else addr pos + c@ bl <> then 1069 while 1070 pos char+ to pos 1071 repeat 1072 addr len pos addr r@ + pos r> - 1073; 1074 1075: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 1076 skip_leading_spaces 1077 get_file_name 1078; 1079 1080: print_current_file 1081 current_file_name_ref strtype 1082; 1083 1084: process_conf_errors 1085 dup 0= if true to any_conf_read? drop exit then 1086 >r 2drop r> 1087 dup ESYNTAX = if 1088 ." Warning: syntax error on file " print_current_file cr 1089 print_syntax_error drop exit 1090 then 1091 dup ESETERROR = if 1092 ." Warning: bad definition on file " print_current_file cr 1093 print_line drop exit 1094 then 1095 dup EREAD = if 1096 ." Warning: error reading file " print_current_file cr drop exit 1097 then 1098 dup EOPEN = if 1099 verbose? if ." Warning: unable to open file " print_current_file cr then 1100 drop exit 1101 then 1102 dup EFREE = abort" Fatal error freeing memory" 1103 dup ENOMEM = abort" Out of memory" 1104 throw \ Unknown error -- pass ahead 1105; 1106 1107\ Process loader_conf_files recursively 1108\ Interface to loader_conf_files processing 1109 1110: include_conf_files 1111 get_conf_files 0 ( addr len offset ) 1112 begin 1113 get_next_file ?dup ( addr len 1 | 0 ) 1114 while 1115 current_file_name_ref strref 1116 ['] load_conf catch 1117 process_conf_errors 1118 conf_files .addr @ if recurse then 1119 repeat 1120; 1121 1122: get_nextboot_conf_file ( -- addr len ) 1123 nextboot_conf_file strget 1124; 1125 1126: rewrite_nextboot_file ( -- ) 1127 get_nextboot_conf_file 1128 O_WRONLY fopen fd ! 1129 fd @ -1 = if EOPEN throw then 1130 fd @ s' nextboot_enable="NO" ' fwrite ( fd buf len -- nwritten ) drop 1131 fd @ fclose 1132; 1133 1134: include_nextboot_file ( -- ) 1135 s" nextboot_enable" getenv dup -1 <> if 1136 2dup s' "YES"' compare >r 1137 2dup s' "yes"' compare >r 1138 2dup s" YES" compare >r 1139 2dup s" yes" compare r> r> r> and and and 0= to nextboot? 1140 else 1141 drop 1142 get_nextboot_conf_file 1143 ['] peek_file catch if 2drop then 1144 then 1145 nextboot? if 1146 get_nextboot_conf_file 1147 current_file_name_ref strref 1148 ['] load_conf catch 1149 process_conf_errors 1150 ['] rewrite_nextboot_file catch if 2drop then 1151 then 1152 s' "NO"' s" nextboot_enable" setenv 1153; 1154 1155\ Module loading functions 1156 1157: load_parameters { addr -- addr addrN lenN ... addr1 len1 N } 1158 addr 1159 addr module.args strget 1160 addr module.loadname .len @ if 1161 addr module.loadname strget 1162 else 1163 addr module.name strget 1164 then 1165 addr module.type .len @ if 1166 addr module.type strget 1167 s" -t " 1168 4 ( -t type name flags ) 1169 else 1170 2 ( name flags ) 1171 then 1172; 1173 1174: before_load ( addr -- addr ) 1175 dup module.beforeload .len @ if 1176 dup module.beforeload strget 1177 ['] evaluate catch if EBEFORELOAD throw then 1178 then 1179; 1180 1181: after_load ( addr -- addr ) 1182 dup module.afterload .len @ if 1183 dup module.afterload strget 1184 ['] evaluate catch if EAFTERLOAD throw then 1185 then 1186; 1187 1188: load_error ( addr -- addr ) 1189 dup module.loaderror .len @ if 1190 dup module.loaderror strget 1191 evaluate \ This we do not intercept so it can throw errors 1192 then 1193; 1194 1195: pre_load_message ( addr -- addr ) 1196 verbose? if 1197 dup module.name strtype 1198 ." ..." 1199 then 1200; 1201 1202: load_error_message verbose? if ." failed!" cr then ; 1203 1204: load_successful_message verbose? if ." ok" cr then ; 1205 1206: load_module 1207 load_parameters load 1208; 1209 1210: process_module ( addr -- addr ) 1211 pre_load_message 1212 before_load 1213 begin 1214 ['] load_module catch if 1215 dup module.loaderror .len @ if 1216 load_error \ Command should return a flag! 1217 else 1218 load_error_message true \ Do not retry 1219 then 1220 else 1221 after_load 1222 load_successful_message true \ Successful, do not retry 1223 then 1224 until 1225; 1226 1227: process_module_errors ( addr ior -- ) 1228 dup EBEFORELOAD = if 1229 drop 1230 ." Module " 1231 dup module.name strtype 1232 dup module.loadname .len @ if 1233 ." (" dup module.loadname strtype ." )" 1234 then 1235 cr 1236 ." Error executing " 1237 dup module.beforeload strtype cr \ XXX there was a typo here 1238 abort 1239 then 1240 1241 dup EAFTERLOAD = if 1242 drop 1243 ." Module " 1244 dup module.name .addr @ over module.name .len @ type 1245 dup module.loadname .len @ if 1246 ." (" dup module.loadname strtype ." )" 1247 then 1248 cr 1249 ." Error executing " 1250 dup module.afterload strtype cr 1251 abort 1252 then 1253 1254 throw \ Don't know what it is all about -- pass ahead 1255; 1256 1257\ Module loading interface 1258 1259\ scan the list of modules, load enabled ones. 1260: load_modules ( -- ) ( throws: abort & user-defined ) 1261 module_options @ ( list_head ) 1262 begin 1263 ?dup 1264 while 1265 dup module.flag @ if 1266 ['] process_module catch 1267 process_module_errors 1268 then 1269 module.next @ 1270 repeat 1271; 1272 1273\ h00h00 magic used to try loading either a kernel with a given name, 1274\ or a kernel with the default name in a directory of a given name 1275\ (the pain!) 1276 1277: bootpath s" /boot/" ; 1278: modulepath s" module_path" ; 1279 1280\ Functions used to save and restore module_path's value. 1281: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 1282 dup -1 = if 0 swap exit then 1283 strdup 1284; 1285: freeenv ( addr len | 0 -1 ) 1286 -1 = if drop else free abort" Freeing error" then 1287; 1288: restoreenv ( addr len | 0 -1 -- ) 1289 dup -1 = if ( it wasn't set ) 1290 2drop 1291 modulepath unsetenv 1292 else 1293 over >r 1294 modulepath setenv 1295 r> free abort" Freeing error" 1296 then 1297; 1298 1299: clip_args \ Drop second string if only one argument is passed 1300 1 = if 1301 2swap 2drop 1302 1 1303 else 1304 2 1305 then 1306; 1307 1308also builtins 1309 1310\ Parse filename from a semicolon-separated list 1311 1312\ replacement, not working yet 1313: newparse-; { addr len | a1 -- a' len-x addr x } 1314 addr len [char] ; strchr dup if ( a1 len1 ) 1315 swap to a1 ( store address ) 1316 1 - a1 @ 1 + swap ( remove match ) 1317 addr a1 addr - 1318 else 1319 0 0 addr len 1320 then 1321; 1322 1323: parse-; ( addr len -- addr' len-x addr x ) 1324 over 0 2swap ( addr 0 addr len ) 1325 begin 1326 dup 0 <> ( addr 0 addr len ) 1327 while 1328 over c@ [char] ; <> ( addr 0 addr len flag ) 1329 while 1330 1- swap 1+ swap 1331 2swap 1+ 2swap 1332 repeat then 1333 dup 0 <> if 1334 1- swap 1+ swap 1335 then 1336 2swap 1337; 1338 1339\ Try loading one of multiple kernels specified 1340 1341: try_multiple_kernels ( addr len addr' len' args -- flag ) 1342 >r 1343 begin 1344 parse-; 2>r 1345 2over 2r> 1346 r@ clip_args 1347 s" DEBUG" getenv? if 1348 s" echo Module_path: ${module_path}" evaluate 1349 ." Kernel : " >r 2dup type r> cr 1350 dup 2 = if ." Flags : " >r 2over type r> cr then 1351 then 1352 1 load 1353 while 1354 dup 0= 1355 until 1356 1 >r \ Failure 1357 else 1358 0 >r \ Success 1359 then 1360 2drop 2drop 1361 r> 1362 r> drop 1363; 1364 1365\ Try to load a kernel; the kernel name is taken from one of 1366\ the following lists, as ordered: 1367\ 1368\ 1. The "bootfile" environment variable 1369\ 2. The "kernel" environment variable 1370\ 1371\ Flags are passed, if available. If not, dummy values must be given. 1372\ 1373\ The kernel gets loaded from the current module_path. 1374 1375: load_a_kernel ( flags len 1 | x x 0 -- flag ) 1376 local args 1377 2local flags 1378 0 0 2local kernel 1379 end-locals 1380 1381 \ Check if a default kernel name exists at all, exits if not 1382 s" bootfile" getenv dup -1 <> if 1383 to kernel 1384 flags kernel args 1+ try_multiple_kernels 1385 dup 0= if exit then 1386 then 1387 drop 1388 1389 s" kernel" getenv dup -1 <> if 1390 to kernel 1391 else 1392 drop 1393 1 exit \ Failure 1394 then 1395 1396 \ Try all default kernel names 1397 flags kernel args 1+ try_multiple_kernels 1398; 1399 1400\ Try to load a kernel; the kernel name is taken from one of 1401\ the following lists, as ordered: 1402\ 1403\ 1. The "bootfile" environment variable 1404\ 2. The "kernel" environment variable 1405\ 1406\ Flags are passed, if provided. 1407\ 1408\ The kernel will be loaded from a directory computed from the 1409\ path given. Two directories will be tried in the following order: 1410\ 1411\ 1. /boot/path 1412\ 2. path 1413\ 1414\ The module_path variable is overridden if load is successful, by 1415\ prepending the successful path. 1416 1417: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 1418 local args 1419 2local path 1420 args 1 = if 0 0 then 1421 2local flags 1422 0 0 2local oldmodulepath \ like a string 1423 0 0 2local newmodulepath \ like a string 1424 end-locals 1425 1426 \ Set the environment variable module_path, and try loading 1427 \ the kernel again. 1428 modulepath getenv saveenv to oldmodulepath 1429 1430 \ Try prepending /boot/ first 1431 bootpath nip path nip + \ total length 1432 oldmodulepath nip dup -1 = if 1433 drop 1434 else 1435 1+ + \ add oldpath -- XXX why the 1+ ? 1436 then 1437 allocate if ( out of memory ) 1 exit then \ XXX throw ? 1438 1439 0 1440 bootpath strcat 1441 path strcat 1442 2dup to newmodulepath 1443 modulepath setenv 1444 1445 \ Try all default kernel names 1446 flags args 1- load_a_kernel 1447 0= if ( success ) 1448 oldmodulepath nip -1 <> if 1449 newmodulepath s" ;" strcat 1450 oldmodulepath strcat 1451 modulepath setenv 1452 newmodulepath drop free-memory 1453 oldmodulepath drop free-memory 1454 then 1455 0 exit 1456 then 1457 1458 \ Well, try without the prepended /boot/ 1459 path newmodulepath drop swap move 1460 newmodulepath drop path nip 1461 2dup to newmodulepath 1462 modulepath setenv 1463 1464 \ Try all default kernel names 1465 flags args 1- load_a_kernel 1466 if ( failed once more ) 1467 oldmodulepath restoreenv 1468 newmodulepath drop free-memory 1469 1 1470 else 1471 oldmodulepath nip -1 <> if 1472 newmodulepath s" ;" strcat 1473 oldmodulepath strcat 1474 modulepath setenv 1475 newmodulepath drop free-memory 1476 oldmodulepath drop free-memory 1477 then 1478 0 1479 then 1480; 1481 1482\ Try to load a kernel; the kernel name is taken from one of 1483\ the following lists, as ordered: 1484\ 1485\ 1. The "bootfile" environment variable 1486\ 2. The "kernel" environment variable 1487\ 3. The "path" argument 1488\ 1489\ Flags are passed, if provided. 1490\ 1491\ The kernel will be loaded from a directory computed from the 1492\ path given. Two directories will be tried in the following order: 1493\ 1494\ 1. /boot/path 1495\ 2. path 1496\ 1497\ Unless "path" is meant to be kernel name itself. In that case, it 1498\ will first be tried as a full path, and, next, search on the 1499\ directories pointed by module_path. 1500\ 1501\ The module_path variable is overridden if load is successful, by 1502\ prepending the successful path. 1503 1504: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 1505 local args 1506 2local path 1507 args 1 = if 0 0 then 1508 2local flags 1509 end-locals 1510 1511 \ First, assume path is an absolute path to a directory 1512 flags path args clip_args load_from_directory 1513 dup 0= if exit else drop then 1514 1515 \ Next, assume path points to the kernel 1516 flags path args try_multiple_kernels 1517; 1518 1519: initialize ( addr len -- ) 1520 strdup conf_files strset 1521; 1522 1523: kernel_options ( -- addr len 1 | 0 ) 1524 s" kernel_options" getenv 1525 dup -1 = if drop 0 else 1 then 1526; 1527 1528: standard_kernel_search ( flags 1 | 0 -- flag ) 1529 local args 1530 args 0= if 0 0 then 1531 2local flags 1532 s" kernel" getenv 1533 dup -1 = if 0 swap then 1534 2local path 1535 end-locals 1536 1537 path nip -1 = if ( there isn't a "kernel" environment variable ) 1538 flags args load_a_kernel 1539 else 1540 flags path args 1+ clip_args load_directory_or_file 1541 then 1542; 1543 1544: load_kernel ( -- ) ( throws: abort ) 1545 kernel_options standard_kernel_search 1546 abort" Unable to load a kernel!" 1547; 1548 1549: load_xen ( -- flag ) 1550 s" xen_kernel" getenv dup -1 <> if 1551 1 1 load ( c-addr/u flag N -- flag ) 1552 else 1553 drop 1554 0 ( -1 -- flag ) 1555 then 1556; 1557 1558: load_xen_throw ( -- ) ( throws: abort ) 1559 load_xen 1560 abort" Unable to load Xen!" 1561; 1562 1563: set_defaultoptions ( -- ) 1564 s" kernel_options" getenv dup -1 = if 1565 drop 1566 else 1567 s" temp_options" setenv 1568 then 1569; 1570 1571\ pick the i-th argument, i starts at 0 1572: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 1573 2dup = if 0 0 exit then \ out of range 1574 dup >r 1575 1+ 2* ( skip N and ui ) 1576 pick 1577 r> 1578 1+ 2* ( skip N and ai ) 1579 pick 1580; 1581 1582: drop_args ( aN uN ... a1 u1 N -- ) 1583 0 ?do 2drop loop 1584; 1585 1586: argc 1587 dup 1588; 1589 1590: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 1591 >r 1592 over 2* 1+ -roll 1593 r> 1594 over 2* 1+ -roll 1595 1+ 1596; 1597 1598: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 1599 1- -rot 1600; 1601 1602\ compute the length of the buffer including the spaces between words 1603: strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len ) 1604 dup 0= if 0 exit then 1605 0 >r \ Size 1606 0 >r \ Index 1607 begin 1608 argc r@ <> 1609 while 1610 r@ argv[] 1611 nip 1612 r> r> rot + 1+ 1613 >r 1+ >r 1614 repeat 1615 r> drop 1616 r> 1617; 1618 1619: concat_argv ( aN uN ... a1 u1 N -- a u ) 1620 strlen(argv) allocate if ENOMEM throw then 1621 0 2>r ( save addr 0 on return stack ) 1622 1623 begin 1624 dup 1625 while 1626 unqueue_argv ( ... N a1 u1 ) 1627 2r> 2swap ( old a1 u1 ) 1628 strcat 1629 s" " strcat ( append one space ) \ XXX this gives a trailing space 1630 2>r ( store string on the result stack ) 1631 repeat 1632 drop_args 1633 2r> 1634; 1635 1636: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 1637 \ Save the first argument, if it exists and is not a flag 1638 argc if 1639 0 argv[] drop c@ [char] - <> if 1640 unqueue_argv 2>r \ Filename 1641 1 >r \ Filename present 1642 else 1643 0 >r \ Filename not present 1644 then 1645 else 1646 0 >r \ Filename not present 1647 then 1648 1649 \ If there are other arguments, assume they are flags 1650 ?dup if 1651 concat_argv 1652 2dup s" temp_options" setenv 1653 drop free if EFREE throw then 1654 else 1655 set_defaultoptions 1656 then 1657 1658 \ Bring back the filename, if one was provided 1659 r> if 2r> 1 else 0 then 1660; 1661 1662: get_arguments ( -- addrN lenN ... addr1 len1 N ) 1663 0 1664 begin 1665 \ Get next word on the command line 1666 parse-word 1667 ?dup while 1668 queue_argv 1669 repeat 1670 drop ( empty string ) 1671; 1672 1673: load_kernel_and_modules ( args -- flag ) 1674 set_tempoptions 1675 argc >r 1676 s" temp_options" getenv dup -1 <> if 1677 queue_argv 1678 else 1679 drop 1680 then 1681 load_xen 1682 ?dup 0= if ( success ) 1683 r> if ( a path was passed ) 1684 load_directory_or_file 1685 else 1686 standard_kernel_search 1687 then 1688 ?dup 0= if ['] load_modules catch then 1689 then 1690; 1691 1692only forth definitions 1693