Remove AGAIN definition, as FICL 2.04 provides it.

Add strlen, to help handling data generated by C code.

Add 2>r 2r>, because OO programming without them sucks.

\ 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

\ Crude structure support

: structure: create here 0 , 0 does> create @ allot ;
: member: create dup , over , + does> cell+ @ + ;
: ;structure swap ! ;
: 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
;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

\ Global variables

string conf_files
string password
create module_options sizeof module.next allot
create last_module_option sizeof module.next allot
0 value verbose?

\ 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

\ 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

\ File data temporary storage

string line_buffer
string read_buffer
0 value read_buffer_ptr

\ File's line reading function

0 value end_of_file?
variable fd

: 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
  0 line_buffer .addr !
  0 line_buffer .len !
;

: read_line
  reset_line_buffer
  skip_newlines
  begin
    read_from_buffer
    refill_required?
  while
    refill_buffer
  repeat
;

\ 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>}

0 value parsing_function

0 value end_of_line
0 value line_pointer

: 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] 0 >=
  r> [char] 9 <= and
;

: 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
;

: 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
;

\ 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?
;

: 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 !
;

: 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_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
  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
  line_buffer .addr @ dup if free then
  name_buffer .addr @ dup if free then
  value_buffer .addr @ dup if free then
  or 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

: 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
;

: create_null_terminated_string  { addr len -- addr' len }
  len char+ allocate if out_of_memory throw then
  >r
  addr r@ len move
  0 r@ len + c!
  r> len
;

\ Interface to loading conf files

: load_conf  ( addr len -- )
  0 to end_of_file?
  0 to read_buffer_ptr
  create_null_terminated_string
  over >r
  fopen fd !
  r> free-memory
  fd @ -1 = if open_error throw then
  ['] process_conf catch
  fd @ fclose
  throw
;

: initialize_support
  0 read_buffer .addr !
  0 conf_files .addr !
  0 password .addr !
  0 module_options !
  0 last_module_option !
  0 to verbose?
;

: 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
;

\ Depuration 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
;

\ 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
;

\ Additional functions used in "start"

: initialize  ( addr len -- )
  initialize_support
  strdup conf_files .len ! conf_files .addr !
;

: load_kernel  ( -- ) ( throws: abort )
  s" load ${kernel} ${kernel_options}" ['] evaluate catch
  if s" echo Unable to load kernel: ${kernel_name}" evaluate abort 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

\ 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)
\ 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

\ Crude structure support

: structure: create here 0 , 0 does> create @ allot ;
: member: create dup , over , + does> cell+ @ + ;
: ;structure swap ! ;
: 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
;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

\ Global variables

string conf_files
string password
create module_options sizeof module.next allot
create last_module_option sizeof module.next allot
0 value verbose?

\ 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' +
;

: s'
  [char] ' parse
  state @ if
    postpone sliteral
  then
; immediate

\ How come ficl doesn't have again?

: again false postpone literal postpone until ; immediate

\ 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

\ File data temporary storage

string line_buffer
string read_buffer
0 value read_buffer_ptr

\ File's line reading function

0 value end_of_file?
variable fd

: 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
  0 line_buffer .addr !
  0 line_buffer .len !
;

: read_line
  reset_line_buffer
  skip_newlines
  begin
    read_from_buffer
    refill_required?
  while
    refill_buffer
  repeat
;

\ 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>}

0 value parsing_function

0 value end_of_line
0 value line_pointer

: 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] 0 >=
  r> [char] 9 <= and
;

: 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
;

: 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
;

\ 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?
;

: 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 !
;

: 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_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
  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
  line_buffer .addr @ dup if free then
  name_buffer .addr @ dup if free then
  value_buffer .addr @ dup if free then
  or 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

: 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
;

