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