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