: create_null_terminated_string  { addr len -- addr' len }
  len char+ allocate if out_of_memory throw then
  >r
  addr r@ len move
  0 r@ len + c!
  r> len
;

\ Interface to loading conf files

: load_conf  ( addr len -- )
  0 to end_of_file?
  0 to read_buffer_ptr
  create_null_terminated_string
  over >r
  fopen fd !
  r> free-memory
  fd @ -1 = if open_error throw then
  ['] process_conf catch
  fd @ fclose
  throw
;

: initialize_support
  0 read_buffer .addr !
  0 conf_files .addr !
  0 password .addr !
  0 module_options !
  0 last_module_option !
  0 to verbose?
;

: 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
;

\ Depuration 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
;

\ 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
;

\ Additional functions used in "start"

: initialize  ( addr len -- )
  initialize_support
  strdup conf_files .len ! conf_files .addr !
;

: load_kernel  ( -- ) ( throws: abort )
  s" load ${kernel} ${kernel_options}" ['] evaluate catch
  if s" echo Unable to load kernel: ${kernel_name}" evaluate abort 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


Get rid of interp_max

Get rid of interp_max

(( Clock Code ))

\ The gadget that drives it all.   This is rigged for debugging,
\ terminate it by setting clockterm to non-zero.
: CLOCKSTART ( -- )
  load-defaults
  icroot 0 over inter.rtcsem ! \ Reset the free-running counters.
         0 over inter.rtcdsem ! \ Reset the free-running counters.

  begin
   	dup inter.rtcsem  @offex! ?dup if advancehms then
   	dup inter.rtcdsem @offex! ?dup if advancedhms then
    [asm wfi asm]
    uiupdate if use-uivals else use-clockvals then
  key? until drop
;

\ These two contain loops to ensure that we don't
\ drop any timer ticks on the floor.
: ADVANCEHMS ( n -- ) 0 do hms advancetime loop ;
: ADVANCEDHMS ( n -- ) 0 do dhms advancetime loop ;

: LOAD-DEFAULTS ( -- )
  interp-init
;

\ ----------------------------------------------------------
\ Define the structures before they get used.
\ ----------------------------------------------------------
struct ODN \ On-Deck Needle
	2 field odn.s
	2 field odn.m
	2 field odn.h
end-struct

struct _HMS
	int hms.subsec
	int hms.s
	int hms.m
	int hms.h
	int hms.maxsubsec \ Max Value for subseconds
	int hms.maxsec   \ Max Value for secs+minutes
	int hms.maxhour   \ Max for hours
	ptr hms.w_s    \ Increment the seconds value
	ptr hms.w_m    \ increment the minutes + hours
end-struct

struct _interp_set
	4 cells field interp.a
	4 cells field interp.b
	4 cells field interp.c
end-struct

\ ----------------------------------------------------------
\ Defaults get saved in the user data page.
\ ----------------------------------------------------------

: NVRAMVALID? ( addr -- t/f )
\ *G See if there is valid data in the NVRAM.
\ ** It consists of 3 words.  If any of them are
\ ** set to 0xffff:ffff, we go with the defaults.
  dup      @ -1 =
  over 4 + @ -1 = or
  swap 8 + @ -1 = or
;

: NVRAMLOAD ( addr -- ) $C 0 do dup I + @ needle_max I + ! 4 + loop ;

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
idata
create ODN_HMS  odn allot \ On-Deck, HMS
create ODN_DHMS odn allot \ On-Deck, DHMS
create ODN_UI   odn allot \ On-Deck, Generated by the UI.
cdata

idata
create NEEDLE_MAX #850 , #850 , #850 ,
cdata

: rangecheck ( max n -- n or zero ) dup >R <= if R> drop 0 else R> then ;

: ++NEEDLE_S \ Called every time.
    odn_hms    odn.s   \ Stash this address for the moment.

	needle_max odn.s @ \ Get the max
	over w@             \ Current value

	interp_hms interp.a interp-next + \ Returns a value.

	\ If we've wrapped to zero, reset the interpolator
	\ so that we don't accumulate errors during setting/
	\ calibration operations.
    rangecheck dup  0= if  interp_hms interp.a  interp-reset  then
	swap w!
	;

: ++NEEDLE_DS ; \ Called every time.

: ++NEEDLE_M ; \ Every time we roll the seconds.
: ++NEEDLE_DM ; \ Every time we roll the seconds.

: _USE ( odn-addr -- )
  dup w@ pwm0!
  dup 2 + w@ pwm1!
  4 + w@ pwm2!
  ;

: USE-CLOCKVALS odn_hms _use ;
: USE-UIVALS    odn_ui  _use ;

\ ----------------------------------------------------------
\ PWM/Timer Manipulation
\ ----------------------------------------------------------
_timer0 $34 + equ _PWM0
_timer0 $44 + equ _PWM1
_timer0 $54 + equ _PWM2

: PWM0! ( n -- ) _pwm0 ! ;
: PWM1! ( n -- ) _pwm1 ! ;
: PWM2! ( n -- ) _pwm2 ! ;

: PWM0@ ( -- n ) _pwm0 w@ ;
: PWM1@ ( -- n ) _pwm1 w@ ;
: PWM2@ ( -- n ) _pwm2 w@ ;

: SCALE0 #1000 0 do I pwm0! loop ;
: SCALE1 #1000 0 do I pwm0! [asm wfi asm] loop ;

\ ----------------------------------------------------------
\ PWM/Timer Quadrature
\ ----------------------------------------------------------

: QUAD@ ( addr -- n ) \ Fetch and zero
  @off [asm sxth tos, tos asm] ;

\ ----------------------------------------------------------
\ Keeping track of the time.
\ ----------------------------------------------------------
idata
create HMS
  0 , 0 , 0 , 0 , \ Running Counters
  #16 , #60 , #24 , \ Limits
  ' ++needle_s , ' ++needle_m , \ Words to invoke
create DHMS
  0 , 0 , 0 , 0 , \ Running Counters
  #10 , #100 , #10 , \ Limits
' ++needle_ds , ' ++needle_dm , \ Words to invoke
cdata

\ Core concept - We update the seconds
\ each time this gets called.
\ If the seconds wrap, we update the minutes
\ and the hours.
: ADVANCETIME ( struct-addr -- )
  dup hms.w_s @ execute \ Invoke the official update word.
  1 over hms.subsec +!  \ Increment
   dup hms.subsec @
   over hms.maxsubsec @ < if drop exit then \ If less then max, we're done
  0 over hms.subsec ! \ Reset the subsecs

  dup hms.w_m @ execute
  1 over hms.s +!
   dup hms.s @ over hms.maxsec @ < if drop exit then
  0 over hms.s ! \ Reset the seconds

  1 over hms.m +!
   dup hms.m @ over hms.maxsec @ < if drop exit then
  0 over hms.m ! \ Reset the minutes

  1 over hms.h +!
   dup hms.h @ over hms.maxhour @ < if drop exit then
  0 over hms.h ! \ Reset the minutes

  drop

;

: ? @ . ;
: .hms ( addr -- )
  dup hms.h ?
  dup hms.m ?
  dup hms.s ?
  hms.subsec ?
  cr
;

\ : foo 0 do hms advancetime loop ;

\ ----------------------------------------------------------
\ The interpolator.
\ Implement bresenhams algorithm.  All of this code already
\ exists in C, but we'll own the data structures.  They contain
\ A total of 4 words - fixed, err, num, & denom
\ ----------------------------------------------------------
udata
create interp_hms  _interp_set allot
create interp_dhms _interp_set allot
create adj_list #50 cells allot \ 100 16-bit words.
cdata

#16  #60 * equ raw_sec
#10 #100 * equ raw_dsec

: INTERP-INIT ( -- )
  (interp_init) interp_hms
  2dup interp.a needle_max     @ raw_sec call3--
  2dup interp.b needle_max 4 + @     #60 call3--
       interp.c needle_max 8 + @     #12 call3--

  (interp_init) interp_dhms
  2dup interp.a needle_max     @  raw_dsec call3--
  2dup interp.b needle_max 4 + @      #100 call3--
       interp.c needle_max 8 + @       #10 call3--
;

\ Call the reset fn.
: INTERP-RESET ( interp_addr -- )
  (interp_reset) swap call1--
;

: INTERP-NEXT ( addr -- n )
  (interp_next) swap call1--n
;

\ ============================ UNTESTED =======================
\ VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV

\ ----------------------------------------------------------
\ User Interface
\ ----------------------------------------------------------
variable uistate
variable uicount

_GPIO $64  + equ _BUTTONIO
: BUTTONUP?   ( -- t/f ) _buttonio @ 1 and ;
: BUTTONDOWN? ( -- t/f )  buttonup? 1 or ;

\ The wrapper for all of the UI stuff.
\ Returns true if the UI is active - ie, use the values generated by the UI.
: UIUPDATE ( -- t/f )
  StateHandlers uistate @ + @ execute
;

\ -----------------------------------------------
\ State numbers.  These are defined x4 so that
\ we can just use the state number as an index
\ into a table of words.
\ -----------------------------------------------
0 4 * equ _s_init
1 4 * equ _s_b1
2 4 * equ _s_1sec
3 4 * equ _s_seth
4 4 * equ _s_pendset_m
5 4 * equ _s_setmin
6 4 * equ _s_pendcal0
7 4 * equ _s_cal0
8 4 * equ _s_pendcalh
9 4 * equ _s_calh
10 4 * equ _s_pendcalm
11 4 * equ _s_calm
12 4 * equ _s_pendcals
13 4 * equ _s_cals

\ All of the state handlers.
\ Everybody needs to know the state of the button, so that must
\ get passed in, thus they all look like this:
\ state ( t/f -- t/f )
: shInit false
   buttondown? if
   _s_b1 uistate !
   uicount off \ Reset this.
   then
  ;

\ Waiting for a full second to go by.
: shB1 false
  buttonup? if _s_init uistate ! exit then
  \ The Button is down.
  uicount @ 16 > if
    _s_1sec uistate !
    else
    1 uicount +!
	then
  ;

\ We're in the 1 second state
: sh1sec true
  buttonup? if _s_seth uistate ! true exit then
  uicount @ 48 > if
    _s_pendcal0 uistate !
    else
    1 uicount +!
	then
;

\ -------------------------------------------------
\ Setting the time
\ -------------------------------------------------
: shSetH true buttondown? if _s_pendset_m uistate ! exit then ;

: shPendSetM true  buttonup? if _s_setmin uistate ! then ;
: shSetMin true  buttondown? if _s_pendset_m uistate ! exit then ;

\ -------------------------------------------------
\ Calibration
\ -------------------------------------------------
: shPendCal0 true  buttonup? if _s_cal0 uistate ! then ;
: shCal0 true    buttondown? if _s_pendcalh uistate ! exit then ;

: shPendCalH true buttonup? if _s_calh uistate ! then ;
: shCalH true   buttondown? if _s_pendcalm uistate ! exit then ;

: shPendCalM true buttonup? if _s_calm uistate ! then ;
: shCalM true   buttondown? if _s_pendcals uistate ! exit then ;

: shPendCalS true buttonup? if _s_calm uistate ! then ;
: shCalS true   buttondown? if _s_init uistate ! exit then ;

create StateHandlers
' shInit ,
' shB1 ,
' sh1sec ,
' shSetH ,
' shPendSetM ,  ' shSetMin ,

' shPendCal0 ,  ' shCal0 ,
' shPendCalH ,  ' shCalH ,
' shPendCalM ,  ' shCalM ,
' shPendCalS ,  ' shCalS ,

(( Clock Code ))

\ The gadget that drives it all.   This is rigged for debugging,
\ terminate it by setting clockterm to non-zero.
: CLOCKSTART ( -- )
  load-defaults
  icroot 0 over inter.rtcsem ! \ Reset the free-running counters.
         0 over inter.rtcdsem ! \ Reset the free-running counters.

  begin
   	dup inter.rtcsem  @offex! ?dup if advancehms then
   	dup inter.rtcdsem @offex! ?dup if advancedhms then
    [asm wfi asm]
    uiupdate if use-uivals else use-clockvals then
  key? until drop
;

\ These two contain loops to ensure that we don't
\ drop any timer ticks on the floor.
: ADVANCEHMS ( n -- ) 0 do hms advancetime loop ;
: ADVANCEDHMS ( n -- ) 0 do dhms advancetime loop ;

: LOAD-DEFAULTS ( -- )
  #1000 needlemax
  2dup ! 4 + 2dup ! 4 +  !
  interp-init
;

\ ----------------------------------------------------------
\ Define the structures before they get used.
\ ----------------------------------------------------------
struct ODN \ On-Deck Needle
	2 field odn.s
	2 field odn.m
	2 field odn.h
end-struct

struct _HMS
	int hms.subsec
	int hms.s
	int hms.m
	int hms.h
	int hms.maxsubsec \ Max Value for subseconds
	int hms.maxsec   \ Max Value for secs+minutes
	int hms.maxhour   \ Max for hours
	ptr hms.w_s    \ Increment the seconds value
	ptr hms.w_m    \ increment the minutes + hours
end-struct

struct _interp_set
	4 cells field interp.a
	4 cells field interp.b
	4 cells field interp.c
end-struct

\ ----------------------------------------------------------
\ Defaults get saved in the user data page.
\ ----------------------------------------------------------

: NVRAMVALID? ( addr -- t/f )
\ *G See if there is valid data in the NVRAM.
\ ** It consists of 3 words.  If any of them are
\ ** set to 0xffff:ffff, we go with the defaults.
  dup      @ -1 =
  over 4 + @ -1 = or
  swap 8 + @ -1 = or
;

: NVRAMLOAD ( addr -- ) $C 0 do dup I + @ needle_max I + ! 4 + loop ;

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
idata
create ODN_HMS  odn allot \ On-Deck, HMS
create ODN_DHMS odn allot \ On-Deck, DHMS
create ODN_UI   odn allot \ On-Deck, Generated by the UI.
cdata

idata
create NEEDLE_MAX #850 , #850 , #850 ,
cdata

: rangecheck ( max n -- n or zero ) dup >R <= if R> drop 0 else R> then ;

: ++NEEDLE_S \ Called every time.
    odn_hms    odn.s   \ Stash this address for the moment.

	needle_max odn.s @ \ Get the max
	over w@             \ Current value

	interp_hms interp.a interp-next + \ Returns a value.

	\ If we've wrapped to zero, reset the interpolator
	\ so that we don't accumulate errors during setting/
	\ calibration operations.
    rangecheck dup  0= if  interp_hms interp.a  interp-reset  then
	swap w!
	;

: ++NEEDLE_DS ; \ Called every time.

: ++NEEDLE_M ; \ Every time we roll the seconds.
: ++NEEDLE_DM ; \ Every time we roll the seconds.

: _USE ( odn-addr -- )
  dup w@ pwm0!
  dup 2 + w@ pwm1!
  4 + w@ pwm2!
  ;

: USE-CLOCKVALS odn_hms _use ;
: USE-UIVALS    odn_ui  _use ;

\ ----------------------------------------------------------
\ PWM/Timer Manipulation
\ ----------------------------------------------------------
_timer0 $34 + equ _PWM0
_timer0 $44 + equ _PWM1
_timer0 $54 + equ _PWM2

: PWM0! ( n -- ) _pwm0 ! ;
: PWM1! ( n -- ) _pwm1 ! ;
: PWM2! ( n -- ) _pwm2 ! ;

: PWM0@ ( -- n ) _pwm0 w@ ;
: PWM1@ ( -- n ) _pwm1 w@ ;
: PWM2@ ( -- n ) _pwm2 w@ ;

: SCALE0 #1000 0 do I pwm0! loop ;
: SCALE1 #1000 0 do I pwm0! [asm wfi asm] loop ;

\ ----------------------------------------------------------
\ PWM/Timer Quadrature
\ ----------------------------------------------------------

: QUAD@ ( addr -- n ) \ Fetch and zero
  @off [asm sxth tos, tos asm] ;

\ ----------------------------------------------------------
\ Keeping track of the time.
\ ----------------------------------------------------------
idata
create HMS
  0 , 0 , 0 , 0 , \ Running Counters
  #16 , #60 , #24 , \ Limits
  ' ++needle_s , ' ++needle_m , \ Words to invoke
create DHMS
  0 , 0 , 0 , 0 , \ Running Counters
  #10 , #100 , #10 , \ Limits
' ++needle_ds , ' ++needle_dm , \ Words to invoke
cdata

\ Core concept - We update the seconds
\ each time this gets called.
\ If the seconds wrap, we update the minutes
\ and the hours.
: ADVANCETIME ( struct-addr -- )
  dup hms.w_s @ execute \ Invoke the official update word.
  1 over hms.subsec +!  \ Increment
   dup hms.subsec @
   over hms.maxsubsec @ < if drop exit then \ If less then max, we're done
  0 over hms.subsec ! \ Reset the subsecs

  dup hms.w_m @ execute
  1 over hms.s +!
   dup hms.s @ over hms.maxsec @ < if drop exit then
  0 over hms.s ! \ Reset the seconds

  1 over hms.m +!
   dup hms.m @ over hms.maxsec @ < if drop exit then
  0 over hms.m ! \ Reset the minutes

  1 over hms.h +!
   dup hms.h @ over hms.maxhour @ < if drop exit then
  0 over hms.h ! \ Reset the minutes

  drop

;

: ? @ . ;
: .hms ( addr -- )
  dup hms.h ?
  dup hms.m ?
  dup hms.s ?
  hms.subsec ?
  cr
;

\ : foo 0 do hms advancetime loop ;

\ ----------------------------------------------------------
\ The interpolator.
\ Implement bresenhams algorithm.  All of this code already
\ exists in C, but we'll own the data structures.  They contain
\ A total of 4 words - fixed, err, num, & denom
\ ----------------------------------------------------------
udata
create interp_hms  _interp_set allot
create interp_dhms _interp_set allot
create adj_list #50 cells allot \ 100 16-bit words.
cdata

\ Heres the default values.   These are universal.
idata
create interp_max #850 , #850 , #850 ,
cdata

#16  #60 * equ raw_sec
#10 #100 * equ raw_dsec

: INTERP-INIT ( -- )
  (interp_init) interp_hms
  2dup interp.a interp_max     @ raw_sec call3--
  2dup interp.b interp_max 4 + @     #60 call3--
       interp.c interp_max 8 + @     #12 call3--

  (interp_init) interp_dhms
  2dup interp.a interp_max     @  raw_dsec call3--
  2dup interp.b interp_max 4 + @      #100 call3--
       interp.c interp_max 8 + @       #10 call3--
;

\ Call the reset fn.
: INTERP-RESET ( interp_addr -- )
  (interp_reset) swap call1--
;

: INTERP-NEXT ( addr -- n )
  (interp_next) swap call1--n
;

\ ============================ UNTESTED =======================
\ VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV

\ ----------------------------------------------------------
\ User Interface
\ ----------------------------------------------------------
variable uistate
variable uicount

_GPIO $64  + equ _BUTTONIO
: BUTTONUP?   ( -- t/f ) _buttonio @ 1 and ;
: BUTTONDOWN? ( -- t/f )  buttonup? 1 or ;

\ The wrapper for all of the UI stuff.
\ Returns true if the UI is active - ie, use the values generated by the UI.
: UIUPDATE ( -- t/f )
  StateHandlers uistate @ + @ execute
;

\ -----------------------------------------------
\ State numbers.  These are defined x4 so that
\ we can just use the state number as an index
\ into a table of words.
\ -----------------------------------------------
0 4 * equ _s_init
1 4 * equ _s_b1
2 4 * equ _s_1sec
3 4 * equ _s_seth
4 4 * equ _s_pendset_m
5 4 * equ _s_setmin
6 4 * equ _s_pendcal0
7 4 * equ _s_cal0
8 4 * equ _s_pendcalh
9 4 * equ _s_calh
10 4 * equ _s_pendcalm
11 4 * equ _s_calm
12 4 * equ _s_pendcals
13 4 * equ _s_cals

\ All of the state handlers.
\ Everybody needs to know the state of the button, so that must
\ get passed in, thus they all look like this:
\ state ( t/f -- t/f )
: shInit false
   buttondown? if
   _s_b1 uistate !
   uicount off \ Reset this.
   then
  ;

\ Waiting for a full second to go by.
: shB1 false
  buttonup? if _s_init uistate ! exit then
  \ The Button is down.
  uicount @ 16 > if
    _s_1sec uistate !
    else
    1 uicount +!
	then
  ;

\ We're in the 1 second state
: sh1sec true
  buttonup? if _s_seth uistate ! true exit then
  uicount @ 48 > if
    _s_pendcal0 uistate !
    else
    1 uicount +!
	then
;

\ -------------------------------------------------
\ Setting the time
\ -------------------------------------------------
: shSetH true buttondown? if _s_pendset_m uistate ! exit then ;

: shPendSetM true  buttonup? if _s_setmin uistate ! then ;
: shSetMin true  buttondown? if _s_pendset_m uistate ! exit then ;

\ -------------------------------------------------
\ Calibration
\ -------------------------------------------------
: shPendCal0 true  buttonup? if _s_cal0 uistate ! then ;
: shCal0 true    buttondown? if _s_pendcalh uistate ! exit then ;

: shPendCalH true buttonup? if _s_calh uistate ! then ;
: shCalH true   buttondown? if _s_pendcalm uistate ! exit then ;

: shPendCalM true buttonup? if _s_calm uistate ! then ;
: shCalM true   buttondown? if _s_pendcals uistate ! exit then ;

: shPendCalS true buttonup? if _s_calm uistate ! then ;
: shCalS true   buttondown? if _s_init uistate ! exit then ;

create StateHandlers
' shInit ,
' shB1 ,
' sh1sec ,
' shSetH ,
' shPendSetM ,  ' shSetMin ,

' shPendCal0 ,  ' shCal0 ,
' shPendCalH ,  ' shCalH ,
' shPendCalM ,  ' shCalM ,
' shPendCalS ,  ' shCalS ,


boot: change branding for -devel

boot: change branding for -devel

\ Copyright (c) 2006-2015 Devin Teske <dteske@FreeBSD.org>
\ Copyright (c) 2016 Deciso B.V.
\ 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$

48 logoX ! 9 logoY ! \ Initialize logo placement defaults

: logo+ ( x y c-addr/u -- x y' )
	2swap 2dup at-xy 2swap \ position the cursor
	[char] # escc! \ replace # with Esc
	type \ print to the screen
	1+ \ increase y for next time we're called
;

: logo ( x y -- ) \ color hourglass logo (15 rows x 32 columns)

	s" #[37;1m  @@@@@@@@@@@@@@@@@@@@@@@@@@@@" logo+
	s" @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" logo+
	s" @@@@@                    @@@@@" logo+
	s"     @@@@@            @@@@@    " logo+
	s"  @@@@@@@@@@@       @@@@@@@@@@@" logo+
	s"       #[31;1m\\\\\         /////     " logo+
	s" ))))))))))))       (((((((((((" logo+
	s"       /////         \\\\\     #[m" logo+
	s" #[37;1m @@@@@@@@@@@       @@@@@@@@@@@" logo+
	s"     @@@@@            @@@@@    " logo+
	s" @@@@@                    @@@@@" logo+
	s" @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" logo+
	s" @@@@@@@@@@@@@@@@@@@@@@@@@@@@  " logo+
	s"  #[m                              " logo+
	s"   17.1  ``Insert Name Here''  #[m" logo+

	2drop
;

\ Copyright (c) 2006-2015 Devin Teske <dteske@FreeBSD.org>
\ Copyright (c) 2016 Deciso B.V.
\ 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$

48 logoX ! 9 logoY ! \ Initialize logo placement defaults

: logo+ ( x y c-addr/u -- x y' )
	2swap 2dup at-xy 2swap \ position the cursor
	[char] # escc! \ replace # with Esc
	type \ print to the screen
	1+ \ increase y for next time we're called
;

: logo ( x y -- ) \ color hourglass logo (15 rows x 32 columns)

	s" #[37;1m  @@@@@@@@@@@@@@@@@@@@@@@@@@@@" logo+
	s" @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" logo+
	s" @@@@@                    @@@@@" logo+
	s"     @@@@@            @@@@@    " logo+
	s"  @@@@@@@@@@@       @@@@@@@@@@@" logo+
	s"       #[31;1m\\\\\         /////     " logo+
	s" ))))))))))))       (((((((((((" logo+
	s"       /////         \\\\\     #[m" logo+
	s" #[37;1m @@@@@@@@@@@       @@@@@@@@@@@" logo+
	s"     @@@@@            @@@@@    " logo+
	s" @@@@@                    @@@@@" logo+
	s" @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" logo+
	s" @@@@@@@@@@@@@@@@@@@@@@@@@@@@  " logo+
	s"  #[m                              " logo+
	s"    16.7 ``Dancing Dolphin''   #[m" logo+

	2drop
;


Comments.

Comments.

\ serCM3_sapi_p.fth - SAPI polled RX, polled TX, serial communication drivers
\ Written to run against the SockPuppet API.

((
Adapted from: the LPC polled driver.
))

only forth definitions
variable cnt.pause

\ ==============
\ *! serCM3_sapi_p
\ *T SAPI polled serial driver
\ ==============
\ *P This driver provides polled serial comms for Cortex-M3 CPUs
\ ** using the internal UARTs via the SAPI call layer.

\ ****************
\ *S Configuration
\ ****************
\ *P Configuration is managed by the SAPI

\ ********
\ *S Tools
\ ********

target

\ ********************
\ *S Serial primitives
\ ********************

0 value sercallback

internal

: +FaultConsole	( -- )  ;
\ *G Because this is a polled driver, *\fo{+FaultConsole} for
\ ** fault handling is a *\fo{NOOP}. See *\i{Cortex/FaultCortex.fth}
\ ** for more details.

target

CODE (seremitfc)	\ char base --
\ *G Service call for a single char - just fill in the registers
\ from the stack and make the call, and get back the flow control feedback
\ Put TOS into r0, pull r1 off the stack, and refresh the stack.
	mov r0, tos
	ldr r1, [ psp ], # 4
	svc # SAPI_VEC_PUTCHAR
	mov tos, r0
    next,
END-CODE

: (seremit)	\ char base --
\ *G Wrapped call that checks for throttling, and if so,
\ calls PAUSE to let another task run.  Count these events for debugging purposes.
	(seremitfc)
	0<> IF 1 cnt.pause +! #5 ms THEN
	;

: (sertype)	\ caddr len base --
\ *G Transmit a string on the given UART.
  -rot bounds
  ?do  i c@ over (seremit)  loop
  drop
;

: (sercr)	\ base --
\ *G Transmit a CR/LF pair on the given UART.
  $0D over (seremit)  $0A swap (seremit)
;

CODE (sergetchar) \ base -- c
\ *G Get a character from the port
	mov r0, tos
	svc # SAPI_VEC_GETCHAR
	mov tos, r0
	next,
END-CODE

CODE (serkey?)     \ base -- t/f
\ *G Return true if the given UART has a character avilable to read.
\ The call returns 0 or 1.
	mov r0, tos
	svc # SAPI_VEC_CHARSAVAIL
	mov tos, r0
	next,
END-CODE

: (serkey-basic)
	begin pause
	dup (serkey?) until
	(sergetchar)
;

: (serkey-sleep?)
	self tcb.bbstatus @ over 1 setiocallback drop ( base )
	self halt
	dup (serkey?) IF self restart ELSE PAUSE THEN \ We are now armed and ready to block
    (serkey?)
;

\ *G Wait for a character to come available on the given UART and
\ ** return the character.
\ Advanced usage - Register a callback.
\ The tricky part is not screwing things up by missing a character
\ in the window between when you register, and when you pick up your
\ character.   The way to do that is by registering, then self
\ halting, and then checking for a new character.  That ensures that
\ if a character has slipped in, you will catch it.
: (serkey)	\ base -- char
	begin dup (serkey-sleep?) until (sergetchar)
;

external

: seremit0	\ char --
\ *G Transmit a character on UART0.
  0 (seremit)  ;
: sertype0	\ c-addr len --
\ *G Transmit a string on UART0.
  0 (sertype)  ;
: sercr0	\ --
\ *G Issue a CR/LF pair to UART0.
  0 (sercr)  ;
: serkey?0	\ -- flag
\ *G Return true if UART0 has a character available.
  0 (serkey?)  ;
: serkey0	\ -- char
\ *G Wait for a character on UART0.
  0 (serkey)  ;
create Console0	\ -- addr ; OUT managed by upper driver
\ *G Generic I/O device for UART0.
  ' serkey0 ,		\ -- char ; receive char
  ' serkey?0 ,		\ -- flag ; check receive char
  ' seremit0 ,		\ -- char ; display char
  ' sertype0 ,		\ caddr len -- ; display string
  ' sercr0 ,		\ -- ; display new line

\ UART2
: seremit2      #2 (seremit)  ;
: sertype2	#2 (sertype)  ;
: sercr2	#2 (sercr)  ;
: serkey?2	#2 (serkey?)  ;
: serkey2	#2 (serkey)  ;
create Console2 ' serkey2 , ' serkey?2 , ' seremit2 , ' sertype2 , ' sercr2 ,

\ Versions for use with the TCP Port (10)
: seremit10  #10 (seremit)  ;
: sertype10	#10 (sertype)  ;
: sercr10	#10 (sercr)  ;
: serkey?10	#10 (serkey?)  ;
: serkey10	#10 (serkey)  ;
create Console10 ' serkey10 , ' serkey?10 , ' seremit10 , ' sertype10 , ' sercr10 ,

console-port 0 = [if]
  console0 constant console
\ *G *\fo{CONSOLE} is the device used by the Forth system for interaction.
\ ** It may be changed by one of the phrases of the form:
\ *C   <device>  dup opvec !  ipvec !
\ *C   <device>  SetConsole
[then]

console-port #1 = [if]
  console1 constant console
[then]

console-port  #10 = [if]
  console10 constant console
[then]

\ ************************
\ *S System initialisation
\ ************************

\ This is a NOP in the SAPI environment
: init-ser ;	\ --
\ *G Initialise all serial ports

\ ======
\ *> ###
\ ======

decimal

\ serCM3_sapi_p.fth - SAPI polled RX, polled TX, serial communication drivers
\ Written to run against the SockPuppet API.

((
Adapted from: the LPC polled driver.
))

only forth definitions
variable cnt.pause

\ ==============
\ *! serCM3_sapi_p
\ *T SAPI polled serial driver
\ ==============
\ *P This driver provides polled serial comms for Cortex-M3 CPUs
\ ** using the internal UARTs via the SAPI call layer.

\ ****************
\ *S Configuration
\ ****************
\ *P Configuration is managed by the SAPI

\ ********
\ *S Tools
\ ********

target

\ ********************
\ *S Serial primitives
\ ********************

0 value sercallback

internal

: +FaultConsole	( -- )  ;
\ *G Because this is a polled driver, *\fo{+FaultConsole} for
\ ** fault handling is a *\fo{NOOP}. See *\i{Cortex/FaultCortex.fth}
\ ** for more details.

target

CODE (seremitfc)	\ char base --
\ *G Service call for a single char - just fill in the registers
\ from the stack and make the call, and get back the flow control feedback
\ Put TOS into r0, pull r1 off the stack, and refresh the stack.
	mov r0, tos
	ldr r1, [ psp ], # 4
	svc # SAPI_VEC_PUTCHAR
	mov tos, r0
    next,
END-CODE

: (seremit)	\ char base --
\ *G Wrapped call that checks for throttling, and if so,
\ calls PAUSE to let another task run.  Count these events for debugging purposes.
	(seremitfc)
	0<> IF 1 cnt.pause +! #5 ms THEN
	;

: (sertype)	\ caddr len base --
\ *G Transmit a string on the given UART.
  -rot bounds
  ?do  i c@ over (seremit)  loop
  drop
;

: (sercr)	\ base --
\ *G Transmit a CR/LF pair on the given UART.
  $0D over (seremit)  $0A swap (seremit)
;

CODE (sergetchar) \ base -- c
\ *G Get a character from the port
	mov r0, tos
	svc # SAPI_VEC_GETCHAR
	mov tos, r0
	next,
END-CODE

CODE (serkey?)     \ base -- t/f
\ *G Return true if the given UART has a character avilable to read.
\ The call returns 0 or 1.
	mov r0, tos
	svc # SAPI_VEC_CHARSAVAIL
	mov tos, r0
	next,
END-CODE

: (serkey-basic)
	begin pause
	dup (serkey?) until
	(sergetchar)
;

: (serkey-sleep?)
	self tcb.bbstatus @ over 1 setiocallback drop ( base oldcb )
	self halt
	dup (serkey?) IF self restart ELSE PAUSE THEN \ We are now armed and ready to block
    (serkey?)
;

\ *G Wait for a character to come available on the given UART and
\ ** return the character.
\ Advanced usage - Register a callback.
\ The tricky part is not screwing things up by missing a character
\ in the window between when you register, and when you pick up your
\ character.   The way to do that is by registering, then self
\ halting, and then checking for a new character.  That ensures that
\ if a character has slipped in, you will catch it.
: (serkey)	\ base -- char
	begin dup (serkey-sleep?) until (sergetchar)
;

external

: seremit0	\ char --
\ *G Transmit a character on UART0.
  0 (seremit)  ;
: sertype0	\ c-addr len --
\ *G Transmit a string on UART0.
  0 (sertype)  ;
: sercr0	\ --
\ *G Issue a CR/LF pair to UART0.
  0 (sercr)  ;
: serkey?0	\ -- flag
\ *G Return true if UART0 has a character available.
  0 (serkey?)  ;
: serkey0	\ -- char
\ *G Wait for a character on UART0.
  0 (serkey)  ;
create Console0	\ -- addr ; OUT managed by upper driver
\ *G Generic I/O device for UART0.
  ' serkey0 ,		\ -- char ; receive char
  ' serkey?0 ,		\ -- flag ; check receive char
  ' seremit0 ,		\ -- char ; display char
  ' sertype0 ,		\ caddr len -- ; display string
  ' sercr0 ,		\ -- ; display new line

\ UART2
: seremit2      #2 (seremit)  ;
: sertype2	#2 (sertype)  ;
: sercr2	#2 (sercr)  ;
: serkey?2	#2 (serkey?)  ;
: serkey2	#2 (serkey)  ;
create Console2 ' serkey2 , ' serkey?2 , ' seremit2 , ' sertype2 , ' sercr2 ,

\ Versions for use with the TCP Port (10)
: seremit10  #10 (seremit)  ;
: sertype10	#10 (sertype)  ;
: sercr10	#10 (sercr)  ;
: serkey?10	#10 (serkey?)  ;
: serkey10	#10 (serkey)  ;
create Console10 ' serkey10 , ' serkey?10 , ' seremit10 , ' sertype10 , ' sercr10 ,

console-port 0 = [if]
  console0 constant console
\ *G *\fo{CONSOLE} is the device used by the Forth system for interaction.
\ ** It may be changed by one of the phrases of the form:
\ *C   <device>  dup opvec !  ipvec !
\ *C   <device>  SetConsole
[then]

console-port #1 = [if]
  console1 constant console
[then]

console-port  #10 = [if]
  console10 constant console
[then]

\ ************************
\ *S System initialisation
\ ************************

\ This is a NOP in the SAPI environment
: init-ser ;	\ --
\ *G Initialise all serial ports

\ ======
\ *> ###
\ ======

decimal