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