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