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