Fix an error message which was using the wrong variable to get the kernel name from.

\ 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 , ['] 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 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?

\ 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

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

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

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

only forth also support-functions definitions

: 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?
  reset_line_reading
  create_null_terminated_string
  over >r
  fopen fd !
  r> free-memory
  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
;

\ 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 -- )
  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}" 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)
\ 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 , ['] 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 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?

\ 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

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

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

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

only forth also support-functions definitions

: 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?
  reset_line_reading
  create_null_terminated_string
  over >r
  fopen fd !
  r> free-memory
  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
;

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


- m command accepts address - waste remaining memory with a help message ;-)

( vi:ft=forth

  Serial input output [X-Protocol] Example.
  Hardware: Launchpad
  Serial Port Settings: 2400,8,N,1

  Copyright [C] 2011 Chris Liechti <cliechti@gmx.net>
  All Rights Reserved.
  Simplified BSD License [see LICENSE.txt for full text]
)

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )
INCLUDE core.forth
INCLUDE msp430.forth
INCLUDE io.forth

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )

CODE WRITE ( s -- )
    TOS->R15
    ." \t call \x23 write\n "
    ASM-NEXT
END-CODE

CODE EMIT ( u -- )
    TOS->R15
    ." \t call \x23 putchar\n "
    ASM-NEXT
END-CODE

CODE TIMER_A_UART_INIT ( -- )
    ." \t call \x23 timer_uart_rx_setup\n "
    ASM-NEXT
END-CODE

CODE RX-CHAR ( -- u )
    ." \t mov.b timer_a_uart_rxd, W\n "
    ." \t push W\n "
    ASM-NEXT
END-CODE

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )
( Control the LEDs on the Launchpad )
: RED_ON    ( -- ) BIT0 P1OUT CSET ;
: RED_OFF   ( -- ) BIT0 P1OUT CRESET ;
: GREEN_ON  ( -- ) BIT6 P1OUT CSET ;
: GREEN_OFF ( -- ) BIT6 P1OUT CRESET ;

( Read in the button on the Launchpad )
: S2        P1IN C@ BIT3 AND NOT ;

( Delay functions )
: SHORT-DELAY     ( -- ) 0x4fff DELAY ;
: LONG-DELAY      ( -- ) 0xffff DELAY ;
: VERY-LONG-DELAY ( -- ) LONG-DELAY LONG-DELAY ;
( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )
( Simple event handler. A bit field is used to keep track of events. )
VARIABLE EVENTS
( Bit masks for the individual events )
BIT0 CONSTANT KEY-EVENT
BIT1 CONSTANT TIMER-EVENT
BIT2 CONSTANT RX-EVENT

( ------ Helper functions ------ )
( Start an event )
: START ( u -- ) EVENTS CSET ;
( Test if event was started. Reset its flag anyway and return true when it was set. )
: PENDING? ( -- b )
    DUP                 ( copy bit mask )
    EVENTS CTESTBIT IF  ( test if bit is set )
        EVENTS CRESET   ( it is, reset )
        TRUE            ( indicate true as return value )
    ELSE
        DROP            ( drop bit mask )
        FALSE           ( indicate false as return value )
    ENDIF
;
( Return true if no events are pending )
: IDLE? ( -- b )
    EVENTS C@ 0=
;
( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )

( Interrupt handler for P1 )
PORT1_VECTOR INTERRUPT P1-IRQ-HANDLER
    KEY-EVENT START     ( Set event flag for key )
    WAKEUP              ( terminate LPM modes )
    0 P1IFG C!          ( clear all interrupt flags )
END-INTERRUPT

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )

( Watchdog interrupts with SMCLK = 1MHz are too fast for us.
  Only wakeup every n-th interrupt. This is the counter
  used to achieve this. )
VARIABLE SLOWDOWN

( Interrupt handler for Watchdog module in timer mode )
WDT_VECTOR INTERRUPT WATCHDOG-TIMER-HANDLER
    SLOWDOWN C@ 1+     ( get and increment counter )
    DUP 30 > IF         ( check value )
        TIMER-EVENT START ( set event flag for timer )
        WAKEUP          ( terminate LPM modes )
        DROP 0          ( reset counter )
    ENDIF
    SLOWDOWN C!         ( store new value )
END-INTERRUPT

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )

( Received data is put into a small line buffer. When a newline
  is received processing in the foreground is started.
)
0 VALUE RX-POS
RAM CREATE RX-BUFFER 8 ALLOT

100 INTERRUPT TAUART_RX_INTERRUPT
    RX-CHAR DUP             ( get the received character )
    RX-BUFFER RX-POS + C!   ( store character )
    RX-POS 7 < IF           ( increment write pos if there is space )
        RX-POS 1+ TO RX-POS
    ENDIF
    '\n' = IF               ( check for EOL )
        RX-EVENT START      ( set event flag for reception )
        WAKEUP              ( terminate LPM modes )
        0 TO RX-POS         ( reset read position )
    ENDIF
