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