crank version of the ofwboot, so we can tell which is which

\	$OpenBSD: bootblk.fth,v 1.6 2010/02/26 23:03:50 deraadt Exp $
\	$NetBSD: bootblk.fth,v 1.3 2001/08/15 20:10:24 eeh Exp $
\
\	IEEE 1275 Open Firmware Boot Block
\
\	Parses disklabel and UFS and loads the file called `ofwboot'
\
\
\	Copyright (c) 1998 Eduardo Horvath.
\	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.
\	3. All advertising materials mentioning features or use of this software
\	   must display the following acknowledgement:
\	     This product includes software developed by Eduardo Horvath.
\	4. The name of the author may not be used to endorse or promote products
\	   derived from this software without specific prior written permission
\
\	THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 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.
\

offset16
hex
headers

false value boot-debug?

\
\ First some housekeeping:  Open /chosen and set up vectors into
\	client-services

" /chosen" find-package 0=  if ." Cannot find /chosen" 0 then
constant chosen-phandle

" /openprom/client-services" find-package 0=  if
	." Cannot find client-services" cr abort
then constant cif-phandle

defer cif-claim ( align size virt -- base )
defer cif-release ( size virt -- )
defer cif-open ( cstr -- ihandle|0 )
defer cif-close ( ihandle -- )
defer cif-read ( len adr ihandle -- #read )
defer cif-seek ( low high ihandle -- -1|0|1 )
\ defer cif-peer ( phandle -- phandle )
\ defer cif-getprop ( len adr cstr phandle -- )

: find-cif-method ( method,len -- xf )
   cif-phandle find-method drop
;

" claim" find-cif-method to cif-claim
" open" find-cif-method to cif-open
" close" find-cif-method to cif-close
" read" find-cif-method to cif-read
" seek" find-cif-method to cif-seek

: twiddle ( -- ) ." ." ; \ Need to do this right.  Just spit out periods for now.

\
\ Support routines
\

: strcmp ( s1 l1 s2 l2 -- true:false )
   rot tuck <> if  3drop false exit then
   comp 0=
;

\ Move string into buffer

: strmov ( s1 l1 d -- d l1 )
   dup 2over swap -rot		( s1 l1 d s1 d l1 )
   move				( s1 l1 d )
   rot drop swap
;

\ Move s1 on the end of s2 and return the result

: strcat ( s1 l1 s2 l2 -- d tot )
   2over swap 				( s1 l1 s2 l2 l1 s1 )
   2over + rot				( s1 l1 s2 l2 s1 d l1 )
   move rot + 				( s1 s2 len )
   rot drop				( s2 len )
;

: strchr ( s1 l1 c -- s2 l2 )
   begin
      dup 2over 0= if			( s1 l1 c c s1  )
         2drop drop exit then
      c@ = if				( s1 l1 c )
         drop exit then
      -rot /c - swap ca1+		( c l2 s2 )
     swap rot
  again
;

: cstr ( ptr -- str len )
   dup
   begin dup c@ 0<>  while + repeat
   over -
;

\
\ BSD FFS parameters
\

fload	assym.fth.h

sbsize buffer: sb-buf
-1 value boot-ihandle
dev_bsize value bsize
0 value raid-offset	\ Offset if it's a raid-frame partition

: strategy ( addr size start -- nread )
   raid-offset + bsize * 0 " seek" boot-ihandle $call-method
   -1 = if
      ." strategy: Seek failed" cr
      abort
   then
   " read" boot-ihandle $call-method
;

\
\ Cylinder group macros
\

: cgbase ( cg fs -- cgbase ) fs_fpg l@ * ;
: cgstart ( cg fs -- cgstart )
   2dup fs_cgmask l@ not and		( cg fs stuff -- )
   over fs_cgoffset l@ * -rot		( stuffcg fs -- )
   cgbase +
;
: cgdmin ( cg fs -- 1st-data-block ) dup fs_dblkno l@ -rot cgstart + ;
: cgimin ( cg fs -- inode-block ) dup fs_iblkno l@ -rot cgstart + ;
: cgsblock ( cg fs -- super-block ) dup fs_sblkno l@ -rot cgstart + ;
: cgstod ( cg fs -- cg-block ) dup fs_cblkno l@ -rot cgstart + ;

\
\ Block and frag position macros
\

: blkoff ( pos fs -- off ) fs_qbmask x@ and ;
: fragoff ( pos fs -- off ) fs_qfmask x@ and ;
: lblktosize ( blk fs -- off ) fs_bshift l@ << ;
: lblkno ( pos fs -- off ) fs_bshift l@ >> ;
: numfrags ( pos fs -- off ) fs_fshift l@ >> ;
: blkroundup ( pos fs -- off ) dup fs_bmask l@ -rot fs_qbmask x@ + and ;
: fragroundup ( pos fs -- off ) dup fs_fmask l@ -rot fs_qfmask x@ + and ;
\ : fragroundup ( pos fs -- off ) tuck fs_qfmask x@ + swap fs_fmask l@ and ;
: fragstoblks ( pos fs -- off ) fs_fragshift l@ >> ;
: blkstofrags ( blk fs -- frag ) fs_fragshift l@ << ;
: fragnum ( fsb fs -- off ) fs_frag l@ 1- and ;
: blknum ( fsb fs -- off ) fs_frag l@ 1- not and ;
: dblksize ( lbn dino fs -- size )
   -rot 				( fs lbn dino )
   di_size x@				( fs lbn di_size )
   -rot dup 1+				( di_size fs lbn lbn+1 )
   2over fs_bshift l@			( di_size fs lbn lbn+1 di_size b_shift )
   rot swap <<	>=			( di_size fs lbn res1 )
   swap ndaddr >= or if			( di_size fs )
      swap drop fs_bsize l@ exit	( size )
   then	tuck blkoff swap fragroundup	( size )
;

: ino-to-cg ( ino fs -- cg ) fs_ipg l@ / ;
: ino-to-fsbo ( ino fs -- fsb0 ) fs_inopb l@ mod ;
: ino-to-fsba ( ino fs -- ba )	\ Need to remove the stupid stack diags someday
   2dup 				( ino fs ino fs )
   ino-to-cg				( ino fs cg )
   over					( ino fs cg fs )
   cgimin				( ino fs inode-blk )
   -rot					( inode-blk ino fs )
   tuck 				( inode-blk fs ino fs )
   fs_ipg l@ 				( inode-blk fs ino ipg )
   mod					( inode-blk fs mod )
   swap					( inode-blk mod fs )
   dup 					( inode-blk mod fs fs )
   fs_inopb l@ 				( inode-blk mod fs inopb )
   rot 					( inode-blk fs inopb mod )
   swap					( inode-blk fs mod inopb )
   /					( inode-blk fs div )
   swap					( inode-blk div fs )
   blkstofrags				( inode-blk frag )
   +
;
: fsbtodb ( fsb fs -- db ) fs_fsbtodb l@ << ;

\
\ File stuff
\

niaddr /w* constant narraysize

struct
   8		field	>f_ihandle	\ device handle
   8 		field 	>f_seekp	\ seek pointer
   8 		field 	>f_fs		\ pointer to super block
   ufs1_dinode_SIZEOF 	field 	>f_di	\ copy of on-disk inode
   8		field	>f_buf		\ buffer for data block
   4		field 	>f_buf_size	\ size of data block
   4		field	>f_buf_blkno	\ block number of data block
constant file_SIZEOF

file_SIZEOF buffer: the-file
sb-buf the-file >f_fs x!

ufs1_dinode_SIZEOF buffer: cur-inode
h# 2000 buffer: indir-block
-1 value indir-addr

\
\ Translate a fileblock to a disk block
\
\ We only allow single indirection
\

: block-map ( fileblock -- diskblock )
   \ Direct block?
   dup ndaddr <  if 			( fileblock )
      cur-inode di_db			( arr-indx arr-start )
      swap la+ l@ exit			( diskblock )
   then 				( fileblock )
   ndaddr -				( fileblock' )
   \ Now we need to check the indirect block
   dup sb-buf fs_nindir l@ <  if	( fileblock' )
      cur-inode di_ib l@ dup		( fileblock' indir-block indir-block )
      indir-addr <>  if 		( fileblock' indir-block )
         to indir-addr			( fileblock' )
         indir-block 			( fileblock' indir-block )
         sb-buf dup fs_bsize l@		( fileblock' indir-block fs fs_bsize )
         swap indir-addr swap		( fileblock' indir-block fs_bsize indiraddr fs )
         fsbtodb 			( fileblock' indir-block fs_bsize db )
         strategy			( fileblock' nread )
      then				( fileblock' nread|indir-block )
      drop \ Really should check return value
      indir-block swap la+ l@ exit
   then
   dup sb-buf fs_nindir -		( fileblock'' )
   \ Now try 2nd level indirect block -- just read twice
   dup sb-buf fs_nindir l@ dup * < if	( fileblock'' )
      cur-inode di_ib 1 la+ l@		( fileblock'' indir2-block )
      to indir-addr			( fileblock'' )
      \ load 1st level indir block
      indir-block 			( fileblock'' indir-block )
      sb-buf dup fs_bsize l@		( fileblock'' indir-block fs fs_bsize )
      swap indir-addr swap		( fileblock'' indir-block fs_bsize indiraddr fs )
      fsbtodb 				( fileblock'' indir-block fs_bsize db )
      strategy				( fileblock'' nread )
      drop				( fileblock'' )
      dup sb-buf fs_nindir /		( fileblock'' indir-offset )
      indir-block swap la+ l@		( fileblock'' indirblock )
      to indir-addr			( fileblock'' )
      \ load 2nd level indir block
      indir-block 			( fileblock'' indir-block )
      sb-buf dup fs_bsize l@		( fileblock'' indir-block fs fs_bsize )
      swap indir-addr swap		( fileblock'' indir-block fs_bsize indiraddr fs )
      fsbtodb 				( fileblock'' indir-block fs_bsize db )
      strategy				( fileblock'' nread )
      drop				( fileblock'' )
      sb-buf fs_nindir l@ mod indir-block swap la+ l@ exit
   then
   ." block-map: exceeded max file size" cr
   abort
;

\
\ Read file into internal buffer and return pointer and len
\

0 value cur-block			\ allocated dynamically in ufs-open
0 value cur-blocksize			\ size of cur-block
-1 value cur-blockno
0 value cur-offset

: buf-read-file ( fs -- len buf )
   cur-offset swap			( seekp fs )
   2dup blkoff				( seekp fs off )
   -rot 2dup lblkno			( off seekp fs block )
   swap 2dup cur-inode			( off seekp block fs block fs inop )
   swap dblksize			( off seekp block fs size )
   rot dup cur-blockno			( off seekp fs size block block cur )
   <>  if 				( off seekp fs size block )
      block-map				( off seekp fs size diskblock )
      dup 0=  if			( off seekp fs size diskblock )
         over cur-block swap 0 fill	( off seekp fs size diskblock )
         boot-debug?  if ." buf-read-file fell off end of file" cr then
      else
         2dup sb-buf fsbtodb cur-block -rot strategy	( off seekp fs size diskblock nread )
         rot 2dup <>  if " buf-read-file: short read." cr abort then
      then				( off seekp fs diskblock nread size )
      nip nip				( off seekp fs size )
   else					( off seekp fs size block block cur )
      2drop				( off seekp fs size )
   then
\   dup cur-offset + to cur-offset	\ Set up next xfer -- not done
   nip nip swap -			( len )
   cur-block
;

\
\ Read inode into cur-inode -- uses cur-block
\

: read-inode ( inode fs -- )
   twiddle				( inode fs -- inode fs )

   cur-block				( inode fs -- inode fs buffer )

   over					( inode fs buffer -- inode fs buffer fs )
   fs_bsize l@				( inode fs buffer -- inode fs buffer size )

   2over				( inode fs buffer size -- inode fs buffer size inode fs )
   2over				( inode fs buffer size inode fs -- inode fs buffer size inode fs buffer size )
   2swap tuck				( inode fs buffer size inode fs buffer size -- inode fs buffer size buffer size fs inode fs )

   ino-to-fsba 				( inode fs buffer size buffer size fs inode fs -- inode fs buffer size buffer size fs fsba )
   swap					( inode fs buffer size buffer size fs fsba -- inode fs buffer size buffer size fsba fs )
   fsbtodb				( inode fs buffer size buffer size fsba fs -- inode fs buffer size buffer size db )

   dup to cur-blockno			( inode fs buffer size buffer size dstart -- inode fs buffer size buffer size dstart )
   strategy				( inode fs buffer size buffer size dstart -- inode fs buffer size nread )
   <>  if ." read-inode - residual" cr abort then
   dup 2over				( inode fs buffer -- inode fs buffer buffer inode fs )
   ino-to-fsbo				( inode fs buffer -- inode fs buffer buffer fsbo )
   ufs1_dinode_SIZEOF * +			( inode fs buffer buffer fsbo -- inode fs buffer dinop )
   cur-inode ufs1_dinode_SIZEOF move 	( inode fs buffer dinop -- inode fs buffer )
	\ clear out the old buffers
   drop					( inode fs buffer -- inode fs )
   2drop
;

\ Identify inode type

: is-dir? ( dinode -- true:false ) di_mode w@ ifmt and ifdir = ;
: is-symlink? ( dinode -- true:false ) di_mode w@ ifmt and iflnk = ;

\
\ Hunt for directory entry:
\
\ repeat
\    load a buffer
\    while entries do
\       if entry == name return
\       next entry
\ until no buffers
\

: search-directory ( str len -- ino|0 )
   0 to cur-offset
   begin cur-offset cur-inode di_size x@ < while	( str len )
      sb-buf buf-read-file		( str len len buf )
      over 0=  if ." search-directory: buf-read-file zero len" cr abort then
      swap dup cur-offset + to cur-offset	( str len buf len )
      2dup + nip			( str len buf bufend )
      swap 2swap rot			( bufend str len buf )
      begin dup 4 pick < while		( bufend str len buf )
         dup d_ino l@ 0<>  if 		( bufend str len buf )
            boot-debug?  if dup dup d_name swap d_namlen c@ type cr then
            2dup d_namlen c@ =  if	( bufend str len buf )
               dup d_name 2over		( bufend str len buf dname str len )
               comp 0= if		( bufend str len buf )
                  \ Found it -- return inode
                  d_ino l@ nip nip nip	( dino )
                  boot-debug?  if ." Found it" cr then
                  exit 			( dino )
               then
            then			( bufend str len buf )
         then				( bufend str len buf )
         dup d_reclen w@ +		( bufend str len nextbuf )
      repeat
      drop rot drop			( str len )
   repeat
   2drop 2drop 0			( 0 )
;

: ffs_oldcompat ( -- )
\ Make sure old ffs values in sb-buf are sane
   sb-buf fs_npsect dup l@ sb-buf fs_nsect l@ max swap l!
   sb-buf fs_interleave dup l@ 1 max swap l!
   sb-buf fs_postblformat l@ fs_42postblfmt =  if
      8 sb-buf fs_nrpos l!
   then
   sb-buf fs_inodefmt l@ fs_44inodefmt <  if
      sb-buf fs_bsize l@
      dup ndaddr * 1- sb-buf fs_maxfilesize x!
      niaddr 0 ?do
	sb-buf fs_nindir l@ * dup	( sizebp sizebp -- )
	sb-buf fs_maxfilesize dup x@	( sizebp sizebp *fs_maxfilesize fs_maxfilesize -- )
	rot 				( sizebp *fs_maxfilesize fs_maxfilesize sizebp -- )
	+ 				( sizebp *fs_maxfilesize new_fs_maxfilesize  -- )
        swap x! 			( sizebp -- )
      loop drop 			( -- )
      sb-buf dup fs_bmask l@ not swap fs_qbmask x!
      sb-buf dup fs_fmask l@ not swap fs_qfmask x!
   then
;

: read-super ( sector -- )
0 " seek" boot-ihandle $call-method
   -1 = if
      ." Seek failed" cr
      abort
   then
   sb-buf sbsize " read" boot-ihandle $call-method
   dup sbsize <>  if
      ." Read of superblock failed" cr
      ." requested" space sbsize .
      ." actual" space . cr
      abort
   else
      drop
   then
;

: ufs-open ( bootpath,len -- )
   boot-ihandle -1 =  if
      over cif-open dup 0=  if 		( boot-path len ihandle? )
         ." Could not open device" space type cr
         abort
      then 				( boot-path len ihandle )
      to boot-ihandle			\ Save ihandle to boot device
   then 2drop
   sboff read-super
   sb-buf fs_magic l@ fs_magic_value <>  if
      64 dup to raid-offset
      dev_bsize * sboff + read-super
      sb-buf fs_magic l@ fs_magic_value <>  if
         ." Invalid superblock magic" cr
         abort
      then
   then
   sb-buf fs_bsize l@ dup maxbsize >  if
      ." Superblock bsize" space . ." too large" cr
      abort
   then
   dup fs_SIZEOF <  if
      ." Superblock bsize < size of superblock" cr
      abort
   then
   ffs_oldcompat	( fs_bsize -- fs_bsize )
   dup to cur-blocksize alloc-mem to cur-block    \ Allocate cur-block
   boot-debug?  if ." ufs-open complete" cr then
;

: ufs-close ( -- )
   boot-ihandle dup -1 <>  if
      cif-close -1 to boot-ihandle
   then
   cur-block 0<> if
      cur-block cur-blocksize free-mem
   then
;

: boot-path ( -- boot-path )
   " bootpath" chosen-phandle get-package-property  if
      ." Could not find bootpath in /chosen" cr
      abort
   else
      decode-string 2swap 2drop
   then
;

: boot-args ( -- boot-args )
   " bootargs" chosen-phandle get-package-property  if
      ." Could not find bootargs in /chosen" cr
      abort
   else
      decode-string 2swap 2drop
   then
;

2000 buffer: boot-path-str
2000 buffer: boot-path-tmp

: split-path ( path len -- right len left len )
\ Split a string at the `/'
   begin
      dup -rot				( oldlen right len left )
      ascii / left-parse-string		( oldlen right len left len )
      dup 0<>  if 4 roll drop exit then
      2drop				( oldlen right len )
      rot over =			( right len diff )
   until