END-INTERRUPT

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )
( Initializations run after reset )
: INIT ( -- )
    ( Initialize pins )
    OUT TACCTL0 !       ( Init Timer A CCTL before pin is activated DIR, SEL)
    BIT1 P1OUT C!       ( TXD )
    [ BIT1 BIT2 + ] LITERAL P1SEL C! ( TXD RXD )
    [ BIT0 BIT1 + BIT6 + ] LITERAL P1DIR C!
    BIT3 P1IES C!       ( select neg edge )
    0 P1IFG C!          ( reset flags )
    BIT3 P1IE C!        ( enable interrupts for S2 )

    ( Use Watchdog module as timer )
    [ WDTPW WDTTMSEL + ] LITERAL WDTCTL !
    WDTIE IE1 C!

    ( Initialize clock from calibration values )
    CALDCO_1MHZ DCOCTL  C@!
    CALBC1_1MHZ BCSCTL1 C@!

    ( Set up Timer A - used for UART )
    [ TASSEL1 MC1 + ] LITERAL TACTL !
    TIMER_A_UART_INIT

    ( Indicate startup with LED )
    GREEN_ON
    VERY-LONG-DELAY
    GREEN_OFF

    ( Enable interrupts now )
    EINT
;

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )

( Decode a hex digit, text -> number. supported input: 0123456789abcdefABCDEF )
( This decoding does not check for invalid characters. It will simply return
  garbage, however in the range of 0 ... 15 )
: HEXDIGIT ( char - u )
    DUP 'A' >= IF
        [ 'A' 10 - ] LITERAL -
    ENDIF
    0xf AND
;

( Decode text, hex digits, at given address and return value )
: HEX-DECODE ( adr -- u )
    DUP
    C@ HEXDIGIT 4 LSHIFT SWAP
    1+ C@ HEXDIGIT OR
;

( Output OK message )
: XOK ( -- )  ." xOK\n" ;

( Output one hex digit for the number on the stack )
: .HEXDIGIT ( u -- )
    0xf AND
    DUP 10 >= IF
        [ 'A' 10 - ] LITERAL
    ELSE
        '0'
    ENDIF
    + EMIT
;

( Output two hex digits for the byte on the stack )
: .HEX ( u -- )
    DUP
    4 RSHIFT .HEXDIGIT
    .HEXDIGIT
;

( Output a line with 16 bytes as hex and ASCII dump. Includes newline. )
: .HEXLINE ( adr -- )
    [CHAR] h EMIT BL EMIT               ( write prefix )
    OVER DUP 8 RSHIFT .HEX .HEX SPACE SPACE ( write address )
    DUP 16 + SWAP       ( calculate end_adr start_adr )
    ( output hex dump )
    BEGIN
        2DUP >          ( end address not yet reached )
    WHILE
        DUP C@ .HEX     ( hex dump of address )
        SPACE
        1+              ( next address )
    REPEAT
    ( reset address )
    16 -
    ( output ASCII dump )
    SPACE
    BEGIN
        2DUP >          ( end address not yet reached )
    WHILE
        DUP C@          ( get byte )
        DUP 32 < IF
            DROP [CHAR] .
        ENDIF
        EMIT
        1+              ( next address )
    REPEAT
    2DROP ." \n"        ( finish hex dump, drop address on stack )
;

( Print a hex dump of the given address range )
: HEXDUMP ( adr_hi adr_low -- )
    BEGIN
        2DUP >
    WHILE
        DUP .HEXLINE
        16 +
    REPEAT
;

