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