;

: find-file ( load-file len -- )
   rootino dup sb-buf read-inode	( load-file len -- load-file len ino )
   -rot					( load-file len ino -- pino load-file len )
   \
   \ For each path component
   \
   begin split-path dup 0<> while	( pino right len left len -- )
      cur-inode is-dir? not  if ." Inode not directory" cr abort then
      boot-debug?  if ." Looking for" space 2dup type space ." in directory..." cr then
      search-directory			( pino right len left len -- pino right len ino|false )
      dup 0=  if ." Bad path" cr abort then	( pino right len cino )
      sb-buf read-inode			( pino right len )
      cur-inode is-symlink?  if		\ Symlink -- follow the damn thing
         \ Save path in boot-path-tmp
         boot-path-tmp strmov		( pino new-right len )

         \ Now deal with symlink
         cur-inode di_size x@		( pino right len linklen )
         dup sb-buf fs_maxsymlinklen l@	( pino right len linklen linklen maxlinklen )
         <  if				\ Now join the link to the path
            cur-inode di_shortlink l@	( pino right len linklen linkp )
            swap boot-path-str strmov	( pino right len new-linkp linklen )
         else				\ Read file for symlink -- Ugh
            \ Read link into boot-path-str
            boot-path-str dup sb-buf fs_bsize l@
            0 block-map			( pino right len linklen boot-path-str bsize blockno )
            strategy drop swap		( pino right len boot-path-str linklen )
         then 				( pino right len linkp linklen )
         \ Concatenate the two paths
         strcat				( pino new-right newlen )
         swap dup c@ ascii / =  if	\ go to root inode?
            rot drop rootino -rot	( rino len right )
         then
         rot dup sb-buf read-inode	( len right pino )
         -rot swap			( pino right len )
      then				( pino right len )
   repeat
   2drop drop
;

: read-file ( size addr -- )
   \ Read x bytes from a file to buffer
   begin over 0> while
      cur-offset cur-inode di_size x@ >  if ." read-file EOF exceeded" cr abort then
      sb-buf buf-read-file		( size addr len buf )
      over 2over drop swap		( size addr len buf addr len )
      move				( size addr len )
      dup cur-offset + to cur-offset	( size len newaddr )
      tuck +				( size len newaddr )
      -rot - swap			( newaddr newsize )
   repeat
   2drop
;

\
\ According to the 1275 addendum for SPARC processors:
\ Default load-base is 0x4000.  At least 0x8.0000 or
\ 512KB must be available at that address.
\
\ The Fcode bootblock can take up up to 8KB (O.K., 7.5KB)
\ so load programs at 0x4000 + 0x2000=> 0x6000
\

h# 6000 constant loader-base

\
\ Elf support -- find the load addr
\

: is-elf? ( hdr -- res? ) h# 7f454c46 = ;

\
\ Finally we finish it all off
\

: load-file-signon ( load-file len boot-path len -- load-file len boot-path len )
   ." Loading file" space 2over type cr ." from device" space 2dup type cr
;

: load-file-print-size ( size -- size )
   ." Loading" space dup . space ." bytes of file..." cr
;

: load-file ( load-file len boot-path len -- load-base )
   boot-debug?  if load-file-signon then
   the-file file_SIZEOF 0 fill		\ Clear out file structure
   ufs-open 				( load-file len )
   find-file				( )

   \
   \ Now we've found the file we should read it in in one big hunk
   \

   cur-inode di_size x@			( file-len )
   dup " to file-size" evaluate		( file-len )
   boot-debug?  if load-file-print-size then
   0 to cur-offset
   loader-base				( buf-len addr )
   2dup read-file			( buf-len addr )
   ufs-close				( buf-len addr )
   dup is-elf?  if ." load-file: not an elf executable" cr abort then

   \ Luckily the prom should be able to handle ELF executables by itself

   nip					( addr )
;

: do-boot ( bootfile -- )
   ." OpenBSD IEEE 1275 Bootblock 1.2" cr
   boot-path load-file ( -- load-base )
   dup 0<> if  " to load-base init-program" evaluate then
;

boot-args ascii V strchr 0<> swap drop if
 true to boot-debug?
then

boot-args ascii D strchr 0= swap drop if
  " /ofwboot" do-boot
then exit

