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 26\ Loader.rc support functions: 27\ 28\ initialize ( addr len -- ) as above, plus load_conf_files 29\ load_conf ( addr len -- ) load conf file given 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 47\ string module.args flags to be passed during load 48\ string module.beforeload command to be executed before load 49\ string module.afterload command to be executed after load 50\ string module.loaderror command to be executed if load fails 51\ cell module.next list chain 52\ 53\ Exported global variables; 54\ 55\ string conf_files configuration files to be loaded 56\ cell modules_options pointer to first module information 57\ value verbose? indicates if user wants a verbose loading 58\ value any_conf_read? indicates if a conf file was successfully read 59\ 60\ Other exported words: 61\ note, strlen is internal 62\ strdup ( addr len -- addr' len) similar to strdup(3) 63\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3) 64\ s' ( | string' -- addr len | ) similar to s" 65\ rudimentary structure support 66 67\ Exception values 68 691 constant ESYNTAX 702 constant ENOMEM 713 constant EFREE 724 constant ESETERROR \ error setting environment variable 735 constant EREAD \ error reading 746 constant EOPEN 757 constant EEXEC \ XXX never catched 768 constant EBEFORELOAD 779 constant EAFTERLOAD 78 79\ I/O constants 80 810 constant SEEK_SET 821 constant SEEK_CUR 832 constant SEEK_END 84 850 constant O_RDONLY 861 constant O_WRONLY 872 constant O_RDWR 88 89\ Crude structure support 90 91: structure: 92 create here 0 , ['] drop , 0 93 does> create here swap dup @ allot cell+ @ execute 94; 95: member: create dup , over , + does> cell+ @ + ; 96: ;structure swap ! ; 97: constructor! >body cell+ ! ; 98: constructor: over :noname ; 99: ;constructor postpone ; swap cell+ ! ; immediate 100: sizeof ' >body @ state @ if postpone literal then ; immediate 101: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate 102: ptr 1 cells member: ; 103: int 1 cells member: ; 104 105\ String structure 106 107structure: string 108 ptr .addr 109 int .len 110 constructor: 111 0 over .addr ! 112 0 swap .len ! 113 ;constructor 114;structure 115 116 117\ Module options linked list 118 119structure: module 120 int module.flag 121 sizeof string member: module.name 122 sizeof string member: module.loadname 123 sizeof string member: module.type 124 sizeof string member: module.args 125 sizeof string member: module.beforeload 126 sizeof string member: module.afterload 127 sizeof string member: module.loaderror 128 ptr module.next 129;structure 130 131\ Internal loader structures (preloaded_file, kernel_module, file_metadata) 132\ must be in sync with the C struct in stand/common/bootstrap.h 133structure: preloaded_file 134 ptr pf.name 135 ptr pf.type 136 ptr pf.args 137 ptr pf.metadata \ file_metadata 138 int pf.loader 139 int pf.addr 140 int pf.size 141 ptr pf.modules \ kernel_module 142 ptr pf.next \ preloaded_file 143;structure 144 145structure: kernel_module 146 ptr km.name 147 \ ptr km.args 148 ptr km.fp \ preloaded_file 149 ptr km.next \ kernel_module 150;structure 151 152structure: file_metadata 153 int md.size 154 2 member: md.type \ this is not ANS Forth compatible (XXX) 155 ptr md.next \ file_metadata 156 0 member: md.data \ variable size 157;structure 158 159\ end of structures 160 161\ Global variables 162 163string conf_files 164string nextboot_conf_file 165create module_options sizeof module.next allot 0 module_options ! 166create last_module_option sizeof module.next allot 0 last_module_option ! 1670 value verbose? 1680 value nextboot? 169 170\ Support string functions 171: strdup { addr len -- addr' len' } 172 len allocate if ENOMEM throw then 173 addr over len move len 174; 175 176: strcat { addr len addr' len' -- addr len+len' } 177 addr' addr len + len' move 178 addr len len' + 179; 180 181: strchr { addr len c -- addr' len' } 182 begin 183 len 184 while 185 addr c@ c = if addr len exit then 186 addr 1 + to addr 187 len 1 - to len 188 repeat 189 0 0 190; 191 192: strspn { addr len addr1 len1 | paddr plen -- addr' len' } 193 begin 194 len 195 while 196 addr1 to paddr 197 len1 to plen 198 begin 199 plen 200 while 201 addr c@ paddr c@ = if addr len exit then 202 paddr 1+ to paddr 203 plen 1- to plen 204 repeat 205 addr 1 + to addr 206 len 1 - to len 207 repeat 208 0 0 209; 210 211: s' \ same as s", allows " in the string 212 [char] ' parse 213 state @ if postpone sliteral then 214; immediate 215 216: 2>r postpone >r postpone >r ; immediate 217: 2r> postpone r> postpone r> ; immediate 218: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate 219 220: getenv? getenv -1 = if false else drop true then ; 221 222\ execute xt for each device listed in console variable. 223\ this allows us to have device specific output for logos, menu frames etc 224: console-iterate { xt | caddr clen taddr tlen -- } 225 \ get current console and save it 226 s" console" getenv 227 ['] strdup catch if 2drop exit then 228 to clen to caddr 229 230 clen to tlen 231 caddr to taddr 232 begin 233 tlen 234 while 235 taddr tlen s" , " strspn 236 \ we need to handle 3 cases for addr len pairs on stack: 237 \ addr len are 0 0 - there was no comma nor space 238 \ addr len are x 0 - the first char is either comma or space 239 \ addr len are x y. 240 2dup + 0= if 241 \ there was no comma nor space. 242 2drop 243 taddr tlen s" console" setenv 244 xt execute 245 0 to tlen 246 else dup 0= if 247 2drop 248 else 249 dup ( taddr' tlen' tlen' ) 250 tlen swap - dup 251 0= if \ sequence of comma and space? 252 drop 253 else 254 taddr swap s" console" setenv 255 xt execute 256 then 257 to tlen 258 to taddr 259 then then 260 tlen 0> if \ step over separator 261 tlen 1- to tlen 262 taddr 1+ to taddr 263 then 264 repeat 265 caddr clen s" console" setenv \ restore console setup 266 caddr free drop 267; 268 269\ determine if a word appears in a string, case-insensitive 270: contains? ( addr1 len1 addr2 len2 -- 0 | -1 ) 271 2 pick 0= if 2drop 2drop true exit then 272 dup 0= if 2drop 2drop false exit then 273 begin 274 begin 275 swap dup c@ dup 32 = over 9 = or over 10 = or 276 over 13 = or over 44 = or swap drop 277 while 1+ swap 1- repeat 278 swap 2 pick 1- over < 279 while 280 2over 2over drop over compare-insensitive 0= if 281 2 pick over = if 2drop 2drop true exit then 282 2 pick tuck - -rot + swap over c@ dup 32 = 283 over 9 = or over 10 = or over 13 = or over 44 = or 284 swap drop if 2drop 2drop true exit then 285 then begin 286 swap dup c@ dup 32 = over 9 = or over 10 = or 287 over 13 = or over 44 = or swap drop 288 if false else true then 2 pick 0> and 289 while 1+ swap 1- repeat 290 swap 291 repeat 292 2drop 2drop false 293; 294 295: boot_serial? ( -- 0 | -1 ) 296 s" console" getenv dup -1 <> if 297 s" comconsole" 2swap contains? 298 else drop false then 299\ s" boot_serial" getenv dup -1 <> if 300\ swap drop 0> 301\ else drop false then 302\ or \ console contains comconsole ( or ) boot_serial 303\ s" boot_multicons" getenv dup -1 <> if 304\ swap drop 0> 305\ else drop false then 306\ or \ previous boolean ( or ) boot_multicons 307; 308 309: framebuffer? ( -- t ) 310 s" console" getenv 311 2dup s" efi" compare 0<> >r 312 s" vidconsole" compare 0<> r> and if 313 FALSE exit 314 then 315 s" screen.depth" getenv? 316; 317 318\ Private definitions 319 320vocabulary support-functions 321only forth also support-functions definitions 322 323\ Some control characters constants 324 3257 constant bell 3268 constant backspace 3279 constant tab 32810 constant lf 32913 constant <cr> 330 331\ Read buffer size 332 33380 constant read_buffer_size 334 335\ Standard suffixes 336 337: load_module_suffix s" _load" ; 338: module_loadname_suffix s" _name" ; 339: module_type_suffix s" _type" ; 340: module_args_suffix s" _flags" ; 341: module_beforeload_suffix s" _before" ; 342: module_afterload_suffix s" _after" ; 343: module_loaderror_suffix s" _error" ; 344 345\ Support operators 346 347: >= < 0= ; 348: <= > 0= ; 349 350\ Assorted support functions 351 352: free-memory free if EFREE throw then ; 353 354: strget { var -- addr len } var .addr @ var .len @ ; 355 356\ assign addr len to variable. 357: strset { addr len var -- } addr var .addr ! len var .len ! ; 358 359\ free memory and reset fields 360: strfree { var -- } var .addr @ ?dup if free-memory 0 0 var strset then ; 361 362\ free old content, make a copy of the string and assign to variable 363: string= { addr len var -- } var strfree addr len strdup var strset ; 364 365: strtype ( str -- ) strget type ; 366 367\ assign a reference to what is on the stack 368: strref { addr len var -- addr len } 369 addr var .addr ! len var .len ! addr len 370; 371 372\ unquote a string 373: unquote ( addr len -- addr len ) 374 over c@ [char] " = if 2 chars - swap char+ swap then 375; 376 377\ Assignment data temporary storage 378 379string name_buffer 380string value_buffer 381 382\ Line by line file reading functions 383\ 384\ exported: 385\ line_buffer 386\ end_of_file? 387\ fd 388\ read_line 389\ reset_line_reading 390 391vocabulary line-reading 392also line-reading definitions 393 394\ File data temporary storage 395 396string read_buffer 3970 value read_buffer_ptr 398 399\ File's line reading function 400 401get-current ( -- wid ) previous definitions 402 403string line_buffer 4040 value end_of_file? 405variable fd 406 407>search ( wid -- ) definitions 408 409: skip_newlines 410 begin 411 read_buffer .len @ read_buffer_ptr > 412 while 413 read_buffer .addr @ read_buffer_ptr + c@ lf = if 414 read_buffer_ptr char+ to read_buffer_ptr 415 else 416 exit 417 then 418 repeat 419; 420 421: scan_buffer ( -- addr len ) 422 read_buffer_ptr >r 423 begin 424 read_buffer .len @ r@ > 425 while 426 read_buffer .addr @ r@ + c@ lf = if 427 read_buffer .addr @ read_buffer_ptr + ( -- addr ) 428 r@ read_buffer_ptr - ( -- len ) 429 r> to read_buffer_ptr 430 exit 431 then 432 r> char+ >r 433 repeat 434 read_buffer .addr @ read_buffer_ptr + ( -- addr ) 435 r@ read_buffer_ptr - ( -- len ) 436 r> to read_buffer_ptr 437; 438 439: line_buffer_resize ( len -- len ) 440 dup 0= if exit then 441 >r 442 line_buffer .len @ if 443 line_buffer .addr @ 444 line_buffer .len @ r@ + 445 resize if ENOMEM throw then 446 else 447 r@ allocate if ENOMEM throw then 448 then 449 line_buffer .addr ! 450 r> 451; 452 453: append_to_line_buffer ( addr len -- ) 454 dup 0= if 2drop exit then 455 line_buffer strget 456 2swap strcat 457 line_buffer .len ! 458 drop 459; 460 461: read_from_buffer 462 scan_buffer ( -- addr len ) 463 line_buffer_resize ( len -- len ) 464 append_to_line_buffer ( addr len -- ) 465; 466 467: refill_required? 468 read_buffer .len @ read_buffer_ptr = 469 end_of_file? 0= and 470; 471 472: refill_buffer 473 0 to read_buffer_ptr 474 read_buffer .addr @ 0= if 475 read_buffer_size allocate if ENOMEM throw then 476 read_buffer .addr ! 477 then 478 fd @ read_buffer .addr @ read_buffer_size fread 479 dup -1 = if EREAD throw then 480 dup 0= if true to end_of_file? then 481 read_buffer .len ! 482; 483 484get-current ( -- wid ) previous definitions >search ( wid -- ) 485 486: reset_line_reading 487 0 to read_buffer_ptr 488 0 read_buffer .len ! 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