( Main application, run after INIT )
: MAIN ( -- )
    BEGIN
        ( Test if events are pending )
        IDLE? IF
            ( XXX actually we could miss an event and go to sleep if it was set
                  between test and LPM. The event flag is not lost, but it is
                  executed later when some other event wakes up the CPU. )
            ( Wait in low power mode )
            ENTER-LPM0
        ENDIF
        ( After wakeup test for the different events )

        RX-EVENT PENDING? IF
            GREEN_ON    ( Show activity )
            ( RX-CHAR EMIT ( send echo )
            RX-BUFFER C@ CASE

                [CHAR] s OF         ( read switch command )
                    [CHAR] i EMIT
                    ( return state of button )
                    S2 IF [CHAR] 1 ELSE [CHAR] 0 ENDIF EMIT
                    '\n' EMIT
                    XOK
                ENDOF

                [CHAR] o OF         ( output a message / echo )
                    RX-BUFFER WRITE
                    XOK
                ENDOF

                [CHAR] c OF         ( memory dump of calibration values )
                    ( hex dump of INFOMEM segment with calibration values )
                    0x10ff 0x10c0 HEXDUMP
                    XOK
                ENDOF

                [CHAR] m OF         ( memory dump of given address, 64B blocks )
                    RX-BUFFER 1+ DUP HEX-DECODE 8 LSHIFT
                    SWAP 2+ HEX-DECODE OR
                    DUP 64 + SWAP HEXDUMP
                    XOK
                ENDOF

                [CHAR] h OF         ( help )
                    ." oCommands:\n"
                    ." o 's' \t\tread switch\n"
                    ." o 'oM..' \tEcho message\n"
                    ." o 'c' \t\tDump calibration\n"
                    ." o 'mHHHH' \thexdump of given address\n"
                    XOK
                ENDOF

                ( default )
                ." xERR (try 'h') unknown command: "
                RX-BUFFER WRITE
            ENDCASE
            RX-BUFFER 8 ZERO            ( erase buffer for next round )
            GREEN_OFF                   ( Activity done )
        ENDIF

        KEY-EVENT PENDING? IF
            ( Green flashing  )
            GREEN_ON
            SHORT-DELAY
            GREEN_OFF
        ENDIF

        TIMER-EVENT PENDING? IF
            ( Red flashing )
            RED_ON
            SHORT-DELAY
            RED_OFF
        ENDIF
(        S2 IF
        ELSE
        ENDIF
)
    AGAIN
;

( ========================================================================= )
( Generate the assembler file now )
" Advanced demo " HEADER

( output important runtime core parts )
" Core " HEADER
CROSS-COMPILE-CORE

( cross compile application )
" Application " HEADER
CROSS-COMPILE-VARIABLES
CROSS-COMPILE INIT
CROSS-COMPILE MAIN
CROSS-COMPILE P1-IRQ-HANDLER
CROSS-COMPILE WATCHDOG-TIMER-HANDLER
CROSS-COMPILE TAUART_RX_INTERRUPT
CROSS-COMPILE-MISSING ( This compiles all words that were used indirectly )

( vi:ft=forth

  Serial input output [X-Protocol] Example.
  Hardware: Launchpad
  Serial Port Settings: 2400,8,N,1

  Copyright [C] 2011 Chris Liechti <cliechti@gmx.net>
  All Rights Reserved.
  Simplified BSD License [see LICENSE.txt for full text]
)

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )
INCLUDE core.forth
INCLUDE msp430.forth
INCLUDE io.forth

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )

CODE WRITE ( s -- )
    TOS->R15
    ." \t call \x23 write\n "
    ASM-NEXT
END-CODE

CODE EMIT ( u -- )
    TOS->R15
    ." \t call \x23 putchar\n "
    ASM-NEXT
END-CODE

CODE TIMER_A_UART_INIT ( -- )
    ." \t call \x23 timer_uart_rx_setup\n "
    ASM-NEXT
END-CODE

CODE RX-CHAR ( -- u )
    ." \t mov.b timer_a_uart_rxd, W\n "
    ." \t push W\n "
    ASM-NEXT
END-CODE

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )
( Control the LEDs on the Launchpad )
: RED_ON    ( -- ) BIT0 P1OUT CSET ;
: RED_OFF   ( -- ) BIT0 P1OUT CRESET ;
: GREEN_ON  ( -- ) BIT6 P1OUT CSET ;
: GREEN_OFF ( -- ) BIT6 P1OUT CRESET ;

( Read in the button on the Launchpad )
: S2        P1IN C@ BIT3 AND NOT ;

( Delay functions )
: SHORT-DELAY     ( -- ) 0x4fff DELAY ;
: LONG-DELAY      ( -- ) 0xffff DELAY ;
: VERY-LONG-DELAY ( -- ) LONG-DELAY LONG-DELAY ;
( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )
( Simple event handler. A bit field is used to keep track of events. )
VARIABLE EVENTS
( Bit masks for the individual events )
BIT0 CONSTANT KEY-EVENT
BIT1 CONSTANT TIMER-EVENT
BIT2 CONSTANT RX-EVENT

( ------ Helper functions ------ )
( Start an event )
: START ( u -- ) EVENTS CSET ;
( Test if event was started. Reset its flag anyway and return true when it was set. )
: PENDING? ( -- b )
    DUP                 ( copy bit mask )
    EVENTS CTESTBIT IF  ( test if bit is set )
        EVENTS CRESET   ( it is, reset )
        TRUE            ( indicate true as return value )
    ELSE
        DROP            ( drop bit mask )
        FALSE           ( indicate false as return value )
    ENDIF
;
( Return true if no events are pending )
: IDLE? ( -- b )
    EVENTS C@ 0=
;
( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )

( Interrupt handler for P1 )
PORT1_VECTOR INTERRUPT P1-IRQ-HANDLER
    KEY-EVENT START     ( Set event flag for key )
    WAKEUP              ( terminate LPM modes )
    0 P1IFG C!          ( clear all interrupt flags )
END-INTERRUPT

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )

( Watchdog interrupts with SMCLK = 1MHz are too fast for us.
  Only wakeup every n-th interrupt. This is the counter
  used to achieve this. )
VARIABLE SLOWDOWN

( Interrupt handler for Watchdog module in timer mode )
WDT_VECTOR INTERRUPT WATCHDOG-TIMER-HANDLER
    SLOWDOWN C@ 1+     ( get and increment counter )
    DUP 30 > IF         ( check value )
        TIMER-EVENT START ( set event flag for timer )
        WAKEUP          ( terminate LPM modes )
        DROP 0          ( reset counter )
    ENDIF
    SLOWDOWN C!         ( store new value )