\	$OpenBSD: bootblk.fth,v 1.5 2010/02/26 19:59:11 deraadt Exp $
\	$NetBSD: bootblk.fth,v 1.3 2001/08/15 20:10:24 eeh Exp $
\
\	IEEE 1275 Open Firmware Boot Block
\
\	Parses disklabel and UFS and loads the file called `ofwboot'
\
\
\	Copyright (c) 1998 Eduardo Horvath.
\	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.
\	3. All advertising materials mentioning features or use of this software
\	   must display the following acknowledgement:
\	     This product includes software developed by Eduardo Horvath.
\	4. The name of the author may not be used to endorse or promote products
\	   derived from this software without specific prior written permission
\
\	THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 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.
\

offset16
hex
headers

false value boot-debug?

\
\ First some housekeeping:  Open /chosen and set up vectors into
\	client-services

" /chosen" find-package 0=  if ." Cannot find /chosen" 0 then
constant chosen-phandle

" /openprom/client-services" find-package 0=  if
	." Cannot find client-services" cr abort
then constant cif-phandle

defer cif-claim ( align size virt -- base )
defer cif-release ( size virt -- )
defer cif-open ( cstr -- ihandle|0 )
defer cif-close ( ihandle -- )
defer cif-read ( len adr ihandle -- #read )
defer cif-seek ( low high ihandle -- -1|0|1 )
\ defer cif-peer ( phandle -- phandle )
\ defer cif-getprop ( len adr cstr phandle -- )

: find-cif-method ( method,len -- xf )
   cif-phandle find-method drop
;

" claim" find-cif-method to cif-claim
" open" find-cif-method to cif-open
" close" find-cif-method to cif-close
" read" find-cif-method to cif-read
" seek" find-cif-method to cif-seek

: twiddle ( -- ) ." ." ; \ Need to do this right.  Just spit out periods for now.

\
\ Support routines
\

: strcmp ( s1 l1 s2 l2 -- true:false )
   rot tuck <> if  3drop false exit then
   comp 0=
;

\ Move string into buffer

: strmov ( s1 l1 d -- d l1 )
   dup 2over swap -rot		( s1 l1 d s1 d l1 )
   move				( s1 l1 d )
   rot drop swap
;

\ Move s1 on the end of s2 and return the result

: strcat ( s1 l1 s2 l2 -- d tot )
   2over swap 				( s1 l1 s2 l2 l1 s1 )
   2over + rot				( s1 l1 s2 l2 s1 d l1 )
   move rot + 				( s1 s2 len )
   rot drop				( s2 len )
;

: strchr ( s1 l1 c -- s2 l2 )
   begin
      dup 2over 0= if			( s1 l1 c c s1  )
         2drop drop exit then
      c@ = if				( s1 l1 c )
         drop exit then
      -rot /c - swap ca1+		( c l2 s2 )
     swap rot
  again
;

: cstr ( ptr -- str len )
   dup
   begin dup c@ 0<>  while + repeat
   over -
;

\
\ BSD FFS parameters
\

fload	assym.fth.h

sbsize buffer: sb-buf
-1 value boot-ihandle
dev_bsize value bsize
0 value raid-offset	\ Offset if it's a raid-frame partition

: strategy ( addr size start -- nread )
   raid-offset + bsize * 0 " seek" boot-ihandle $call-method
   -1 = if
      ." strategy: Seek failed" cr
      abort
   then
   " read" boot-ihandle $call-method
;

\
\ Cylinder group macros
\

: cgbase ( cg fs -- cgbase ) fs_fpg l@ * ;
: cgstart ( cg fs -- cgstart )
   2dup fs_cgmask l@ not and		( cg fs stuff -- )
   over fs_cgoffset l@ * -rot		( stuffcg fs -- )
   cgbase +
;
: cgdmin ( cg fs -- 1st-data-block ) dup fs_dblkno l@ -rot cgstart + ;
: cgimin ( cg fs -- inode-block ) dup fs_iblkno l@ -rot cgstart + ;
: cgsblock ( cg fs -- super-block ) dup fs_sblkno l@ -rot cgstart + ;
: cgstod ( cg fs -- cg-block ) dup fs_cblkno l@ -rot cgstart + ;

\
\ Block and frag position macros
\

: blkoff ( pos fs -- off ) fs_qbmask x@ and ;
: fragoff ( pos fs -- off ) fs_qfmask x@ and ;
: lblktosize ( blk fs -- off ) fs_bshift l@ << ;
: lblkno ( pos fs -- off ) fs_bshift l@ >> ;
: numfrags ( pos fs -- off ) fs_fshift l@ >> ;
: blkroundup ( pos fs -- off ) dup fs_bmask l@ -rot fs_qbmask x@ + and ;
: fragroundup ( pos fs -- off ) dup fs_fmask l@ -rot fs_qfmask x@ + and ;
\ : fragroundup ( pos fs -- off ) tuck fs_qfmask x@ + swap fs_fmask l@ and ;
: fragstoblks ( pos fs -- off ) fs_fragshift l@ >> ;
: blkstofrags ( blk fs -- frag ) fs_fragshift l@ << ;
: fragnum ( fsb fs -- off ) fs_frag l@ 1- and ;
: blknum ( fsb fs -- off ) fs_frag l@ 1- not and ;
: dblksize ( lbn dino fs -- size )
   -rot 				( fs lbn dino )
   di_size x@				( fs lbn di_size )
   -rot dup 1+				( di_size fs lbn lbn+1 )
   2over fs_bshift l@			( di_size fs lbn lbn+1 di_size b_shift )
   rot swap <<	>=			( di_size fs lbn res1 )
   swap ndaddr >= or if			( di_size fs )
      swap drop fs_bsize l@ exit	( size )
   then	tuck blkoff swap fragroundup	( size )
;

: ino-to-cg ( ino fs -- cg ) fs_ipg l@ / ;
: ino-to-fsbo ( ino fs -- fsb0 ) fs_inopb l@ mod ;
: ino-to-fsba ( ino fs -- ba )	\ Need to remove the stupid stack diags someday
   2dup 				( ino fs ino fs )
   ino-to-cg				( ino fs cg )
   over					( ino fs cg fs )
   cgimin				( ino fs inode-blk )
   -rot					( inode-blk ino fs )
   tuck 				( inode-blk fs ino fs )
   fs_ipg l@ 				( inode-blk fs ino ipg )
   mod					( inode-blk fs mod )
   swap					( inode-blk mod fs )
   dup 					( inode-blk mod fs fs )
   fs_inopb l@ 				( inode-blk mod fs inopb )
   rot 					( inode-blk fs inopb mod )
   swap					( inode-blk fs mod inopb )
   /					( inode-blk fs div )
   swap					( inode-blk div fs )
   blkstofrags				( inode-blk frag )
   +
;
: fsbtodb ( fsb fs -- db ) fs_fsbtodb l@ << ;

\
\ File stuff
\

niaddr /w* constant narraysize

struct
   8		field	>f_ihandle	\ device handle
   8 		field 	>f_seekp	\ seek pointer
   8 		field 	>f_fs		\ pointer to super block
   ufs1_dinode_SIZEOF 	field 	>f_di	\ copy of on-disk inode
   8		field	>f_buf		\ buffer for data block
   4		field 	>f_buf_size	\ size of data block
   4		field	>f_buf_blkno	\ block number of data block
constant file_SIZEOF

file_SIZEOF buffer: the-file
sb-buf the-file >f_fs x!

ufs1_dinode_SIZEOF buffer: cur-inode
h# 2000 buffer: indir-block
-1 value indir-addr

\
\ Translate a fileblock to a disk block
\
\ We only allow single indirection
\

: block-map ( fileblock -- diskblock )
   \ Direct block?
   dup ndaddr <  if 			( fileblock )
      cur-inode di_db			( arr-indx arr-start )
      swap la+ l@ exit			( diskblock )
   then 				( fileblock )
   ndaddr -				( fileblock' )
   \ Now we need to check the indirect block
   dup sb-buf fs_nindir l@ <  if	( fileblock' )
      cur-inode di_ib l@ dup		( fileblock' indir-block indir-block )
      indir-addr <>  if 		( fileblock' indir-block )
         to indir-addr			( fileblock' )
         indir-block 			( fileblock' indir-block )
         sb-buf dup fs_bsize l@		( fileblock' indir-block fs fs_bsize )
         swap indir-addr swap		( fileblock' indir-block fs_bsize indiraddr fs )
         fsbtodb 			( fileblock' indir-block fs_bsize db )
         strategy			( fileblock' nread )
      then				( fileblock' nread|indir-block )
      drop \ Really should check return value
      indir-block swap la+ l@ exit
   then
   dup sb-buf fs_nindir -		( fileblock'' )
   \ Now try 2nd level indirect block -- just read twice
   dup sb-buf fs_nindir l@ dup * < if	( fileblock'' )
      cur-inode di_ib 1 la+ l@		( fileblock'' indir2-block )
      to indir-addr			( fileblock'' )
      \ load 1st level indir block
      indir-block 			( fileblock'' indir-block )
      sb-buf dup fs_bsize l@		( fileblock'' indir-block fs fs_bsize )
      swap indir-addr swap		( fileblock'' indir-block fs_bsize indiraddr fs )
      fsbtodb 				( fileblock'' indir-block fs_bsize db )
      strategy				( fileblock'' nread )
      drop				( fileblock'' )
      dup sb-buf fs_nindir /		( fileblock'' indir-offset )
      indir-block swap la+ l@		( fileblock'' indirblock )
      to indir-addr			( fileblock'' )
      \ load 2nd level indir block
      indir-block 			( fileblock'' indir-block )
      sb-buf dup fs_bsize l@		( fileblock'' indir-block fs fs_bsize )
      swap indir-addr swap		( fileblock'' indir-block fs_bsize indiraddr fs )
      fsbtodb 				( fileblock'' indir-block fs_bsize db )
      strategy				( fileblock'' nread )
      drop				( fileblock'' )
      sb-buf fs_nindir l@ mod indir-block swap la+ l@ exit
   then
   ." block-map: exceeded max file size" cr
   abort
;

\
\ Read file into internal buffer and return pointer and len
\

0 value cur-block			\ allocated dynamically in ufs-open
0 value cur-blocksize			\ size of cur-block
-1 value cur-blockno
0 value cur-offset

: buf-read-file ( fs -- len buf )
   cur-offset swap			( seekp fs )
   2dup blkoff				( seekp fs off )
   -rot 2dup lblkno			( off seekp fs block )
   swap 2dup cur-inode			( off seekp block fs block fs inop )
   swap dblksize			( off seekp block fs size )
   rot dup cur-blockno			( off seekp fs size block block cur )
   <>  if 				( off seekp fs size block )
      block-map				( off seekp fs size diskblock )
      dup 0=  if			( off seekp fs size diskblock )
         over cur-block swap 0 fill	( off seekp fs size diskblock )
         boot-debug?  if ." buf-read-file fell off end of file" cr then
      else
         2dup sb-buf fsbtodb cur-block -rot strategy	( off seekp fs size diskblock nread )
         rot 2dup <>  if " buf-read-file: short read." cr abort then
      then				( off seekp fs diskblock nread size )
      nip nip				( off seekp fs size )
   else					( off seekp fs size block block cur )
      2drop				( off seekp fs size )
   then
\   dup cur-offset + to cur-offset	\ Set up next xfer -- not done
   nip nip swap -			( len )
   cur-block
;

\
\ Read inode into cur-inode -- uses cur-block
\

: read-inode ( inode fs -- )
   twiddle				( inode fs -- inode fs )

   cur-block				( inode fs -- inode fs buffer )

   over					( inode fs buffer -- inode fs buffer fs )
   fs_bsize l@				( inode fs buffer -- inode fs buffer size )

   2over				( inode fs buffer size -- inode fs buffer size inode fs )
   2over				( inode fs buffer size inode fs -- inode fs buffer size inode fs buffer size )
   2swap tuck				( inode fs buffer size inode fs buffer size -- inode fs buffer size buffer size fs inode fs )

   ino-to-fsba 				( inode fs buffer size buffer size fs inode fs -- inode fs buffer size buffer size fs fsba )
   swap					( inode fs buffer size buffer size fs fsba -- inode fs buffer size buffer size fsba fs )
   fsbtodb				( inode fs buffer size buffer size fsba fs -- inode fs buffer size buffer size db )

   dup to cur-blockno			( inode fs buffer size buffer size dstart -- inode fs buffer size buffer size dstart )
   strategy				( inode fs buffer size buffer size dstart -- inode fs buffer size nread )
   <>  if ." read-inode - residual" cr abort then
   dup 2over				( inode fs buffer -- inode fs buffer buffer inode fs )
   ino-to-fsbo				( inode fs buffer -- inode fs buffer buffer fsbo )
   ufs1_dinode_SIZEOF * +			( inode fs buffer buffer fsbo -- inode fs buffer dinop )
   cur-inode ufs1_dinode_SIZEOF move 	( inode fs buffer dinop -- inode fs buffer )
	\ clear out the old buffers
   drop					( inode fs buffer -- inode fs )
   2drop
;

\ Identify inode type

: is-dir? ( dinode -- true:false ) di_mode w@ ifmt and ifdir = ;
: is-symlink? ( dinode -- true:false ) di_mode w@ ifmt and iflnk = ;

\
\ Hunt for directory entry:
\
\ repeat
\    load a buffer
\    while entries do
\       if entry == name return
\       next entry
\ until no buffers
\

: search-directory ( str len -- ino|0 )
   0 to cur-offset
   begin cur-offset cur-inode di_size x@ < while	( str len )
      sb-buf buf-read-file		( str len len buf )
      over 0=  if ." search-directory: buf-read-file zero len" cr abort then
      swap dup cur-offset + to cur-offset	( str len buf len )
      2dup + nip			( str len buf bufend )
      swap 2swap rot			( bufend str len buf )
      begin dup 4 pick < while		( bufend str len buf )
         dup d_ino l@ 0<>  if 		( bufend str len buf )
            boot-debug?  if dup dup d_name swap d_namlen c@ type cr then
            2dup d_namlen c@ =  if	( bufend str len buf )
               dup d_name 2over		( bufend str len buf dname str len )
               comp 0= if		( bufend str len buf )
                  \ Found it -- return inode
                  d_ino l@ nip nip nip	( dino )
                  boot-debug?  if ." Found it" cr then
                  exit 			( dino )
               then
            then			( bufend str len buf )
         then				( bufend str len buf )
         dup d_reclen w@ +		( bufend str len nextbuf )
      repeat
      drop rot drop			( str len )
   repeat
   2drop 2drop 0			( 0 )
;

: ffs_oldcompat ( -- )
\ Make sure old ffs values in sb-buf are sane
   sb-buf fs_npsect dup l@ sb-buf fs_nsect l@ max swap l!
   sb-buf fs_interleave dup l@ 1 max swap l!
   sb-buf fs_postblformat l@ fs_42postblfmt =  if
      8 sb-buf fs_nrpos l!
   then
   sb-buf fs_inodefmt l@ fs_44inodefmt <  if
      sb-buf fs_bsize l@
      dup ndaddr * 1- sb-buf fs_maxfilesize x!
      niaddr 0 ?do
	sb-buf fs_nindir l@ * dup	( sizebp sizebp -- )
	sb-buf fs_maxfilesize dup x@	( sizebp sizebp *fs_maxfilesize fs_maxfilesize -- )
	rot 				( sizebp *fs_maxfilesize fs_maxfilesize sizebp -- )
	+ 				( sizebp *fs_maxfilesize new_fs_maxfilesize  -- )
        swap x! 			( sizebp -- )
      loop drop 			( -- )
      sb-buf dup fs_bmask l@ not swap fs_qbmask x!
      sb-buf dup fs_fmask l@ not swap fs_qfmask x!
   then
;

: read-super ( sector -- )
0 " seek" boot-ihandle $call-method
   -1 = if
      ." Seek failed" cr
      abort
   then
   sb-buf sbsize " read" boot-ihandle $call-method
   dup sbsize <>  if
      ." Read of superblock failed" cr
      ." requested" space sbsize .
      ." actual" space . cr
      abort
   else
      drop
   then
;

: ufs-open ( bootpath,len -- )
   boot-ihandle -1 =  if
      over cif-open dup 0=  if 		( boot-path len ihandle? )
         ." Could not open device" space type cr
         abort
      then 				( boot-path len ihandle )
      to boot-ihandle			\ Save ihandle to boot device
   then 2drop
   sboff read-super
   sb-buf fs_magic l@ fs_magic_value <>  if
      64 dup to raid-offset
      dev_bsize * sboff + read-super
      sb-buf fs_magic l@ fs_magic_value <>  if
         ." Invalid superblock magic" cr
         abort
      then
   then
   sb-buf fs_bsize l@ dup maxbsize >  if
      ." Superblock bsize" space . ." too large" cr
      abort
   then
   dup fs_SIZEOF <  if
      ." Superblock bsize < size of superblock" cr
      abort
   then
   ffs_oldcompat	( fs_bsize -- fs_bsize )
   dup to cur-blocksize alloc-mem to cur-block    \ Allocate cur-block
   boot-debug?  if ." ufs-open complete" cr then
;

: ufs-close ( -- )
   boot-ihandle dup -1 <>  if
      cif-close -1 to boot-ihandle
   then
   cur-block 0<> if
      cur-block cur-blocksize free-mem
   then
;

: boot-path ( -- boot-path )
   " bootpath" chosen-phandle get-package-property  if
      ." Could not find bootpath in /chosen" cr
      abort
   else
      decode-string 2swap 2drop
   then
;

: boot-args ( -- boot-args )
   " bootargs" chosen-phandle get-package-property  if
      ." Could not find bootargs in /chosen" cr
      abort
   else
      decode-string 2swap 2drop
   then
;

2000 buffer: boot-path-str
2000 buffer: boot-path-tmp

: split-path ( path len -- right len left len )
\ Split a string at the `/'
   begin
      dup -rot				( oldlen right len left )
      ascii / left-parse-string		( oldlen right len left len )
      dup 0<>  if 4 roll drop exit then
      2drop				( oldlen right len )
      rot over =			( right len diff )
   until
