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