sys/boot/forth/support.4th

   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: src/sys/boot/forth/support.4th,v 1.3.2.1 2000/07/07 00:15:53 obrien Exp $
  26 \ $DragonFly: src/sys/boot/forth/support.4th,v 1.2 2003/06/17 04:28:18 dillon Exp $
  27
  28 \ Loader.rc support functions:
  29 \
  30 \ initialize_support ( -- )     initialize global variables
  31 \ initialize ( addr len -- )    as above, plus load_conf_files
  32 \ load_conf ( addr len -- )     load conf file given
  33 \ include_conf_files ( -- )     load all conf files in load_conf_files
  34 \ print_syntax_error ( -- )     print line and marker of where a syntax
  35 \                               error was detected
  36 \ print_line ( -- )             print last line processed
  37 \ load_kernel ( -- )            load kernel
  38 \ load_modules ( -- )           load modules flagged
  39 \
  40 \ Exported structures:
  41 \
  42 \ string                        counted string structure
  43 \       cell .addr                      string address
  44 \       cell .len                       string length
  45 \ module                        module loading information structure
  46 \       cell module.flag                should we load it?
  47 \       string module.name              module's name
  48 \       string module.loadname          name to be used in loading the module
  49 \       string module.type              module's type
  50 \       string module.args              flags to be passed during load
  51 \       string module.beforeload        command to be executed before load
  52 \       string module.afterload         command to be executed after load
  53 \       string module.loaderror         command to be executed if load fails
  54 \       cell module.next                list chain
  55 \
  56 \ Exported global variables;
  57 \
  58 \ string conf_files             configuration files to be loaded
  59 \ string password               password
  60 \ cell modules_options          pointer to first module information
  61 \ value verbose?                indicates if user wants a verbose loading
  62 \ value any_conf_read?          indicates if a conf file was succesfully read
  63 \
  64 \ Other exported words:
  65 \
  66 \ strdup ( addr len -- addr' len)                       similar to strdup(3)
  67 \ strcat ( addr len addr' len' -- addr len+len' )       similar to strcat(3)
  68 \ strlen ( addr -- len )                                similar to strlen(3)
  69 \ s' ( | string' -- addr len | )                        similar to s"
  70 \ rudimentary structure support
  71
  72 \ Exception values
  73
  74 1 constant syntax_error
  75 2 constant out_of_memory
  76 3 constant free_error
  77 4 constant set_error
  78 5 constant read_error
  79 6 constant open_error
  80 7 constant exec_error
  81 8 constant before_load_error
  82 9 constant after_load_error
  83
  84 \ Crude structure support
  85
  86 : structure: create here 0 , 0 does> create @ allot ;
  87 : member: create dup , over , + does> cell+ @ + ;
  88 : ;structure swap ! ;
  89 : sizeof ' >body @ state @ if postpone literal then ; immediate
  90 : offsetof ' >body cell+ @ state @ if postpone literal then ; immediate
  91 : ptr 1 cells member: ;
  92 : int 1 cells member: ;
  93
  94 \ String structure
  95
  96 structure: string
  97         ptr .addr
  98         int .len
  99 ;structure
 100
 101 \ Module options linked list
 102
 103 structure: module
 104         int module.flag
 105         sizeof string member: module.name
 106         sizeof string member: module.loadname
 107         sizeof string member: module.type
 108         sizeof string member: module.args
 109         sizeof string member: module.beforeload
 110         sizeof string member: module.afterload
 111         sizeof string member: module.loaderror
 112         ptr module.next
 113 ;structure
 114
 115 \ Global variables
 116
 117 string conf_files
 118 string password
 119 create module_options sizeof module.next allot
 120 create last_module_option sizeof module.next allot
 121 0 value verbose?
 122
 123 \ Support string functions
 124
 125 : strdup  ( addr len -- addr' len )
 126   >r r@ allocate if out_of_memory throw then
 127   tuck r@ move
 128   r>
 129 ;
 130
 131 : strcat  { addr len addr' len' -- addr len+len' }
 132   addr' addr len + len' move
 133   addr len len' +
 134 ;
 135
 136 : strlen ( addr -- len )
 137   0 >r
 138   begin
 139     dup c@ while
 140     1+ r> 1+ >r repeat
 141   drop r>
 142 ;
 143
 144 : s'
 145   [char] ' parse
 146   state @ if
 147     postpone sliteral
 148   then
 149 ; immediate
 150
 151 : 2>r postpone >r postpone >r ; immediate
 152 : 2r> postpone r> postpone r> ; immediate
 153
 154 \ Private definitions
 155
 156 vocabulary support-functions
 157 only forth also support-functions definitions
 158
 159 \ Some control characters constants
 160
 161 7 constant bell
 162 8 constant backspace
 163 9 constant tab
 164 10 constant lf
 165 13 constant <cr>
 166
 167 \ Read buffer size
 168
 169 80 constant read_buffer_size
 170
 171 \ Standard suffixes
 172
 173 : load_module_suffix s" _load" ;
 174 : module_loadname_suffix s" _name" ;
 175 : module_type_suffix s" _type" ;
 176 : module_args_suffix s" _flags" ;
 177 : module_beforeload_suffix s" _before" ;
 178 : module_afterload_suffix s" _after" ;
 179 : module_loaderror_suffix s" _error" ;
 180
 181 \ Support operators
 182
 183 : >= < 0= ;
 184 : <= > 0= ;
 185
 186 \ Assorted support funcitons
 187
 188 : free-memory free if free_error throw then ;
 189
 190 \ Assignment data temporary storage
 191
 192 string name_buffer
 193 string value_buffer
 194
 195 \ File data temporary storage
 196
 197 string line_buffer
 198 string read_buffer
 199 0 value read_buffer_ptr
 200
 201 \ File's line reading function
 202
 203 0 value end_of_file?
 204 variable fd
 205
 206 : skip_newlines
 207   begin
 208     read_buffer .len @ read_buffer_ptr >
 209   while
 210     read_buffer .addr @ read_buffer_ptr + c@ lf = if
 211       read_buffer_ptr char+ to read_buffer_ptr
 212     else
 213       exit
 214     then
 215   repeat
 216 ;
 217
 218 : scan_buffer  ( -- addr len )
 219   read_buffer_ptr >r
 220   begin
 221     read_buffer .len @ r@ >
 222   while
 223     read_buffer .addr @ r@ + c@ lf = if
 224       read_buffer .addr @ read_buffer_ptr +  ( -- addr )
 225       r@ read_buffer_ptr -                   ( -- len )
 226       r> to read_buffer_ptr
 227       exit
 228     then
 229     r> char+ >r
 230   repeat
 231   read_buffer .addr @ read_buffer_ptr +  ( -- addr )
 232   r@ read_buffer_ptr -                   ( -- len )
 233   r> to read_buffer_ptr
 234 ;
 235
 236 : line_buffer_resize  ( len -- len )
 237   >r
 238   line_buffer .len @ if
 239     line_buffer .addr @
 240     line_buffer .len @ r@ +
 241     resize if out_of_memory throw then
 242   else
 243     r@ allocate if out_of_memory throw then
 244   then
 245   line_buffer .addr !
 246   r>
 247 ;
 248
 249 : append_to_line_buffer  ( addr len -- )
 250   line_buffer .addr @ line_buffer .len @
 251   2swap strcat
 252   line_buffer .len !
 253   drop
 254 ;
 255
 256 : read_from_buffer
 257   scan_buffer            ( -- addr len )
 258   line_buffer_resize     ( len -- len )
 259   append_to_line_buffer  ( addr len -- )
 260 ;
 261
 262 : refill_required?
 263   read_buffer .len @ read_buffer_ptr =
 264   end_of_file? 0= and
 265 ;
 266
 267 : refill_buffer
 268   0 to read_buffer_ptr
 269   read_buffer .addr @ 0= if
 270     read_buffer_size allocate if out_of_memory throw then
 271     read_buffer .addr !
 272   then
 273   fd @ read_buffer .addr @ read_buffer_size fread
 274   dup -1 = if read_error throw then
 275   dup 0= if true to end_of_file? then
 276   read_buffer .len !
 277 ;
 278
 279 : reset_line_buffer
 280   0 line_buffer .addr !
 281   0 line_buffer .len !
 282 ;
 283
 284 : read_line
 285   reset_line_buffer
 286   skip_newlines
 287   begin
 288     read_from_buffer
 289     refill_required?
 290   while
 291     refill_buffer
 292   repeat
 293 ;
 294
 295 \ Conf file line parser:
 296 \ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
 297 \            <spaces>[<comment>]
 298 \ <name> ::= <letter>{<letter>|<digit>|'_'}
 299 \ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name>
 300 \ <character_set> ::= ASCII 32 to 126, except '\' and '"'
 301 \ <comment> ::= '#'{<anything>}
 302
 303 0 value parsing_function
 304
 305 0 value end_of_line
 306 0 value line_pointer
 307
 308 : end_of_line?
 309   line_pointer end_of_line =
 310 ;
 311
 312 : letter?
 313   line_pointer c@ >r
 314   r@ [char] A >=
 315   r@ [char] Z <= and
 316   r@ [char] a >=
 317   r> [char] z <= and
 318   or
 319 ;
 320
 321 : digit?
 322   line_pointer c@ >r
 323   r@ [char] 0 >=
 324   r> [char] 9 <= and
 325 ;
 326
 327 : quote?
 328   line_pointer c@ [char] " =
 329 ;
 330
 331 : assignment_sign?
 332   line_pointer c@ [char] = =
 333 ;
 334
 335 : comment?
 336   line_pointer c@ [char] # =
 337 ;
 338
 339 : space?
 340   line_pointer c@ bl =
 341   line_pointer c@ tab = or
 342 ;
 343
 344 : backslash?
 345   line_pointer c@ [char] \ =
 346 ;
 347
 348 : underscore?
 349   line_pointer c@ [char] _ =
 350 ;
 351
 352 : dot?
 353   line_pointer c@ [char] . =
 354 ;
 355
 356 : skip_character
 357   line_pointer char+ to line_pointer
 358 ;
 359
 360 : skip_to_end_of_line
 361   end_of_line to line_pointer
 362 ;
 363
 364 : eat_space
 365   begin
 366     space?
 367   while
 368     skip_character
 369     end_of_line? if exit then
 370   repeat
 371 ;
 372
 373 : parse_name  ( -- addr len )
 374   line_pointer
 375   begin
 376     letter? digit? underscore? dot? or or or
 377   while
 378     skip_character
 379     end_of_line? if
 380       line_pointer over -
 381       strdup
 382       exit
 383     then
 384   repeat
 385   line_pointer over -
 386   strdup
 387 ;
 388
 389 : remove_backslashes  { addr len | addr' len' -- addr' len' }
 390   len allocate if out_of_memory throw then
 391   to addr'
 392   addr >r
 393   begin
 394     addr c@ [char] \ <> if
 395       addr c@ addr' len' + c!
 396       len' char+ to len'
 397     then
 398     addr char+ to addr
 399     r@ len + addr =
 400   until
 401   r> drop
 402   addr' len'
 403 ;
 404
 405 : parse_quote  ( -- addr len )
 406   line_pointer
 407   skip_character
 408   end_of_line? if syntax_error throw then
 409   begin
 410     quote? 0=
 411   while
 412     backslash? if
 413       skip_character
 414       end_of_line? if syntax_error throw then
 415     then
 416     skip_character
 417     end_of_line? if syntax_error throw then
 418   repeat
 419   skip_character
 420   line_pointer over -
 421   remove_backslashes
 422 ;
 423
 424 : read_name
 425   parse_name            ( -- addr len )
 426   name_buffer .len !
 427   name_buffer .addr !
 428 ;
 429
 430 : read_value
 431   quote? if
 432     parse_quote         ( -- addr len )
 433   else
 434     parse_name          ( -- addr len )
 435   then
 436   value_buffer .len !
 437   value_buffer .addr !
 438 ;
 439
 440 : comment
 441   skip_to_end_of_line
 442 ;
 443
 444 : white_space_4
 445   eat_space
 446   comment? if ['] comment to parsing_function exit then
 447   end_of_line? 0= if syntax_error throw then
 448 ;
 449
 450 : variable_value
 451   read_value
 452   ['] white_space_4 to parsing_function
 453 ;
 454
 455 : white_space_3
 456   eat_space
 457   letter? digit? quote? or or if
 458     ['] variable_value to parsing_function exit
 459   then
 460   syntax_error throw
 461 ;
 462
 463 : assignment_sign
 464   skip_character
 465   ['] white_space_3 to parsing_function
 466 ;
 467
 468 : white_space_2
 469   eat_space
 470   assignment_sign? if ['] assignment_sign to parsing_function exit then
 471   syntax_error throw
 472 ;
 473
 474 : variable_name
 475   read_name
 476   ['] white_space_2 to parsing_function
 477 ;
 478
 479 : white_space_1
 480   eat_space
 481   letter?  if ['] variable_name to parsing_function exit then
 482   comment? if ['] comment to parsing_function exit then
 483   end_of_line? 0= if syntax_error throw then
 484 ;
 485
 486 : get_assignment
 487   line_buffer .addr @ line_buffer .len @ + to end_of_line
 488   line_buffer .addr @ to line_pointer
 489   ['] white_space_1 to parsing_function
 490   begin
 491     end_of_line? 0=
 492   while
 493     parsing_function execute
 494   repeat
 495   parsing_function ['] comment =
 496   parsing_function ['] white_space_1 =
 497   parsing_function ['] white_space_4 =
 498   or or 0= if syntax_error throw then
 499 ;
 500
 501 \ Process line
 502
 503 : assignment_type?  ( addr len -- flag )
 504   name_buffer .addr @ name_buffer .len @
 505   compare 0=
 506 ;
 507
 508 : suffix_type?  ( addr len -- flag )
 509   name_buffer .len @ over <= if 2drop false exit then
 510   name_buffer .len @ over - name_buffer .addr @ +
 511   over compare 0=
 512 ;
 513
 514 : loader_conf_files?
 515   s" loader_conf_files" assignment_type?
 516 ;
 517
 518 : verbose_flag?
 519   s" verbose_loading" assignment_type?
 520 ;
 521
 522 : execute?
 523   s" exec" assignment_type?
 524 ;
 525
 526 : password?
 527   s" password" assignment_type?
 528 ;
 529
 530 : module_load?
 531   load_module_suffix suffix_type?
 532 ;
 533
 534 : module_loadname?
 535   module_loadname_suffix suffix_type?
 536 ;
 537
 538 : module_type?
 539   module_type_suffix suffix_type?
 540 ;
 541
 542 : module_args?
 543   module_args_suffix suffix_type?
 544 ;
 545
 546 : module_beforeload?
 547   module_beforeload_suffix suffix_type?
 548 ;
 549
 550 : module_afterload?
 551   module_afterload_suffix suffix_type?
 552 ;
 553
 554 : module_loaderror?
 555   module_loaderror_suffix suffix_type?
 556 ;
 557
 558 : set_conf_files
 559   conf_files .addr @ ?dup if
 560     free-memory
 561   then
 562   value_buffer .addr @ c@ [char] " = if
 563     value_buffer .addr @ char+ value_buffer .len @ 2 chars -
 564   else
 565     value_buffer .addr @ value_buffer .len @
 566   then
 567   strdup
 568   conf_files .len ! conf_files .addr !
 569 ;
 570
 571 : append_to_module_options_list  ( addr -- )
 572   module_options @ 0= if
 573     dup module_options !
 574     last_module_option !
 575   else
 576     dup last_module_option @ module.next !
 577     last_module_option !
 578   then
 579 ;
 580
 581 : set_module_name  ( addr -- )
 582   name_buffer .addr @ name_buffer .len @
 583   strdup
 584   >r over module.name .addr !
 585   r> swap module.name .len !
 586 ;
 587
 588 : yes_value?
 589   value_buffer .addr @ value_buffer .len @
 590   2dup s' "YES"' compare >r
 591   2dup s' "yes"' compare >r
 592   2dup s" YES" compare >r
 593   s" yes" compare r> r> r> and and and 0=
 594 ;
 595
 596 : find_module_option  ( -- addr | 0 )
 597   module_options @
 598   begin
 599     dup
 600   while
 601     dup module.name dup .addr @ swap .len @
 602     name_buffer .addr @ name_buffer .len @
 603     compare 0= if exit then
 604     module.next @
 605   repeat
 606 ;
 607
 608 : new_module_option  ( -- addr )
 609   sizeof module allocate if out_of_memory throw then
 610   dup sizeof module erase
 611   dup append_to_module_options_list
 612   dup set_module_name
 613 ;
 614
 615 : get_module_option  ( -- addr )
 616   find_module_option
 617   ?dup 0= if new_module_option then
 618 ;
 619
 620 : set_module_flag
 621   name_buffer .len @ load_module_suffix nip - name_buffer .len !
 622   yes_value? get_module_option module.flag !
 623 ;
 624
 625 : set_module_args
 626   name_buffer .len @ module_args_suffix nip - name_buffer .len !
 627   get_module_option module.args
 628   dup .addr @ ?dup if free-memory then
 629   value_buffer .addr @ value_buffer .len @
 630   over c@ [char] " = if
 631     2 chars - swap char+ swap
 632   then
 633   strdup
 634   >r over .addr !
 635   r> swap .len !
 636 ;
 637
 638 : set_module_loadname
 639   name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
 640   get_module_option module.loadname
 641   dup .addr @ ?dup if free-memory then
 642   value_buffer .addr @ value_buffer .len @
 643   over c@ [char] " = if
 644     2 chars - swap char+ swap
 645   then
 646   strdup
 647   >r over .addr !
 648   r> swap .len !
 649 ;
 650
 651 : set_module_type
 652   name_buffer .len @ module_type_suffix nip - name_buffer .len !
 653   get_module_option module.type
 654   dup .addr @ ?dup if free-memory then
 655   value_buffer .addr @ value_buffer .len @
 656   over c@ [char] " = if
 657     2 chars - swap char+ swap
 658   then
 659   strdup
 660   >r over .addr !
 661   r> swap .len !
 662 ;
 663
 664 : set_module_beforeload
 665   name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
 666   get_module_option module.beforeload
 667   dup .addr @ ?dup if free-memory then
 668   value_buffer .addr @ value_buffer .len @
 669   over c@ [char] " = if
 670     2 chars - swap char+ swap
 671   then
 672   strdup
 673   >r over .addr !
 674   r> swap .len !
 675 ;
 676
 677 : set_module_afterload
 678   name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
 679   get_module_option module.afterload
 680   dup .addr @ ?dup if free-memory then
 681   value_buffer .addr @ value_buffer .len @
 682   over c@ [char] " = if
 683     2 chars - swap char+ swap
 684   then
 685   strdup
 686   >r over .addr !
 687   r> swap .len !
 688 ;
 689
 690 : set_module_loaderror
 691   name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
 692   get_module_option module.loaderror
 693   dup .addr @ ?dup if free-memory then
 694   value_buffer .addr @ value_buffer .len @
 695   over c@ [char] " = if
 696     2 chars - swap char+ swap
 697   then
 698   strdup
 699   >r over .addr !
 700   r> swap .len !
 701 ;
 702
 703 : set_environment_variable
 704   name_buffer .len @
 705   value_buffer .len @ +
 706   5 chars +
 707   allocate if out_of_memory throw then
 708   dup 0  ( addr -- addr addr len )
 709   s" set " strcat
 710   name_buffer .addr @ name_buffer .len @ strcat
 711   s" =" strcat
 712   value_buffer .addr @ value_buffer .len @ strcat
 713   ['] evaluate catch if
 714     2drop free drop
 715     set_error throw
 716   else
 717     free-memory
 718   then
 719 ;
 720
 721 : set_verbose
 722   yes_value? to verbose?
 723 ;
 724
 725 : execute_command
 726   value_buffer .addr @ value_buffer .len @
 727   over c@ [char] " = if
 728     2 - swap char+ swap
 729   then
 730   ['] evaluate catch if exec_error throw then
 731 ;
 732
 733 : set_password
 734   password .addr @ ?dup if free if free_error throw then then
 735   value_buffer .addr @ c@ [char] " = if
 736     value_buffer .addr @ char+ value_buffer .len @ 2 - strdup
 737     value_buffer .addr @ free if free_error throw then
 738   else
 739     value_buffer .addr @ value_buffer .len @
 740   then
 741   password .len ! password .addr !
 742   0 value_buffer .addr !
 743 ;
 744
 745 : process_assignment
 746   name_buffer .len @ 0= if exit then
 747   loader_conf_files?    if set_conf_files exit then
 748   verbose_flag?         if set_verbose exit then
 749   execute?              if execute_command exit then
 750   password?             if set_password exit then
 751   module_load?          if set_module_flag exit then
 752   module_loadname?      if set_module_loadname exit then
 753   module_type?          if set_module_type exit then
 754   module_args?          if set_module_args exit then
 755   module_beforeload?    if set_module_beforeload exit then
 756   module_afterload?     if set_module_afterload exit then
 757   module_loaderror?     if set_module_loaderror exit then
 758   set_environment_variable
 759 ;
 760
 761 \ free_buffer  ( -- )
 762 \
 763 \ Free some pointers if needed. The code then tests for errors
 764 \ in freeing, and throws an exception if needed. If a pointer is
 765 \ not allocated, it's value (0) is used as flag.
 766
 767 : free_buffers
 768   line_buffer .addr @ dup if free then
 769   name_buffer .addr @ dup if free then
 770   value_buffer .addr @ dup if free then
 771   or or if free_error throw then
 772 ;
 773
 774 : reset_assignment_buffers
 775   0 name_buffer .addr !
 776   0 name_buffer .len !
 777   0 value_buffer .addr !
 778   0 value_buffer .len !
 779 ;
 780
 781 \ Higher level file processing
 782
 783 : process_conf
 784   begin
 785     end_of_file? 0=
 786   while
 787     reset_assignment_buffers
 788     read_line
 789     get_assignment
 790     ['] process_assignment catch
 791     ['] free_buffers catch
 792     swap throw throw
 793   repeat
 794 ;
 795
 796 : create_null_terminated_string  { addr len -- addr' len }
 797   len char+ allocate if out_of_memory throw then
 798   >r
 799   addr r@ len move
 800   0 r@ len + c!
 801   r> len
 802 ;
 803
 804 \ Interface to loading conf files
 805
 806 : load_conf  ( addr len -- )
 807   0 to end_of_file?
 808   0 to read_buffer_ptr
 809   create_null_terminated_string
 810   over >r
 811   fopen fd !
 812   r> free-memory
 813   fd @ -1 = if open_error throw then
 814   ['] process_conf catch
 815   fd @ fclose
 816   throw
 817 ;
 818
 819 : initialize_support
 820   0 read_buffer .addr !
 821   0 conf_files .addr !
 822   0 password .addr !
 823   0 module_options !
 824   0 last_module_option !
 825   0 to verbose?
 826 ;
 827
 828 : print_line
 829   line_buffer .addr @ line_buffer .len @ type cr
 830 ;
 831
 832 : print_syntax_error
 833   line_buffer .addr @ line_buffer .len @ type cr
 834   line_buffer .addr @
 835   begin
 836     line_pointer over <>
 837   while
 838     bl emit
 839     char+
 840   repeat
 841   drop
 842   ." ^" cr
 843 ;
 844
 845 \ Depuration support functions
 846
 847 only forth definitions also support-functions
 848
 849 : test-file
 850   ['] load_conf catch dup .
 851   syntax_error = if cr print_syntax_error then
 852 ;
 853
 854 : show-module-options
 855   module_options @
 856   begin
 857     ?dup
 858   while
 859     ." Name: " dup module.name dup .addr @ swap .len @ type cr
 860     ." Path: " dup module.loadname dup .addr @ swap .len @ type cr
 861     ." Type: " dup module.type dup .addr @ swap .len @ type cr
 862     ." Flags: " dup module.args dup .addr @ swap .len @ type cr
 863     ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr
 864     ." After load: " dup module.afterload dup .addr @ swap .len @ type cr
 865     ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr
 866     ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr
 867     module.next @
 868   repeat
 869 ;
 870
 871 only forth also support-functions definitions
 872
 873 \ Variables used for processing multiple conf files
 874
 875 string current_file_name
 876 variable current_conf_files
 877
 878 \ Indicates if any conf file was succesfully read
 879
 880 0 value any_conf_read?
 881
 882 \ loader_conf_files processing support functions
 883
 884 : set_current_conf_files
 885   conf_files .addr @ current_conf_files !
 886 ;
 887
 888 : get_conf_files
 889   conf_files .addr @ conf_files .len @ strdup
 890 ;
 891
 892 : recurse_on_conf_files?
 893   current_conf_files @ conf_files .addr @ <>
 894 ;
 895
 896 : skip_leading_spaces  { addr len pos -- addr len pos' }
 897   begin
 898     pos len = if addr len pos exit then
 899     addr pos + c@ bl =
 900   while
 901     pos char+ to pos
 902   repeat
 903   addr len pos
 904 ;
 905
 906 : get_file_name  { addr len pos -- addr len pos' addr' len' || 0 }
 907   pos len = if
 908     addr free abort" Fatal error freeing memory"
 909     0 exit
 910   then
 911   pos >r
 912   begin
 913     addr pos + c@ bl <>
 914   while
 915     pos char+ to pos
 916     pos len = if
 917       addr len pos addr r@ + pos r> - exit
 918     then
 919   repeat
 920   addr len pos addr r@ + pos r> -
 921 ;
 922
 923 : get_next_file  ( addr len ptr -- addr len ptr' addr' len' | 0 )
 924   skip_leading_spaces
 925   get_file_name
 926 ;
 927
 928 : set_current_file_name
 929   over current_file_name .addr !
 930   dup current_file_name .len !
 931 ;
 932
 933 : print_current_file
 934   current_file_name .addr @ current_file_name .len @ type
 935 ;
 936
 937 : process_conf_errors
 938   dup 0= if true to any_conf_read? drop exit then
 939   >r 2drop r>
 940   dup syntax_error = if
 941     ." Warning: syntax error on file " print_current_file cr
 942     print_syntax_error drop exit
 943   then
 944   dup set_error = if
 945     ." Warning: bad definition on file " print_current_file cr
 946     print_line drop exit
 947   then
 948   dup read_error = if
 949     ." Warning: error reading file " print_current_file cr drop exit
 950   then
 951   dup open_error = if
 952     verbose? if ." Warning: unable to open file " print_current_file cr then
 953     drop exit
 954   then
 955   dup free_error = abort" Fatal error freeing memory"
 956   dup out_of_memory = abort" Out of memory"
 957   throw  \ Unknown error -- pass ahead
 958 ;
 959
 960 \ Process loader_conf_files recursively
 961 \ Interface to loader_conf_files processing
 962
 963 : include_conf_files
 964   set_current_conf_files
 965   get_conf_files 0
 966   begin
 967     get_next_file ?dup
 968   while
 969     set_current_file_name
 970     ['] load_conf catch
 971     process_conf_errors
 972     recurse_on_conf_files? if recurse then
 973   repeat
 974 ;
 975
 976 \ Module loading functions
 977
 978 : load_module?
 979   module.flag @
 980 ;
 981
 982 : load_parameters  ( addr -- addr addrN lenN ... addr1 len1 N )
 983   dup >r
 984   r@ module.args .addr @ r@ module.args .len @
 985   r@ module.loadname .len @ if
 986     r@ module.loadname .addr @ r@ module.loadname .len @
 987   else
 988     r@ module.name .addr @ r@ module.name .len @
 989   then
 990   r@ module.type .len @ if
 991     r@ module.type .addr @ r@ module.type .len @
 992     s" -t "
 993     4 ( -t type name flags )
 994   else
 995     2 ( name flags )
 996   then
 997   r> drop
 998 ;
 999
1000 : before_load  ( addr -- addr )
1001   dup module.beforeload .len @ if
1002     dup module.beforeload .addr @ over module.beforeload .len @
1003     ['] evaluate catch if before_load_error throw then
1004   then
1005 ;
1006
1007 : after_load  ( addr -- addr )
1008   dup module.afterload .len @ if
1009     dup module.afterload .addr @ over module.afterload .len @
1010     ['] evaluate catch if after_load_error throw then
1011   then
1012 ;
1013
1014 : load_error  ( addr -- addr )
1015   dup module.loaderror .len @ if
1016     dup module.loaderror .addr @ over module.loaderror .len @
1017     evaluate  \ This we do not intercept so it can throw errors
1018   then
1019 ;
1020
1021 : pre_load_message  ( addr -- addr )
1022   verbose? if
1023     dup module.name .addr @ over module.name .len @ type
1024     ." ..."
1025   then
1026 ;
1027
1028 : load_error_message verbose? if ." failed!" cr then ;
1029
1030 : load_succesful_message verbose? if ." ok" cr then ;
1031
1032 : load_module
1033   load_parameters load
1034 ;
1035
1036 : process_module  ( addr -- addr )
1037   pre_load_message
1038   before_load
1039   begin
1040     ['] load_module catch if
1041       dup module.loaderror .len @ if
1042         load_error                      \ Command should return a flag!
1043       else
1044         load_error_message true         \ Do not retry
1045       then
1046     else
1047       after_load
1048       load_succesful_message true       \ Succesful, do not retry
1049     then
1050   until
1051 ;
1052
1053 : process_module_errors  ( addr ior -- )
1054   dup before_load_error = if
1055     drop
1056     ." Module "
1057     dup module.name .addr @ over module.name .len @ type
1058     dup module.loadname .len @ if
1059       ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1060     then
1061     cr
1062     ." Error executing "
1063     dup module.beforeload .addr @ over module.afterload .len @ type cr
1064     abort
1065   then
1066
1067   dup after_load_error = if
1068     drop
1069     ." Module "
1070     dup module.name .addr @ over module.name .len @ type
1071     dup module.loadname .len @ if
1072       ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1073     then
1074     cr
1075     ." Error executing "
1076     dup module.afterload .addr @ over module.afterload .len @ type cr
1077     abort
1078   then
1079
1080   throw  \ Don't know what it is all about -- pass ahead
1081 ;
1082
1083 \ Module loading interface
1084
1085 : load_modules  ( -- ) ( throws: abort & user-defined )
1086   module_options @
1087   begin
1088     ?dup
1089   while
1090     dup load_module? if
1091       ['] process_module catch
1092       process_module_errors
1093     then
1094     module.next @
1095   repeat
1096 ;
1097
1098 \ Additional functions used in "start"
1099
1100 : initialize  ( addr len -- )
1101   initialize_support
1102   strdup conf_files .len ! conf_files .addr !
1103 ;
1104
1105 : load_kernel  ( -- ) ( throws: abort )
1106   s" load ${kernel} ${kernel_options}" ['] evaluate catch
1107   if s" echo Unable to load kernel: ${kernel_name}" evaluate abort then
1108 ;
1109
1110 : read-password { size | buf len -- }
1111   size allocate if out_of_memory throw then
1112   to buf
1113   0 to len
1114   begin
1115     key
1116     dup backspace = if
1117       drop
1118       len if
1119         backspace emit bl emit backspace emit
1120         len 1 - to len
1121       else
1122         bell emit
1123       then
1124     else
1125       dup <cr> = if cr drop buf len exit then
1126       [char] * emit
1127       len size < if
1128         buf len chars + c!
1129       else
1130         drop
1131       then
1132       len 1+ to len
1133     then
1134   again
1135 ;
1136
1137 \ Go back to straight forth vocabulary
1138
1139 only forth also definitions
1140