;

: find-file ( load-file len -- )
   rootino dup sb-buf read-inode	( load-file len -- load-file len ino )
   -rot					( load-file len ino -- pino load-file len )
   \
   \ For each path component
   \
   begin split-path dup 0<> while	( pino right len left len -- )
      cur-inode is-dir? not  if ." Inode not directory" cr abort then
      boot-debug?  if ." Looking for" space 2dup type space ." in directory..." cr then
      search-directory			( pino right len left len -- pino right len ino|false )
      dup 0=  if ." Bad path" cr abort then	( pino right len cino )
      sb-buf read-inode			( pino right len )
      cur-inode is-symlink?  if		\ Symlink -- follow the damn thing
         \ Save path in boot-path-tmp
         boot-path-tmp strmov		( pino new-right len )

         \ Now deal with symlink
         cur-inode di_size x@		( pino right len linklen )
         dup sb-buf fs_maxsymlinklen l@	( pino right len linklen linklen maxlinklen )
         <  if				\ Now join the link to the path
            cur-inode di_shortlink l@	( pino right len linklen linkp )
            swap boot-path-str strmov	( pino right len new-linkp linklen )
         else				\ Read file for symlink -- Ugh
            \ Read link into boot-path-str
            boot-path-str dup sb-buf fs_bsize l@
            0 block-map			( pino right len linklen boot-path-str bsize blockno )
            strategy drop swap		( pino right len boot-path-str linklen )
         then 				( pino right len linkp linklen )
         \ Concatenate the two paths
         strcat				( pino new-right newlen )
         swap dup c@ ascii / =  if	\ go to root inode?
            rot drop rootino -rot	( rino len right )
         then
         rot dup sb-buf read-inode	( len right pino )
         -rot swap			( pino right len )
      then				( pino right len )
   repeat
   2drop drop
;

: read-file ( size addr -- )
   \ Read x bytes from a file to buffer
   begin over 0> while
      cur-offset cur-inode di_size x@ >  if ." read-file EOF exceeded" cr abort then
      sb-buf buf-read-file		( size addr len buf )
      over 2over drop swap		( size addr len buf addr len )
      move				( size addr len )
      dup cur-offset + to cur-offset	( size len newaddr )
      tuck +				( size len newaddr )
      -rot - swap			( newaddr newsize )
   repeat
   2drop
;

\
\ According to the 1275 addendum for SPARC processors:
\ Default load-base is 0x4000.  At least 0x8.0000 or
\ 512KB must be available at that address.
\
\ The Fcode bootblock can take up up to 8KB (O.K., 7.5KB)
\ so load programs at 0x4000 + 0x2000=> 0x6000
\

h# 6000 constant loader-base

\
\ Elf support -- find the load addr
\

: is-elf? ( hdr -- res? ) h# 7f454c46 = ;

\
\ Finally we finish it all off
\

: load-file-signon ( load-file len boot-path len -- load-file len boot-path len )
   ." Loading file" space 2over type cr ." from device" space 2dup type cr
;

: load-file-print-size ( size -- size )
   ." Loading" space dup . space ." bytes of file..." cr
;

: load-file ( load-file len boot-path len -- load-base )
   boot-debug?  if load-file-signon then
   the-file file_SIZEOF 0 fill		\ Clear out file structure
   ufs-open 				( load-file len )
   find-file				( )

   \
   \ Now we've found the file we should read it in in one big hunk
   \

   cur-inode di_size x@			( file-len )
   dup " to file-size" evaluate		( file-len )
   boot-debug?  if load-file-print-size then
   0 to cur-offset
   loader-base				( buf-len addr )
   2dup read-file			( buf-len addr )
   ufs-close				( buf-len addr )
   dup is-elf?  if ." load-file: not an elf executable" cr abort then

   \ Luckily the prom should be able to handle ELF executables by itself

   nip					( addr )
;

: do-boot ( bootfile -- )
   ." OpenBSD IEEE 1275 Bootblock 1.1" cr
   boot-path load-file ( -- load-base )
   dup 0<> if  " to load-base init-program" evaluate then
;

boot-args ascii V strchr 0<> swap drop if
 true to boot-debug?
then

boot-args ascii D strchr 0= swap drop if
  " /ofwboot" do-boot
then exit


Dash the stash

Dash the stash

: (   41 parse 2drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note: default decimal numeric input mode. )

: \ ( <line> -- , comment out the rest of line)
   13 parse 2drop ; immediate

\ 1 echo !   \ Uncomment this line to echo Forth code while compiling.

