support.4th revision 61373
1178580Simp\ Copyright (c) 1999 Daniel C. Sobral <dcs@freebsd.org> 2178580Simp\ All rights reserved. 3281004Semaste\ 4246117Skib\ Redistribution and use in source and binary forms, with or without 5178580Simp\ modification, are permitted provided that the following conditions 6302092Sbrooks\ are met: 7178580Simp\ 1. Redistributions of source code must retain the above copyright 8178580Simp\ notice, this list of conditions and the following disclaimer. 9281714Skib\ 2. Redistributions in binary form must reproduce the above copyright 10178580Simp\ notice, this list of conditions and the following disclaimer in the 11178580Simp\ 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 61373 2000-06-07 22:03:37Z 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: create here 0 , 0 does> create @ allot ; 86: member: create dup , over , + does> cell+ @ + ; 87: ;structure swap ! ; 88: sizeof ' >body @ state @ if postpone literal then ; immediate 89: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate 90: ptr 1 cells member: ; 91: int 1 cells member: ; 92 93\ String structure 94 95structure: string 96 ptr .addr 97 int .len 98;structure 99 100\ Module options linked list 101 102structure: module 103 int module.flag 104 sizeof string member: module.name 105 sizeof string member: module.loadname 106 sizeof string member: module.type 107 sizeof string member: module.args 108 sizeof string member: module.beforeload 109 sizeof string member: module.afterload 110 sizeof string member: module.loaderror 111 ptr module.next 112;structure 113 114\ Global variables 115 116string conf_files 117string password 118create module_options sizeof module.next allot 119create last_module_option sizeof module.next allot 1200 value verbose? 121 122\ Support string functions 123 124: strdup ( addr len -- addr' len ) 125 >r r@ allocate if out_of_memory throw then 126 tuck r@ move 127 r> 128; 129 130: strcat { addr len addr' len' -- addr len+len' } 131 addr' addr len + len' move 132 addr len len' + 133; 134 135: strlen ( addr -- len ) 136 0 >r 137 begin 138 dup c@ while 139 1+ r> 1+ >r repeat 140 drop r> 141; 142 143: s' 144 [char] ' parse 145 state @ if 146 postpone sliteral 147 then 148; immediate 149 150: 2>r postpone >r postpone >r ; immediate 151: 2r> postpone r> postpone r> ; immediate 152 153\ Private definitions 154 155vocabulary support-functions 156only forth also support-functions definitions 157 158\ Some control characters constants 159 1607 constant bell 1618 constant backspace 1629 constant tab 16310 constant lf 16413 constant <cr> 165 166\ Read buffer size 167 16880 constant read_buffer_size 169 170\ Standard suffixes 171 172: load_module_suffix s" _load" ; 173: module_loadname_suffix s" _name" ; 174: module_type_suffix s" _type" ; 175: module_args_suffix s" _flags" ; 176: module_beforeload_suffix s" _before" ; 177: module_afterload_suffix s" _after" ; 178: module_loaderror_suffix s" _error" ; 179 180\ Support operators 181 182: >= < 0= ; 183: <= > 0= ; 184 185\ Assorted support funcitons 186 187: free-memory free if free_error throw then ; 188 189\ Assignment data temporary storage 190 191string name_buffer 192string value_buffer 193 194\ File data temporary storage 195 196string line_buffer 197string read_buffer 1980 value read_buffer_ptr 199 200\ File's line reading function 201 2020 value end_of_file? 203variable fd 204 205: skip_newlines 206 begin 207 read_buffer .len @ read_buffer_ptr > 208 while 209 read_buffer .addr @ read_buffer_ptr + c@ lf = if 210 read_buffer_ptr char+ to read_buffer_ptr 211 else 212 exit 213 then 214 repeat 215; 216 217: scan_buffer ( -- addr len ) 218 read_buffer_ptr >r 219 begin 220 read_buffer .len @ r@ > 221 while 222 read_buffer .addr @ r@ + c@ lf = if 223 read_buffer .addr @ read_buffer_ptr + ( -- addr ) 224 r@ read_buffer_ptr - ( -- len ) 225 r> to read_buffer_ptr 226 exit 227 then 228 r> char+ >r 229 repeat 230 read_buffer .addr @ read_buffer_ptr + ( -- addr ) 231 r@ read_buffer_ptr - ( -- len ) 232 r> to read_buffer_ptr 233; 234 235: line_buffer_resize ( len -- len ) 236 >r 237 line_buffer .len @ if 238 line_buffer .addr @ 239 line_buffer .len @ r@ + 240 resize if out_of_memory throw then 241 else 242 r@ allocate if out_of_memory throw then 243 then 244 line_buffer .addr ! 245 r> 246; 247 248: append_to_line_buffer ( addr len -- ) 249 line_buffer .addr @ line_buffer .len @ 250 2swap strcat 251 line_buffer .len ! 252 drop 253; 254 255: read_from_buffer 256 scan_buffer ( -- addr len ) 257 line_buffer_resize ( len -- len ) 258 append_to_line_buffer ( addr len -- ) 259; 260 261: refill_required? 262 read_buffer .len @ read_buffer_ptr = 263 end_of_file? 0= and 264; 265 266: refill_buffer 267 0 to read_buffer_ptr 268 read_buffer .addr @ 0= if 269 read_buffer_size allocate if out_of_memory throw then 270 read_buffer .addr ! 271 then 272 fd @ read_buffer .addr @ read_buffer_size fread 273 dup -1 = if read_error throw then 274 dup 0= if true to end_of_file? then 275 read_buffer .len ! 276; 277 278: reset_line_buffer 279 0 line_buffer .addr ! 280 0 line_buffer .len ! 281; 282 283: read_line 284 reset_line_buffer 285 skip_newlines 286 begin 287 read_from_buffer 288 refill_required? 289 while 290 refill_buffer 291 repeat 292; 293 294\ Conf file line parser: 295\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 296\ <spaces>[<comment>] 297\ <name> ::= <letter>{<letter>|<digit>|'_'} 298\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 299\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 300\ <comment> ::= '#'{<anything>} 301 3020 value parsing_function 303 3040 value end_of_line 3050 value line_pointer 306 307: end_of_line? 308 line_pointer end_of_line = 309; 310 311: letter? 312 line_pointer c@ >r 313 r@ [char] A >= 314 r@ [char] Z <= and 315 r@ [char] a >= 316 r> [char] z <= and 317 or 318; 319 320: digit? 321 line_pointer c@ >r 322 r@ [char] 0 >= 323 r> [char] 9 <= and 324; 325 326: quote? 327 line_pointer c@ [char] " = 328; 329 330: assignment_sign? 331 line_pointer c@ [char] = = 332; 333 334: comment? 335 line_pointer c@ [char] # = 336; 337 338: space? 339 line_pointer c@ bl = 340 line_pointer c@ tab = or 341; 342 343: backslash? 344 line_pointer c@ [char] \ = 345; 346 347: underscore? 348 line_pointer c@ [char] _ = 349; 350 351: dot? 352 line_pointer c@ [char] . = 353; 354 355: skip_character 356 line_pointer char+ to line_pointer 357; 358 359: skip_to_end_of_line 360 end_of_line to line_pointer 361; 362 363: eat_space 364 begin 365 space? 366 while 367 skip_character 368 end_of_line? if exit then 369 repeat 370; 371 372: parse_name ( -- addr len ) 373 line_pointer 374 begin 375 letter? digit? underscore? dot? or or or 376 while 377 skip_character 378 end_of_line? if 379 line_pointer over - 380 strdup 381 exit 382 then 383 repeat 384 line_pointer over - 385 strdup 386; 387 388: remove_backslashes { addr len | addr' len' -- addr' len' } 389 len allocate if out_of_memory throw then 390 to addr' 391 addr >r 392 begin 393 addr c@ [char] \ <> if 394 addr c@ addr' len' + c! 395 len' char+ to len' 396 then 397 addr char+ to addr 398 r@ len + addr = 399 until 400 r> drop 401 addr' len' 402; 403 404: parse_quote ( -- addr len ) 405 line_pointer 406 skip_character 407 end_of_line? if syntax_error throw then 408 begin 409 quote? 0= 410 while 411 backslash? if 412 skip_character 413 end_of_line? if syntax_error throw then 414 then 415 skip_character 416 end_of_line? if syntax_error throw then 417 repeat 418 skip_character 419 line_pointer over - 420 remove_backslashes 421; 422 423: read_name 424 parse_name ( -- addr len ) 425 name_buffer .len ! 426 name_buffer .addr ! 427; 428 429: read_value 430 quote? if 431 parse_quote ( -- addr len ) 432 else 433 parse_name ( -- addr len ) 434 then 435 value_buffer .len ! 436 value_buffer .addr ! 437; 438 439: comment 440 skip_to_end_of_line 441; 442 443: white_space_4 444 eat_space 445 comment? if ['] comment to parsing_function exit then 446 end_of_line? 0= if syntax_error throw then 447; 448 449: variable_value 450 read_value 451 ['] white_space_4 to parsing_function 452; 453 454: white_space_3 455 eat_space 456 letter? digit? quote? or or if 457 ['] variable_value to parsing_function exit 458 then 459 syntax_error throw 460; 461 462: assignment_sign 463 skip_character 464 ['] white_space_3 to parsing_function 465; 466 467: white_space_2 468 eat_space 469 assignment_sign? if ['] assignment_sign to parsing_function exit then 470 syntax_error throw 471; 472 473: variable_name 474 read_name 475 ['] white_space_2 to parsing_function 476; 477 478: white_space_1 479 eat_space 480 letter? if ['] variable_name to parsing_function exit then 481 comment? if ['] comment to parsing_function exit then 482 end_of_line? 0= if syntax_error throw then 483; 484 485: get_assignment 486 line_buffer .addr @ line_buffer .len @ + to end_of_line 487 line_buffer .addr @ to line_pointer 488 ['] white_space_1 to parsing_function 489 begin 490 end_of_line? 0= 491 while 492 parsing_function execute 493 repeat 494 parsing_function ['] comment = 495 parsing_function ['] white_space_1 = 496 parsing_function ['] white_space_4 = 497 or or 0= if syntax_error throw then 498; 499 500\ Process line 501 502: assignment_type? ( addr len -- flag ) 503 name_buffer .addr @ name_buffer .len @ 504 compare 0= 505; 506 507: suffix_type? ( addr len -- flag ) 508 name_buffer .len @ over <= if 2drop false exit then 509 name_buffer .len @ over - name_buffer .addr @ + 510 over compare 0= 511; 512 513: loader_conf_files? 514 s" loader_conf_files" assignment_type? 515; 516 517: verbose_flag? 518 s" verbose_loading" assignment_type? 519; 520 521: execute? 522 s" exec" assignment_type? 523; 524 525: password? 526 s" password" assignment_type? 527; 528 529: module_load? 530 load_module_suffix suffix_type? 531; 532 533: module_loadname? 534 module_loadname_suffix suffix_type? 535; 536 537: module_type? 538 module_type_suffix suffix_type? 539; 540 541: module_args? 542 module_args_suffix suffix_type? 543; 544 545: module_beforeload? 546 module_beforeload_suffix suffix_type? 547; 548 549: module_afterload? 550 module_afterload_suffix suffix_type? 551; 552 553: module_loaderror? 554 module_loaderror_suffix suffix_type? 555; 556 557: set_conf_files 558 conf_files .addr @ ?dup if 559 free-memory 560 then 561 value_buffer .addr @ c@ [char] " = if 562 value_buffer .addr @ char+ value_buffer .len @ 2 chars - 563 else 564 value_buffer .addr @ value_buffer .len @ 565 then 566 strdup 567 conf_files .len ! conf_files .addr ! 568; 569 570: append_to_module_options_list ( addr -- ) 571 module_options @ 0= if 572 dup module_options ! 573 last_module_option ! 574 else 575 dup last_module_option @ module.next ! 576 last_module_option ! 577 then 578; 579 580: set_module_name ( addr -- ) 581 name_buffer .addr @ name_buffer .len @ 582 strdup 583 >r over module.name .addr ! 584 r> swap module.name .len ! 585; 586 587: yes_value? 588 value_buffer .addr @ value_buffer .len @ 589 2dup s' "YES"' compare >r 590 2dup s' "yes"' compare >r 591 2dup s" YES" compare >r 592 s" yes" compare r> r> r> and and and 0= 593; 594 595: find_module_option ( -- addr | 0 ) 596 module_options @ 597 begin 598 dup 599 while 600 dup module.name dup .addr @ swap .len @ 601 name_buffer .addr @ name_buffer .len @ 602 compare 0= if exit then 603 module.next @ 604 repeat 605; 606 607: new_module_option ( -- addr ) 608 sizeof module allocate if out_of_memory throw then 609 dup sizeof module erase 610 dup append_to_module_options_list 611 dup set_module_name 612; 613 614: get_module_option ( -- addr ) 615 find_module_option 616 ?dup 0= if new_module_option then 617; 618 619: set_module_flag 620 name_buffer .len @ load_module_suffix nip - name_buffer .len ! 621 yes_value? get_module_option module.flag ! 622; 623 624: set_module_args 625 name_buffer .len @ module_args_suffix nip - name_buffer .len ! 626 get_module_option module.args 627 dup .addr @ ?dup if free-memory then 628 value_buffer .addr @ value_buffer .len @ 629 over c@ [char] " = if 630 2 chars - swap char+ swap 631 then 632 strdup 633 >r over .addr ! 634 r> swap .len ! 635; 636 637: set_module_loadname 638 name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 639 get_module_option module.loadname 640 dup .addr @ ?dup if free-memory then 641 value_buffer .addr @ value_buffer .len @ 642 over c@ [char] " = if 643 2 chars - swap char+ swap 644 then 645 strdup 646 >r over .addr ! 647 r> swap .len ! 648; 649 650: set_module_type 651 name_buffer .len @ module_type_suffix nip - name_buffer .len ! 652 get_module_option module.type 653 dup .addr @ ?dup if free-memory then 654 value_buffer .addr @ value_buffer .len @ 655 over c@ [char] " = if 656 2 chars - swap char+ swap 657 then 658 strdup 659 >r over .addr ! 660 r> swap .len ! 661; 662 663: set_module_beforeload 664 name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 665 get_module_option module.beforeload 666 dup .addr @ ?dup if free-memory then 667 value_buffer .addr @ value_buffer .len @ 668 over c@ [char] " = if 669 2 chars - swap char+ swap 670 then 671 strdup 672 >r over .addr ! 673 r> swap .len ! 674; 675 676: set_module_afterload 677 name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 678 get_module_option module.afterload 679 dup .addr @ ?dup if free-memory then 680 value_buffer .addr @ value_buffer .len @ 681 over c@ [char] " = if 682 2 chars - swap char+ swap 683 then 684 strdup 685 >r over .addr ! 686 r> swap .len ! 687; 688 689: set_module_loaderror 690 name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 691 get_module_option module.loaderror 692 dup .addr @ ?dup if free-memory then 693 value_buffer .addr @ value_buffer .len @ 694 over c@ [char] " = if 695 2 chars - swap char+ swap 696 then 697 strdup 698 >r over .addr ! 699 r> swap .len ! 700; 701 702: set_environment_variable 703 name_buffer .len @ 704 value_buffer .len @ + 705 5 chars + 706 allocate if out_of_memory throw then 707 dup 0 ( addr -- addr addr len ) 708 s" set " strcat 709 name_buffer .addr @ name_buffer .len @ strcat 710 s" =" strcat 711 value_buffer .addr @ value_buffer .len @ strcat 712 ['] evaluate catch if 713 2drop free drop 714 set_error throw 715 else 716 free-memory 717 then 718; 719 720: set_verbose 721 yes_value? to verbose? 722; 723 724: execute_command 725 value_buffer .addr @ value_buffer .len @ 726 over c@ [char] " = if 727 2 - swap char+ swap 728 then 729 ['] evaluate catch if exec_error throw then 730; 731 732: set_password 733 password .addr @ ?dup if free if free_error throw then then 734 value_buffer .addr @ c@ [char] " = if 735 value_buffer .addr @ char+ value_buffer .len @ 2 - strdup 736 value_buffer .addr @ free if free_error throw then 737 else 738 value_buffer .addr @ value_buffer .len @ 739 then 740 password .len ! password .addr ! 741 0 value_buffer .addr ! 742; 743 744: process_assignment 745 name_buffer .len @ 0= if exit then 746 loader_conf_files? if set_conf_files exit then 747 verbose_flag? if set_verbose exit then 748 execute? if execute_command exit then 749 password? if set_password exit then 750 module_load? if set_module_flag exit then 751 module_loadname? if set_module_loadname exit then 752 module_type? if set_module_type exit then 753 module_args? if set_module_args exit then 754 module_beforeload? if set_module_beforeload exit then 755 module_afterload? if set_module_afterload exit then 756 module_loaderror? if set_module_loaderror exit then 757 set_environment_variable 758; 759 760\ free_buffer ( -- ) 761\ 762\ Free some pointers if needed. The code then tests for errors 763\ in freeing, and throws an exception if needed. If a pointer is 764\ not allocated, it's value (0) is used as flag. 765 766: free_buffers 767 line_buffer .addr @ dup if free then 768 name_buffer .addr @ dup if free then 769 value_buffer .addr @ dup if free then 770 or or if free_error throw then 771; 772 773: reset_assignment_buffers 774 0 name_buffer .addr ! 775 0 name_buffer .len ! 776 0 value_buffer .addr ! 777 0 value_buffer .len ! 778; 779 780\ Higher level file processing 781 782: process_conf 783 begin 784 end_of_file? 0= 785 while 786 reset_assignment_buffers 787 read_line 788 get_assignment 789 ['] process_assignment catch 790 ['] free_buffers catch 791 swap throw throw 792 repeat 793; 794 795: create_null_terminated_string { addr len -- addr' len } 796 len char+ allocate if out_of_memory throw then 797 >r 798 addr r@ len move 799 0 r@ len + c! 800 r> len 801; 802 803\ Interface to loading conf files 804 805: load_conf ( addr len -- ) 806 0 to end_of_file? 807 0 to read_buffer_ptr 808 create_null_terminated_string 809 over >r 810 fopen fd ! 811 r> free-memory 812 fd @ -1 = if open_error throw then 813 ['] process_conf catch 814 fd @ fclose 815 throw 816; 817 818: initialize_support 819 0 read_buffer .addr ! 820 0 conf_files .addr ! 821 0 password .addr ! 822 0 module_options ! 823 0 last_module_option ! 824 0 to verbose? 825; 826 827: print_line 828 line_buffer .addr @ line_buffer .len @ type cr 829; 830 831: print_syntax_error 832 line_buffer .addr @ line_buffer .len @ type cr 833 line_buffer .addr @ 834 begin 835 line_pointer over <> 836 while 837 bl emit 838 char+ 839 repeat 840 drop 841 ." ^" cr 842; 843 844\ Depuration support functions 845 846only forth definitions also support-functions 847 848: test-file 849 ['] load_conf catch dup . 850 syntax_error = if cr print_syntax_error then 851; 852 853: show-module-options 854 module_options @ 855 begin 856 ?dup 857 while 858 ." Name: " dup module.name dup .addr @ swap .len @ type cr 859 ." Path: " dup module.loadname dup .addr @ swap .len @ type cr 860 ." Type: " dup module.type dup .addr @ swap .len @ type cr 861 ." Flags: " dup module.args dup .addr @ swap .len @ type cr 862 ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr 863 ." After load: " dup module.afterload dup .addr @ swap .len @ type cr 864 ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr 865 ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr 866 module.next @ 867 repeat 868; 869 870only forth also support-functions definitions 871 872\ Variables used for processing multiple conf files 873 874string current_file_name 875variable current_conf_files 876 877\ Indicates if any conf file was succesfully read 878 8790 value any_conf_read? 880 881\ loader_conf_files processing support functions 882 883: set_current_conf_files 884 conf_files .addr @ current_conf_files ! 885; 886 887: get_conf_files 888 conf_files .addr @ conf_files .len @ strdup 889; 890 891: recurse_on_conf_files? 892 current_conf_files @ conf_files .addr @ <> 893; 894 895: skip_leading_spaces { addr len pos -- addr len pos' } 896 begin 897 pos len = if addr len pos exit then 898 addr pos + c@ bl = 899 while 900 pos char+ to pos 901 repeat 902 addr len pos 903; 904 905: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 906 pos len = if 907 addr free abort" Fatal error freeing memory" 908 0 exit 909 then 910 pos >r 911 begin 912 addr pos + c@ bl <> 913 while 914 pos char+ to pos 915 pos len = if 916 addr len pos addr r@ + pos r> - exit 917 then 918 repeat 919 addr len pos addr r@ + pos r> - 920; 921 922: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 923 skip_leading_spaces 924 get_file_name 925; 926 927: set_current_file_name 928 over current_file_name .addr ! 929 dup current_file_name .len ! 930; 931 932: print_current_file 933 current_file_name .addr @ current_file_name .len @ type 934; 935 936: process_conf_errors 937 dup 0= if true to any_conf_read? drop exit then 938 >r 2drop r> 939 dup syntax_error = if 940 ." Warning: syntax error on file " print_current_file cr 941 print_syntax_error drop exit 942 then 943 dup set_error = if 944 ." Warning: bad definition on file " print_current_file cr 945 print_line drop exit 946 then 947 dup read_error = if 948 ." Warning: error reading file " print_current_file cr drop exit 949 then 950 dup open_error = if 951 verbose? if ." Warning: unable to open file " print_current_file cr then 952 drop exit 953 then 954 dup free_error = abort" Fatal error freeing memory" 955 dup out_of_memory = abort" Out of memory" 956 throw \ Unknown error -- pass ahead 957; 958 959\ Process loader_conf_files recursively 960\ Interface to loader_conf_files processing 961 962: include_conf_files 963 set_current_conf_files 964 get_conf_files 0 965 begin 966 get_next_file ?dup 967 while 968 set_current_file_name 969 ['] load_conf catch 970 process_conf_errors 971 recurse_on_conf_files? if recurse then 972 repeat 973; 974 975\ Module loading functions 976 977: load_module? 978 module.flag @ 979; 980 981: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N ) 982 dup >r 983 r@ module.args .addr @ r@ module.args .len @ 984 r@ module.loadname .len @ if 985 r@ module.loadname .addr @ r@ module.loadname .len @ 986 else 987 r@ module.name .addr @ r@ module.name .len @ 988 then 989 r@ module.type .len @ if 990 r@ module.type .addr @ r@ module.type .len @ 991 s" -t " 992 4 ( -t type name flags ) 993 else 994 2 ( name flags ) 995 then 996 r> drop 997; 998 999: before_load ( addr -- addr ) 1000 dup module.beforeload .len @ if 1001 dup module.beforeload .addr @ over module.beforeload .len @ 1002 ['] evaluate catch if before_load_error throw then 1003 then 1004; 1005 1006: after_load ( addr -- addr ) 1007 dup module.afterload .len @ if 1008 dup module.afterload .addr @ over module.afterload .len @ 1009 ['] evaluate catch if after_load_error throw then 1010 then 1011; 1012 1013: load_error ( addr -- addr ) 1014 dup module.loaderror .len @ if 1015 dup module.loaderror .addr @ over module.loaderror .len @ 1016 evaluate \ This we do not intercept so it can throw errors 1017 then 1018; 1019 1020: pre_load_message ( addr -- addr ) 1021 verbose? if 1022 dup module.name .addr @ over module.name .len @ type 1023 ." ..." 1024 then 1025; 1026 1027: load_error_message verbose? if ." failed!" cr then ; 1028 1029: load_succesful_message verbose? if ." ok" cr then ; 1030 1031: load_module 1032 load_parameters load 1033; 1034 1035: process_module ( addr -- addr ) 1036 pre_load_message 1037 before_load 1038 begin 1039 ['] load_module catch if 1040 dup module.loaderror .len @ if 1041 load_error \ Command should return a flag! 1042 else 1043 load_error_message true \ Do not retry 1044 then 1045 else 1046 after_load 1047 load_succesful_message true \ Succesful, do not retry 1048 then 1049 until 1050; 1051 1052: process_module_errors ( addr ior -- ) 1053 dup before_load_error = if 1054 drop 1055 ." Module " 1056 dup module.name .addr @ over module.name .len @ type 1057 dup module.loadname .len @ if 1058 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 1059 then 1060 cr 1061 ." Error executing " 1062 dup module.beforeload .addr @ over module.afterload .len @ type cr 1063 abort 1064 then 1065 1066 dup after_load_error = if 1067 drop 1068 ." Module " 1069 dup module.name .addr @ over module.name .len @ type 1070 dup module.loadname .len @ if 1071 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 1072 then 1073 cr 1074 ." Error executing " 1075 dup module.afterload .addr @ over module.afterload .len @ type cr 1076 abort 1077 then 1078 1079 throw \ Don't know what it is all about -- pass ahead 1080; 1081 1082\ Module loading interface 1083 1084: load_modules ( -- ) ( throws: abort & user-defined ) 1085 module_options @ 1086 begin 1087 ?dup 1088 while 1089 dup load_module? if 1090 ['] process_module catch 1091 process_module_errors 1092 then 1093 module.next @ 1094 repeat 1095; 1096 1097\ Additional functions used in "start" 1098 1099: initialize ( addr len -- ) 1100 initialize_support 1101 strdup conf_files .len ! conf_files .addr ! 1102; 1103 1104: load_kernel ( -- ) ( throws: abort ) 1105 s" load ${kernel} ${kernel_options}" ['] evaluate catch 1106 if s" echo Unable to load kernel: ${kernel_name}" evaluate abort then 1107; 1108 1109: read-password { size | buf len -- } 1110 size allocate if out_of_memory throw then 1111 to buf 1112 0 to len 1113 begin 1114 key 1115 dup backspace = if 1116 drop 1117 len if 1118 backspace emit bl emit backspace emit 1119 len 1 - to len 1120 else 1121 bell emit 1122 then 1123 else 1124 dup <cr> = if cr drop buf len exit then 1125 [char] * emit 1126 len size < if 1127 buf len chars + c! 1128 else 1129 drop 1130 then 1131 len 1+ to len 1132 then 1133 again 1134; 1135 1136\ Go back to straight forth vocabulary 1137 1138only forth also definitions 1139 1140