END-INTERRUPT

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )

( Received data is put into a small line buffer. When a newline
  is received processing in the foreground is started.
)
0 VALUE RX-POS
RAM CREATE RX-BUFFER 8 ALLOT

100 INTERRUPT TAUART_RX_INTERRUPT
    RX-CHAR DUP             ( get the received character )
    RX-BUFFER RX-POS + C!   ( store character )
    RX-POS 7 < IF           ( increment write pos if there is space )
        RX-POS 1+ TO RX-POS
    ENDIF
    '\n' = IF               ( check for EOL )
        RX-EVENT START      ( set event flag for reception )
        WAKEUP              ( terminate LPM modes )
        0 TO RX-POS         ( reset read position )
    ENDIF
END-INTERRUPT

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )
( Initializations run after reset )
: INIT ( -- )
    ( Initialize pins )
    OUT TACCTL0 !       ( Init Timer A CCTL before pin is activated DIR, SEL)
    BIT1 P1OUT C!       ( TXD )
    [ BIT1 BIT2 + ] LITERAL P1SEL C! ( TXD RXD )
    [ BIT0 BIT1 + BIT6 + ] LITERAL P1DIR C!
    BIT3 P1IES C!       ( select neg edge )
    0 P1IFG C!          ( reset flags )
    BIT3 P1IE C!        ( enable interrupts for S2 )

    ( Use Watchdog module as timer )
    [ WDTPW WDTTMSEL + ] LITERAL WDTCTL !
    WDTIE IE1 C!

    ( Initialize clock from calibration values )
    CALDCO_1MHZ DCOCTL  C@!
    CALBC1_1MHZ BCSCTL1 C@!

    ( Set up Timer A - used for UART )
    [ TASSEL1 MC1 + ] LITERAL TACTL !
    TIMER_A_UART_INIT

    ( Indicate startup with LED )
    GREEN_ON
    VERY-LONG-DELAY
    GREEN_OFF

    ( Enable interrupts now )
    EINT
;

( - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - )

( Output OK message )
: XOK ( -- )  ." xOK\n" ;

( Output one hex digit for the number on the stack )
: .HEXDIGIT ( u -- )
    0xf AND
    DUP 10 >= IF
        [ 'A' 10 - ] LITERAL
    ELSE
        '0'
    ENDIF
    + EMIT
;

( Output two hex digits for the byte on the stack )
: .HEX ( u -- )
    DUP
    4 RSHIFT .HEXDIGIT
    .HEXDIGIT
;

( Output a line with 16 bytes as hex and ASCII dump. Includes newline. )
: .HEXLINE ( adr -- )
    [CHAR] h EMIT BL EMIT               ( write prefix )
    OVER DUP 8 RSHIFT .HEX .HEX SPACE SPACE ( write address )
    DUP 16 + SWAP       ( calculate end_adr start_adr )
    ( output hex dump )
    BEGIN
        2DUP >          ( end address not yet reached )
    WHILE
        DUP C@ .HEX     ( hex dump of address )
        SPACE
        1+              ( next address )
    REPEAT
    ( reset address )
    16 -
    ( output ASCII dump )
    SPACE
    BEGIN
        2DUP >          ( end address not yet reached )
    WHILE
        DUP C@          ( get byte )
        DUP 32 < IF
            DROP [CHAR] .
        ENDIF
        EMIT
        1+              ( next address )
    REPEAT
    2DROP ." \n"        ( finish hex dump, drop address on stack )
;

( Print a hex dump of the given address range )
: HEXDUMP ( adr_hi adr_low -- )
    BEGIN
        2DUP >
    WHILE
        DUP .HEXLINE
        16 +
    REPEAT
;

