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