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