1716 lines
36 KiB
Forth
1716 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 ;
|
|
|
|
\ 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_conf_files
|
|
conf_files .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
|
|
conf_files .len ! conf_files .addr !
|
|
;
|
|
|
|
: 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_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
|
|
variable current_conf_files
|
|
|
|
\ Indicates if any conf file was succesfully read
|
|
|
|
0 value any_conf_read?
|
|
|
|
\ loader_conf_files processing support functions
|
|
|
|
: set_current_conf_files
|
|
conf_files .addr @ current_conf_files !
|
|
;
|
|
|
|
: get_conf_files
|
|
conf_files .addr @ conf_files .len @ strdup
|
|
;
|
|
|
|
: recurse_on_conf_files?
|
|
current_conf_files @ conf_files .addr @ <>
|
|
;
|
|
|
|
: 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
|
|
set_current_conf_files
|
|
get_conf_files 0
|
|
begin
|
|
get_next_file ?dup
|
|
while
|
|
set_current_file_name
|
|
['] load_conf catch
|
|
process_conf_errors
|
|
recurse_on_conf_files? 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
|
|
|