( Main application, run after INIT )
: MAIN ( -- )
    BEGIN
        ( Test if events are pending )
        IDLE? IF
            ( XXX actually we could miss an event and go to sleep if it was set
                  between test and LPM. The event flag is not lost, but it is
                  executed later when some other event wakes up the CPU. )
            ( Wait in low power mode )
            ENTER-LPM0
        ENDIF
        ( After wakeup test for the different events )

        RX-EVENT PENDING? IF
            GREEN_ON    ( Show activity )
            ( RX-CHAR EMIT ( send echo )
            RX-BUFFER C@ CASE

                [CHAR] s OF         ( read switch command )
                    [CHAR] i EMIT
                    ( return state of button )
                    S2 IF [CHAR] 1 ELSE [CHAR] 0 ENDIF EMIT
                    '\n' EMIT
                    XOK
                ENDOF

                [CHAR] o OF         ( output a message / echo )
                    RX-BUFFER WRITE
                    XOK
                ENDOF

                [CHAR] m OF         ( memory dump )
                    ( XXX read start address and range from command )
                    ( hex dump of INFOMEM segment with calibration values )
                    0x10ff 0x10c0 HEXDUMP
                    XOK
                ENDOF

                ( default )
                ." xERR unknown command: "
                RX-BUFFER WRITE
            ENDCASE
            RX-BUFFER 8 ZERO            ( erase buffer for next round )
            GREEN_OFF                   ( Activity done )
        ENDIF

        KEY-EVENT PENDING? IF
            ( Green flashing  )
            GREEN_ON
            SHORT-DELAY
            GREEN_OFF
        ENDIF

        TIMER-EVENT PENDING? IF
            ( Red flashing )
            RED_ON
            SHORT-DELAY
            RED_OFF
        ENDIF
(        S2 IF
        ELSE
        ENDIF
)
    AGAIN
;

( ========================================================================= )
( Generate the assembler file now )
" Advanced demo " HEADER

( output important runtime core parts )
" Core " HEADER
CROSS-COMPILE-CORE

( cross compile application )
" Application " HEADER
CROSS-COMPILE-VARIABLES
CROSS-COMPILE INIT
CROSS-COMPILE MAIN
CROSS-COMPILE P1-IRQ-HANDLER
CROSS-COMPILE WATCHDOG-TIMER-HANDLER
CROSS-COMPILE TAUART_RX_INTERRUPT
CROSS-COMPILE-MISSING ( This compiles all words that were used indirectly )


fix irc nick bug

fix irc nick bug

package IRC::Handlers

share $handlers = (
    PING:       ping,
    "001":      welcome,
    "004":      myInfo,
    "376":      endOfMOTD,      # end of motd
    "396":      hiddenHost,     # is now your hidden host
    "422":      endOfMOTD,      # no motd found
    "433":      nickInUse       # nickname already in use
)

func ping {
    need $msg
    %send("PONG :" + $msg.params[-1])
}

func welcome {
    need $msg
    %registered = true          # remember that we've finished registration
    %me.nick = $msg.params[0]   # assume the target is our actual nickname

    # we can't actually depend on this always being the case, but a
    # lot of IRC servers have nick!ident@host as the final word here.
    # if not, we will get that info the first time we recv a message from %me.
    if $msg.params[-1] =~ /(\S+)!(.+)\@(.+)$/ {
        %me.nick = $1
        %me.user = $2
        %me.host = $3
        %me.realHost = $3
    }
}

func myInfo {
    need $msg
    %server.name    = $msg.params[1]
    %server.version = $msg.params[2]
}

func endOfMOTD {
    if !%autojoin || %_didAutojoin
        return
    %sendJoin(channelNames: %autojoin)
    %_didAutojoin = true
}

# recv: :k.notroll.net 396 booby 73.88.xkw.t :is now your hidden host
func hiddenHost {
    need $msg
    %me.host = $msg.params[1]
}

# during registration, add underscores to nickname as necessary
func nickInUse {
    if %registered
        return
    %me.nick += "_"
    %sendNick(%me.nick)
}

package IRC::Handlers

share $handlers = (
    PING:       ping,
    "001":      welcome,
    "004":      myInfo,
    "376":      endOfMOTD,      # end of motd
    "396":      hiddenHost,     # is now your hidden host
    "422":      endOfMOTD,      # no motd found
    "433":      nickInUse       # nickname already in use
)

func ping {
    need $msg
    %send("PONG :" + $msg.params[-1])
}

func welcome {
    need $msg
    %registered = true          # remember that we've finished registration
    %me.nick = $msg.params[0]   # assume the target is our actual nickname

    # we can't actually depend on this always being the case, but a
    # lot of IRC servers have nick!ident@host as the final word here.
    # if not, we will get that info the first time we recv a message from %me.
    if $msg.params[-1] =~ /^(.+)!(.+)\@(.+)$/ {
        %me.nick = $1
        %me.user = $2
        %me.host = $3
        %me.realHost = $3
    }
}

func myInfo {
    need $msg
    %server.name    = $msg.params[1]
    %server.version = $msg.params[2]
}

func endOfMOTD {
    if !%autojoin || %_didAutojoin
        return
    %sendJoin(channelNames: %autojoin)
    %_didAutojoin = true
}

# recv: :k.notroll.net 396 booby 73.88.xkw.t :is now your hidden host
func hiddenHost {
    need $msg
    %me.host = $msg.params[1]
}

# during registration, add underscores to nickname as necessary
func nickInUse {
    if %registered
        return
    %me.nick += "_"
    %sendNick(%me.nick)
}


Turn off verbose logging

Turn off verbose logging

\ The test cases in John Hayes' original test suite were designed to test
\ features before they were used in later tests. Due to the structure of
\ this annex the progressive testing has been lost. This section attempts
\ to retain the integrity of the original test suite by laying out the
\ test progression for the core word set.
\
\ While this suite does test many aspects of the core word set, it is not
\ comprehensive. A standard system should pass all of the tests within this
\ suite. A system cannot claim to be standard simply because it passes this
\ test suite.
\
\ The test starts by verifying basic assumptions about number representation.
\ It then builds on this with tests of boolean logic, shifting, and comparisons.
\ It then tests the basic stack manipulations and arithmetic. Ultimately, it
\ tests the Forth interpreter and compiler.
\
\ Note that all of the tests in this suite assume the current base is hexadecimal.

\ ------------------------------------------------------------------------

require forth/tester.fth

0 VERBOSE !
HEX

TESTING CORE WORDS

\ The test cases in John Hayes' original test suite were designed to test
\ features before they were used in later tests. Due to the structure of
\ this annex the progressive testing has been lost. This section attempts
\ to retain the integrity of the original test suite by laying out the
\ test progression for the core word set.
\
\ While this suite does test many aspects of the core word set, it is not
\ comprehensive. A standard system should pass all of the tests within this
\ suite. A system cannot claim to be standard simply because it passes this
\ test suite.
\
\ The test starts by verifying basic assumptions about number representation.
\ It then builds on this with tests of boolean logic, shifting, and comparisons.
\ It then tests the basic stack manipulations and arithmetic. Ultimately, it
\ tests the Forth interpreter and compiler.
\
\ Note that all of the tests in this suite assume the current base is hexadecimal.

\ ------------------------------------------------------------------------

require forth/tester.fth

1 VERBOSE !
HEX

TESTING CORE WORDS


Re-Write for the new API.

Re-Write for the new API.

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

\ Level 0 support, with WFI instead of pause.
\ The SAPI is a system call interace, so there is no blocking.
\ KEY requires blocking, so that must be implemented here.

only forth definitions

\ ==============
\ *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.   This is
\ ** The simplest implementation level.

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

target

\ ********************
\ *S Serial primitives
\ ********************
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 --
\ This is a system call.

: (seremit)	\ char base --
\ *G Wrapped call that checks for throttling, and if so,
\ calls PAUSE to let another task run, or just does a WFI if no multitasker.
\ The only interesting thing is failure, or -1.  That means retry.
	begin
	2dup (seremitfc) dup 0 < \ char base ret t/f
	IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] THEN \ char base ret
    0 >= until
    2drop
	;

