FreeBSD/Linux Kernel Cross Reference
sys/boot/forth/support.4th

   \ Copyright (c) 1999 Daniel C. Sobral <dcs@freebsd.org>
   \ All rights reserved.
   \ 
   \ Redistribution and use in source and binary forms, with or without
   \ modification, are permitted provided that the following conditions
   \ are met:
   \ 1. Redistributions of source code must retain the above copyright
   \    notice, this list of conditions and the following disclaimer.
   \ 2. Redistributions in binary form must reproduce the above copyright
  \    notice, this list of conditions and the following disclaimer in the
  \    documentation and/or other materials provided with the distribution.
  \
  \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
  \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  \ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
  \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  \ SUCH DAMAGE.
  \
  \ $FreeBSD: src/sys/boot/forth/support.4th,v 1.19 2009/01/05 20:09:54 luigi Exp $
  
  \ Loader.rc support functions:
  \
  \ initialize ( addr len -- )    as above, plus load_conf_files
  \ load_conf ( addr len -- )     load conf file given
  \ include_conf_files ( -- )     load all conf files in load_conf_files
  \ print_syntax_error ( -- )     print line and marker of where a syntax
  \                               error was detected
  \ print_line ( -- )             print last line processed
  \ load_kernel ( -- )            load kernel
  \ load_modules ( -- )           load modules flagged
  \
  \ Exported structures:
  \
  \ string                        counted string structure
  \       cell .addr                      string address
  \       cell .len                       string length
  \ module                        module loading information structure
  \       cell module.flag                should we load it?
  \       string module.name              module's name
  \       string module.loadname          name to be used in loading the module
  \       string module.type              module's type
  \       string module.args              flags to be passed during load
  \       string module.beforeload        command to be executed before load
  \       string module.afterload         command to be executed after load
  \       string module.loaderror         command to be executed if load fails
  \       cell module.next                list chain
  \
  \ Exported global variables;
  \
  \ string conf_files             configuration files to be loaded
  \ string password               password
  \ cell modules_options          pointer to first module information
  \ value verbose?                indicates if user wants a verbose loading
  \ value any_conf_read?          indicates if a conf file was succesfully read
  \
  \ Other exported words:
  \    note, strlen is internal
  \ strdup ( addr len -- addr' len)                       similar to strdup(3)
  \ strcat ( addr len addr' len' -- addr len+len' )       similar to strcat(3)
  \ s' ( | string' -- addr len | )                        similar to s"
  \ rudimentary structure support
  
  \ Exception values
  
  1 constant ESYNTAX
  2 constant ENOMEM
  3 constant EFREE
  4 constant ESETERROR    \ error setting environment variable
  5 constant EREAD        \ error reading
  6 constant EOPEN
  7 constant EEXEC        \ XXX never catched
  8 constant EBEFORELOAD
  9 constant EAFTERLOAD
  
  \ I/O constants
  
  0 constant SEEK_SET
  1 constant SEEK_CUR
  2 constant SEEK_END
  
  0 constant O_RDONLY
  1 constant O_WRONLY
  2 constant O_RDWR
  
  \ Crude structure support
  
  : structure:
    create here 0 , ['] drop , 0
    does> create here swap dup @ allot cell+ @ execute
  ;
  : member: create dup , over , + does> cell+ @ + ;
  : ;structure swap ! ;
  : constructor! >body cell+ ! ;
 : constructor: over :noname ;
 : ;constructor postpone ; swap cell+ ! ; immediate
 : sizeof ' >body @ state @ if postpone literal then ; immediate
 : offsetof ' >body cell+ @ state @ if postpone literal then ; immediate
 : ptr 1 cells member: ;
 : int 1 cells member: ;
 
 \ String structure
 
 structure: string
         ptr .addr
         int .len
         constructor:
           0 over .addr !
           0 swap .len !
         ;constructor
 ;structure
 
 
 \ Module options linked list
 
 structure: module
         int module.flag
         sizeof string member: module.name
         sizeof string member: module.loadname
         sizeof string member: module.type
         sizeof string member: module.args
         sizeof string member: module.beforeload
         sizeof string member: module.afterload
         sizeof string member: module.loaderror
         ptr module.next
 ;structure
 
 \ Internal loader structures (preloaded_file, kernel_module, file_metadata)
 \ must be in sync with the C struct in sys/boot/common/bootstrap.h
 structure: preloaded_file
         ptr pf.name
         ptr pf.type
         ptr pf.args
         ptr pf.metadata \ file_metadata
         int pf.loader
         int pf.addr
         int pf.size
         ptr pf.modules  \ kernel_module
         ptr pf.next     \ preloaded_file
 ;structure
 
 structure: kernel_module
         ptr km.name
         \ ptr km.args
         ptr km.fp       \ preloaded_file
         ptr km.next     \ kernel_module
 ;structure
 
 structure: file_metadata
         int             md.size
         2 member:       md.type \ this is not ANS Forth compatible (XXX)
         ptr             md.next \ file_metadata
         0 member:       md.data \ variable size
 ;structure
 
 \ end of structures
 
 \ Global variables
 
 string conf_files
 string nextboot_conf_file
 string password
 create module_options sizeof module.next allot 0 module_options !
 create last_module_option sizeof module.next allot 0 last_module_option !
 0 value verbose?
 0 value nextboot?
 
 \ Support string functions
 : strdup { addr len -- addr' len' }
   len allocate if ENOMEM throw then
   addr over len move len
 ;
 
 : strcat  { addr len addr' len' -- addr len+len' }
   addr' addr len + len' move
   addr len len' +
 ;
 
 : strchr { addr len c -- addr' len' }
   begin
     len
   while
     addr c@ c = if addr len exit then
     addr 1 + to addr
     len 1 - to len
   repeat
   0 0
 ;
 
 : s' \ same as s", allows " in the string
   [char] ' parse
   state @ if postpone sliteral then
 ; immediate
 
 : 2>r postpone >r postpone >r ; immediate
 : 2r> postpone r> postpone r> ; immediate
 : 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate
 
 : getenv?  getenv -1 = if false else drop true then ;
 
 \ Private definitions
 
 vocabulary support-functions
 only forth also support-functions definitions
 
 \ Some control characters constants
 
 7 constant bell
 8 constant backspace
 9 constant tab
 10 constant lf
 13 constant <cr>
 
 \ Read buffer size
 
 80 constant read_buffer_size
 
 \ Standard suffixes
 
 : load_module_suffix            s" _load" ;
 : module_loadname_suffix        s" _name" ;
 : module_type_suffix            s" _type" ;
 : module_args_suffix            s" _flags" ;
 : module_beforeload_suffix      s" _before" ;
 : module_afterload_suffix       s" _after" ;
 : module_loaderror_suffix       s" _error" ;
 
 \ Support operators
 
 : >= < 0= ;
 : <= > 0= ;
 
 \ Assorted support functions
 
 : free-memory free if EFREE throw then ;
 
 : strget { var -- addr len } var .addr @ var .len @ ;
 
 \ assign addr len to variable.
 : strset  { addr len var -- } addr var .addr !  len var .len !  ;
 
 \ free memory and reset fields
 : strfree { var -- } var .addr @ ?dup if free-memory 0 0 var strset then ;
 
 \ free old content, make a copy of the string and assign to variable
 : string= { addr len var -- } var strfree addr len strdup var strset ;
 
 : strtype ( str -- ) strget type ;
 
 \ assign a reference to what is on the stack
 : strref { addr len var -- addr len }
   addr var .addr ! len var .len ! addr len
 ;
 
 \ unquote a string
 : unquote ( addr len -- addr len )
   over c@ [char] " = if 2 chars - swap char+ swap then
 ;
 
 \ Assignment data temporary storage
 
 string name_buffer
 string value_buffer
 
 \ Line by line file reading functions
 \
 \ exported:
 \       line_buffer
 \       end_of_file?
 \       fd
 \       read_line
 \       reset_line_reading
 
 vocabulary line-reading
 also line-reading definitions also
 
 \ File data temporary storage
 
 string read_buffer
 0 value read_buffer_ptr
 
 \ File's line reading function
 
 support-functions definitions
 
 string line_buffer
 0 value end_of_file?
 variable fd
 
 line-reading definitions
 
 : skip_newlines
   begin
     read_buffer .len @ read_buffer_ptr >
   while
     read_buffer .addr @ read_buffer_ptr + c@ lf = if
       read_buffer_ptr char+ to read_buffer_ptr
     else
       exit
     then
   repeat
 ;
 
 : scan_buffer  ( -- addr len )
   read_buffer_ptr >r
   begin
     read_buffer .len @ r@ >
   while
     read_buffer .addr @ r@ + c@ lf = if
       read_buffer .addr @ read_buffer_ptr +  ( -- addr )
       r@ read_buffer_ptr -                   ( -- len )
       r> to read_buffer_ptr
       exit
     then
     r> char+ >r
   repeat
   read_buffer .addr @ read_buffer_ptr +  ( -- addr )
   r@ read_buffer_ptr -                   ( -- len )
   r> to read_buffer_ptr
 ;
 
 : line_buffer_resize  ( len -- len )
   >r
   line_buffer .len @ if
     line_buffer .addr @
     line_buffer .len @ r@ +
     resize if ENOMEM throw then
   else
     r@ allocate if ENOMEM throw then
   then
   line_buffer .addr !
   r>
 ;
     
 : append_to_line_buffer  ( addr len -- )
   line_buffer strget
   2swap strcat
   line_buffer .len !
   drop
 ;
 
 : read_from_buffer
   scan_buffer            ( -- addr len )
   line_buffer_resize     ( len -- len )
   append_to_line_buffer  ( addr len -- )
 ;
 
 : refill_required?
   read_buffer .len @ read_buffer_ptr =
   end_of_file? 0= and
 ;
 
 : refill_buffer
   0 to read_buffer_ptr
   read_buffer .addr @ 0= if
     read_buffer_size allocate if ENOMEM throw then
     read_buffer .addr !
   then
   fd @ read_buffer .addr @ read_buffer_size fread
   dup -1 = if EREAD throw then
   dup 0= if true to end_of_file? then
   read_buffer .len !
 ;
 
 support-functions definitions
 
 : reset_line_reading
   0 to read_buffer_ptr
 ;
 
 : read_line
   line_buffer strfree
   skip_newlines
   begin
     read_from_buffer
     refill_required?
   while
     refill_buffer
   repeat
 ;
 
 only forth also support-functions definitions
 
 \ Conf file line parser:
 \ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
 \            <spaces>[<comment>]
 \ <name> ::= <letter>{<letter>|<digit>|'_'}
 \ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name>
 \ <character_set> ::= ASCII 32 to 126, except '\' and '"'
 \ <comment> ::= '#'{<anything>}
 \
 \ exported:
 \       line_pointer
 \       process_conf
 
 0 value line_pointer
 
 vocabulary file-processing
 also file-processing definitions
 
 \ parser functions
 \
 \ exported:
 \       get_assignment
 
 vocabulary parser
 also parser definitions also
 
 0 value parsing_function
 0 value end_of_line
 
 : end_of_line?  line_pointer end_of_line = ;
 
 \ classifiers for various character classes in the input line
 
 : letter?
   line_pointer c@ >r
   r@ [char] A >=
   r@ [char] Z <= and
   r@ [char] a >=
   r> [char] z <= and
   or
 ;
 
 : digit?
   line_pointer c@ >r
   r@ [char] - =
   r@ [char] 0 >=
   r> [char] 9 <= and
   or
 ;
 
 : quote?  line_pointer c@ [char] " = ;
 
 : assignment_sign?  line_pointer c@ [char] = = ;
 
 : comment?  line_pointer c@ [char] # = ;
 
 : space?  line_pointer c@ bl = line_pointer c@ tab = or ;
 
 : backslash?  line_pointer c@ [char] \ = ;
 
 : underscore?  line_pointer c@ [char] _ = ;
 
 : dot?  line_pointer c@ [char] . = ;
 
 \ manipulation of input line
 : skip_character line_pointer char+ to line_pointer ;
 
 : skip_to_end_of_line end_of_line to line_pointer ;
 
 : eat_space
   begin
     end_of_line? if 0 else space? then
   while
     skip_character
   repeat
 ;
 
 : parse_name  ( -- addr len )
   line_pointer
   begin
     end_of_line? if 0 else letter? digit? underscore? dot? or or or then
   while
     skip_character
   repeat
   line_pointer over -
   strdup
 ;
 
 : remove_backslashes  { addr len | addr' len' -- addr' len' }
   len allocate if ENOMEM throw then
   to addr'
   addr >r
   begin
     addr c@ [char] \ <> if
       addr c@ addr' len' + c!
       len' char+ to len'
     then
     addr char+ to addr
     r@ len + addr =
   until
   r> drop
   addr' len'
 ;
 
 : parse_quote  ( -- addr len )
   line_pointer
   skip_character
   end_of_line? if ESYNTAX throw then
   begin
     quote? 0=
   while
     backslash? if
       skip_character
       end_of_line? if ESYNTAX throw then
     then
     skip_character
     end_of_line? if ESYNTAX throw then 
   repeat
   skip_character
   line_pointer over -
   remove_backslashes
 ;
 
 : read_name
   parse_name            ( -- addr len )
   name_buffer strset
 ;
 
 : read_value
   quote? if
     parse_quote         ( -- addr len )
   else
     parse_name          ( -- addr len )
   then
   value_buffer strset
 ;
 
 : comment
   skip_to_end_of_line
 ;
 
 : white_space_4
   eat_space
   comment? if ['] comment to parsing_function exit then
   end_of_line? 0= if ESYNTAX throw then
 ;
 
 : variable_value
   read_value
   ['] white_space_4 to parsing_function
 ;
 
 : white_space_3
   eat_space
   letter? digit? quote? or or if
     ['] variable_value to parsing_function exit
   then
   ESYNTAX throw
 ;
 
 : assignment_sign
   skip_character
   ['] white_space_3 to parsing_function
 ;
 
 : white_space_2
   eat_space
   assignment_sign? if ['] assignment_sign to parsing_function exit then
   ESYNTAX throw
 ;
 
 : variable_name
   read_name
   ['] white_space_2 to parsing_function
 ;
 
 : white_space_1
   eat_space
   letter?  if ['] variable_name to parsing_function exit then
   comment? if ['] comment to parsing_function exit then
   end_of_line? 0= if ESYNTAX throw then
 ;
 
 file-processing definitions
 
 : get_assignment
   line_buffer strget + to end_of_line
   line_buffer .addr @ to line_pointer
   ['] white_space_1 to parsing_function
   begin
     end_of_line? 0=
   while
     parsing_function execute
   repeat
   parsing_function ['] comment =
   parsing_function ['] white_space_1 =
   parsing_function ['] white_space_4 =
   or or 0= if ESYNTAX throw then
 ;
 
 only forth also support-functions also file-processing definitions also
 
 \ Process line
 
 : assignment_type?  ( addr len -- flag )
   name_buffer strget
   compare 0=
 ;
 
 : suffix_type?  ( addr len -- flag )
   name_buffer .len @ over <= if 2drop false exit then
   name_buffer .len @ over - name_buffer .addr @ +
   over compare 0=
 ;
 
 : loader_conf_files?  s" loader_conf_files" assignment_type?  ;
 
 : nextboot_flag?  s" nextboot_enable" assignment_type?  ;
 
 : nextboot_conf? s" nextboot_conf" assignment_type?  ;
 
 : verbose_flag? s" verbose_loading" assignment_type?  ;
 
 : execute? s" exec" assignment_type?  ;
 
 : password? s" password" assignment_type?  ;
 
 : module_load? load_module_suffix suffix_type? ;
 
 : module_loadname?  module_loadname_suffix suffix_type?  ;
 
 : module_type?  module_type_suffix suffix_type?  ;
 
 : module_args?  module_args_suffix suffix_type?  ;
 
 : module_beforeload?  module_beforeload_suffix suffix_type?  ;
 
 : module_afterload?  module_afterload_suffix suffix_type?  ;
 
 : module_loaderror?  module_loaderror_suffix suffix_type?  ;
 
 \ build a 'set' statement and execute it
 : set_environment_variable
   name_buffer .len @ value_buffer .len @ + 5 chars + \ size of result string
   allocate if ENOMEM throw then
   dup 0  \ start with an empty string and append the pieces
   s" set " strcat
   name_buffer strget strcat
   s" =" strcat
   value_buffer strget strcat
   ['] evaluate catch if
     2drop free drop
     ESETERROR throw
   else
     free-memory
   then
 ;
 
 : set_conf_files
   set_environment_variable
   s" loader_conf_files" getenv conf_files string=
 ;
 
 : set_nextboot_conf \ XXX maybe do as set_conf_files ?
   value_buffer strget unquote nextboot_conf_file string=
 ;
 
 : append_to_module_options_list  ( addr -- )
   module_options @ 0= if
     dup module_options !
     last_module_option !
   else
     dup last_module_option @ module.next !
     last_module_option !
   then
 ;
 
 : set_module_name  { addr -- }  \ check leaks
   name_buffer strget addr module.name string=
 ;
 
 : yes_value?
   value_buffer strget   \ XXX could use unquote
   2dup s' "YES"' compare >r
   2dup s' "yes"' compare >r
   2dup s" YES" compare >r
   s" yes" compare r> r> r> and and and 0=
 ;
 
 : find_module_option  ( -- addr | 0 ) \ return ptr to entry matching name_buffer
   module_options @
   begin
     dup
   while
     dup module.name strget
     name_buffer strget
     compare 0= if exit then
     module.next @
   repeat
 ;
 
 : new_module_option  ( -- addr )
   sizeof module allocate if ENOMEM throw then
   dup sizeof module erase
   dup append_to_module_options_list
   dup set_module_name
 ;
 
 : get_module_option  ( -- addr )
   find_module_option
   ?dup 0= if new_module_option then
 ;
 
 : set_module_flag
   name_buffer .len @ load_module_suffix nip - name_buffer .len !
   yes_value? get_module_option module.flag !
 ;
 
 : set_module_args
   name_buffer .len @ module_args_suffix nip - name_buffer .len !
   value_buffer strget unquote
   get_module_option module.args string=
 ;
 
 : set_module_loadname
   name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
   value_buffer strget unquote
   get_module_option module.loadname string=
 ;
 
 : set_module_type
   name_buffer .len @ module_type_suffix nip - name_buffer .len !
   value_buffer strget unquote
   get_module_option module.type string=
 ;
 
 : set_module_beforeload
   name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
   value_buffer strget unquote
   get_module_option module.beforeload string=
 ;
 
 : set_module_afterload
   name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
   value_buffer strget unquote
   get_module_option module.afterload string=
 ;
 
 : set_module_loaderror
   name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
   value_buffer strget unquote
   get_module_option module.loaderror string=
 ;
 
 : set_nextboot_flag
   yes_value? to nextboot?
 ;
 
 : set_verbose
   yes_value? to verbose?
 ;
 
 : execute_command
   value_buffer strget unquote
   ['] evaluate catch if EEXEC throw then
 ;
 
 : set_password
   value_buffer strget unquote password string=
 ;
 
 : process_assignment
   name_buffer .len @ 0= if exit then
   loader_conf_files?    if set_conf_files exit then
   nextboot_flag?        if set_nextboot_flag exit then
   nextboot_conf?        if set_nextboot_conf exit then
   verbose_flag?         if set_verbose exit then
   execute?              if execute_command exit then
   password?             if set_password exit then
   module_load?          if set_module_flag exit then
   module_loadname?      if set_module_loadname exit then
   module_type?          if set_module_type exit then
   module_args?          if set_module_args exit then
   module_beforeload?    if set_module_beforeload exit then
   module_afterload?     if set_module_afterload exit then
   module_loaderror?     if set_module_loaderror exit then
   set_environment_variable
 ;
 
 \ free_buffer  ( -- )
 \
 \ Free some pointers if needed. The code then tests for errors
 \ in freeing, and throws an exception if needed. If a pointer is
 \ not allocated, it's value (0) is used as flag.
 
 : free_buffers
   name_buffer strfree
   value_buffer strfree
 ;
 
 \ Higher level file processing
 
 support-functions definitions
 
 : process_conf
   begin
     end_of_file? 0=
   while
     free_buffers
     read_line
     get_assignment
     ['] process_assignment catch
     ['] free_buffers catch
     swap throw throw
   repeat
 ;
 
 : peek_file
   0 to end_of_file?
   reset_line_reading
   O_RDONLY fopen fd !
   fd @ -1 = if EOPEN throw then
   free_buffers
   read_line
   get_assignment
   ['] process_assignment catch
   ['] free_buffers catch
   fd @ fclose
 ;
   
 only forth also support-functions definitions
 
 \ Interface to loading conf files
 
 : load_conf  ( addr len -- )
   ." ----- Trying conf " 2dup type cr
   0 to end_of_file?
   reset_line_reading
   O_RDONLY fopen fd !
   fd @ -1 = if EOPEN throw then
   ['] process_conf catch
   fd @ fclose
   throw
 ;
 
 : print_line line_buffer strtype cr ;
 
 : print_syntax_error
   line_buffer strtype cr
   line_buffer .addr @
   begin
     line_pointer over <>
   while
     bl emit char+
   repeat
   drop
   ." ^" cr
 ;
 
 
 \ Debugging support functions
 
 only forth definitions also support-functions
 
 : test-file 
   ['] load_conf catch dup .
   ESYNTAX = if cr print_syntax_error then
 ;
 
 \ find a module name, leave addr on the stack (0 if not found)
 : find-module ( <module> -- ptr | 0 )
   bl parse ( addr len )
   module_options @ >r ( store current pointer )
   begin
     r@
   while
     2dup ( addr len addr len )
     r@ module.name strget
     compare 0= if drop drop r> exit then ( found it )
     r> module.next @ >r
   repeat
   type ."  was not found" cr r>
 ;
 
 : show-nonempty ( addr len mod -- )
   strget dup verbose? or if
     2swap type type cr
   else
     drop drop drop drop
   then ;
 
 : show-one-module { addr -- addr }
   ." Name:        " addr module.name strtype cr
   s" Path:        " addr module.loadname show-nonempty
   s" Type:        " addr module.type show-nonempty
   s" Flags:       " addr module.args show-nonempty
   s" Before load: " addr module.beforeload show-nonempty
   s" After load:  " addr module.afterload show-nonempty
   s" Error:       " addr module.loaderror show-nonempty
   ." Status:      " addr module.flag @ if ." Load" else ." Don't load" then cr
   cr
   addr
 ;
 
 : show-module-options
   module_options @
   begin
     ?dup
   while
     show-one-module
     module.next @
   repeat
 ;
 
 only forth also support-functions definitions
 
 \ Variables used for processing multiple conf files
 
 string current_file_name_ref    \ used to print the file name
 
 \ Indicates if any conf file was succesfully read
 
 0 value any_conf_read?
 
 \ loader_conf_files processing support functions
 
 : get_conf_files ( -- addr len )  \ put addr/len on stack, reset var
   ." -- starting on <" conf_files strtype ." >" cr
   conf_files strget 0 0 conf_files strset
 ;
 
 : skip_leading_spaces  { addr len pos -- addr len pos' }
   begin
     pos len = if 0 else addr pos + c@ bl = then
   while
     pos char+ to pos
   repeat
   addr len pos
 ;
 
 \ return the file name at pos, or free the string if nothing left
 : get_file_name  { addr len pos -- addr len pos' addr' len' || 0 }
   pos len = if 
     addr free abort" Fatal error freeing memory"
     0 exit
   then
   pos >r
   begin
     \ stay in the loop until have chars and they are not blank
     pos len = if 0 else addr pos + c@ bl <> then
   while
     pos char+ to pos
   repeat
   addr len pos addr r@ + pos r> -
   2dup
   ." get_file_name has " type cr
 ;
 
 : get_next_file  ( addr len ptr -- addr len ptr' addr' len' | 0 )
   skip_leading_spaces
   get_file_name
 ;
 
 : print_current_file
   current_file_name_ref strtype
 ;
 
 : process_conf_errors
   dup 0= if true to any_conf_read? drop exit then
   >r 2drop r>
   dup ESYNTAX = if
     ." Warning: syntax error on file " print_current_file cr
     print_syntax_error drop exit
   then
   dup ESETERROR = if
     ." Warning: bad definition on file " print_current_file cr
     print_line drop exit
   then
   dup EREAD = if
     ." Warning: error reading file " print_current_file cr drop exit
   then
   dup EOPEN = if
     verbose? if ." Warning: unable to open file " print_current_file cr then
     drop exit
   then
   dup EFREE = abort" Fatal error freeing memory"
   dup ENOMEM = abort" Out of memory"
   throw  \ Unknown error -- pass ahead
 ;
 
 \ Process loader_conf_files recursively
 \ Interface to loader_conf_files processing
 
 : include_conf_files
   get_conf_files 0      ( addr len offset )
   begin
     get_next_file ?dup ( addr len 1 | 0 )
   while
     current_file_name_ref strref
     ['] load_conf catch
     process_conf_errors
     conf_files .addr @ if recurse then
   repeat
 ;
 
 : get_nextboot_conf_file ( -- addr len )
   nextboot_conf_file strget strdup      \ XXX is the strdup a leak ?
 ;
 
 : rewrite_nextboot_file ( -- )
   get_nextboot_conf_file
   O_WRONLY fopen fd !
   fd @ -1 = if EOPEN throw then
   fd @ s' nextboot_enable="NO" ' fwrite
   fd @ fclose
 ;
 
 : include_nextboot_file
   get_nextboot_conf_file
   ['] peek_file catch
   nextboot? if
     get_nextboot_conf_file
     ['] load_conf catch
     process_conf_errors
     ['] rewrite_nextboot_file catch
   then
 ;
 
 \ Module loading functions
 
 : load_parameters  { addr -- addr addrN lenN ... addr1 len1 N }
   addr
   addr module.args strget
   addr module.loadname .len @ if
     addr module.loadname strget
   else
     addr module.name strget
   then
   addr module.type .len @ if
     addr module.type strget
     s" -t "
     4 ( -t type name flags )
   else
     2 ( name flags )
   then
 ;
 
 : before_load  ( addr -- addr )
   dup module.beforeload .len @ if
     dup module.beforeload strget
     ['] evaluate catch if EBEFORELOAD throw then
   then
 ;
 
 : after_load  ( addr -- addr )
   dup module.afterload .len @ if
     dup module.afterload strget
     ['] evaluate catch if EAFTERLOAD throw then
   then
 ;
 
 : load_error  ( addr -- addr )
   dup module.loaderror .len @ if
     dup module.loaderror strget
     evaluate  \ This we do not intercept so it can throw errors
   then
 ;
 
 : pre_load_message  ( addr -- addr )
   verbose? if
     dup module.name strtype
     ." ..."
   then
 ;
 
 : load_error_message verbose? if ." failed!" cr then ;
 
 : load_succesful_message verbose? if ." ok" cr then ;
 
 : load_module
   load_parameters load
 ;
 
 : process_module  ( addr -- addr )
   pre_load_message
   before_load
   begin
     ['] load_module catch if
       dup module.loaderror .len @ if
         load_error                      \ Command should return a flag!
       else 
         load_error_message true         \ Do not retry
       then
     else
       after_load
       load_succesful_message true       \ Succesful, do not retry
     then
   until
 ;
 
 : process_module_errors  ( addr ior -- )
   dup EBEFORELOAD = if
     drop
     ." Module "
     dup module.name strtype
     dup module.loadname .len @ if
       ." (" dup module.loadname strtype ." )"
     then
     cr
     ." Error executing "
     dup module.beforeload strtype cr    \ XXX there was a typo here
     abort
   then
 
   dup EAFTERLOAD = if
     drop
     ." Module "
     dup module.name .addr @ over module.name .len @ type
     dup module.loadname .len @ if
       ." (" dup module.loadname strtype ." )"
     then
     cr
     ." Error executing "
     dup module.afterload strtype cr
     abort
   then
 
   throw  \ Don't know what it is all about -- pass ahead
 ;
 
 \ Module loading interface
 
 \ scan the list of modules, load enabled ones.
 : load_modules  ( -- ) ( throws: abort & user-defined )
   module_options @      ( list_head )
   begin
     ?dup
   while
     dup module.flag @ if
       ['] process_module catch
       process_module_errors
     then
     module.next @
   repeat
 ;
 
 \ h00h00 magic used to try loading either a kernel with a given name,
 \ or a kernel with the default name in a directory of a given name
 \ (the pain!)
 
 : bootpath s" /boot/" ;
 : modulepath s" module_path" ;
 
 \ Functions used to save and restore module_path's value.
 : saveenv ( addr len | -1 -- addr' len | 0 -1 )
   dup -1 = if 0 swap exit then
   strdup
 ;
 : freeenv ( addr len | 0 -1 )
   -1 = if drop else free abort" Freeing error" then
 ;
 : restoreenv  ( addr len | 0 -1 -- )
   dup -1 = if ( it wasn't set )
     2drop
     modulepath unsetenv
   else
     over >r
     modulepath setenv
     r> free abort" Freeing error"
   then
 ;
 
 : clip_args   \ Drop second string if only one argument is passed
   1 = if
     2swap 2drop
     1
   else
     2
   then
 ;
 
 also builtins
 
 \ Parse filename from a semicolon-separated list
 
 \ replacement, not working yet
 : newparse-; { addr len | a1 -- a' len-x addr x }
   addr len [char] ; strchr dup if       ( a1 len1 )
     swap to a1  ( store address )
     1 - a1 @ 1 + swap ( remove match )
     addr a1 addr -
   else
     0 0 addr len
   then
 ;
 
 : parse-; ( addr len -- addr' len-x addr x )
   over 0 2swap                  ( addr 0 addr len )
   begin
     dup 0 <>                    ( addr 0 addr len )
   while
     over c@ [char] ; <>         ( addr 0 addr len flag )
   while
     1- swap 1+ swap
     2swap 1+ 2swap
   repeat then
   dup 0 <> if
     1- swap 1+ swap
   then
   2swap
 ;
 
 \ Try loading one of multiple kernels specified
 
 : try_multiple_kernels ( addr len addr' len' args -- flag )
   >r
   begin
     parse-; 2>r
     2over 2r>
     r@ clip_args
     s" DEBUG" getenv? if
       s" echo Module_path: ${module_path}" evaluate
       ." Kernel     : " >r 2dup type r> cr
       dup 2 = if ." Flags      : " >r 2over type r> cr then
     then
     1 load
   while
     dup 0=
   until
     1 >r \ Failure
   else
     0 >r \ Success
   then
   2drop 2drop
   r>
   r> drop
 ;
 
 \ Try to load a kernel; the kernel name is taken from one of
 \ the following lists, as ordered:
 \
 \   1. The "bootfile" environment variable
 \   2. The "kernel" environment variable
 \
 \ Flags are passed, if available. If not, dummy values must be given.
 \
 \ The kernel gets loaded from the current module_path.
 
 : load_a_kernel ( flags len 1 | x x 0 -- flag )
   local args
   2local flags
   0 0 2local kernel
   end-locals
 
   \ Check if a default kernel name exists at all, exits if not
   s" bootfile" getenv dup -1 <> if
     to kernel
     flags kernel args 1+ try_multiple_kernels
     dup 0= if exit then
   then
   drop
 
   s" kernel" getenv dup -1 <> if
     to kernel
   else
     drop
     1 exit \ Failure
   then
 
   \ Try all default kernel names
   flags kernel args 1+ try_multiple_kernels
 ;
 
 \ Try to load a kernel; the kernel name is taken from one of
 \ the following lists, as ordered:
 \
 \   1. The "bootfile" environment variable
 \   2. The "kernel" environment variable
 \
 \ Flags are passed, if provided.
 \
 \ The kernel will be loaded from a directory computed from the
 \ path given. Two directories will be tried in the following order:
 \
 \   1. /boot/path
 \   2. path
 \
 \ The module_path variable is overridden if load is succesful, by
 \ prepending the successful path.
 
 : load_from_directory ( path len 1 | flags len' path len 2 -- flag )
   local args
   2local path
   args 1 = if 0 0 then
   2local flags
   0 0 2local oldmodulepath \ like a string
   0 0 2local newmodulepath \ like a string
   end-locals
 
   \ Set the environment variable module_path, and try loading
   \ the kernel again.
   modulepath getenv saveenv to oldmodulepath
 
   \ Try prepending /boot/ first
   bootpath nip path nip +       \ total length
   oldmodulepath nip dup -1 = if
     drop
   else
     1+ +                        \ add oldpath -- XXX why the 1+ ?
   then
   allocate if ( out of memory ) 1 exit then \ XXX throw ?
 
   0
   bootpath strcat
   path strcat
   2dup to newmodulepath
   modulepath setenv
 
   \ Try all default kernel names
   flags args 1- load_a_kernel
   0= if ( success )
     oldmodulepath nip -1 <> if
       newmodulepath s" ;" strcat
       oldmodulepath strcat
       modulepath setenv
       newmodulepath drop free-memory
       oldmodulepath drop free-memory
     then
     0 exit
   then
 
   \ Well, try without the prepended /boot/
   path newmodulepath drop swap move
   newmodulepath drop path nip
   2dup to newmodulepath
   modulepath setenv
 
   \ Try all default kernel names
   flags args 1- load_a_kernel
   if ( failed once more )
     oldmodulepath restoreenv
     newmodulepath drop free-memory
     1
   else
     oldmodulepath nip -1 <> if
       newmodulepath s" ;" strcat
       oldmodulepath strcat
       modulepath setenv
       newmodulepath drop free-memory
       oldmodulepath drop free-memory
     then
     0
   then
 ;
 
 \ Try to load a kernel; the kernel name is taken from one of
 \ the following lists, as ordered:
 \
 \   1. The "bootfile" environment variable
 \   2. The "kernel" environment variable
 \   3. The "path" argument
 \
 \ Flags are passed, if provided.
 \
 \ The kernel will be loaded from a directory computed from the
 \ path given. Two directories will be tried in the following order:
 \
 \   1. /boot/path
 \   2. path
 \
 \ Unless "path" is meant to be kernel name itself. In that case, it
 \ will first be tried as a full path, and, next, search on the
 \ directories pointed by module_path.
 \
 \ The module_path variable is overridden if load is succesful, by
 \ prepending the successful path.
 
 : load_directory_or_file ( path len 1 | flags len' path len 2 -- flag )
   local args
   2local path
   args 1 = if 0 0 then
   2local flags
   end-locals
 
   \ First, assume path is an absolute path to a directory
   flags path args clip_args load_from_directory
   dup 0= if exit else drop then
 
   \ Next, assume path points to the kernel
   flags path args try_multiple_kernels
 ;
 
 : initialize  ( addr len -- )
   strdup conf_files strset
 ;
 
 : kernel_options ( -- addr len 1 | 0 )
   s" kernel_options" getenv
   dup -1 = if drop 0 else 1 then
 ;
 
 : standard_kernel_search  ( flags 1 | 0 -- flag )
   local args
   args 0= if 0 0 then
   2local flags
   s" kernel" getenv
   dup -1 = if 0 swap then
   2local path
   end-locals
 
   path nip -1 = if ( there isn't a "kernel" environment variable )
     flags args load_a_kernel
   else
     flags path args 1+ clip_args load_directory_or_file
   then
 ;
 
 : load_kernel  ( -- ) ( throws: abort )
   kernel_options standard_kernel_search
   abort" Unable to load a kernel!"
 ;
 
 : set_defaultoptions  ( -- )
   s" kernel_options" getenv dup -1 = if
     drop
   else
     s" temp_options" setenv
   then
 ;
 
 \ pick the i-th argument, i starts at 0
 : argv[]  ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
   2dup = if 0 0 exit then       \ out of range
   dup >r
   1+ 2*