support.4th revision 277215
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 277215 2015-01-15 16:27:20Z royger $ 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 also 319 320\ File data temporary storage 321 322string read_buffer 3230 value read_buffer_ptr 324 325\ File's line reading function 326 327support-functions definitions 328 329string line_buffer 3300 value end_of_file? 331variable fd 332 333line-reading 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 408support-functions definitions 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 also 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 609file-processing definitions 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 also 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 \ XXX maybe do as set_conf_files ? 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 821support-functions definitions 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 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; 848 849only forth also support-functions definitions 850 851\ Interface to loading conf files 852 853: load_conf ( addr len -- ) 854 \ ." ----- Trying conf " 2dup type cr \ debugging 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 \ ." -- starting on <" conf_files strtype ." >" cr \ debugging 947 conf_files strget 0 0 conf_files strset 948; 949 950: skip_leading_spaces { addr len pos -- addr len pos' } 951 begin 952 pos len = if 0 else addr pos + c@ bl = then 953 while 954 pos char+ to pos 955 repeat 956 addr len pos 957; 958 959\ return the file name at pos, or free the string if nothing left 960: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 961 pos len = if 962 addr free abort" Fatal error freeing memory" 963 0 exit 964 then 965 pos >r 966 begin 967 \ stay in the loop until have chars and they are not blank 968 pos len = if 0 else addr pos + c@ bl <> then 969 while 970 pos char+ to pos 971 repeat 972 addr len pos addr r@ + pos r> - 973 \ 2dup ." get_file_name has " type cr \ debugging 974; 975 976: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 977 skip_leading_spaces 978 get_file_name 979; 980 981: print_current_file 982 current_file_name_ref strtype 983; 984 985: process_conf_errors 986 dup 0= if true to any_conf_read? drop exit then 987 >r 2drop r> 988 dup ESYNTAX = if 989 ." Warning: syntax error on file " print_current_file cr 990 print_syntax_error drop exit 991 then 992 dup ESETERROR = if 993 ." Warning: bad definition on file " print_current_file cr 994 print_line drop exit 995 then 996 dup EREAD = if 997 ." Warning: error reading file " print_current_file cr drop exit 998 then 999 dup EOPEN = if 1000 verbose? if ." Warning: unable to open file " print_current_file cr then 1001 drop exit 1002 then 1003 dup EFREE = abort" Fatal error freeing memory" 1004 dup ENOMEM = abort" Out of memory" 1005 throw \ Unknown error -- pass ahead 1006; 1007 1008\ Process loader_conf_files recursively 1009\ Interface to loader_conf_files processing 1010 1011: include_conf_files 1012 get_conf_files 0 ( addr len offset ) 1013 begin 1014 get_next_file ?dup ( addr len 1 | 0 ) 1015 while 1016 current_file_name_ref strref 1017 ['] load_conf catch 1018 process_conf_errors 1019 conf_files .addr @ if recurse then 1020 repeat 1021; 1022 1023: get_nextboot_conf_file ( -- addr len ) 1024 nextboot_conf_file strget strdup \ XXX is the strdup a leak ? 1025; 1026 1027: rewrite_nextboot_file ( -- ) 1028 get_nextboot_conf_file 1029 O_WRONLY fopen fd ! 1030 fd @ -1 = if EOPEN throw then 1031 fd @ s' nextboot_enable="NO" ' fwrite 1032 fd @ fclose 1033; 1034 1035: include_nextboot_file 1036 get_nextboot_conf_file 1037 ['] peek_file catch 1038 nextboot? if 1039 get_nextboot_conf_file 1040 ['] load_conf catch 1041 process_conf_errors 1042 ['] rewrite_nextboot_file catch 1043 then 1044; 1045 1046\ Module loading functions 1047 1048: load_parameters { addr -- addr addrN lenN ... addr1 len1 N } 1049 addr 1050 addr module.args strget 1051 addr module.loadname .len @ if 1052 addr module.loadname strget 1053 else 1054 addr module.name strget 1055 then 1056 addr module.type .len @ if 1057 addr module.type strget 1058 s" -t " 1059 4 ( -t type name flags ) 1060 else 1061 2 ( name flags ) 1062 then 1063; 1064 1065: before_load ( addr -- addr ) 1066 dup module.beforeload .len @ if 1067 dup module.beforeload strget 1068 ['] evaluate catch if EBEFORELOAD throw then 1069 then 1070; 1071 1072: after_load ( addr -- addr ) 1073 dup module.afterload .len @ if 1074 dup module.afterload strget 1075 ['] evaluate catch if EAFTERLOAD throw then 1076 then 1077; 1078 1079: load_error ( addr -- addr ) 1080 dup module.loaderror .len @ if 1081 dup module.loaderror strget 1082 evaluate \ This we do not intercept so it can throw errors 1083 then 1084; 1085 1086: pre_load_message ( addr -- addr ) 1087 verbose? if 1088 dup module.name strtype 1089 ." ..." 1090 then 1091; 1092 1093: load_error_message verbose? if ." failed!" cr then ; 1094 1095: load_succesful_message verbose? if ." ok" cr then ; 1096 1097: load_module 1098 load_parameters load 1099; 1100 1101: process_module ( addr -- addr ) 1102 pre_load_message 1103 before_load 1104 begin 1105 ['] load_module catch if 1106 dup module.loaderror .len @ if 1107 load_error \ Command should return a flag! 1108 else 1109 load_error_message true \ Do not retry 1110 then 1111 else 1112 after_load 1113 load_succesful_message true \ Succesful, do not retry 1114 then 1115 until 1116; 1117 1118: process_module_errors ( addr ior -- ) 1119 dup EBEFORELOAD = if 1120 drop 1121 ." Module " 1122 dup module.name strtype 1123 dup module.loadname .len @ if 1124 ." (" dup module.loadname strtype ." )" 1125 then 1126 cr 1127 ." Error executing " 1128 dup module.beforeload strtype cr \ XXX there was a typo here 1129 abort 1130 then 1131 1132 dup EAFTERLOAD = if 1133 drop 1134 ." Module " 1135 dup module.name .addr @ over module.name .len @ type 1136 dup module.loadname .len @ if 1137 ." (" dup module.loadname strtype ." )" 1138 then 1139 cr 1140 ." Error executing " 1141 dup module.afterload strtype cr 1142 abort 1143 then 1144 1145 throw \ Don't know what it is all about -- pass ahead 1146; 1147 1148\ Module loading interface 1149 1150\ scan the list of modules, load enabled ones. 1151: load_modules ( -- ) ( throws: abort & user-defined ) 1152 module_options @ ( list_head ) 1153 begin 1154 ?dup 1155 while 1156 dup module.flag @ if 1157 ['] process_module catch 1158 process_module_errors 1159 then 1160 module.next @ 1161 repeat 1162; 1163 1164\ h00h00 magic used to try loading either a kernel with a given name, 1165\ or a kernel with the default name in a directory of a given name 1166\ (the pain!) 1167 1168: bootpath s" /boot/" ; 1169: modulepath s" module_path" ; 1170 1171\ Functions used to save and restore module_path's value. 1172: saveenv ( addr len | -1 -- addr' len | 0 -1 ) 1173 dup -1 = if 0 swap exit then 1174 strdup 1175; 1176: freeenv ( addr len | 0 -1 ) 1177 -1 = if drop else free abort" Freeing error" then 1178; 1179: restoreenv ( addr len | 0 -1 -- ) 1180 dup -1 = if ( it wasn't set ) 1181 2drop 1182 modulepath unsetenv 1183 else 1184 over >r 1185 modulepath setenv 1186 r> free abort" Freeing error" 1187 then 1188; 1189 1190: clip_args \ Drop second string if only one argument is passed 1191 1 = if 1192 2swap 2drop 1193 1 1194 else 1195 2 1196 then 1197; 1198 1199also builtins 1200 1201\ Parse filename from a semicolon-separated list 1202 1203\ replacement, not working yet 1204: newparse-; { addr len | a1 -- a' len-x addr x } 1205 addr len [char] ; strchr dup if ( a1 len1 ) 1206 swap to a1 ( store address ) 1207 1 - a1 @ 1 + swap ( remove match ) 1208 addr a1 addr - 1209 else 1210 0 0 addr len 1211 then 1212; 1213 1214: parse-; ( addr len -- addr' len-x addr x ) 1215 over 0 2swap ( addr 0 addr len ) 1216 begin 1217 dup 0 <> ( addr 0 addr len ) 1218 while 1219 over c@ [char] ; <> ( addr 0 addr len flag ) 1220 while 1221 1- swap 1+ swap 1222 2swap 1+ 2swap 1223 repeat then 1224 dup 0 <> if 1225 1- swap 1+ swap 1226 then 1227 2swap 1228; 1229 1230\ Try loading one of multiple kernels specified 1231 1232: try_multiple_kernels ( addr len addr' len' args -- flag ) 1233 >r 1234 begin 1235 parse-; 2>r 1236 2over 2r> 1237 r@ clip_args 1238 s" DEBUG" getenv? if 1239 s" echo Module_path: ${module_path}" evaluate 1240 ." Kernel : " >r 2dup type r> cr 1241 dup 2 = if ." Flags : " >r 2over type r> cr then 1242 then 1243 1 load 1244 while 1245 dup 0= 1246 until 1247 1 >r \ Failure 1248 else 1249 0 >r \ Success 1250 then 1251 2drop 2drop 1252 r> 1253 r> drop 1254; 1255 1256\ Try to load a kernel; the kernel name is taken from one of 1257\ the following lists, as ordered: 1258\ 1259\ 1. The "bootfile" environment variable 1260\ 2. The "kernel" environment variable 1261\ 1262\ Flags are passed, if available. If not, dummy values must be given. 1263\ 1264\ The kernel gets loaded from the current module_path. 1265 1266: load_a_kernel ( flags len 1 | x x 0 -- flag ) 1267 local args 1268 2local flags 1269 0 0 2local kernel 1270 end-locals 1271 1272 \ Check if a default kernel name exists at all, exits if not 1273 s" bootfile" getenv dup -1 <> if 1274 to kernel 1275 flags kernel args 1+ try_multiple_kernels 1276 dup 0= if exit then 1277 then 1278 drop 1279 1280 s" kernel" getenv dup -1 <> if 1281 to kernel 1282 else 1283 drop 1284 1 exit \ Failure 1285 then 1286 1287 \ Try all default kernel names 1288 flags kernel args 1+ try_multiple_kernels 1289; 1290 1291\ Try to load a kernel; the kernel name is taken from one of 1292\ the following lists, as ordered: 1293\ 1294\ 1. The "bootfile" environment variable 1295\ 2. The "kernel" environment variable 1296\ 1297\ Flags are passed, if provided. 1298\ 1299\ The kernel will be loaded from a directory computed from the 1300\ path given. Two directories will be tried in the following order: 1301\ 1302\ 1. /boot/path 1303\ 2. path 1304\ 1305\ The module_path variable is overridden if load is succesful, by 1306\ prepending the successful path. 1307 1308: load_from_directory ( path len 1 | flags len' path len 2 -- flag ) 1309 local args 1310 2local path 1311 args 1 = if 0 0 then 1312 2local flags 1313 0 0 2local oldmodulepath \ like a string 1314 0 0 2local newmodulepath \ like a string 1315 end-locals 1316 1317 \ Set the environment variable module_path, and try loading 1318 \ the kernel again. 1319 modulepath getenv saveenv to oldmodulepath 1320 1321 \ Try prepending /boot/ first 1322 bootpath nip path nip + \ total length 1323 oldmodulepath nip dup -1 = if 1324 drop 1325 else 1326 1+ + \ add oldpath -- XXX why the 1+ ? 1327 then 1328 allocate if ( out of memory ) 1 exit then \ XXX throw ? 1329 1330 0 1331 bootpath strcat 1332 path strcat 1333 2dup to newmodulepath 1334 modulepath setenv 1335 1336 \ Try all default kernel names 1337 flags args 1- load_a_kernel 1338 0= if ( success ) 1339 oldmodulepath nip -1 <> if 1340 newmodulepath s" ;" strcat 1341 oldmodulepath strcat 1342 modulepath setenv 1343 newmodulepath drop free-memory 1344 oldmodulepath drop free-memory 1345 then 1346 0 exit 1347 then 1348 1349 \ Well, try without the prepended /boot/ 1350 path newmodulepath drop swap move 1351 newmodulepath drop path nip 1352 2dup to newmodulepath 1353 modulepath setenv 1354 1355 \ Try all default kernel names 1356 flags args 1- load_a_kernel 1357 if ( failed once more ) 1358 oldmodulepath restoreenv 1359 newmodulepath drop free-memory 1360 1 1361 else 1362 oldmodulepath nip -1 <> if 1363 newmodulepath s" ;" strcat 1364 oldmodulepath strcat 1365 modulepath setenv 1366 newmodulepath drop free-memory 1367 oldmodulepath drop free-memory 1368 then 1369 0 1370 then 1371; 1372 1373\ Try to load a kernel; the kernel name is taken from one of 1374\ the following lists, as ordered: 1375\ 1376\ 1. The "bootfile" environment variable 1377\ 2. The "kernel" environment variable 1378\ 3. The "path" argument 1379\ 1380\ Flags are passed, if provided. 1381\ 1382\ The kernel will be loaded from a directory computed from the 1383\ path given. Two directories will be tried in the following order: 1384\ 1385\ 1. /boot/path 1386\ 2. path 1387\ 1388\ Unless "path" is meant to be kernel name itself. In that case, it 1389\ will first be tried as a full path, and, next, search on the 1390\ directories pointed by module_path. 1391\ 1392\ The module_path variable is overridden if load is succesful, by 1393\ prepending the successful path. 1394 1395: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) 1396 local args 1397 2local path 1398 args 1 = if 0 0 then 1399 2local flags 1400 end-locals 1401 1402 \ First, assume path is an absolute path to a directory 1403 flags path args clip_args load_from_directory 1404 dup 0= if exit else drop then 1405 1406 \ Next, assume path points to the kernel 1407 flags path args try_multiple_kernels 1408; 1409 1410: initialize ( addr len -- ) 1411 strdup conf_files strset 1412; 1413 1414: kernel_options ( -- addr len 1 | 0 ) 1415 s" kernel_options" getenv 1416 dup -1 = if drop 0 else 1 then 1417; 1418 1419: standard_kernel_search ( flags 1 | 0 -- flag ) 1420 local args 1421 args 0= if 0 0 then 1422 2local flags 1423 s" kernel" getenv 1424 dup -1 = if 0 swap then 1425 2local path 1426 end-locals 1427 1428 path nip -1 = if ( there isn't a "kernel" environment variable ) 1429 flags args load_a_kernel 1430 else 1431 flags path args 1+ clip_args load_directory_or_file 1432 then 1433; 1434 1435: load_kernel ( -- ) ( throws: abort ) 1436 kernel_options standard_kernel_search 1437 abort" Unable to load a kernel!" 1438; 1439 1440: load_xen ( -- ) 1441 s" xen_kernel" getenv dup -1 <> if 1442 1 1 load 1443 else 1444 drop 1445 0 1446 then 1447; 1448 1449: load_xen_throw ( -- ) ( throws: abort ) 1450 load_xen 1451 abort" Unable to load Xen!" 1452; 1453 1454: set_defaultoptions ( -- ) 1455 s" kernel_options" getenv dup -1 = if 1456 drop 1457 else 1458 s" temp_options" setenv 1459 then 1460; 1461 1462\ pick the i-th argument, i starts at 0 1463: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 1464 2dup = if 0 0 exit then \ out of range 1465 dup >r 1466 1+ 2* ( skip N and ui ) 1467 pick 1468 r> 1469 1+ 2* ( skip N and ai ) 1470 pick 1471; 1472 1473: drop_args ( aN uN ... a1 u1 N -- ) 1474 0 ?do 2drop loop 1475; 1476 1477: argc 1478 dup 1479; 1480 1481: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) 1482 >r 1483 over 2* 1+ -roll 1484 r> 1485 over 2* 1+ -roll 1486 1+ 1487; 1488 1489: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 1490 1- -rot 1491; 1492 1493\ compute the length of the buffer including the spaces between words 1494: strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len ) 1495 dup 0= if 0 exit then 1496 0 >r \ Size 1497 0 >r \ Index 1498 begin 1499 argc r@ <> 1500 while 1501 r@ argv[] 1502 nip 1503 r> r> rot + 1+ 1504 >r 1+ >r 1505 repeat 1506 r> drop 1507 r> 1508; 1509 1510: concat_argv ( aN uN ... a1 u1 N -- a u ) 1511 strlen(argv) allocate if ENOMEM throw then 1512 0 2>r ( save addr 0 on return stack ) 1513 1514 begin 1515 dup 1516 while 1517 unqueue_argv ( ... N a1 u1 ) 1518 2r> 2swap ( old a1 u1 ) 1519 strcat 1520 s" " strcat ( append one space ) \ XXX this gives a trailing space 1521 2>r ( store string on the result stack ) 1522 repeat 1523 drop_args 1524 2r> 1525; 1526 1527: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) 1528 \ Save the first argument, if it exists and is not a flag 1529 argc if 1530 0 argv[] drop c@ [char] - <> if 1531 unqueue_argv 2>r \ Filename 1532 1 >r \ Filename present 1533 else 1534 0 >r \ Filename not present 1535 then 1536 else 1537 0 >r \ Filename not present 1538 then 1539 1540 \ If there are other arguments, assume they are flags 1541 ?dup if 1542 concat_argv 1543 2dup s" temp_options" setenv 1544 drop free if EFREE throw then 1545 else 1546 set_defaultoptions 1547 then 1548 1549 \ Bring back the filename, if one was provided 1550 r> if 2r> 1 else 0 then 1551; 1552 1553: get_arguments ( -- addrN lenN ... addr1 len1 N ) 1554 0 1555 begin 1556 \ Get next word on the command line 1557 parse-word 1558 ?dup while 1559 queue_argv 1560 repeat 1561 drop ( empty string ) 1562; 1563 1564: load_kernel_and_modules ( args -- flag ) 1565 set_tempoptions 1566 argc >r 1567 s" temp_options" getenv dup -1 <> if 1568 queue_argv 1569 else 1570 drop 1571 then 1572 load_xen 1573 ?dup 0= if ( success ) 1574 r> if ( a path was passed ) 1575 load_directory_or_file 1576 else 1577 standard_kernel_search 1578 then 1579 ?dup 0= if ['] load_modules catch then 1580 then 1581; 1582 1583\ Go back to straight forth vocabulary 1584 1585only forth also definitions 1586 1587