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