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