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