support.4th revision 65615
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 65615 2000-09-08 16:57:28Z 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 237\ Private definitions 238 239vocabulary support-functions 240only forth also support-functions definitions 241 242\ Some control characters constants 243 2447 constant bell 2458 constant backspace 2469 constant tab 24710 constant lf 24813 constant <cr> 249 250\ Read buffer size 251 25280 constant read_buffer_size 253 254\ Standard suffixes 255 256: load_module_suffix s" _load" ; 257: module_loadname_suffix s" _name" ; 258: module_type_suffix s" _type" ; 259: module_args_suffix s" _flags" ; 260: module_beforeload_suffix s" _before" ; 261: module_afterload_suffix s" _after" ; 262: module_loaderror_suffix s" _error" ; 263 264\ Support operators 265 266: >= < 0= ; 267: <= > 0= ; 268 269\ Assorted support funcitons 270 271: free-memory free if free_error throw then ; 272 273\ Assignment data temporary storage 274 275string name_buffer 276string value_buffer 277 278\ Line by line file reading functions 279\ 280\ exported: 281\ line_buffer 282\ end_of_file? 283\ fd 284\ read_line 285\ reset_line_reading 286 287vocabulary line-reading 288also line-reading definitions also 289 290\ File data temporary storage 291 292string read_buffer 2930 value read_buffer_ptr 294 295\ File's line reading function 296 297support-functions definitions 298 299string line_buffer 3000 value end_of_file? 301variable fd 302 303line-reading definitions 304 305: skip_newlines 306 begin 307 read_buffer .len @ read_buffer_ptr > 308 while 309 read_buffer .addr @ read_buffer_ptr + c@ lf = if 310 read_buffer_ptr char+ to read_buffer_ptr 311 else 312 exit 313 then 314 repeat 315; 316 317: scan_buffer ( -- addr len ) 318 read_buffer_ptr >r 319 begin 320 read_buffer .len @ r@ > 321 while 322 read_buffer .addr @ r@ + c@ lf = if 323 read_buffer .addr @ read_buffer_ptr + ( -- addr ) 324 r@ read_buffer_ptr - ( -- len ) 325 r> to read_buffer_ptr 326 exit 327 then 328 r> char+ >r 329 repeat 330 read_buffer .addr @ read_buffer_ptr + ( -- addr ) 331 r@ read_buffer_ptr - ( -- len ) 332 r> to read_buffer_ptr 333; 334 335: line_buffer_resize ( len -- len ) 336 >r 337 line_buffer .len @ if 338 line_buffer .addr @ 339 line_buffer .len @ r@ + 340 resize if out_of_memory throw then 341 else 342 r@ allocate if out_of_memory throw then 343 then 344 line_buffer .addr ! 345 r> 346; 347 348: append_to_line_buffer ( addr len -- ) 349 line_buffer .addr @ line_buffer .len @ 350 2swap strcat 351 line_buffer .len ! 352 drop 353; 354 355: read_from_buffer 356 scan_buffer ( -- addr len ) 357 line_buffer_resize ( len -- len ) 358 append_to_line_buffer ( addr len -- ) 359; 360 361: refill_required? 362 read_buffer .len @ read_buffer_ptr = 363 end_of_file? 0= and 364; 365 366: refill_buffer 367 0 to read_buffer_ptr 368 read_buffer .addr @ 0= if 369 read_buffer_size allocate if out_of_memory throw then 370 read_buffer .addr ! 371 then 372 fd @ read_buffer .addr @ read_buffer_size fread 373 dup -1 = if read_error throw then 374 dup 0= if true to end_of_file? then 375 read_buffer .len ! 376; 377 378: reset_line_buffer 379 line_buffer .addr @ ?dup if 380 free-memory 381 then 382 0 line_buffer .addr ! 383 0 line_buffer .len ! 384; 385 386support-functions definitions 387 388: reset_line_reading 389 0 to read_buffer_ptr 390; 391 392: read_line 393 reset_line_buffer 394 skip_newlines 395 begin 396 read_from_buffer 397 refill_required? 398 while 399 refill_buffer 400 repeat 401; 402 403only forth also support-functions definitions 404 405\ Conf file line parser: 406\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] | 407\ <spaces>[<comment>] 408\ <name> ::= <letter>{<letter>|<digit>|'_'} 409\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name> 410\ <character_set> ::= ASCII 32 to 126, except '\' and '"' 411\ <comment> ::= '#'{<anything>} 412\ 413\ exported: 414\ line_pointer 415\ process_conf 416 4170 value line_pointer 418 419vocabulary file-processing 420also file-processing definitions 421 422\ parser functions 423\ 424\ exported: 425\ get_assignment 426 427vocabulary parser 428also parser definitions also 429 4300 value parsing_function 4310 value end_of_line 432 433: end_of_line? 434 line_pointer end_of_line = 435; 436 437: letter? 438 line_pointer c@ >r 439 r@ [char] A >= 440 r@ [char] Z <= and 441 r@ [char] a >= 442 r> [char] z <= and 443 or 444; 445 446: digit? 447 line_pointer c@ >r 448 r@ [char] 0 >= 449 r> [char] 9 <= and 450; 451 452: quote? 453 line_pointer c@ [char] " = 454; 455 456: assignment_sign? 457 line_pointer c@ [char] = = 458; 459 460: comment? 461 line_pointer c@ [char] # = 462; 463 464: space? 465 line_pointer c@ bl = 466 line_pointer c@ tab = or 467; 468 469: backslash? 470 line_pointer c@ [char] \ = 471; 472 473: underscore? 474 line_pointer c@ [char] _ = 475; 476 477: dot? 478 line_pointer c@ [char] . = 479; 480 481: skip_character 482 line_pointer char+ to line_pointer 483; 484 485: skip_to_end_of_line 486 end_of_line to line_pointer 487; 488 489: eat_space 490 begin 491 space? 492 while 493 skip_character 494 end_of_line? if exit then 495 repeat 496; 497 498: parse_name ( -- addr len ) 499 line_pointer 500 begin 501 letter? digit? underscore? dot? or or or 502 while 503 skip_character 504 end_of_line? if 505 line_pointer over - 506 strdup 507 exit 508 then 509 repeat 510 line_pointer over - 511 strdup 512; 513 514: remove_backslashes { addr len | addr' len' -- addr' len' } 515 len allocate if out_of_memory throw then 516 to addr' 517 addr >r 518 begin 519 addr c@ [char] \ <> if 520 addr c@ addr' len' + c! 521 len' char+ to len' 522 then 523 addr char+ to addr 524 r@ len + addr = 525 until 526 r> drop 527 addr' len' 528; 529 530: parse_quote ( -- addr len ) 531 line_pointer 532 skip_character 533 end_of_line? if syntax_error throw then 534 begin 535 quote? 0= 536 while 537 backslash? if 538 skip_character 539 end_of_line? if syntax_error throw then 540 then 541 skip_character 542 end_of_line? if syntax_error throw then 543 repeat 544 skip_character 545 line_pointer over - 546 remove_backslashes 547; 548 549: read_name 550 parse_name ( -- addr len ) 551 name_buffer .len ! 552 name_buffer .addr ! 553; 554 555: read_value 556 quote? if 557 parse_quote ( -- addr len ) 558 else 559 parse_name ( -- addr len ) 560 then 561 value_buffer .len ! 562 value_buffer .addr ! 563; 564 565: comment 566 skip_to_end_of_line 567; 568 569: white_space_4 570 eat_space 571 comment? if ['] comment to parsing_function exit then 572 end_of_line? 0= if syntax_error throw then 573; 574 575: variable_value 576 read_value 577 ['] white_space_4 to parsing_function 578; 579 580: white_space_3 581 eat_space 582 letter? digit? quote? or or if 583 ['] variable_value to parsing_function exit 584 then 585 syntax_error throw 586; 587 588: assignment_sign 589 skip_character 590 ['] white_space_3 to parsing_function 591; 592 593: white_space_2 594 eat_space 595 assignment_sign? if ['] assignment_sign to parsing_function exit then 596 syntax_error throw 597; 598 599: variable_name 600 read_name 601 ['] white_space_2 to parsing_function 602; 603 604: white_space_1 605 eat_space 606 letter? if ['] variable_name to parsing_function exit then 607 comment? if ['] comment to parsing_function exit then 608 end_of_line? 0= if syntax_error throw then 609; 610 611file-processing definitions 612 613: get_assignment 614 line_buffer .addr @ line_buffer .len @ + to end_of_line 615 line_buffer .addr @ to line_pointer 616 ['] white_space_1 to parsing_function 617 begin 618 end_of_line? 0= 619 while 620 parsing_function execute 621 repeat 622 parsing_function ['] comment = 623 parsing_function ['] white_space_1 = 624 parsing_function ['] white_space_4 = 625 or or 0= if syntax_error throw then 626; 627 628only forth also support-functions also file-processing definitions also 629 630\ Process line 631 632: assignment_type? ( addr len -- flag ) 633 name_buffer .addr @ name_buffer .len @ 634 compare 0= 635; 636 637: suffix_type? ( addr len -- flag ) 638 name_buffer .len @ over <= if 2drop false exit then 639 name_buffer .len @ over - name_buffer .addr @ + 640 over compare 0= 641; 642 643: loader_conf_files? 644 s" loader_conf_files" assignment_type? 645; 646 647: verbose_flag? 648 s" verbose_loading" assignment_type? 649; 650 651: execute? 652 s" exec" assignment_type? 653; 654 655: password? 656 s" password" assignment_type? 657; 658 659: module_load? 660 load_module_suffix suffix_type? 661; 662 663: module_loadname? 664 module_loadname_suffix suffix_type? 665; 666 667: module_type? 668 module_type_suffix suffix_type? 669; 670 671: module_args? 672 module_args_suffix suffix_type? 673; 674 675: module_beforeload? 676 module_beforeload_suffix suffix_type? 677; 678 679: module_afterload? 680 module_afterload_suffix suffix_type? 681; 682 683: module_loaderror? 684 module_loaderror_suffix suffix_type? 685; 686 687: set_conf_files 688 conf_files .addr @ ?dup if 689 free-memory 690 then 691 value_buffer .addr @ c@ [char] " = if 692 value_buffer .addr @ char+ value_buffer .len @ 2 chars - 693 else 694 value_buffer .addr @ value_buffer .len @ 695 then 696 strdup 697 conf_files .len ! conf_files .addr ! 698; 699 700: append_to_module_options_list ( addr -- ) 701 module_options @ 0= if 702 dup module_options ! 703 last_module_option ! 704 else 705 dup last_module_option @ module.next ! 706 last_module_option ! 707 then 708; 709 710: set_module_name ( addr -- ) 711 name_buffer .addr @ name_buffer .len @ 712 strdup 713 >r over module.name .addr ! 714 r> swap module.name .len ! 715; 716 717: yes_value? 718 value_buffer .addr @ value_buffer .len @ 719 2dup s' "YES"' compare >r 720 2dup s' "yes"' compare >r 721 2dup s" YES" compare >r 722 s" yes" compare r> r> r> and and and 0= 723; 724 725: find_module_option ( -- addr | 0 ) 726 module_options @ 727 begin 728 dup 729 while 730 dup module.name dup .addr @ swap .len @ 731 name_buffer .addr @ name_buffer .len @ 732 compare 0= if exit then 733 module.next @ 734 repeat 735; 736 737: new_module_option ( -- addr ) 738 sizeof module allocate if out_of_memory throw then 739 dup sizeof module erase 740 dup append_to_module_options_list 741 dup set_module_name 742; 743 744: get_module_option ( -- addr ) 745 find_module_option 746 ?dup 0= if new_module_option then 747; 748 749: set_module_flag 750 name_buffer .len @ load_module_suffix nip - name_buffer .len ! 751 yes_value? get_module_option module.flag ! 752; 753 754: set_module_args 755 name_buffer .len @ module_args_suffix nip - name_buffer .len ! 756 get_module_option module.args 757 dup .addr @ ?dup if free-memory then 758 value_buffer .addr @ value_buffer .len @ 759 over c@ [char] " = if 760 2 chars - swap char+ swap 761 then 762 strdup 763 >r over .addr ! 764 r> swap .len ! 765; 766 767: set_module_loadname 768 name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! 769 get_module_option module.loadname 770 dup .addr @ ?dup if free-memory then 771 value_buffer .addr @ value_buffer .len @ 772 over c@ [char] " = if 773 2 chars - swap char+ swap 774 then 775 strdup 776 >r over .addr ! 777 r> swap .len ! 778; 779 780: set_module_type 781 name_buffer .len @ module_type_suffix nip - name_buffer .len ! 782 get_module_option module.type 783 dup .addr @ ?dup if free-memory then 784 value_buffer .addr @ value_buffer .len @ 785 over c@ [char] " = if 786 2 chars - swap char+ swap 787 then 788 strdup 789 >r over .addr ! 790 r> swap .len ! 791; 792 793: set_module_beforeload 794 name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! 795 get_module_option module.beforeload 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_afterload 807 name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! 808 get_module_option module.afterload 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_loaderror 820 name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! 821 get_module_option module.loaderror 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_environment_variable 833 name_buffer .len @ 834 value_buffer .len @ + 835 5 chars + 836 allocate if out_of_memory throw then 837 dup 0 ( addr -- addr addr len ) 838 s" set " strcat 839 name_buffer .addr @ name_buffer .len @ strcat 840 s" =" strcat 841 value_buffer .addr @ value_buffer .len @ strcat 842 ['] evaluate catch if 843 2drop free drop 844 set_error throw 845 else 846 free-memory 847 then 848; 849 850: set_verbose 851 yes_value? to verbose? 852; 853 854: execute_command 855 value_buffer .addr @ value_buffer .len @ 856 over c@ [char] " = if 857 2 - swap char+ swap 858 then 859 ['] evaluate catch if exec_error throw then 860; 861 862: set_password 863 password .addr @ ?dup if free if free_error throw then then 864 value_buffer .addr @ c@ [char] " = if 865 value_buffer .addr @ char+ value_buffer .len @ 2 - strdup 866 value_buffer .addr @ free if free_error throw then 867 else 868 value_buffer .addr @ value_buffer .len @ 869 then 870 password .len ! password .addr ! 871 0 value_buffer .addr ! 872; 873 874: process_assignment 875 name_buffer .len @ 0= if exit then 876 loader_conf_files? if set_conf_files exit then 877 verbose_flag? if set_verbose exit then 878 execute? if execute_command exit then 879 password? if set_password exit then 880 module_load? if set_module_flag exit then 881 module_loadname? if set_module_loadname exit then 882 module_type? if set_module_type exit then 883 module_args? if set_module_args exit then 884 module_beforeload? if set_module_beforeload exit then 885 module_afterload? if set_module_afterload exit then 886 module_loaderror? if set_module_loaderror exit then 887 set_environment_variable 888; 889 890\ free_buffer ( -- ) 891\ 892\ Free some pointers if needed. The code then tests for errors 893\ in freeing, and throws an exception if needed. If a pointer is 894\ not allocated, it's value (0) is used as flag. 895 896: free_buffers 897 name_buffer .addr @ dup if free then 898 value_buffer .addr @ dup if free then 899 or if free_error throw then 900; 901 902: reset_assignment_buffers 903 0 name_buffer .addr ! 904 0 name_buffer .len ! 905 0 value_buffer .addr ! 906 0 value_buffer .len ! 907; 908 909\ Higher level file processing 910 911support-functions definitions 912 913: process_conf 914 begin 915 end_of_file? 0= 916 while 917 reset_assignment_buffers 918 read_line 919 get_assignment 920 ['] process_assignment catch 921 ['] free_buffers catch 922 swap throw throw 923 repeat 924; 925 926only forth also support-functions definitions 927 928: create_null_terminated_string { addr len -- addr' len } 929 len char+ allocate if out_of_memory throw then 930 >r 931 addr r@ len move 932 0 r@ len + c! 933 r> len 934; 935 936\ Interface to loading conf files 937 938: load_conf ( addr len -- ) 939 0 to end_of_file? 940 reset_line_reading 941 create_null_terminated_string 942 over >r 943 fopen fd ! 944 r> free-memory 945 fd @ -1 = if open_error throw then 946 ['] process_conf catch 947 fd @ fclose 948 throw 949; 950 951: print_line 952 line_buffer .addr @ line_buffer .len @ type cr 953; 954 955: print_syntax_error 956 line_buffer .addr @ line_buffer .len @ type cr 957 line_buffer .addr @ 958 begin 959 line_pointer over <> 960 while 961 bl emit 962 char+ 963 repeat 964 drop 965 ." ^" cr 966; 967 968\ Depuration support functions 969 970only forth definitions also support-functions 971 972: test-file 973 ['] load_conf catch dup . 974 syntax_error = if cr print_syntax_error then 975; 976 977: show-module-options 978 module_options @ 979 begin 980 ?dup 981 while 982 ." Name: " dup module.name dup .addr @ swap .len @ type cr 983 ." Path: " dup module.loadname dup .addr @ swap .len @ type cr 984 ." Type: " dup module.type dup .addr @ swap .len @ type cr 985 ." Flags: " dup module.args dup .addr @ swap .len @ type cr 986 ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr 987 ." After load: " dup module.afterload dup .addr @ swap .len @ type cr 988 ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr 989 ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr 990 module.next @ 991 repeat 992; 993 994only forth also support-functions definitions 995 996\ Variables used for processing multiple conf files 997 998string current_file_name 999variable current_conf_files 1000 1001\ Indicates if any conf file was succesfully read 1002 10030 value any_conf_read? 1004 1005\ loader_conf_files processing support functions 1006 1007: set_current_conf_files 1008 conf_files .addr @ current_conf_files ! 1009; 1010 1011: get_conf_files 1012 conf_files .addr @ conf_files .len @ strdup 1013; 1014 1015: recurse_on_conf_files? 1016 current_conf_files @ conf_files .addr @ <> 1017; 1018 1019: skip_leading_spaces { addr len pos -- addr len pos' } 1020 begin 1021 pos len = if addr len pos exit then 1022 addr pos + c@ bl = 1023 while 1024 pos char+ to pos 1025 repeat 1026 addr len pos 1027; 1028 1029: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 1030 pos len = if 1031 addr free abort" Fatal error freeing memory" 1032 0 exit 1033 then 1034 pos >r 1035 begin 1036 addr pos + c@ bl <> 1037 while 1038 pos char+ to pos 1039 pos len = if 1040 addr len pos addr r@ + pos r> - exit 1041 then 1042 repeat 1043 addr len pos addr r@ + pos r> - 1044; 1045 1046: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 1047 skip_leading_spaces 1048 get_file_name 1049; 1050 1051: set_current_file_name 1052 over current_file_name .addr ! 1053 dup current_file_name .len ! 1054; 1055 1056: print_current_file 1057 current_file_name .addr @ current_file_name .len @ type 1058; 1059 1060: process_conf_errors 1061 dup 0= if true to any_conf_read? drop exit then 1062 >r 2drop r> 1063 dup syntax_error = if 1064 ." Warning: syntax error on file " print_current_file cr 1065 print_syntax_error drop exit 1066 then 1067 dup set_error = if 1068 ." Warning: bad definition on file " print_current_file cr 1069 print_line drop exit 1070 then 1071 dup read_error = if 1072 ." Warning: error reading file " print_current_file cr drop exit 1073 then 1074 dup open_error = if 1075 verbose? if ." Warning: unable to open file " print_current_file cr then 1076 drop exit 1077 then 1078 dup free_error = abort" Fatal error freeing memory" 1079 dup out_of_memory = abort" Out of memory" 1080 throw \ Unknown error -- pass ahead 1081; 1082 1083\ Process loader_conf_files recursively 1084\ Interface to loader_conf_files processing 1085 1086: include_conf_files 1087 set_current_conf_files 1088 get_conf_files 0 1089 begin 1090 get_next_file ?dup 1091 while 1092 set_current_file_name 1093 ['] load_conf catch 1094 process_conf_errors 1095 recurse_on_conf_files? if recurse then 1096 repeat 1097; 1098 1099\ Module loading functions 1100 1101: load_module? 1102 module.flag @ 1103; 1104 1105: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N ) 1106 dup >r 1107 r@ module.args .addr @ r@ module.args .len @ 1108 r@ module.loadname .len @ if 1109 r@ module.loadname .addr @ r@ module.loadname .len @ 1110 else 1111 r@ module.name .addr @ r@ module.name .len @ 1112 then 1113 r@ module.type .len @ if 1114 r@ module.type .addr @ r@ module.type .len @ 1115 s" -t " 1116 4 ( -t type name flags ) 1117 else 1118 2 ( name flags ) 1119 then 1120 r> drop 1121; 1122 1123: before_load ( addr -- addr ) 1124 dup module.beforeload .len @ if 1125 dup module.beforeload .addr @ over module.beforeload .len @ 1126 ['] evaluate catch if before_load_error throw then 1127 then 1128; 1129 1130: after_load ( addr -- addr ) 1131 dup module.afterload .len @ if 1132 dup module.afterload .addr @ over module.afterload .len @ 1133 ['] evaluate catch if after_load_error throw then 1134 then 1135; 1136 1137: load_error ( addr -- addr ) 1138 dup module.loaderror .len @ if 1139 dup module.loaderror .addr @ over module.loaderror .len @ 1140 evaluate \ This we do not intercept so it can throw errors 1141 then 1142; 1143 1144: pre_load_message ( addr -- addr ) 1145 verbose? if 1146 dup module.name .addr @ over module.name .len @ type 1147 ." ..." 1148 then 1149; 1150 1151: load_error_message verbose? if ." failed!" cr then ; 1152 1153: load_succesful_message verbose? if ." ok" cr then ; 1154 1155: load_module 1156 load_parameters load 1157; 1158 1159: process_module ( addr -- addr ) 1160 pre_load_message 1161 before_load 1162 begin 1163 ['] load_module catch if 1164 dup module.loaderror .len @ if 1165 load_error \ Command should return a flag! 1166 else 1167 load_error_message true \ Do not retry 1168 then 1169 else 1170 after_load 1171 load_succesful_message true \ Succesful, do not retry 1172 then 1173 until 1174; 1175 1176: process_module_errors ( addr ior -- ) 1177 dup before_load_error = if 1178 drop 1179 ." Module " 1180 dup module.name .addr @ over module.name .len @ type 1181 dup module.loadname .len @ if 1182 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 1183 then 1184 cr 1185 ." Error executing " 1186 dup module.beforeload .addr @ over module.afterload .len @ type cr 1187 abort 1188 then 1189 1190 dup after_load_error = if 1191 drop 1192 ." Module " 1193 dup module.name .addr @ over module.name .len @ type 1194 dup module.loadname .len @ if 1195 ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )" 1196 then 1197 cr 1198 ." Error executing " 1199 dup module.afterload .addr @ over module.afterload .len @ type cr 1200 abort 1201 then 1202 1203 throw \ Don't know what it is all about -- pass ahead 1204; 1205 1206\ Module loading interface 1207 1208: load_modules ( -- ) ( throws: abort & user-defined ) 1209 module_options @ 1210 begin 1211 ?dup 1212 while 1213 dup load_module? if 1214 ['] process_module catch 1215 process_module_errors 1216 then 1217 module.next @ 1218 repeat 1219; 1220 1221\ Additional functions used in "start" 1222 1223: initialize ( addr len -- ) 1224 strdup conf_files .len ! conf_files .addr ! 1225; 1226 1227: load_kernel ( -- ) ( throws: abort ) 1228 s" load ${kernel} ${kernel_options}" ['] evaluate catch 1229 if s" echo Unable to load kernel: ${kernel_name}" evaluate abort then 1230; 1231 1232: read-password { size | buf len -- } 1233 size allocate if out_of_memory throw then 1234 to buf 1235 0 to len 1236 begin 1237 key 1238 dup backspace = if 1239 drop 1240 len if 1241 backspace emit bl emit backspace emit 1242 len 1 - to len 1243 else 1244 bell emit 1245 then 1246 else 1247 dup <cr> = if cr drop buf len exit then 1248 [char] * emit 1249 len size < if 1250 buf len chars + c! 1251 else 1252 drop 1253 then 1254 len 1+ to len 1255 then 1256 again 1257; 1258 1259\ Go back to straight forth vocabulary 1260 1261only forth also definitions 1262 1263