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