mirror of
https://github.com/opnsense/src.git
synced 2026-03-09 09:41:05 -04:00
5e5391084a
loader_conf_files="foo bar baz"
should cause loading the files listed, and then resume with the
remaining config files (from previous values of the variable).
Unfortunately, sometimes the line was ignored -- actually even
modifying the line in /boot/default/loader.conf sometimes doesn't work.
ANALYSIS: After much investigation, turned out to be a bug in the logic.
The existing code detected a new assignment by looking at the address
of the the variable containing the string. This only worked by pure
chance, i.e. if the new string is longer than the previous value
then the memory allocator may return a different address
to store the string hence triggering the detection.
SOLUTION: This commit contains a minimal change to fix the problem,
without altering too much the existing structure of the code.
However, as a step towards improving the quality and reliability of
this code, I have introduced a handful of one-line functions
(strget, strset, strfree, string= ) that could be used in dozens
of places in the existing code.
HOWEVER:
There is a much bigger problem here. Even though I am no Forth
expert (as most fellow src committers) I can tell that much of the
forth code (in support.4th at least) is in severe need of a
review/refactoring:
+ pieces of code are replicated multiple times instead of writing
functions (see e.g. set_module_*);
+ a lot of stale code (e.g. "structure" definitions for
preloaded_files, kernel_module, pnp stuff) which is not used
or at least belongs elsewhere.
The code bload is extremely bad as the loader runs with very small
memory constraints, and we already hit the limit once (see
http://svn.freebsd.org/viewvc/base?view=revision&revision=185132
Reducing the footprint of the forth files is critical.
+ two different styles of coding, one using pure stack functions
(maybe beautiful but surely highly unreadable), one using
high level mechanisms to give names to arguments and local
variables (which leads to readable code).
Note that this code is used by default by all FreeBSD installations,
so the fragility and the code bloat are extremely damaging.
I will try to work fixing the three items above, but if others have
time, please have a look at these issues.
MFC after: 4 weeks
1708 lines
36 KiB
Forth
1708 lines
36 KiB
Forth
\ 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$
|
|
|
|
\ Loader.rc support functions:
|
|
\
|
|
\ initialize_support ( -- ) initialize global variables
|
|
\ 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:
|
|
\
|
|
\ strdup ( addr len -- addr' len) similar to strdup(3)
|
|
\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3)
|
|
\ strlen ( addr -- len ) similar to strlen(3)
|
|
\ s' ( | string' -- addr len | ) similar to s"
|
|
\ rudimentary structure support
|
|
|
|
\ Exception values
|
|
|
|
1 constant syntax_error
|
|
2 constant out_of_memory
|
|
3 constant free_error
|
|
4 constant set_error
|
|
5 constant read_error
|
|
6 constant open_error
|
|
7 constant exec_error
|
|
8 constant before_load_error
|
|
9 constant after_load_error
|
|
|
|
\ 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
|
|
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
|
|
|
|
structure: config_resource
|
|
ptr cf.name
|
|
int cf.type
|
|
0 constant RES_INT
|
|
1 constant RES_STRING
|
|
2 constant RES_LONG
|
|
2 cells member: u
|
|
;structure
|
|
|
|
structure: config_device
|
|
ptr cd.name
|
|
int cd.unit
|
|
int cd.resource_count
|
|
ptr cd.resources \ config_resource
|
|
;structure
|
|
|
|
structure: STAILQ_HEAD
|
|
ptr stqh_first \ type*
|
|
ptr stqh_last \ type**
|
|
;structure
|
|
|
|
structure: STAILQ_ENTRY
|
|
ptr stqe_next \ type*
|
|
;structure
|
|
|
|
structure: pnphandler
|
|
ptr pnph.name
|
|
ptr pnph.enumerate
|
|
;structure
|
|
|
|
structure: pnpident
|
|
ptr pnpid.ident \ char*
|
|
sizeof STAILQ_ENTRY cells member: pnpid.link \ pnpident
|
|
;structure
|
|
|
|
structure: pnpinfo
|
|
ptr pnpi.desc
|
|
int pnpi.revision
|
|
ptr pnpi.module \ (char*) module args
|
|
int pnpi.argc
|
|
ptr pnpi.argv
|
|
ptr pnpi.handler \ pnphandler
|
|
sizeof STAILQ_HEAD member: pnpi.ident \ pnpident
|
|
sizeof STAILQ_ENTRY member: pnpi.link \ pnpinfo
|
|
;structure
|
|
|
|
\ 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 )
|
|
>r r@ allocate if out_of_memory throw then
|
|
tuck r@ move
|
|
r>
|
|
;
|
|
|
|
: strcat { addr len addr' len' -- addr len+len' }
|
|
addr' addr len + len' move
|
|
addr len len' +
|
|
;
|
|
|
|
: strlen ( addr -- len )
|
|
0 >r
|
|
begin
|
|
dup c@ while
|
|
1+ r> 1+ >r repeat
|
|
drop r>
|
|
;
|
|
|
|
: s'
|
|
[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 funcitons
|
|
|
|
: free-memory free if free_error 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 ;
|
|
|
|
\ 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 out_of_memory throw then
|
|
else
|
|
r@ allocate if out_of_memory throw then
|
|
then
|
|
line_buffer .addr !
|
|
r>
|
|
;
|
|
|
|
: append_to_line_buffer ( addr len -- )
|
|
line_buffer .addr @ line_buffer .len @
|
|
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 out_of_memory throw then
|
|
read_buffer .addr !
|
|
then
|
|
fd @ read_buffer .addr @ read_buffer_size fread
|
|
dup -1 = if read_error throw then
|
|
dup 0= if true to end_of_file? then
|
|
read_buffer .len !
|
|
;
|
|
|
|
: reset_line_buffer
|
|
line_buffer .addr @ ?dup if
|
|
free-memory
|
|
then
|
|
0 line_buffer .addr !
|
|
0 line_buffer .len !
|
|
;
|
|
|
|
support-functions definitions
|
|
|
|
: reset_line_reading
|
|
0 to read_buffer_ptr
|
|
;
|
|
|
|
: read_line
|
|
reset_line_buffer
|
|
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 =
|
|
;
|
|
|
|
: 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] . =
|
|
;
|
|
|
|
: skip_character
|
|
line_pointer char+ to line_pointer
|
|
;
|
|
|
|
: skip_to_end_of_line
|
|
end_of_line to line_pointer
|
|
;
|
|
|
|
: eat_space
|
|
begin
|
|
space?
|
|
while
|
|
skip_character
|
|
end_of_line? if exit then
|
|
repeat
|
|
;
|
|
|
|
: parse_name ( -- addr len )
|
|
line_pointer
|
|
begin
|
|
letter? digit? underscore? dot? or or or
|
|
while
|
|
skip_character
|
|
end_of_line? if
|
|
line_pointer over -
|
|
strdup
|
|
exit
|
|
then
|
|
repeat
|
|
line_pointer over -
|
|
strdup
|
|
;
|
|
|
|
: remove_backslashes { addr len | addr' len' -- addr' len' }
|
|
len allocate if out_of_memory 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 syntax_error throw then
|
|
begin
|
|
quote? 0=
|
|
while
|
|
backslash? if
|
|
skip_character
|
|
end_of_line? if syntax_error throw then
|
|
then
|
|
skip_character
|
|
end_of_line? if syntax_error throw then
|
|
repeat
|
|
skip_character
|
|
line_pointer over -
|
|
remove_backslashes
|
|
;
|
|
|
|
: read_name
|
|
parse_name ( -- addr len )
|
|
name_buffer .len !
|
|
name_buffer .addr !
|
|
;
|
|
|
|
: read_value
|
|
quote? if
|
|
parse_quote ( -- addr len )
|
|
else
|
|
parse_name ( -- addr len )
|
|
then
|
|
value_buffer .len !
|
|
value_buffer .addr !
|
|
;
|
|
|
|
: comment
|
|
skip_to_end_of_line
|
|
;
|
|
|
|
: white_space_4
|
|
eat_space
|
|
comment? if ['] comment to parsing_function exit then
|
|
end_of_line? 0= if syntax_error 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
|
|
syntax_error 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
|
|
syntax_error 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 syntax_error throw then
|
|
;
|
|
|
|
file-processing definitions
|
|
|
|
: get_assignment
|
|
line_buffer .addr @ line_buffer .len @ + 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 syntax_error throw then
|
|
;
|
|
|
|
only forth also support-functions also file-processing definitions also
|
|
|
|
\ Process line
|
|
|
|
: assignment_type? ( addr len -- flag )
|
|
name_buffer .addr @ name_buffer .len @
|
|
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?
|
|
;
|
|
|
|
: set_nextboot_conf
|
|
nextboot_conf_file .addr @ ?dup if
|
|
free-memory
|
|
then
|
|
value_buffer .addr @ c@ [char] " = if
|
|
value_buffer .addr @ char+ value_buffer .len @ 2 chars -
|
|
else
|
|
value_buffer .addr @ value_buffer .len @
|
|
then
|
|
strdup
|
|
nextboot_conf_file .len ! nextboot_conf_file .addr !
|
|
;
|
|
|
|
: 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 -- )
|
|
name_buffer .addr @ name_buffer .len @
|
|
strdup
|
|
>r over module.name .addr !
|
|
r> swap module.name .len !
|
|
;
|
|
|
|
: yes_value?
|
|
value_buffer .addr @ value_buffer .len @
|
|
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 )
|
|
module_options @
|
|
begin
|
|
dup
|
|
while
|
|
dup module.name dup .addr @ swap .len @
|
|
name_buffer .addr @ name_buffer .len @
|
|
compare 0= if exit then
|
|
module.next @
|
|
repeat
|
|
;
|
|
|
|
: new_module_option ( -- addr )
|
|
sizeof module allocate if out_of_memory 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 !
|
|
get_module_option module.args
|
|
dup .addr @ ?dup if free-memory then
|
|
value_buffer .addr @ value_buffer .len @
|
|
over c@ [char] " = if
|
|
2 chars - swap char+ swap
|
|
then
|
|
strdup
|
|
>r over .addr !
|
|
r> swap .len !
|
|
;
|
|
|
|
: set_module_loadname
|
|
name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
|
|
get_module_option module.loadname
|
|
dup .addr @ ?dup if free-memory then
|
|
value_buffer .addr @ value_buffer .len @
|
|
over c@ [char] " = if
|
|
2 chars - swap char+ swap
|
|
then
|
|
strdup
|
|
>r over .addr !
|
|
r> swap .len !
|
|
;
|
|
|
|
: set_module_type
|
|
name_buffer .len @ module_type_suffix nip - name_buffer .len !
|
|
get_module_option module.type
|
|
dup .addr @ ?dup if free-memory then
|
|
value_buffer .addr @ value_buffer .len @
|
|
over c@ [char] " = if
|
|
2 chars - swap char+ swap
|
|
then
|
|
strdup
|
|
>r over .addr !
|
|
r> swap .len !
|
|
;
|
|
|
|
: set_module_beforeload
|
|
name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
|
|
get_module_option module.beforeload
|
|
dup .addr @ ?dup if free-memory then
|
|
value_buffer .addr @ value_buffer .len @
|
|
over c@ [char] " = if
|
|
2 chars - swap char+ swap
|
|
then
|
|
strdup
|
|
>r over .addr !
|
|
r> swap .len !
|
|
;
|
|
|
|
: set_module_afterload
|
|
name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
|
|
get_module_option module.afterload
|
|
dup .addr @ ?dup if free-memory then
|
|
value_buffer .addr @ value_buffer .len @
|
|
over c@ [char] " = if
|
|
2 chars - swap char+ swap
|
|
then
|
|
strdup
|
|
>r over .addr !
|
|
r> swap .len !
|
|
;
|
|
|
|
: set_module_loaderror
|
|
name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
|
|
get_module_option module.loaderror
|
|
dup .addr @ ?dup if free-memory then
|
|
value_buffer .addr @ value_buffer .len @
|
|
over c@ [char] " = if
|
|
2 chars - swap char+ swap
|
|
then
|
|
strdup
|
|
>r over .addr !
|
|
r> swap .len !
|
|
;
|
|
|
|
: set_environment_variable
|
|
name_buffer .len @
|
|
value_buffer .len @ +
|
|
5 chars +
|
|
allocate if out_of_memory throw then
|
|
dup 0 ( addr -- addr addr len )
|
|
s" set " strcat
|
|
name_buffer .addr @ name_buffer .len @ strcat
|
|
s" =" strcat
|
|
value_buffer .addr @ value_buffer .len @ strcat
|
|
['] evaluate catch if
|
|
2drop free drop
|
|
set_error throw
|
|
else
|
|
free-memory
|
|
then
|
|
;
|
|
|
|
: set_conf_files
|
|
set_environment_variable
|
|
s" loader_conf_files" getenv conf_files string=
|
|
;
|
|
|
|
: set_nextboot_flag
|
|
yes_value? to nextboot?
|
|
;
|
|
|
|
: set_verbose
|
|
yes_value? to verbose?
|
|
;
|
|
|
|
: execute_command
|
|
value_buffer .addr @ value_buffer .len @
|
|
over c@ [char] " = if
|
|
2 - swap char+ swap
|
|
then
|
|
['] evaluate catch if exec_error throw then
|
|
;
|
|
|
|
: set_password
|
|
password .addr @ ?dup if free if free_error throw then then
|
|
value_buffer .addr @ c@ [char] " = if
|
|
value_buffer .addr @ char+ value_buffer .len @ 2 - strdup
|
|
value_buffer .addr @ free if free_error throw then
|
|
else
|
|
value_buffer .addr @ value_buffer .len @
|
|
then
|
|
password .len ! password .addr !
|
|
0 value_buffer .addr !
|
|
;
|
|
|
|
: 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 .addr @ dup if free then
|
|
value_buffer .addr @ dup if free then
|
|
or if free_error throw then
|
|
;
|
|
|
|
: reset_assignment_buffers
|
|
0 name_buffer .addr !
|
|
0 name_buffer .len !
|
|
0 value_buffer .addr !
|
|
0 value_buffer .len !
|
|
;
|
|
|
|
\ Higher level file processing
|
|
|
|
support-functions definitions
|
|
|
|
: process_conf
|
|
begin
|
|
end_of_file? 0=
|
|
while
|
|
reset_assignment_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 open_error throw then
|
|
reset_assignment_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 -- )
|
|
0 to end_of_file?
|
|
reset_line_reading
|
|
O_RDONLY fopen fd !
|
|
fd @ -1 = if open_error throw then
|
|
['] process_conf catch
|
|
fd @ fclose
|
|
throw
|
|
;
|
|
|
|
: print_line
|
|
line_buffer .addr @ line_buffer .len @ type cr
|
|
;
|
|
|
|
: print_syntax_error
|
|
line_buffer .addr @ line_buffer .len @ type 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 .
|
|
syntax_error = if cr print_syntax_error then
|
|
;
|
|
|
|
: show-module-options
|
|
module_options @
|
|
begin
|
|
?dup
|
|
while
|
|
." Name: " dup module.name dup .addr @ swap .len @ type cr
|
|
." Path: " dup module.loadname dup .addr @ swap .len @ type cr
|
|
." Type: " dup module.type dup .addr @ swap .len @ type cr
|
|
." Flags: " dup module.args dup .addr @ swap .len @ type cr
|
|
." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr
|
|
." After load: " dup module.afterload dup .addr @ swap .len @ type cr
|
|
." Error: " dup module.loaderror dup .addr @ swap .len @ type cr
|
|
." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr
|
|
module.next @
|
|
repeat
|
|
;
|
|
|
|
only forth also support-functions definitions
|
|
|
|
\ Variables used for processing multiple conf files
|
|
|
|
string current_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
|
|
conf_files strget 0 0 conf_files strset
|
|
;
|
|
|
|
: skip_leading_spaces { addr len pos -- addr len pos' }
|
|
begin
|
|
pos len = if addr len pos exit then
|
|
addr pos + c@ bl =
|
|
while
|
|
pos char+ to pos
|
|
repeat
|
|
addr len pos
|
|
;
|
|
|
|
: 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
|
|
addr pos + c@ bl <>
|
|
while
|
|
pos char+ to pos
|
|
pos len = if
|
|
addr len pos addr r@ + pos r> - exit
|
|
then
|
|
repeat
|
|
addr len pos addr r@ + pos r> -
|
|
;
|
|
|
|
: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 )
|
|
skip_leading_spaces
|
|
get_file_name
|
|
;
|
|
|
|
: set_current_file_name
|
|
over current_file_name .addr !
|
|
dup current_file_name .len !
|
|
;
|
|
|
|
: print_current_file
|
|
current_file_name .addr @ current_file_name .len @ type
|
|
;
|
|
|
|
: process_conf_errors
|
|
dup 0= if true to any_conf_read? drop exit then
|
|
>r 2drop r>
|
|
dup syntax_error = if
|
|
." Warning: syntax error on file " print_current_file cr
|
|
print_syntax_error drop exit
|
|
then
|
|
dup set_error = if
|
|
." Warning: bad definition on file " print_current_file cr
|
|
print_line drop exit
|
|
then
|
|
dup read_error = if
|
|
." Warning: error reading file " print_current_file cr drop exit
|
|
then
|
|
dup open_error = if
|
|
verbose? if ." Warning: unable to open file " print_current_file cr then
|
|
drop exit
|
|
then
|
|
dup free_error = abort" Fatal error freeing memory"
|
|
dup out_of_memory = 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
|
|
begin
|
|
get_next_file ?dup
|
|
while
|
|
set_current_file_name
|
|
['] load_conf catch
|
|
process_conf_errors
|
|
conf_files .addr @ if recurse then
|
|
repeat
|
|
;
|
|
|
|
: get_nextboot_conf_file ( -- addr len )
|
|
nextboot_conf_file .addr @ nextboot_conf_file .len @ strdup
|
|
;
|
|
|
|
: rewrite_nextboot_file ( -- )
|
|
get_nextboot_conf_file
|
|
O_WRONLY fopen fd !
|
|
fd @ -1 = if open_error 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_module?
|
|
module.flag @
|
|
;
|
|
|
|
: load_parameters ( addr -- addr addrN lenN ... addr1 len1 N )
|
|
dup >r
|
|
r@ module.args .addr @ r@ module.args .len @
|
|
r@ module.loadname .len @ if
|
|
r@ module.loadname .addr @ r@ module.loadname .len @
|
|
else
|
|
r@ module.name .addr @ r@ module.name .len @
|
|
then
|
|
r@ module.type .len @ if
|
|
r@ module.type .addr @ r@ module.type .len @
|
|
s" -t "
|
|
4 ( -t type name flags )
|
|
else
|
|
2 ( name flags )
|
|
then
|
|
r> drop
|
|
;
|
|
|
|
: before_load ( addr -- addr )
|
|
dup module.beforeload .len @ if
|
|
dup module.beforeload .addr @ over module.beforeload .len @
|
|
['] evaluate catch if before_load_error throw then
|
|
then
|
|
;
|
|
|
|
: after_load ( addr -- addr )
|
|
dup module.afterload .len @ if
|
|
dup module.afterload .addr @ over module.afterload .len @
|
|
['] evaluate catch if after_load_error throw then
|
|
then
|
|
;
|
|
|
|
: load_error ( addr -- addr )
|
|
dup module.loaderror .len @ if
|
|
dup module.loaderror .addr @ over module.loaderror .len @
|
|
evaluate \ This we do not intercept so it can throw errors
|
|
then
|
|
;
|
|
|
|
: pre_load_message ( addr -- addr )
|
|
verbose? if
|
|
dup module.name .addr @ over module.name .len @ type
|
|
." ..."
|
|
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 before_load_error = if
|
|
drop
|
|
." Module "
|
|
dup module.name .addr @ over module.name .len @ type
|
|
dup module.loadname .len @ if
|
|
." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
|
|
then
|
|
cr
|
|
." Error executing "
|
|
dup module.beforeload .addr @ over module.afterload .len @ type cr
|
|
abort
|
|
then
|
|
|
|
dup after_load_error = if
|
|
drop
|
|
." Module "
|
|
dup module.name .addr @ over module.name .len @ type
|
|
dup module.loadname .len @ if
|
|
." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
|
|
then
|
|
cr
|
|
." Error executing "
|
|
dup module.afterload .addr @ over module.afterload .len @ type cr
|
|
abort
|
|
then
|
|
|
|
throw \ Don't know what it is all about -- pass ahead
|
|
;
|
|
|
|
\ Module loading interface
|
|
|
|
: load_modules ( -- ) ( throws: abort & user-defined )
|
|
module_options @
|
|
begin
|
|
?dup
|
|
while
|
|
dup load_module? 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 comma-separated list
|
|
|
|
: parse-; ( addr len -- addr' len-x addr x )
|
|
over 0 2swap
|
|
begin
|
|
dup 0 <>
|
|
while
|
|
over c@ [char] ; <>
|
|
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
|
|
0 0 2local newmodulepath
|
|
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 +
|
|
oldmodulepath nip dup -1 = if
|
|
drop
|
|
else
|
|
1+ +
|
|
then
|
|
allocate
|
|
if ( out of memory )
|
|
1 exit
|
|
then
|
|
|
|
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 .len ! conf_files .addr !
|
|
;
|
|
|
|
: 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
|
|
;
|
|
|
|
: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
|
|
2dup = if 0 0 exit then
|
|
dup >r
|
|
1+ 2* ( skip N and ui )
|
|
pick
|
|
r>
|
|
1+ 2* ( skip N and ai )
|
|
pick
|
|
;
|
|
|
|
: drop_args ( aN uN ... a1 u1 N -- )
|
|
0 ?do 2drop loop
|
|
;
|
|
|
|
: argc
|
|
dup
|
|
;
|
|
|
|
: queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 )
|
|
>r
|
|
over 2* 1+ -roll
|
|
r>
|
|
over 2* 1+ -roll
|
|
1+
|
|
;
|
|
|
|
: unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 )
|
|
1- -rot
|
|
;
|
|
|
|
: strlen(argv)
|
|
dup 0= if 0 exit then
|
|
0 >r \ Size
|
|
0 >r \ Index
|
|
begin
|
|
argc r@ <>
|
|
while
|
|
r@ argv[]
|
|
nip
|
|
r> r> rot + 1+
|
|
>r 1+ >r
|
|
repeat
|
|
r> drop
|
|
r>
|
|
;
|
|
|
|
: concat_argv ( aN uN ... a1 u1 N -- a u )
|
|
strlen(argv) allocate if out_of_memory throw then
|
|
0 2>r
|
|
|
|
begin
|
|
argc
|
|
while
|
|
unqueue_argv
|
|
2r> 2swap
|
|
strcat
|
|
s" " strcat
|
|
2>r
|
|
repeat
|
|
drop_args
|
|
2r>
|
|
;
|
|
|
|
: set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
|
|
\ Save the first argument, if it exists and is not a flag
|
|
argc if
|
|
0 argv[] drop c@ [char] - <> if
|
|
unqueue_argv 2>r \ Filename
|
|
1 >r \ Filename present
|
|
else
|
|
0 >r \ Filename not present
|
|
then
|
|
else
|
|
0 >r \ Filename not present
|
|
then
|
|
|
|
\ If there are other arguments, assume they are flags
|
|
?dup if
|
|
concat_argv
|
|
2dup s" temp_options" setenv
|
|
drop free if free_error throw then
|
|
else
|
|
set_defaultoptions
|
|
then
|
|
|
|
\ Bring back the filename, if one was provided
|
|
r> if 2r> 1 else 0 then
|
|
;
|
|
|
|
: get_arguments ( -- addrN lenN ... addr1 len1 N )
|
|
0
|
|
begin
|
|
\ Get next word on the command line
|
|
parse-word
|
|
?dup while
|
|
queue_argv
|
|
repeat
|
|
drop ( empty string )
|
|
;
|
|
|
|
: load_kernel_and_modules ( args -- flag )
|
|
set_tempoptions
|
|
argc >r
|
|
s" temp_options" getenv dup -1 <> if
|
|
queue_argv
|
|
else
|
|
drop
|
|
then
|
|
r> if ( a path was passed )
|
|
load_directory_or_file
|
|
else
|
|
standard_kernel_search
|
|
then
|
|
?dup 0= if ['] load_modules catch then
|
|
;
|
|
|
|
: read-password { size | buf len -- }
|
|
size allocate if out_of_memory throw then
|
|
to buf
|
|
0 to len
|
|
begin
|
|
key
|
|
dup backspace = if
|
|
drop
|
|
len if
|
|
backspace emit bl emit backspace emit
|
|
len 1 - to len
|
|
else
|
|
bell emit
|
|
then
|
|
else
|
|
dup <cr> = if cr drop buf len exit then
|
|
[char] * emit
|
|
len size < if
|
|
buf len chars + c!
|
|
else
|
|
drop
|
|
then
|
|
len 1+ to len
|
|
then
|
|
again
|
|
;
|
|
|
|
\ Go back to straight forth vocabulary
|
|
|
|
only forth also definitions
|
|
|