: (sertype) \ caddr len base --
\ *G Transmit a string on the given UART.
\ * The system call wants     base len caddr
\ * and it returns the number of characters sent.
	>R  \ We'll use this a few times.
	begin
	2dup R@ (sertypefc)  dup >R \ caddr len ret
	- dup IF \ If there are still characters left
	  [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then]
	  swap R> + swap \ finish advancing the caddr len pair
	ELSE R> drop
	THEN
	dup 0= until \ Do this until nothing is left.
	2drop
	R> drop
;

: (sercr)	\ base --
\ *G Transmit a CR/LF pair on the given UART.
\ Wrapped version, just like (seremit)
	begin
	dup (sercrfc) dup 0= \ base ret t/f
    IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] THEN \ base ret
    until
    drop
	;

: (serkey) \ base -- c
\ *G Get a character from the port.  Retry until we get it.
\ See if its negative.  If so, discard it and leave false to re-loop.
\ If not negative, leave true on the stack to exit.
    begin \ base ret t/f
	dup (serkeyfc) dup 0 <  \ base ret t/f
	 IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] drop false
	 ELSE true
	 THEN \ base ret t/f
	until  \ base ret
	swap drop
;

\ THis is a system call.
\ CODE (serkey?)     \ base -- t/f
\ *G Return true if the given UART has a character avilable to read.

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

\ Non-UARTs.
: 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  #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_level0.fth - SAPI polled RX, polled TX, serial communication drivers
\ Written to run against the SockPuppet API.

\ Level 0 support, with WFI instead of pause.
\ The SAPI is a system call interace, so there is no blocking.
\ KEY requires blocking, so that must be implemented here.

only forth definitions

\ ==============
\ *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.   This is
\ ** The simplest implementation level.

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

target

\ ********************
\ *S Serial primitives
\ ********************
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 --
\ This is a system call.

: (seremit)	\ char base --
\ *G Wrapped call that checks for throttling, and if so,
\ calls PAUSE to let another task run, or just does a WFI if no multitasker.
\ The only interesting thing is failure, or -1.  That means retry.
	begin
	2dup (seremitfc) dup 0 < \ char base ret t/f
	IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] THEN \ char base ret
    0 >= until
    2drop
	;

: (sertype) \ caddr len base --
\ *G Transmit a string on the given UART.
\ * The system call wants     base len caddr
	>R  \ We'll use this a few times.
	begin
	2dup R@ (sertypefc)  dup \ caddr len ret ret
	IF
	  [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then]
	  dup >R - swap R> + swap \ Advance the caddr len pair
	THEN
	0= until
	2drop
	R> drop
;

: (sercr)	\ base --
\ *G Transmit a CR/LF pair on the given UART.
\ Wrapped version, just like (seremit)
	begin
	dup (sercrfc) dup 0= \ base ret t/f
    IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] THEN \ base ret
    until
    drop
	;

