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