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