\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ BYOK (portmanteau of BYE & OK) is a BYO kernel which happens to
\ implement a forth machine on i686 bare metal.
\
\ Substantial portions of this file were lifted straight from pForth
\ (http://pforth.googlecode.com/svn/trunk/fth/system.fth)
\ *********************************************************************
: BL 32 ;

: SPACE  ( -- )  bl emit ;
: CR  ( -- , cause output to appear at the beginning of the next line )  10 emit ;

: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1+ swap c@ ;

\ Miscellaneous support words
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

: <= ( a b -- f , true if A <= b ) > 0= ;
: >= ( a b -- f , true if A >= b ) < 0= ;
: NOT ( n -- !n , logical negation ) 0= ;
: DNEGATE ( d -- -d , negate by doing 0-d )
        0 swap -
;
: CELL+  ( n -- n+cell )  cell + ;
: CELL-  ( n -- n-cell )  cell - ;
: CELL*  ( n -- n*cell )  cells ;

: CHAR+  ( n -- n+size_of_char ) 1+ ;
: CHARS  ( n -- n*size_of_char, don't do anything ) ; immediate

\ useful stack manipulation words
: -ROT ( a b c -- c a b ) rot rot ;
: 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;

\ ------------------------------------------------------------------
: ID.  ( nfa -- ) count 31 and type ;

: BINARY    2 base ! ;
: OCTAL     8 base ! ;
: DECIMAL  10 base ! ;
: HEX      16 base ! ;

: PAD ( -- addr ) here 128 + ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;

: BETWEEN ( n lo hi -- flag , true if between lo & hi )
        >r over r> > >r
        < r> or 0=
;

: [  ( -- , enter interpreter mode )  0 state ! ; immediate
: ]  ( -- , enter compile mode )      1 state ! ;

: ?  ( <name> -- )  @ . ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ ' (lit) , cell 1- , ]  +
    [ ' (lit) , cell 1- invert , ]  and ;

: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
: ALLOT  ( nbytes -- , allot space in dictionary ) dp +! align ;

: C,  ( c -- ) here c! 1 dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

: SEE ( <name> -- )
    ' dup
    >body swap >size
    disassemble ;

\ Compiler support -------------------------------------------------
: COMPILE,   ( xt -- , compile call to xt ) , ;
: [COMPILE]  ( <name> -- , compile now even if immediate ) ' compile, ; immediate
: (COMPILE)  ( xt -- , postpone compilation of token )
    [compile] literal ( compile a call to literal )
    ( store xt of word to be compiled )

    [ ' compile, ] literal \ compile call to compile,
    compile, ;

: COMPILE  ( <name> --, save xt and compile later ) ' (compile) ; immediate

\ Error codes defined in ANSI Exception word set -------------------
: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

: ABORT ( i*x -- ) err_abort throw ;

\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION  ( f -- )  conditional_key - err_pairs ?error ;
: >MARK       ( -- addr )   here 0 , ;
: >RESOLVE    ( addr -- )   here over - swap ! ;
: <MARK       ( -- addr )   here ;
: <RESOLVE    ( addr -- )   here - , ;

: ?COMP  ( -- , error if not compiling ) state @ 0= err_executing ?error ;
: ?PAIRS ( n m -- ) - err_pairs ?error ;

\ Conditional primitives -------------------------------------------
: IF     ( -- f orig )  ?comp compile 0branch conditional_key >mark ; immediate
: THEN   ( f orig -- )  swap ?condition >resolve ; immediate
: BEGIN  ( -- f dest )  ?comp conditional_key <mark ; immediate
: AGAIN  ( f dest -- )  compile branch swap ?condition <resolve ; immediate
: UNTIL  ( f dest -- )  compile 0branch swap ?condition <resolve ; immediate
: AHEAD  ( -- f orig )  compile branch conditional_key >mark ; immediate

\ Conditionals built from primitives -------------------------------
: ELSE   ( f orig1 -- f orig2 )  [compile] ahead 2swap [compile] then ; immediate
: WHILE  ( f dest -- f origi f dest ) [compile] if 2swap ; immediate
: REPEAT  ( -- f orig f dest ) [compile] again [compile] then ; immediate

: [']  ( <name> -- xt , define compile time tick )
    ?comp ' [compile] literal
; immediate

: (DOES>)  ( xt -- , modify previous definition to execute code at xt )
        latest >body   \ get address of code for new word
        3 cell* +      \ offset to EXIT cell in create word
        !              \ store execution token of DOES> code in new word
;

: DOES>   ( -- , define execution code for CREATE word )
        0 [compile] literal \ dummy literal to hold xt
        here cell-          \ address of zero in literal
        compile (does>)     \ call (DOES>) from new creation word
		>r                  \ move addrz to return stack so ; doesn't see stack garbage
        [compile] ;         \ terminate part of code before does>
		r>
        :noname       ( addrz xt )
        compile rdrop       \ drop a stack frame (call becomes goto)
        swap !              \ save execution token in literal
; immediate

: 2! ( x1 x2 addr -- , store x2 followed by x1 )
        swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 )
        dup cell+ @ swap @ ;

: 2* ( n -- n*2 )
        2 *
;
: 2/ ( n -- n/2 )
        2 /
;

\ define some useful constants ------------------------------
1 0= constant FALSE
0 0= constant TRUE
32 constant BL

\ Stack data structure ----------------------------------------
\ This is a general purpose stack utility used to implement necessary
\ stacks for the compiler or the user.  Not real fast.
\ These stacks grow up which is different then normal.
\   cell 0 - stack pointer, offset from pfa of word
\   cell 1 - limit for range checking
\   cell 2 - first data location

: :STACK   ( #cells -- )
        CREATE  2 cells ,          ( offset of first data location )
                dup ,              ( limit for range checking, not currently used )
                cells cell+ allot  ( allot an extra cell for safety )
;

: >STACK  ( n stack -- , push onto stack, postincrement )
        dup @ 2dup cell+ swap ! ( -- n stack offset )
        + !
;

: STACK>  ( stack -- n , pop , predecrement )
        dup @ cell- 2dup swap !
        + @
;

: STACK@ ( stack -- n , copy )
        dup @ cell- + @
;

: STACK.PICK ( index stack -- n , grab Nth from top of stack )
        dup @ cell- +
        swap cells -   \ offset for index
        @
;
: STACKP ( stack -- ptr , to next empty location on stack )
	dup @ +
;

: 0STACKP  ( stack -- , clear stack)
    8 swap !
;

32 :stack ustack
ustack 0stackp

\ Define JForth like words.
: >US ustack >stack ;
: US> ustack stack> ;
: US@ ustack stack@ ;
: 0USP ustack 0stackp ;

\ DO LOOP ------------------------------------------------

3 constant do_flag
4 constant leave_flag
5 constant ?do_flag

: DO    ( -- , loop-back do_flag jump-from ?do_flag )
        ?comp
        compile  (do)
        here >us do_flag  >us  ( for backward branch )
; immediate

: ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )
        ?comp
        ( leave address to set for forward branch )
        compile  (?do)
        here 0 ,
        here >us do_flag  >us  ( for backward branch )
        >us ( for forward branch ) ?do_flag >us
; immediate

: LEAVE  ( -- addr leave_flag )
        compile (leave)
        here 0 , >us
        leave_flag >us
; immediate

: LOOP-FORWARD  ( -us- jump-from ?do_flag -- )
        BEGIN
                us@ leave_flag =
                us@ ?do_flag =
                OR
        WHILE
                us> leave_flag =
                IF
                        us> here over - cell+ swap !
                ELSE
                        us> dup
                        here swap -
                        cell+ swap !
                THEN
        REPEAT
;

: LOOP-BACK  (  loop-addr do_flag -us- )
        us> do_flag ?pairs
        us> here -  here
        !
        cell allot
;

: LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (loop)
   loop-forward loop-back
; immediate

\ : DOTEST 5 0 do 333 . loop 888 . ;
\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;

: +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (+loop)
   loop-forward loop-back
; immediate

: UNLOOP ( loop-sys -r- )
        r> \ save return pointer
        rdrop rdrop
        >r
;

: RECURSE  ( ? -- ? , call the word currently being defined )
    latest compile,
; immediate

: SPACE  bl emit ;
: 0SP depth 0 ?do drop loop ;

\ : >NEWLINE ( -- , CR if needed )
\         out @ 0>
\         IF cr
\         THEN
\ ;

: 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;

: DABS ( d -- |d| )
        dup 0<
        IF dnegate
        THEN
;

: S>D  ( s -- d , extend signed single precision to double )
        dup 0<
        IF -1
        ELSE 0
        THEN
;

: D>S ( d -- s ) drop ;

: PARSE-WORD ( "<spaces>name<space>" -- c-addr u ) bl parse ;
: /STRING  ( addr len n -- addr' len' ) over min rot over  + -rot - ;
: PLACE    ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ;

: ASCII ( <char> -- char, state smart )
    bl parse drop c@
    state @ 1 =
    IF [compile] literal
    ELSE
    THEN
; immediate

: CHAR    ( <char> -- char , interpret mode ) bl parse drop c@ ;
: [CHAR]  ( <char> -- char , for compile mode )
    char [compile] literal
; immediate

: $TYPE  ( $string -- ) count type ;
: 'word  ( -- addr )  here ;

: EVEN    ( addr -- addr' )   dup 1 and +  ;

: (C")  ( -- $addr ) r> dup count + aligned >r ;
: (S")  ( -- c-addr cnt ) r> count 2dup + aligned >r ;
: (.")  ( -- , type following string ) r> count 2dup + aligned >r type ;
: ",    ( addr len -- , place string into dict ) tuck 'word place 1+ allot align ;
: ,"    ( -- ) [char] " parse ", ;

: .(  ( <string> --, type string delimited by parens )
    [char] ) parse type
; immediate

: ."  ( <string> -- , type string )
    state @ 1 =
    IF compile (.")  ,"
    ELSE [char] " parse type
    THEN
; immediate

: .'   ( <string> -- , type string delimited by single quote )
        state @
        IF    compile (.")  [char] ' parse ",
        ELSE [char] ' parse type
        THEN
; immediate

: C"    ( <string> -- addr , return string address, ANSI )
        state @
        IF compile (c")   ,"
        ELSE [char] " parse pad place pad
        THEN
; immediate

: S"    ( <string> -- , -- addr , return string address, ANSI )
        state @
        IF compile (s")   ,"
        ELSE [char] " parse pad place pad count
        THEN
; immediate

: "    ( <string> -- , -- addr , return string address )
        [compile] C"
; immediate
: P"    ( <string> -- , -- addr , return string address )
        [compile] C"
; immediate

: ""  ( <string> -- addr )
       state @
       IF
               compile (C")
               bl parse-word  ",
       ELSE
               bl parse-word pad place pad
       THEN
; immediate

: SLITERAL ( addr cnt -- , compile string )
	compile (S")
	",
; IMMEDIATE

: $APPEND ( addr count $1 -- , append text to $1 )
    over >r
        dup >r
    count +  ( -- a2 c2 end1 )
    swap cmove
    r> dup c@  ( a1 c1 )
    r> + ( -- a1 totalcount )
    swap c!
;

\ ANSI word to replace [COMPILE] and COMPILE ----------------
: POSTPONE  ( <name> -- )
	bl word find
	dup
    0= -13 ?ERROR
    0>
    IF compile,  \ immediate
    ELSE (compile)  \ normal
    THEN

; immediate

\ -----------------------------------------------------------------
\ Auto Initialization
: AUTO.INIT  ( -- )
\ Kernel finds AUTO.INIT and executes it after loading dictionary.
\	." Begin AUTO.INIT ------" cr
;
: AUTO.TERM  ( -- )
\ Kernel finds AUTO.TERM and executes it on bye.
\	." End AUTO.TERM ------" cr
;

: INCLUDE? ( <word> <file> -- , load file if word not defined )
        bl word find
        IF drop bl word drop  ( eat word from source )
        ELSE drop include
        THEN
; immediate

: CLEARSTACK ( i*x -- )
    BEGIN depth
    WHILE drop
    REPEAT ;

variable pictured_output     \ hidden?
variable pictured_output_len \ hidden?

: <# ( -- ) pad pictured_output !  0 pictured_output_len ! ;
: #> ( -- addr n ) drop pictured_output @ pictured_output_len @ ;

: HOLD ( c -- )
    pictured_output @ dup dup 1+ pictured_output_len @ cmove c!
    1 pictured_output_len +!
;

\ ------------------------ INPUT -------------------------------

: SIGN ( n -- ) < 0 IF 45 hold THEN
;

: DIGIT ( n -- ascii )
   dup 10 < IF 48 ELSE 87 THEN + ;

: # ( n -- n )
    base @ /mod swap digit hold ;

: #S ( n -- )
    BEGIN base @ /mod dup
    WHILE swap digit hold
    REPEAT
    digit hold ;

: LWORD  ( char -- addr )
        parse-word here place here \ 00002 , use PARSE-WORD
;

: (WARNING")  ( flag $message -- )
    swap
    IF count type
    ELSE drop
    THEN
;

: WARNING" ( flag <message> -- , print warning if true. )
	[compile] "  ( compile message )
	state @
	IF  compile (warning")
	ELSE (warning")
	THEN
; IMMEDIATE

: ABORT" ( flag <message> -- , print warning if true. )
	[compile] "  ( compile message )
	state @
	IF  compile (abort")
	ELSE (abort")
	THEN
; IMMEDIATE

: DEFER ( "name" -- )
   CREATE ['] ABORT ,
   DOES> ( ... -- ... ) @ EXECUTE ;

: DEFER! ( xt2 xt1 -- )
   >BODY 4 CELL* + ! ;

: DEFER@ ( xt1 -- xt2 )
   >BODY 4 CELL* + @ ;

\ : IS ( xt "<spaces>name" -- , Skip leading spaces and parse name delimited by a space. Set name to execute xt. )
\    STATE @ IF
\      POSTPONE ['] POSTPONE DEFER!
\    ELSE
\      ' DEFER!
\    THEN ; IMMEDIATE

\ : $ ( <number> -- N , convert next number as hex )
\     base @ hex
\     32 lword number? num_type_single = not
\     abort" Not a single number!"
\     swap base !
\     state @
\     IF [compile] literal
\     THEN
\ ; immediate

: (   41 parse 2drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note: default decimal numeric input mode. )

: \ ( <line> -- , comment out the rest of line)
   13 parse 2drop ; immediate

\ 1 echo !   \ Uncomment this line to echo Forth code while compiling.

\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ BYOK (portmanteau of BYE & OK) is a BYO kernel which happens to
\ implement a forth machine on i686 bare metal.
\
\ Substantial portions of this file were lifted straight from pForth
\ (http://pforth.googlecode.com/svn/trunk/fth/system.fth)
\ *********************************************************************
: BL 32 ;

: SPACE  ( -- )  bl emit ;
: CR  ( -- , cause output to appear at the beginning of the next line )  10 emit ;

: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1+ swap c@ ;

\ Miscellaneous support words
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

: <= ( a b -- f , true if A <= b ) > 0= ;
: >= ( a b -- f , true if A >= b ) < 0= ;
: NOT ( n -- !n , logical negation ) 0= ;
: DNEGATE ( d -- -d , negate by doing 0-d )
        0 swap -
;
: CELL+  ( n -- n+cell )  cell + ;
: CELL-  ( n -- n-cell )  cell - ;
: CELL*  ( n -- n*cell )  cells ;

: CHAR+  ( n -- n+size_of_char ) 1+ ;
: CHARS  ( n -- n*size_of_char, don't do anything ) ; immediate

\ useful stack manipulation words
: -ROT ( a b c -- c a b ) rot rot ;
: 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;

\ ------------------------------------------------------------------
: ID.  ( nfa -- ) count 31 and type ;

: BINARY    2 base ! ;
: OCTAL     8 base ! ;
: DECIMAL  10 base ! ;
: HEX      16 base ! ;

: PAD ( -- addr ) here 128 + ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;

: BETWEEN ( n lo hi -- flag , true if between lo & hi )
        >r over r> > >r
        < r> or 0=
;

: [  ( -- , enter interpreter mode )  0 state ! ; immediate
: ]  ( -- , enter compile mode )      1 state ! ;

: ?  ( <name> -- )  @ . ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ ' (lit) , cell 1- , ]  +
    [ ' (lit) , cell 1- invert , ]  and ;

: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
: ALLOT  ( nbytes -- , allot space in dictionary ) dp +! align ;

: C,  ( c -- ) here c! 1 dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

: SEE ( <name> -- )
    ' dup
    >body swap >size
    disassemble ;

\ Compiler support -------------------------------------------------
: COMPILE,   ( xt -- , compile call to xt ) , ;
: [COMPILE]  ( <name> -- , compile now even if immediate ) ' compile, ; immediate
: (COMPILE)  ( xt -- , postpone compilation of token )
    [compile] literal ( compile a call to literal )
    ( store xt of word to be compiled )

    [ ' compile, ] literal \ compile call to compile,
    compile, ;

: COMPILE  ( <name> --, save xt and compile later ) ' (compile) ; immediate

\ Error codes defined in ANSI Exception word set -------------------
: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

: ABORT ( i*x -- ) err_abort throw ;

\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION  ( f -- )  conditional_key - err_pairs ?error ;
: >MARK       ( -- addr )   here 0 , ;
: >RESOLVE    ( addr -- )   here over - swap ! ;
: <MARK       ( -- addr )   here ;
: <RESOLVE    ( addr -- )   here - , ;

: ?COMP  ( -- , error if not compiling ) state @ 0= err_executing ?error ;
: ?PAIRS ( n m -- ) - err_pairs ?error ;

\ Conditional primitives -------------------------------------------
: IF     ( -- f orig )  ?comp compile 0branch conditional_key >mark ; immediate
: THEN   ( f orig -- )  swap ?condition >resolve ; immediate
: BEGIN  ( -- f dest )  ?comp conditional_key <mark ; immediate
: AGAIN  ( f dest -- )  compile branch swap ?condition <resolve ; immediate
: UNTIL  ( f dest -- )  compile 0branch swap ?condition <resolve ; immediate
: AHEAD  ( -- f orig )  compile branch conditional_key >mark ; immediate

\ Conditionals built from primitives -------------------------------
: ELSE   ( f orig1 -- f orig2 )  [compile] ahead 2swap [compile] then ; immediate
: WHILE  ( f dest -- f origi f dest ) [compile] if 2swap ; immediate
: REPEAT  ( -- f orig f dest ) [compile] again [compile] then ; immediate

: [']  ( <name> -- xt , define compile time tick )
    ?comp ' [compile] literal
; immediate

: (DOES>)  ( xt -- , modify previous definition to execute code at xt )
        latest >body   \ get address of code for new word
        3 cell* +      \ offset to EXIT cell in create word
        !              \ store execution token of DOES> code in new word
;

: DOES>   ( -- , define execution code for CREATE word )
        0 [compile] literal \ dummy literal to hold xt
        here cell-          \ address of zero in literal
        compile (does>)     \ call (DOES>) from new creation word
		>r                  \ move addrz to return stack so ; doesn't see stack garbage
        [compile] ;         \ terminate part of code before does>
		r>
        :noname       ( addrz xt )
        compile rdrop       \ drop a stack frame (call becomes goto)
        swap !              \ save execution token in literal
; immediate

: 2! ( x1 x2 addr -- , store x2 followed by x1 )
        swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 )
        dup cell+ @ swap @ ;

: 2* ( n -- n*2 )
        2 *
;
: 2/ ( n -- n/2 )
        2 /
;

\ define some useful constants ------------------------------
1 0= constant FALSE
0 0= constant TRUE
32 constant BL

\ Stack data structure ----------------------------------------
\ This is a general purpose stack utility used to implement necessary
\ stacks for the compiler or the user.  Not real fast.
\ These stacks grow up which is different then normal.
\   cell 0 - stack pointer, offset from pfa of word
\   cell 1 - limit for range checking
\   cell 2 - first data location

: :STACK   ( #cells -- )
        CREATE  2 cells ,          ( offset of first data location )
                dup ,              ( limit for range checking, not currently used )
                cells cell+ allot  ( allot an extra cell for safety )
;

: >STACK  ( n stack -- , push onto stack, postincrement )
        dup @ 2dup cell+ swap ! ( -- n stack offset )
        + !
;

: STACK>  ( stack -- n , pop , predecrement )
        dup @ cell- 2dup swap !
        + @
;

: STACK@ ( stack -- n , copy )
        dup @ cell- + @
;

: STACK.PICK ( index stack -- n , grab Nth from top of stack )
        dup @ cell- +
        swap cells -   \ offset for index
        @
;
: STACKP ( stack -- ptr , to next empty location on stack )
	dup @ +
;

: 0STACKP  ( stack -- , clear stack)
    8 swap !
;

32 :stack ustack
ustack 0stackp

\ Define JForth like words.
: >US ustack >stack ;
: US> ustack stack> ;
: US@ ustack stack@ ;
: 0USP ustack 0stackp ;

\ DO LOOP ------------------------------------------------

3 constant do_flag
4 constant leave_flag
5 constant ?do_flag

: DO    ( -- , loop-back do_flag jump-from ?do_flag )
        ?comp
        compile  (do)
        here >us do_flag  >us  ( for backward branch )
; immediate

: ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )
        ?comp
        ( leave address to set for forward branch )
        compile  (?do)
        here 0 ,
        here >us do_flag  >us  ( for backward branch )
        >us ( for forward branch ) ?do_flag >us
; immediate

: LEAVE  ( -- addr leave_flag )
        compile (leave)
        here 0 , >us
        leave_flag >us
; immediate

: LOOP-FORWARD  ( -us- jump-from ?do_flag -- )
        BEGIN
                us@ leave_flag =
                us@ ?do_flag =
                OR
        WHILE
                us> leave_flag =
                IF
                        us> here over - cell+ swap !
                ELSE
                        us> dup
                        here swap -
                        cell+ swap !
                THEN
        REPEAT
;

: LOOP-BACK  (  loop-addr do_flag -us- )
        us> do_flag ?pairs
        us> here -  here
        !
        cell allot
;

: LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (loop)
   loop-forward loop-back
; immediate

\ : DOTEST 5 0 do 333 . loop 888 . ;
\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;

: +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (+loop)
   loop-forward loop-back
; immediate

: UNLOOP ( loop-sys -r- )
        r> \ save return pointer
        rdrop rdrop
        >r
;

: RECURSE  ( ? -- ? , call the word currently being defined )
    latest compile,
; immediate

: SPACE  bl emit ;
: 0SP depth 0 ?do drop loop ;

\ : >NEWLINE ( -- , CR if needed )
\         out @ 0>
\         IF cr
\         THEN
\ ;

: 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;

: DABS ( d -- |d| )
        dup 0<
        IF dnegate
        THEN
;

: S>D  ( s -- d , extend signed single precision to double )
        dup 0<
        IF -1
        ELSE 0
        THEN
;

: D>S ( d -- s ) drop ;

: PARSE-WORD ( "<spaces>name<space>" -- c-addr u ) bl parse ;
: /STRING  ( addr len n -- addr' len' ) over min rot over  + -rot - ;
: PLACE    ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ;

: ASCII ( <char> -- char, state smart )
    bl parse drop c@
    state @ 1 =
    IF [compile] literal
    ELSE
    THEN
; immediate

: CHAR    ( <char> -- char , interpret mode ) bl parse drop c@ ;
: [CHAR]  ( <char> -- char , for compile mode )
    char [compile] literal
; immediate

: $TYPE  ( $string -- ) count type ;
: 'word  ( -- addr )  here ;

: EVEN    ( addr -- addr' )   dup 1 and +  ;

: (C")  ( -- $addr ) r> dup count + aligned >r ;
: (S")  ( -- c-addr cnt ) r> count 2dup + aligned >r ;
: (.")  ( -- , type following string ) r> count 2dup + aligned >r type ;
: ",    ( addr len -- , place string into dict ) tuck 'word place 1+ allot align ;
: ,"    ( -- ) [char] " parse ", ;

: .(  ( <string> --, type string delimited by parens )
    [char] ) parse type
; immediate

: ."  ( <string> -- , type string )
    state @ 1 =
    IF compile (.")  ,"
    ELSE [char] " parse type
    THEN
; immediate

: .'   ( <string> -- , type string delimited by single quote )
        state @
        IF    compile (.")  [char] ' parse ",
        ELSE [char] ' parse type
        THEN
; immediate

: C"    ( <string> -- addr , return string address, ANSI )
        state @
        IF compile (c")   ,"
        ELSE [char] " parse pad place pad
        THEN
; immediate

: S"    ( <string> -- , -- addr , return string address, ANSI )
        state @
        IF compile (s")   ,"
        ELSE [char] " parse pad place pad count
        THEN
; immediate

: "    ( <string> -- , -- addr , return string address )
        [compile] C"
; immediate
: P"    ( <string> -- , -- addr , return string address )
        [compile] C"
; immediate

: ""  ( <string> -- addr )
       state @
       IF
               compile (C")
               bl parse-word  ",
       ELSE
               bl parse-word pad place pad
       THEN
; immediate

: SLITERAL ( addr cnt -- , compile string )
	compile (S")
	",
; IMMEDIATE

: $APPEND ( addr count $1 -- , append text to $1 )
    over >r
        dup >r
    count +  ( -- a2 c2 end1 )
    swap cmove
    r> dup c@  ( a1 c1 )
    r> + ( -- a1 totalcount )
    swap c!
;

\ ANSI word to replace [COMPILE] and COMPILE ----------------
: POSTPONE  ( <name> -- )
	bl word find
	dup
    0= -13 ?ERROR
    0>
    IF compile,  \ immediate
    ELSE (compile)  \ normal
    THEN

; immediate

\ -----------------------------------------------------------------
\ Auto Initialization
: AUTO.INIT  ( -- )
\ Kernel finds AUTO.INIT and executes it after loading dictionary.
\	." Begin AUTO.INIT ------" cr
;
: AUTO.TERM  ( -- )
\ Kernel finds AUTO.TERM and executes it on bye.
\	." End AUTO.TERM ------" cr
;

: INCLUDE? ( <word> <file> -- , load file if word not defined )
        bl word find
        IF drop bl word drop  ( eat word from source )
        ELSE drop include
        THEN
; immediate

: CLEARSTACK ( i*x -- )
    BEGIN depth
    WHILE drop
    REPEAT ;

variable pictured_output     \ hidden?
variable pictured_output_len \ hidden?

: <# ( -- ) pad pictured_output !  0 pictured_output_len ! ;
: #> ( -- addr n ) drop pictured_output @ pictured_output_len @ ;

: HOLD ( c -- )
    pictured_output @ dup dup 1+ pictured_output_len @ cmove c!
    1 pictured_output_len +!
;

\ ------------------------ INPUT -------------------------------

: SIGN ( n -- ) < 0 IF 45 hold THEN
;

: DIGIT ( n -- ascii )
   dup 10 < IF 48 ELSE 87 THEN + ;

: # ( n -- n )
    base @ /mod swap digit hold ;

: #S ( n -- )
    BEGIN base @ /mod dup
    WHILE swap digit hold
    REPEAT
    digit hold ;

: (WARNING")  ( flag $message -- )
    swap
    IF count type
    ELSE drop
    THEN
;

: WARNING" ( flag <message> -- , print warning if true. )
	[compile] "  ( compile message )
	state @
	IF  compile (warning")
	ELSE (warning")
	THEN
; IMMEDIATE

: ABORT" ( flag <message> -- , print warning if true. )
	[compile] "  ( compile message )
	state @
	IF  compile (abort")
	ELSE (abort")
	THEN
; IMMEDIATE

: DEFER ( "name" -- )
   CREATE ['] ABORT ,
   DOES> ( ... -- ... ) @ EXECUTE ;

: DEFER! ( xt2 xt1 -- )
   >BODY 4 CELL* + ! ;

: DEFER@ ( xt1 -- xt2 )
   >BODY 4 CELL* + @ ;

\ : IS ( xt "<spaces>name" -- , Skip leading spaces and parse name delimited by a space. Set name to execute xt. )
\    STATE @ IF
\      POSTPONE ['] POSTPONE DEFER!
\    ELSE
\      ' DEFER!
\    THEN ; IMMEDIATE


Capitalize sample assembly

Capitalize sample assembly

( simple assembler/VM test - capitalize [-32] console input )

0 const u
1 const c

label &start

  32 u ldc,
     c in,
 c u c sub,
     c out,
&start jump,

assemble

( simple assembler/VM test - capitalize [-32] console input )

0 const u
1 const c

 32 u ldc,
    c in,
c u c sub,
    c out,
    3 jump,

dump


Add do ... loop words

Add do ... loop words

Add do ... loop words and i, j and k words to access loop variables.
Todo: rewrite to not include _loop and _+loop

: + um+  drop   ;
: cells  dup +  ;
: cell+  2   +  ;
: cell- -2   +  ;
: cell   2      ;
: boot     0 cells ;
: forth    4 cells ;
: dpl      5 cells ;
: sp0      6 cells ;
: rp0      7 cells ;
: '?key    8 cells ;
: 'emit    9 cells ;
: 'expect 10 cells ;
: 'tap    11 cells ;
: 'echo   12 cells ;
: 'prompt 13 cells ;
: base    14 cells ;
: tmp     15 cells ;
: span    16 cells ;
: >in     17 cells ;
: #tibb   18 cells ;
: tibb    19 cells ;
: csp     20 cells ;
: 'eval   21 cells ;
: 'number 22 cells ;
: hld     23 cells ;
: handler 24 cells ;
: context 25 cells ;
: current 27 cells ;
: cp      29 cells ;
: np      30 cells ;
: last    31 cells ;
: state   32 cells ;
: spp     33 cells ;
: rpp     34 cells ;
: true -1 ;
: false 0 ;
: bl 32 ;
: bs 8 ;
: =immed    3 ;
: =wordlist 2 ;
: immediate =immed last @ cell- ! ;
: here cp @ ;
: allot cp @ + cp ! ;
: , here cell allot ! ;
: c, here 1 allot c! ;
: +! swap over @ + swap ! ;
: compile r> dup @ , cell+ >r ;
: state? state @ ;
: literal compile lit , ; immediate
: [ false state ! ; immediate
: ] true state ! ; immediate
: if compile 0branch here 0 , ; immediate
: then here swap ! ; immediate
: for compile >r here ; immediate
: next compile next , ; immediate
: begin here ; immediate
: again compile branch , ; immediate
: until compile 0branch , ; immediate
: ahead compile branch here 0 , ; immediate
: repeat compile branch , here swap ! ; immediate
: aft drop compile branch here 0 ,  here swap ; immediate
: else compile branch here 0 ,  swap here swap !  ; immediate
: while compile 0branch here 0 , swap ; immediate
: execute >r ;
: @execute @ dup if execute then ;
: r@ r> r> dup >r swap >r ;
: #tib #tibb @ ;
: tib tibb @ ;
: \ #tib @ >in ! ; immediate
: rot >r swap r> swap ;
: -rot swap >r swap r> ;
: nip swap drop ;
: tuck swap over ;
: 2>r swap r> swap >r swap >r >r ;
: 2r> r> r> swap r> swap >r swap ;
: 2r@ r> r> r@ swap >r swap r@ swap >r ;
: 2drop drop drop ;
: 2dup over over ;
: 2swap rot >r rot r> ;
: 2over >r >r 2dup r> r> 2swap ;
: 2rot 2>r 2swap 2r> 2swap ;
: -2rot 2rot 2rot ;
: 2nip 2swap 2drop ;
: 2tuck 2swap 2over ;
: not dup nand ;
: and nand not ;
: or not swap not nand ;
: nor or not ;
: xor 2dup and -rot nor nor ;
: xnor xor not ;
: negate not 1 + ;
: - negate + ;
: 1+ 1 + ;
: 1- 1 - ;
: 2+ 2 + ;
: 2- 2 - ;
: d+ >r swap >r um+ r> r> + + ;
: dnegate not >r not 1 um+ r> + ;
: d- dnegate d+ ;
: 2! swap over ! cell+ ! ;
: 2@ dup cell+ @ swap @ ;
: ?dup dup if dup then ;
: s>d dup 0< ;
: abs dup 0< if negate then ;
: dabs dup 0< if dnegate then ;
: u< 2dup xor 0< if swap drop 0< exit then - 0< ;
: u> swap u< ;
: = xor if false exit then true ;
: < 2dup xor 0< if drop 0< exit then - 0< ;
: > swap < ;
: 0> negate 0< ;
: 0<> if true exit then false ;
: 0= 0 = ;
: <> = 0= ;
: d0< swap drop 0< ;
: d0> dnegate d0< ;
: d0= or 0= ;
: d= d- d0= ;
: d< rot 2dup xor if swap 2swap 2drop < ;
: du< rot 2dup xor if swap 2swap then then 2drop u< ;
: dmin 2over 2over 2swap d< if 2swap then 2drop ;
: dmax 2over 2over d< if 2swap then 2drop ;
: m+ s>d d+ ;
: m- s>d d- ;
: min 2dup swap < if swap then drop ;
: max 2dup < if swap then drop ;
: umin 2dup swap u< if swap then drop ;
: umax 2dup u< if swap then drop ;
: within over - >r - r> u< ;
: um/mod
    2dup u<
    if negate
        15 for
            >r dup um+
                >r >r dup um+
                r> + dup r> r@ swap
            >r um+
            r> or
                if >r drop 1+ r>
                else drop
            then r>
        next drop swap exit
    then drop 2drop -1 dup ;
: m/mod
    dup 0< dup >r
        if negate >r
            dnegate r>
        then >r dup 0<
        if r@ +
        then r> um/mod
    r>
    if swap negate swap then ;
: /mod over 0< swap m/mod ;
: mod /mod drop ;
: / /mod nip ;
: um*
    0 swap
    15 for
        dup um+ >r >r
        dup um+
        r> +
        r>
        if >r over um+
            r> +
        then
    next
    rot drop ;
: * um* drop ;
: m*
    2dup xor 0< >r
    abs swap abs um*
    r> if dnegate then ;
: */mod >r m* r> m/mod ;
: */ */mod swap drop ;
: 2* 2 * ;
: 2/ 2 / ;
: mu/mod >r 0 r@ um/mod r> swap >r um/mod r> ;
: d2* 2dup d+ ;
: du2/ 2 mu/mod rot drop ;
: d2/ dup >r 1 and du2/ r> 2/ or ;
: aligned dup 0 2 um/mod drop dup if 2 swap - then + ;
: parse
    tmp ! over >r dup
    if
        1- tmp @ bl =
        if
            for bl over c@ - 0< not
            while 1+
                next r> drop 0 dup exit
            then r>
        then
            over swap
        for tmp @ over c@ - tmp @ bl =
            if 0< then
        while 1+
        next dup >r
        else r> drop dup 1+ >r
        then over - r> r> - exit
    then over r> - ;
: parse >r tib >in @ + #tib c@ >in @ - r> parse >in +! ;
: char bl parse drop c@ ;
: tx! 1 putc ;
: emit 'emit @execute ;
: type for aft dup c@ emit 1+ then next drop ;
: ?rx 0 getc ;
: ?key '?key @execute ;
: key begin ?key until ;
: count dup 1+ swap c@ ;
: cmove
    for
        aft
            >r dup c@ r@ c! 1+ r> 1+
        then
    next 2drop ;
: fill
    swap
    for swap
        aft 2dup c! 1+ then
    next 2drop ;
: -trailing
    for
        aft
        bl over r@ + c@ <
        if
            r> 1+ exit
        then
    then
    next 0 ;
: pack$
    dup >r
        2dup c! 1+ 2dup + 0 swap ! swap cmove
    r> ;
: word parse here pack$ ;
: token bl parse 31 min np @ over - 1- pack$ ;
: link> 3 cells - ;
: code> 2 cells - ;
: type> 1 cells - ;
: data> cell+ ;
: same?
    for aft
        over r@ cells + @
        over r@ cells + @
        - ?dup
        if r> drop exit then
    then
    next 0 ;
: find
    @ begin dup while
        2dup c@ swap c@ = if
        2dup 1+ swap count aligned cell / >r swap r>
        same? 0= if
            2drop swap drop dup code> @ swap -1 exit
        then 2drop then
    link> @ repeat ;
: ' token context @ find if drop else swap drop 0 then ;
: ! ! ;
' tx! 'emit !
' ?rx '?key !
: ['] compile ' ; immediate
: postpone ' , ; immediate
: [char] char postpone literal ; immediate
: ( [char] ) parse 2drop ; immediate
: :noname here postpone ] ;
: overt last @ current @ ! ;
: $,n
    dup last ! cell-
    dup =wordlist
    swap !
    cell- dup here
    swap !
    cell- dup current @ @
    swap !
    cell- np ! ;
: : token $,n postpone ] ;
: ; compile exit postpone [ overt ; immediate
: recurse last @ code> @ , ; immediate
: dovar r> ;
: create token $,n compile dovar overt ;
: does last @ code> @ r> swap ! ;
: does> compile does compile r> ; immediate
: constant create , does> @ ;
: variable create 0 , ;
: 2literal swap postpone literal
    postpone literal ; immediate
: 2constant create , , does> 2@ ;
: 2variable create 2 cells allot ;
: space bl emit ;
: spaces 0 max for space next ;
: pad here 80 + ;
: decimal 10 base ! ;
: hex 16 base ! ;
: binary 2 base ! ;
: octal 8 base ! ;
decimal
: char- 1- ;
: char+ 1+ ;
: chars ;
: >char 127 and dup 127 bl within if drop 95 then ;
: digit 9 over < 7 and + [char] 0 + ;
: <# pad hld ! ;
: hold hld @ char- dup hld ! c! ;
: # 0 base @ um/mod >r base @ um/mod swap digit hold r> ;
: #s begin # 2dup or 0= until ;
: sign 0< if [char] - hold then ;
: #> 2drop hld @ pad over - ;
: s.r over - spaces type ;
: d.r >r dup >r dabs <# #s r> sign #> r> s.r ;
: u.r 0 swap d.r ;
: .r >r s>d r> d.r ;
: d. 0 d.r space ;
: u. 0 d. ;
: . base @ 10 xor if u. exit then s>d d. ;
: ? @ . ;
: du.r >r <# #s #> r> s.r ;
: du. du.r space ;
: do$ r> r@ r> count + aligned >r swap >r ;
: ."| do$ count type ;
: $," [char] " word count + aligned cp ! ;
: ." compile ."| $," ; immediate
: .( [char] ) parse type ; immediate
: $"| do$ ;
: $" compile $"| $," ; immediate
: s" [char] " parse here pack$ ;
: cr 10 emit ;
: tap over c! 1+ ;
: ktap
    10 xor
    if
        bl tap exit
    then
    nip dup ;
: accept
    over + over
    begin
        2dup xor
    while
        key
        dup bl - 95 u<
        if tap else ktap then
    repeat drop over - ;
: expect accept span ! drop ;
: query tib 80 accept #tib c! drop 0 >in ! ;
: digit?
    >r [char] 0 -
    9 over <
    if 7 - dup 10 < or then
    dup r> u< ;
: /string dup >r - swap r> + swap ;
: >number
    begin dup
    while >r dup >r c@ base @ digit?
    while swap base @ um* drop rot
    base @ um* d+ r> char+ r> 1 -
    repeat drop r> r> then ;
: number?
    over c@ [char] - = dup >r if 1 /string then
    >r >r 0 dup r> r> -1 dpl !
    begin >number dup
    while over c@ [char] . xor
        if rot drop rot r> 2drop false exit
    then 1 - dpl ! char+ dpl @
    repeat 2drop r> if dnegate then true ;
' number? 'number !
: $interpret
    context @ find
    if drop execute exit then
    count 'number @execute if
        dpl @ 0< if drop then exit then ." ?" type ;
: $compile
    context @ find
    if cell- @ =immed =
        if execute else , then exit
    then count 'number @execute
    if
        dpl @ 0<
        if drop postpone literal
        else postpone 2literal
        then exit
    then ." ?" type ;
: eval state? if $compile else $interpret then ;
' eval 'eval !
: eval
    begin token dup c@ while
        'eval @execute
    repeat drop ;
: ok cr ." ok." space ;
' ok 'prompt !
: quit
    begin 'prompt @execute query
    eval again ;
: bye ." good bye " cr halt ;
' quit boot !
: sp@ spp @ ;
: depth sp@ sp0 @ - cell / ;
: pick cells sp@ swap - 2 cells - @ ;
: .s cr depth for aft r@ pick . then next space ." <sp " cr ;
: words
    context @ @ begin dup while dup count type link>
    @ space repeat drop cr ;

: rpick r> rpp @ swap >r + 2- @ ;
: do compile 2>r postpone begin ; immediate
: _loop r> r> 1+ dup r@ 1- > swap >r swap >r ;
: _+loop r> swap r> swap + dup r@ 1- > swap >r swap >r ;
: leave r> 2r> 2drop >r ;
: unloop r> r> drop r@ r> r> ;
: loop compile _loop postpone until compile leave ; immediate
: +loop compile _+loop postpone until compile leave ; immediate
: i r> r> tuck >r >r ;
: j 4 rpick ;
: k 4 rpick ;

variable file
: open f_open file ! ;
: close file @ f_close ;
: fput file @ putc ;
: fget file @ getc ;
: fputs count for aft dup c@ fput 1+ then next drop ;

: savevm $" eforth.img" $" wb" open 0
    16384 for aft dup c@ fput 1+ then next close drop ;

savevm

: + um+  drop   ;
: cells  dup +  ;
: cell+  2   +  ;
: cell- -2   +  ;
: cell   2      ;
: boot     0 cells ;
: forth    4 cells ;
: dpl      5 cells ;
: sp0      6 cells ;
: rp0      7 cells ;
: '?key    8 cells ;
: 'emit    9 cells ;
: 'expect 10 cells ;
: 'tap    11 cells ;
: 'echo   12 cells ;
: 'prompt 13 cells ;
: base    14 cells ;
: tmp     15 cells ;
: span    16 cells ;
: >in     17 cells ;
: #tibb   18 cells ;
: tibb    19 cells ;
: csp     20 cells ;
: 'eval   21 cells ;
: 'number 22 cells ;
: hld     23 cells ;
: handler 24 cells ;
: context 25 cells ;
: current 27 cells ;
: cp      29 cells ;
: np      30 cells ;
: last    31 cells ;
: state   32 cells ;
: spp     33 cells ;
: rpp     34 cells ;
: true -1 ;
: false 0 ;
: bl 32 ;
: bs 8 ;
: =immed    3 ;
: =wordlist 2 ;
: immediate =immed last @ cell- ! ;
: here cp @ ;
: allot cp @ + cp ! ;
: , here cell allot ! ;
: c, here 1 allot c! ;
: +! swap over @ + swap ! ;
: compile r> dup @ , cell+ >r ;
: state? state @ ;
: literal compile lit , ; immediate
: [ false state ! ; immediate
: ] true state ! ; immediate
: if compile 0branch here 0 , ; immediate
: then here swap ! ; immediate
: for compile >r here ; immediate
: next compile next , ; immediate
: begin here ; immediate
: again compile branch , ; immediate
: until compile 0branch , ; immediate
: ahead compile branch here 0 , ; immediate
: repeat compile branch , here swap ! ; immediate
: aft drop compile branch here 0 ,  here swap ; immediate
: else compile branch here 0 ,  swap here swap !  ; immediate
: while compile 0branch here 0 , swap ; immediate
: execute >r ;
: @execute @ dup if execute then ;
: r@ r> r> dup >r swap >r ;
: #tib #tibb @ ;
: tib tibb @ ;
: \ #tib @ >in ! ; immediate
: rot >r swap r> swap ;
: -rot swap >r swap r> ;
: nip swap drop ;
: tuck swap over ;
: 2>r swap r> swap >r swap >r >r ;
: 2r> r> r> swap r> swap >r swap ;
: 2r@ r> r> r@ swap >r swap r@ swap >r ;
: 2drop drop drop ;
: 2dup over over ;
: 2swap rot >r rot r> ;
: 2over >r >r 2dup r> r> 2swap ;
: 2rot 2>r 2swap 2r> 2swap ;
: -2rot 2rot 2rot ;
: 2nip 2swap 2drop ;
: 2tuck 2swap 2over ;
: not dup nand ;
: and nand not ;
: or not swap not nand ;
: nor or not ;
: xor 2dup and -rot nor nor ;
: xnor xor not ;
: negate not 1 + ;
: - negate + ;
: 1+ 1 + ;
: 1- 1 - ;
: 2+ 2 + ;
: 2- 2 - ;
: d+ >r swap >r um+ r> r> + + ;
: dnegate not >r not 1 um+ r> + ;
: d- dnegate d+ ;
: 2! swap over ! cell+ ! ;
: 2@ dup cell+ @ swap @ ;
: ?dup dup if dup then ;
: s>d dup 0< ;
: abs dup 0< if negate then ;
: dabs dup 0< if dnegate then ;
: u< 2dup xor 0< if swap drop 0< exit then - 0< ;
: u> swap u< ;
: = xor if false exit then true ;
: < 2dup xor 0< if drop 0< exit then - 0< ;
: > swap < ;
: 0> negate 0< ;
: 0<> if true exit then false ;
: 0= 0 = ;
: <> = 0= ;
: d0< swap drop 0< ;
: d0> dnegate d0< ;
: d0= or 0= ;
: d= d- d0= ;
: d< rot 2dup xor if swap 2swap 2drop < ;
: du< rot 2dup xor if swap 2swap then then 2drop u< ;
: dmin 2over 2over 2swap d< if 2swap then 2drop ;
: dmax 2over 2over d< if 2swap then 2drop ;
: m+ s>d d+ ;
: m- s>d d- ;
: min 2dup swap < if swap then drop ;
: max 2dup < if swap then drop ;
: umin 2dup swap u< if swap then drop ;
: umax 2dup u< if swap then drop ;
: within over - >r - r> u< ;
: um/mod
    2dup u<
    if negate
        15 for
            >r dup um+
                >r >r dup um+
                r> + dup r> r@ swap
            >r um+
            r> or
                if >r drop 1+ r>
                else drop
            then r>
        next drop swap exit
    then drop 2drop -1 dup ;
: m/mod
    dup 0< dup >r
        if negate >r
            dnegate r>
        then >r dup 0<
        if r@ +
        then r> um/mod
    r>
    if swap negate swap then ;
: /mod over 0< swap m/mod ;
: mod /mod drop ;
: / /mod nip ;
: um*
    0 swap
    15 for
        dup um+ >r >r
        dup um+
        r> +
        r>
        if >r over um+
            r> +
        then
    next
    rot drop ;
: * um* drop ;
: m*
    2dup xor 0< >r
    abs swap abs um*
    r> if dnegate then ;
: */mod >r m* r> m/mod ;
: */ */mod swap drop ;
: 2* 2 * ;
: 2/ 2 / ;
: mu/mod >r 0 r@ um/mod r> swap >r um/mod r> ;
: d2* 2dup d+ ;
: du2/ 2 mu/mod rot drop ;
: d2/ dup >r 1 and du2/ r> 2/ or ;
: aligned dup 0 2 um/mod drop dup if 2 swap - then + ;
: parse
    tmp ! over >r dup
    if
        1- tmp @ bl =
        if
            for bl over c@ - 0< not
            while 1+
                next r> drop 0 dup exit
            then r>
        then
            over swap
        for tmp @ over c@ - tmp @ bl =
            if 0< then
        while 1+
        next dup >r
        else r> drop dup 1+ >r
        then over - r> r> - exit
    then over r> - ;
: parse >r tib >in @ + #tib c@ >in @ - r> parse >in +! ;
: char bl parse drop c@ ;
: tx! 1 putc ;
: emit 'emit @execute ;
: type for aft dup c@ emit 1+ then next drop ;
: ?rx 0 getc ;
: ?key '?key @execute ;
: key begin ?key until ;
: count dup 1+ swap c@ ;
: cmove
    for
        aft
            >r dup c@ r@ c! 1+ r> 1+
        then
    next 2drop ;
: fill
    swap
    for swap
        aft 2dup c! 1+ then
    next 2drop ;
: -trailing
    for
        aft
        bl over r@ + c@ <
        if
            r> 1+ exit
        then
    then
    next 0 ;
: pack$
    dup >r
        2dup c! 1+ 2dup + 0 swap ! swap cmove
    r> ;
: word parse here pack$ ;
: token bl parse 31 min np @ over - 1- pack$ ;
: link> 3 cells - ;
: code> 2 cells - ;
: type> 1 cells - ;
: data> cell+ ;
: same?
    for aft
        over r@ cells + @
        over r@ cells + @
        - ?dup
        if r> drop exit then
    then
    next 0 ;
: find
    @ begin dup while
        2dup c@ swap c@ = if
        2dup 1+ swap count aligned cell / >r swap r>
        same? 0= if
            2drop swap drop dup code> @ swap -1 exit
        then 2drop then
    link> @ repeat ;
: ' token context @ find if drop else swap drop 0 then ;
: ! ! ;
' tx! 'emit !
' ?rx '?key !
: ['] compile ' ; immediate
: postpone ' , ; immediate
: [char] char postpone literal ; immediate
: ( [char] ) parse 2drop ; immediate
: :noname here postpone ] ;
: overt last @ current @ ! ;
: $,n
    dup last ! cell-
    dup =wordlist
    swap !
    cell- dup here
    swap !
    cell- dup current @ @
    swap !
    cell- np ! ;
: : token $,n postpone ] ;
: ; compile exit postpone [ overt ; immediate
: recurse last @ code> @ , ; immediate
: dovar r> ;
: create token $,n compile dovar overt ;
: does last @ code> @ r> swap ! ;
: does> compile does compile r> ; immediate
: constant create , does> @ ;
: variable create 0 , ;
: 2literal swap postpone literal
    postpone literal ; immediate
: 2constant create , , does> 2@ ;
: 2variable create 2 cells allot ;
: space bl emit ;
: spaces 0 max for space next ;
: pad here 80 + ;
: decimal 10 base ! ;
: hex 16 base ! ;
: binary 2 base ! ;
: octal 8 base ! ;
decimal
: char- 1- ;
: char+ 1+ ;
: chars ;
: >char 127 and dup 127 bl within if drop 95 then ;
: digit 9 over < 7 and + [char] 0 + ;
: <# pad hld ! ;
: hold hld @ char- dup hld ! c! ;
: # 0 base @ um/mod >r base @ um/mod swap digit hold r> ;
: #s begin # 2dup or 0= until ;
: sign 0< if [char] - hold then ;
: #> 2drop hld @ pad over - ;
: s.r over - spaces type ;
: d.r >r dup >r dabs <# #s r> sign #> r> s.r ;
: u.r 0 swap d.r ;
: .r >r s>d r> d.r ;
: d. 0 d.r space ;
: u. 0 d. ;
: . base @ 10 xor if u. exit then s>d d. ;
: ? @ . ;
: du.r >r <# #s #> r> s.r ;
: du. du.r space ;
: do$ r> r@ r> count + aligned >r swap >r ;
: ."| do$ count type ;
: $," [char] " word count + aligned cp ! ;
: ." compile ."| $," ; immediate
: .( [char] ) parse type ; immediate
: $"| do$ ;
: $" compile $"| $," ; immediate
: s" [char] " parse here pack$ ;
: cr 10 emit ;
: tap over c! 1+ ;
: ktap
    10 xor
    if
        bl tap exit
    then
    nip dup ;
: accept
    over + over
    begin
        2dup xor
    while
        key
        dup bl - 95 u<
        if tap else ktap then
    repeat drop over - ;
: expect accept span ! drop ;
: query tib 80 accept #tib c! drop 0 >in ! ;
: digit?
    >r [char] 0 -
    9 over <
    if 7 - dup 10 < or then
    dup r> u< ;
: /string dup >r - swap r> + swap ;
: >number
    begin dup
    while >r dup >r c@ base @ digit?
    while swap base @ um* drop rot
    base @ um* d+ r> char+ r> 1 -
    repeat drop r> r> then ;
: number?
    over c@ [char] - = dup >r if 1 /string then
    >r >r 0 dup r> r> -1 dpl !
    begin >number dup
    while over c@ [char] . xor
        if rot drop rot r> 2drop false exit
    then 1 - dpl ! char+ dpl @
    repeat 2drop r> if dnegate then true ;
' number? 'number !
: $interpret
    context @ find
    if drop execute exit then
    count 'number @execute if
        dpl @ 0< if drop then exit then ." ?" type ;
: $compile
    context @ find
    if cell- @ =immed =
        if execute else , then exit
    then count 'number @execute
    if
        dpl @ 0<
        if drop postpone literal
        else postpone 2literal
        then exit
    then ." ?" type ;
: eval state? if $compile else $interpret then ;
' eval 'eval !
: eval
    begin token dup c@ while
        'eval @execute
    repeat drop ;
: ok cr ." ok." space ;
' ok 'prompt !
: quit
    begin 'prompt @execute query
    eval again ;
: bye ." good bye " cr halt ;
' quit boot !
: sp@ spp @ ;
: depth sp@ sp0 @ - cell / ;
: pick cells sp@ swap - 2 cells - @ ;
: .s cr depth for aft r@ pick . then next space ." <sp " cr ;
: words
    context @ @ begin dup while dup count type link>
    @ space repeat drop cr ;

variable file
: open f_open file ! ;
: close file @ f_close ;
: fput file @ putc ;
: fget file @ getc ;
: fputs count for aft dup c@ fput 1+ then next drop ;

: savevm $" eforth.img" $" wb" open 0
    16384 for aft dup c@ fput 1+ then next close drop ;

savevm


Define Wakerequest and TICKS

Define Wakerequest and TICKS

\ Wrappers for SAPI functions, ABI 3.x

\ *G Get the version of the binary ABI in use.
SVC(  #0 ) int SAPIVERSION( );              ( -- ver )

\ * Get a pointer to any shared data structures.
SVC(  #1 ) int SHARED_P( int x );                 ( -- addr )

\ *G EMIT - Stream IO
\ Emit a character and return 0 when the output buffer is full.
\ Blocking/Spinning.
\ -1 for output flush.
SVC(  #2 ) int __EMIT( int x, int stream);  ( char channel -- room )

\ *G KEY? - Read a Key.
\ Blocking.  Use with SERKEY? to detect blocking situations.
SVC(  #3 ) int __KEY(int stream);  ( base -- key )

\ *G SERKEY? - Stream IO
\ Return the number of characters available in the input queue,
\ or empty/full.  Pass in a tcb to request a wakeup on new data.
SVC(  #4 ) int __KEY?(int stream, int tcb);      ( base -- int )

\ *G EMIT_NB - Non-blocking emit
\ Returns -1 if the write failed.  Pass in a TCB
SVC(  #7 ) int __EMIT_NB(int c, int stream,  int tcb);  ( base tcb -- key )

\ *G WAKEREQUEST
\ Request a task wake.  The system call will stop the task.
SVC(  #8 ) void WAKEREQUEST(int tcb, int arg1, int arg2 );  ( base tcb -- key )

SVC( #15 ) int TICKS( );          ( -- ms )

\ Wrappers for SAPI functions, ABI 3.x

\ *G Get the version of the binary ABI in use.
SVC(  #0 ) int SAPIVERSION( );              ( -- ver )

\ * Get a pointer to any shared data structures.
SVC(  #1 ) int SHARED_P( );                 ( -- addr )

\ *G EMIT - Stream IO
\ Emit a character and return 0 when the output buffer is full.
\ Blocking/Spinning.
\ -1 for output flush.
SVC(  #2 ) int __EMIT( int x, int stream);  ( char channel -- room )

\ *G KEY? - Read a Key.
\ Blocking.  Use with SERKEY? to detect blocking situations.
SVC(  #3 ) int __KEY(int stream);  ( base -- key )

\ *G SERKEY? - Stream IO
\ Return the number of characters available in the input queue,
\ or empty/full.  Pass in a tcb to request a wakeup on new data.
SVC(  #4 ) int __KEY?(int stream, int tcb);      ( base -- int )

\ *G EMIT_NB - Non-blocking emit
\ Returns -1 if the write failed.  Pass in a TCB
SVC(  #7 ) int __EMIT_NB(int c, int stream,  int tcb);  ( base tcb -- key )

SVC( #15 ) int TICKS();          ( -- ms )