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