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