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