: (serkey) \ base -- c
\ *G Get a character from the port.  Retry until we get it.
\ See if its negative.  If so, discard it and leave false to re-loop.
\ If not negative, leave true on the stack to exit.
    begin \ base ret t/f
	dup (serkeyfc) dup 0 <  \ base ret t/f
	 IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] drop false
	 ELSE true
	 THEN \ base ret t/f
	until  \ base ret
	swap drop
;

\ THis is a system call.
\ CODE (serkey?)     \ base -- t/f
\ *G Return true if the given UART has a character avilable to read.

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

\ Non-UARTs.
: 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  #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


Added Forth example

Added Forth example

: HELLO-WORLD ." Hello, World! " CR ;
HELLO-WORLD

error: pathspec 'examples/hello.fth' did not match any file(s) known to git


Adds EVENP and ODDP.

Adds EVENP and ODDP.

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/SamSkulls/filth.git/'


Initial system calls stuff.

Initial system calls stuff.

\ Wrappers for SAPI functions, ABI 4.0

\ Note that the system call number is embedded into the instruction,
\ so this is not so easily parameterized.

#0 equ SAPI_VEC_VERSION
#1 equ SAPI_VEC_01_GetRuntimeLinks
#2 equ SAPI_VEC_02_PutChar
#3 equ SAPI_VEC_03_GetChar
#4 equ SAPI_VEC_04_GetCharAvail
#5 equ SAPI_VEC_05_PutString
#6 equ SAPI_VEC_06_EOL
#14 equ SAPI_VEC_14_PetWatchdog
#15 equ SAPI_VEC_15_GetTimeMS

CODE SAPI-Version  \ -- n
\ *G Get the version of the binary ABI in use.
	svc # SAPI_VEC_VERSION
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

CODE GETRUNTIMELINKS  \ type -- n
\ *G Get the runtime linking information.   Type 0 - A Dynamic linking
\ ** table with name, address pairs.  Type 1 - A Zero-Terminated Jump table.
	mov r0, tos
	svc # SAPI_VEC_01_GetRuntimeLinks
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

CODE (seremitfc) \ char base --
\ *G Service call for a single char - This one has a special name because
\ ** It'll be wrapped by something that can respond to the flow control
\ ** return code and PAUSE + Retry
	mov r0, tos
	ldr r1, [ psp ], # 4
	mov r2, # 0 \ Don't request a wake.
	svc # SAPI_VEC_02_PutChar
	mov tos, r0
    next,
END-CODE

CODE (serkeyfc) \ base -- char
\ *G Get a character from the port, or -1 for fail
	mov r0, tos
	mov r1, # 0 \ No blocking.
	svc # SAPI_VEC_03_GetChar
	mov tos, r0
	next,
END-CODE

CODE (serkey?) \ base -- t/f
\ *G Return true if the given stream has a character avilable to read.
\ The call returns the number of chars available.
	mov r0, tos
	svc # SAPI_VEC_04_GetCharAvail
	mov tos, r0
	next,
END-CODE

\ These two can be created from simpler things, and are optional.
\ CODE (type)
\ END-CODE

\ CODE (cr)
\ END-CODE

CODE PetWatchDog  \ n --
\ *G Refresh the watchdog.  Pass in a platform-specific number
\ ** To specify a timerout (if supported), or zero for the default value.
	mov r0, tos
	ldr r1, [ psp ], # 4
	svc # SAPI_VEC_14_PetWatchdog
	ldr tos, [ psp ], # 4
	next,
END-CODE

CODE TICKS  \ -- n
\ *G The current value of the millisecond ticker.
	svc # SAPI_VEC_15_GetTimeMS
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

error: pathspec 'leopard/usbforth/SysCalls.fth' did not match any file(s) known to git


Add forth tic-tac-toe

Add forth tic-tac-toe

variable board 8 allot
board 9 0 fill
variable turn
1 turn !

: output-player ( player -- )
case
0 of ." . " endof
1 of ." X " endof
2 of ." O " endof
     ." ? "
endcase ;

: output-board 9 0 do board i + c@ output-player i 3 mod 2 = if cr then loop ;
: output page output-board turn c@ output-player ." to play " cr ;
: output-victory page output-board turn c@ output-player ." wins " cr ;
: output-draw page output-board ." cat's game " cr ;

: ascii-to-pos ( ascii -- pos )
case
113 ( q ) of 0 endof
119 ( w ) of 1 endof
101 ( e ) of 2 endof
97  ( a ) of 3 endof
115 ( s ) of 4 endof
100 ( d ) of 5 endof
122 ( z ) of 6 endof
120 ( x ) of 7 endof
99  ( c ) of 8 endof
             -1
endcase ;

: swap-turn turn @ 2 mod 1 + turn ! ;
: set-cell ( n v -- ) swap board + c! ;
: cell-empty? ( n -- e? ) board + c@ 0 = ;

: do-move ( pos -- ) turn c@ set-cell swap-turn ;
: try-move ( pos -- ) dup cell-empty? if do-move else drop then ;

: get-input ( -- pos ) key ascii-to-pos ;
: try-input ( -- ) get-input dup -1 <> if try-move else drop then ;

