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