: 3check ( a b c -- win? ) over = rot rot over = rot and swap 0 <> and ;

: ?victory ( -- v? )
board     c@ board 3 + c@ board 6 + c@ 3check
board 1 + c@ board 4 + c@ board 7 + c@ 3check or
board 2 + c@ board 5 + c@ board 8 + c@ 3check or
board     c@ board 1 + c@ board 2 + c@ 3check or
board 3 + c@ board 4 + c@ board 5 + c@ 3check or
board 6 + c@ board 7 + c@ board 8 + c@ 3check or
board     c@ board 4 + c@ board 8 + c@ 3check or
board 2 + c@ board 4 + c@ board 6 + c@ 3check or
;

: ?draw ( -- d? ) 1 9 0 do board i + c@ 0 <> and loop ;
: ?game-end ( -- e? ) ?victory ?draw or ;
: show-end ?victory if swap-turn output-victory else output-draw then ;

: reset-board 9 0 do 0 board i + c! loop ;
: reset-turn 1 turn c! ;
: reset-game reset-board reset-turn ;

: game begin output try-input ?game-end until show-end ;
: replay-loop begin reset-game game ." play again? (y/n) " cr key 121 <> until bye ;

replay-loop

error: pathspec 'forth/ttt.fth' did not match any file(s) known to git


new file: add support for multiple numeric bases

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/crcx/rx-nga.git/'


Initial wall clock code.

Initial wall clock code.

(( Clock Code ))

\ The gadget that drives it all.   This is rigged for debugging,
\ terminate it by setting clockterm to non-zero.
: CLOCKSTART ( n -- )
  icroot inter.rtcsem 0 over ! \ Reset the free-running counter.
  swap \ addr n --
  0 do
   dup @resetex! ?dup if advance else [asm wfi asm] then
  loop
  drop
;

: CLOCKINIT ( -- )
  #1000 needlemax
  2dup ! 4 + 2dup ! 4 +  !
;

\ Heres where we advance any needles.
: ADVANCE ( n -- )
  pwm0@ + pwm0!
;

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
udata
create NEEDLEMAX 3 cells allot
cdata

: ++NEEDLE_S ; \ Called ever time.
: ++NEEDLE_M ; \ Every time we roll the seconds.

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

\ ----------------------------------------------------------
\ Keeping track of the time.
\ ----------------------------------------------------------
struct _HMS
	int hms.subsec
	int hms.s
	int hms.m
	int hms.h
	int hms.maxsubsec \ Max Value for subseconds
	int hms.maxs+m \ Max Value for secs+minutes
	int hms.maxh   \ Max for hours
	ptr hms.w_s    \ Increment the seconds value
	ptr hms.w_mh   \ increment the minutes + hours
end-struct

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_s , ' ++needle_m , \ 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 -- )
  ++needle_s  1 over hms.subsec +!
   dup hms.subsec @ #16 < if drop exit then
  0 over hms.subsec ! \ Reset the subsecs

  ++needle_m 1 over hms.s +!
   dup hms.s @ #60 < if drop exit then
  0 over hms.s ! \ Reset the seconds

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

  1 over hms.h +!
   dup hms.h @ #24 < 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 ;

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

error: pathspec 'zero/clock-umb/forth/Clock.fth' did not match any file(s) known to git


new sample code: html generation

new sample code: html generation


Update static/vendors/ace-builds/demo/kitchen-sink/docs/forth.frt

Signed-off-by: Bernard Ojengwa <fccb4cc00c1ba7e51bf5c2b5f77130b9fe8d917e@gmail.com>

: HELLO  ( -- )  CR ." Hello, world!" ;

HELLO <cr>
Hello, world!

: [CHAR]   CHAR  POSTPONE LITERAL ; IMMEDIATE

0 value ii        0 value jj
0 value KeyAddr   0 value KeyLen
create SArray   256 allot   \ state array of 256 bytes
: KeyArray      KeyLen mod   KeyAddr ;

: get_byte      + c@ ;
: set_byte      + c! ;
: as_byte       255 and ;
: reset_ij      0 TO ii   0 TO jj ;
: i_update      1 +   as_byte TO ii ;
: j_update      ii SArray get_byte +   as_byte TO jj ;
: swap_s_ij
    jj SArray get_byte
       ii SArray get_byte  jj SArray set_byte
    ii SArray set_byte
;

: rc4_init ( KeyAddr KeyLen -- )
    256 min TO KeyLen   TO KeyAddr
    256 0 DO   i i SArray set_byte   LOOP
    reset_ij
    BEGIN
        ii KeyArray get_byte   jj +  j_update
        swap_s_ij
        ii 255 < WHILE
        ii i_update
    REPEAT
    reset_ij
;
: rc4_byte
    ii i_update   jj j_update
    swap_s_ij
    ii SArray get_byte   jj SArray get_byte +   as_byte SArray get_byte  xor
;

error: pathspec 'static/vendors/ace-builds/demo/kitchen-sink/docs/forth.frt' did not match any file(s) known to git