The sparc64 boot block currently compares a memory address to the ELF magic
and complains if they do not match. Instead, load the start of the ELF
header from memory and complain if this does not match the ELF magic.

Tested by kettenis@

ok miod@

\	$OpenBSD: bootblk.fth,v 1.4 2009/09/03 16:39:37 jsing 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 l@ is-elf? false = 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

\	$OpenBSD: bootblk.fth,v 1.3 2003/08/28 23:47:31 jason 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


?NEG refactored

?NEG refactored

\ KataDiversion in Forth

\ -- utils

\ empty the stack
: EMPTY
    DEPTH 0 <> IF BEGIN
                    DROP DEPTH 0 =
                  UNTIL
               THEN ;

\ power
: ** ( n1 n2 -- n1_pow_n2 ) 1 SWAP ?DUP IF 0 DO OVER * LOOP THEN NIP ;

\ test if the top is a negative number
: ?NEG ( n -- bool ) 1 < ;

\ compute the highest power of 2 below N.
\ e.g. : 31 -> 16, 4 -> 4
: MAXPOW2 ( n -- log2_n ) DUP 1 < IF 1 ABORT" Maxpow2 need a positive value."
                               ELSE DUP 1 = IF 1
                                            ELSE
                                                1 >R
                                                BEGIN ( n |R: i=1)
                                                    DUP DUP I - 2 *
                                                    ( n n 2*[n-i])
                                                    R> 2 * >R ( … |R: i*2)
                                                    > ( n n>2*[n-i] )
                                                UNTIL
                                                R> 2 /
                                            THEN
                               THEN NIP ;

\ -- kata

\ test if the given N has two adjacent 1 bits
\ e.g. : 11 -> 1011 -> -1
\         9 -> 1001 ->  0
: ?TWO-ADJACENT-1-BITS ( n -- bool )
    \ the word uses the following algorithm :
    \ (stack|return stack)
    \ ( A N | X )  A: 0, X: N LOG2
    \ loop: if N-X > 0 then A++ else A=0 ; X /= 2
    \       return -1 if A=2
    \       if X=1 end loop and return 0
    0 SWAP DUP DUP 0 <> IF
                            MAXPOW2 >R
                            BEGIN
                                DUP I - 0 >= IF
                                                SWAP DUP 1 = IF 1+ SWAP
                                                             ELSE 1+ SWAP I -
                                                            THEN
                                             ELSE NIP 0 SWAP
                                             THEN
                                OVER
                                2 =
                                I 1 = OR
                                R> 2 / >R
                            UNTIL
                            R> 2DROP
                            2 =
                       THEN ;

\ return the maximum number which can be made with N (given number) bits
: ?MAX-NB ( n -- m ) DUP ?NEG IF DROP 0 ( 0 )
                              ELSE
                                  DUP IF DUP 2 SWAP ** NIP ( 2**n )
                                  THEN
                              THEN ;

\ return the number of numbers which can be made with N (given number) bits
\ or less, and which have not two adjacent 1 bits.
\ see http://www.codekata.com/2007/01/code_kata_fifte.html
: ?HOW-MANY-NB-NOT-TWO-ADJACENT-1-BITS ( n -- m ) ( TODO ) ;

\ KataDiversion in Forth

\ -- utils

\ empty the stack
: EMPTY
    DEPTH 0 <> IF BEGIN
                    DROP DEPTH 0 =
                  UNTIL
               THEN ;

\ power
: ** ( n1 n2 -- n1_pow_n2 ) 1 SWAP ?DUP IF 0 DO OVER * LOOP THEN NIP ;

\ test if the top is a negative number
: ?NEG ( n -- bool ) DUP 0= IF -1 ELSE DUP ABS <> THEN ;

\ compute the highest power of 2 below N.
\ e.g. : 31 -> 16, 4 -> 4
: MAXPOW2 ( n -- log2_n ) DUP 1 < IF 1 ABORT" Maxpow2 need a positive value."
                               ELSE DUP 1 = IF 1
                                            ELSE
                                                1 >R
                                                BEGIN ( n |R: i=1)
                                                    DUP DUP I - 2 *
                                                    ( n n 2*[n-i])
                                                    R> 2 * >R ( … |R: i*2)
                                                    > ( n n>2*[n-i] )
                                                UNTIL
                                                R> 2 /
                                            THEN
                               THEN NIP ;

\ -- kata

\ test if the given N has two adjacent 1 bits
\ e.g. : 11 -> 1011 -> -1
\         9 -> 1001 ->  0
: ?TWO-ADJACENT-1-BITS ( n -- bool )
    \ the word uses the following algorithm :
    \ (stack|return stack)
    \ ( A N | X )  A: 0, X: N LOG2
    \ loop: if N-X > 0 then A++ else A=0 ; X /= 2
    \       return -1 if A=2
    \       if X=1 end loop and return 0
    0 SWAP DUP DUP 0 <> IF
                            MAXPOW2 >R
                            BEGIN
                                DUP I - 0 >= IF
                                                SWAP DUP 1 = IF 1+ SWAP
                                                             ELSE 1+ SWAP I -
                                                            THEN
                                             ELSE NIP 0 SWAP
                                             THEN
                                OVER
                                2 =
                                I 1 = OR
                                R> 2 / >R
                            UNTIL
                            R> 2DROP
                            2 =
                       THEN ;

\ return the maximum number which can be made with N (given number) bits
: ?MAX-NB ( n -- m ) DUP ?NEG IF DROP 0 ( 0 )
                              ELSE
                                  DUP IF DUP 2 SWAP ** NIP ( 2**n )
                                  THEN
                              THEN ;

\ return the number of numbers which can be made with N (given number) bits
\ or less, and which have not two adjacent 1 bits.
\ see http://www.codekata.com/2007/01/code_kata_fifte.html
: ?HOW-MANY-NB-NOT-TWO-ADJACENT-1-BITS ( n -- m ) ( TODO ) ;


boot: 19.1 development now

boot: 19.1 development now

\ Copyright (c) 2006-2015 Devin Teske <dteske@FreeBSD.org>
\ Copyright (c) 2016-2017 Deciso B.V.
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions
\ are met:
\ 1. Redistributions of source code must retain the above copyright
\    notice, this list of conditions and the following disclaimer.
\ 2. Redistributions in binary form must reproduce the above copyright
\    notice, this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
\ SUCH DAMAGE.
\
\ $FreeBSD$

48 logoX ! 9 logoY ! \ Initialize logo placement defaults

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

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

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

	2drop
;

\ Copyright (c) 2006-2015 Devin Teske <dteske@FreeBSD.org>
\ Copyright (c) 2016-2017 Deciso B.V.
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions
\ are met:
\ 1. Redistributions of source code must retain the above copyright
\    notice, this list of conditions and the following disclaimer.
\ 2. Redistributions in binary form must reproduce the above copyright
\    notice, this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
\ SUCH DAMAGE.
\
\ $FreeBSD$

48 logoX ! 9 logoY ! \ Initialize logo placement defaults

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

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

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

	2drop
;


added recurse keyword

added recurse keyword

\ Howe Forth: Start up code.
\ @author         Richard James Howe.
\ @copyright      Copyright 2013 Richard James Howe.
\ @license        LGPL
\ @email          howe.r.j.89@gmail.com

: true 1 exit
: false 0 exit

: cpf 13 exit \ Compile Flag
: state cpf !reg exit
: ; immediate
	' exit ,
	false state
exit

\ Register constants
: r 3 ;	        \ Return stack pointer
: v 4 ;	        \ Variable stack pointer
: h 5 ;	        \ Dictionary pointer
: str 6 ;       \ String storage pointer
: pwd 7 ;       \ previous word
: exf 14 ;      \ Pointer to execution token, executed on error.
: iobl 21 ;     \ I/O buf len address
: here h @reg ;

\ Error handling!
: on_err read on_err ;  \ This word is executed when an error occurs.
find on_err exf !reg    \ Write the executable token for on_err into the dictionary.

\ change to command mode
: [ immediate false state ;
\ change to compile mode
: ] true state ;

\ These words represent words with no name in the dictionary,
\ the 'invisible' words.
: _push 0 ;
: _compile 1 ;
: _run 2 ;

\ System calls
: reset 0 ;
: fopen 1 ;
: fclose 2 ;
: fflush 3 ;
: remove 4 ;
: rename 5 ;
: rewind 6 ;
: system 7 ;

\ Constants for system call arguments
: input 0 ;
: output 1 ;

: literal immediate _push , , ;

\ ASCII chars

: 'esc' 27 ;
: '"' 34 ;
: ')' 41 ;

: 0= 0 = ;
: 0< 0 < ;
: 0> 0 > ;

: space 32 emit ;
: cr 10 emit ;
: tab 9 emit ;

: prnn 10 swap printnum ;
: . prnn cr ;

: tuck swap over ;
: nip swap drop ;
: rot >r swap r> swap ;
: <> = 0= ;
: negate -1 * ;
: -rot rot rot ;

: 2drop drop drop ;
: 2dup over over ;
: 2swap rot >r rot r> ;

: 2+ 1+ 1+ ;
: 2* 2 * ;
: 2/ 2 / ;
: 2- 1- 1- ;

: if immediate
	' ?br ,
	here 0 ,
;

: else immediate
	' br ,
	here
	0 ,
	swap dup here swap -
	swap !
;

: then immediate
	dup here
	swap - swap
	!
;

: begin immediate
	here
;

: until immediate
	' ?br ,
	here - ,
;

: ?dup dup if dup then ;
: abs dup 0 < if negate then ;

: min 2dup < if drop else swap drop then  ;
: max 2dup > if drop else swap drop then  ;

: allot here + h !reg ;
: :noname immediate here _run , ] ;
: ? 0= if \ ( bool -- ) ( Conditional evaluation )
      [ find \ literal ] execute
    then
;

: _( \ ( letter bool -- ) \
  >r \ Store bool on return stack for simplicity
     begin
        key 2dup = \ key in a letter, test if it is equal to out terminator
        if
          2drop 1 \ Drop items, quit loop
        else
          r> dup >r \ test for bool
          if        \ bool == 1, emit letter, bool == 0 drop it.
             emit
          else
             drop
          then
          0 \ Continue
        then
    until
  r> drop \ Return stack back to normal now.
;

: ( immediate ')' 0 _( ;  ( Now we have proper comments )
: .( immediate ')' 1 _( ; ( Print out word )

 ( Print out a string stored in string storage )
: prn ( str_ptr -- )
    begin
        dup @str dup 0= ( if null )
        if
            2drop 1
        else
            emit 1+ 0
        then
    until
;

 ( Store a '"' terminated string in string storage )
: _." ( -- )
    str @reg 1-
    begin
        key dup >r '"' =
        if
            r> drop 1
        else
            1+ dup r> swap !str 0
        then
    until
    2+
    str !reg
;

: ." immediate
    cpf @reg 0= if
    '"' 1 _(
    else
        _push , str @reg ,
        _."
        ' prn ,
    then
;

: :: 	( compiles a ':' )
  [ find : , ]
;

( Helper words for create )
: '', ' ' , ;       \ A word that writes ' into the dictionary
: ',, ' , , ;       \ A word that writes , into the dictionary
: 'exit, ' exit , ; \ A word that write exit into the dictionary
: 3+ 2+ 1+ ;

( The word create involves multiple levels of indirection.
 It makes a word which has to write in values into
 another word )
: create immediate              \ This is a complicated word! It makes a
                                \ word that makes a word.
  cpf @reg if                   \ Compile time behavour
  ' :: ,                        \ Make the defining word compile a header
  '', _push , ',,               \ Write in push to the creating word
  ' here , ' 3+ , ',,           \ Write in the number we want the created word to push
  '', here 0 , ',,              \ Write in a place holder (0) and push a
                                \ pointer to to be used by does>
  '', 'exit, ',,                \ Write in an exit in the word we're compiling.
  ' false , ' state ,           \ Make sure to change the state back to command mode
  else                          \ Run time behavour
    ::                          \ Compile a word
    _push ,                     \ Write push into new word
    here 2+ ,                   \ Push a pointer to data field
    'exit,                      \ Write in an exit to new word (data field is after exit)
    false state                 \ Return to command mode.
  then
;

: does> immediate
  'exit,                        \ Write in an exit, we don't want the
                                \ defining to run it, but the *defined* word to.
  here swap !                   \ Patch in the code fields to point to.
  _run ,                        \ Write a run in.
;

: constant create , does> @ ;
: variable create , does> ;
: array create allot does> + ;

( Store temporary filenames here. )
str @reg dup iobl @reg + str !reg constant filename

0 variable strvar
: getstr"
  0 strvar !
  begin
    key dup '"'
    =
    if
      0 strvar @ filename + !str
      drop 1
    else
      strvar @ filename + !str
      strvar @ 1+ strvar !
      0
    then
  until
  filename
;

( file i/o )
: foutput
    filename getword
    filename output fopen kernel
;

: finput
    filename getword
    filename input fopen kernel
    drop
;

: fremove
    filename getword
    filename remove kernel
;

: frewind
    output rewind kernel
;

: system"
  getstr"
  system kernel
;

0 variable i
0 variable j

: i! i ! ;
: j! j ! ;
: i@ i @ ;
: j@ j @ ;

: do immediate ( this needs redoing so it can be nested )
  ' j! ,
  ' i! ,
  here
;

: not ( a -- ~a )
  if 0 else 1 then
;

: >= ( a b -- bool )
  < not
;

: (++i)>=j
  i@ 1+ i! i@ j@ >=
;

: loop immediate
  ' (++i)>=j ,
  ' ?br ,
  here - ,
;

: break ( break out of a do ... loop )
  j@ i!
;

: gcd ( a b -- n ) ( greatest common divisor )
  begin
    dup
    if
      tuck mod 0
    else
      1
    then
  until
  drop
;

: fpwdf \ Find the previous words data field
  pwd @reg 2 +
  dup @ 1 = if
    2+
  else
    1+
  then
;

: recurse immediate
  ' br ,
  fpwdf
  here - ,
;

( =========================================================================== )

\ : vocabulary create pwd @reg , does> @ pwd !reg ;
\ vocabulary forth

finput ../fth/debug.4th    ( Debugging operations )
finput ../fth/rational.4th ( Real type )
finput ../fth/math.4th     ( Math functions )
finput ../fth/auto.4th     ( Auto generated constants )
finput ../fth/memory.4th   ( Memory allocation and manipulation )
finput ../fth/welcome.4th  ( Welcome and cursor control )

.( : hello ; ) cr
: hello ." hello, world " cr ; find hello dup 20 + show
fpwdf .
.( : ihello ; ) cr
: ihello immediate ." hello, world " cr ; find ihello dup 20 + show
fpwdf .

\ Howe Forth: Start up code.
\ @author         Richard James Howe.
\ @copyright      Copyright 2013 Richard James Howe.
\ @license        LGPL
\ @email          howe.r.j.89@gmail.com

: true 1 exit
: false 0 exit

: cpf 13 exit \ Compile Flag
: state cpf !reg exit
: ; immediate
	' exit ,
	false state
exit

\ Register constants
: r 3 ;	        \ Return stack pointer
: v 4 ;	        \ Variable stack pointer
: h 5 ;	        \ Dictionary pointer
: str 6 ;       \ String storage pointer
: pwd 7 ;       \ previous word
: exf 14 ;      \ Pointer to execution token, executed on error.
: iobl 21 ;     \ I/O buf len address
: here h @reg ;

\ Error handling!
: on_err read on_err ;  \ This word is executed when an error occurs.
find on_err exf !reg    \ Write the executable token for on_err into the dictionary.

\ change to command mode
: [ immediate false state ;
\ change to compile mode
: ] true state ;

\ These words represent words with no name in the dictionary,
\ the 'invisible' words.
: _push 0 ;
: _compile 1 ;
: _run 2 ;

\ System calls
: reset 0 ;
: fopen 1 ;
: fclose 2 ;
: fflush 3 ;
: remove 4 ;
: rename 5 ;
: rewind 6 ;
: system 7 ;

\ Constants for system call arguments
: input 0 ;
: output 1 ;

: literal immediate _push , , ;

\ ASCII chars

: 'esc' 27 ;
: '"' 34 ;
: ')' 41 ;

: 0= 0 = ;
: 0< 0 < ;
: 0> 0 > ;

: space 32 emit ;
: cr 10 emit ;
: tab 9 emit ;

: prnn 10 swap printnum ;
: . prnn cr ;

: tuck swap over ;
: nip swap drop ;
: rot >r swap r> swap ;
: <> = 0= ;
: negate -1 * ;
: -rot rot rot ;

: 2drop drop drop ;
: 2dup over over ;
: 2swap rot >r rot r> ;

: 2+ 1+ 1+ ;
: 2* 2 * ;
: 2/ 2 / ;
: 2- 1- 1- ;

: if immediate
	' ?br ,
	here 0 ,
;

: else immediate
	' br ,
	here
	0 ,
	swap dup here swap -
	swap !
;

: then immediate
	dup here
	swap - swap
	!
;

: begin immediate
	here
;

: until immediate
	' ?br ,
	here - ,
;

: ?dup dup if dup then ;
: abs dup 0 < if negate then ;

: min 2dup < if drop else swap drop then  ;
: max 2dup > if drop else swap drop then  ;

: allot here + h !reg ;
: :noname immediate here _run , ] ;
: ? 0= if \ ( bool -- ) ( Conditional evaluation )
      [ find \ literal ] execute
    then
;

: _( \ ( letter bool -- ) \
  >r \ Store bool on return stack for simplicity
     begin
        key 2dup = \ key in a letter, test if it is equal to out terminator
        if
          2drop 1 \ Drop items, quit loop
        else
          r> dup >r \ test for bool
          if        \ bool == 1, emit letter, bool == 0 drop it.
             emit
          else
             drop
          then
          0 \ Continue
        then
    until
  r> drop \ Return stack back to normal now.
;

: ( immediate ')' 0 _( ;  ( Now we have proper comments )
: .( immediate ')' 1 _( ; ( Print out word )

 ( Print out a string stored in string storage )
: prn ( str_ptr -- )
    begin
        dup @str dup 0= ( if null )
        if
            2drop 1
        else
            emit 1+ 0
        then
    until
;

 ( Store a '"' terminated string in string storage )
: _." ( -- )
    str @reg 1-
    begin
        key dup >r '"' =
        if
            r> drop 1
        else
            1+ dup r> swap !str 0
        then
    until
    2+
    str !reg
;

: ." immediate
    cpf @reg 0= if
    '"' 1 _(
    else
        _push , str @reg ,
        _."
        ' prn ,
    then
;

: :: 	( compiles a ':' )
  [ find : , ]
;

( Helper words for create )
: '', ' ' , ;       \ A word that writes ' into the dictionary
: ',, ' , , ;       \ A word that writes , into the dictionary
: 'exit, ' exit , ; \ A word that write exit into the dictionary
: 3+ 2+ 1+ ;

( The word create involves multiple levels of indirection.
 It makes a word which has to write in values into
 another word )
: create immediate              \ This is a complicated word! It makes a
                                \ word that makes a word.
  cpf @reg if                   \ Compile time behavour
  ' :: ,                        \ Make the defining word compile a header
  '', _push , ',,               \ Write in push to the creating word
  ' here , ' 3+ , ',,           \ Write in the number we want the created word to push
  '', here 0 , ',,              \ Write in a place holder (0) and push a
                                \ pointer to to be used by does>
  '', 'exit, ',,                \ Write in an exit in the word we're compiling.
  ' false , ' state ,           \ Make sure to change the state back to command mode
  else                          \ Run time behavour
    ::                          \ Compile a word
    _push ,                     \ Write push into new word
    here 2+ ,                   \ Push a pointer to data field
    'exit,                      \ Write in an exit to new word (data field is after exit)
    false state                 \ Return to command mode.
  then
;

: does> immediate
  'exit,                        \ Write in an exit, we don't want the
                                \ defining to run it, but the *defined* word to.
  here swap !                   \ Patch in the code fields to point to.
  _run ,                        \ Write a run in.
;

: constant create , does> @ ;
: variable create , does> ;
: array create allot does> + ;

( Store temporary filenames here. )
str @reg dup iobl @reg + str !reg constant filename

0 variable strvar
: getstr"
  0 strvar !
  begin
    key dup '"'
    =
    if
      0 strvar @ filename + !str
      drop 1
    else
      strvar @ filename + !str
      strvar @ 1+ strvar !
      0
    then
  until
  filename
;

( file i/o )
: foutput
    filename getword
    filename output fopen kernel
;

: finput
    filename getword
    filename input fopen kernel
    drop
;

: fremove
    filename getword
    filename remove kernel
;

: frewind
    output rewind kernel
;

: system"
  getstr"
  system kernel
;

0 variable i
0 variable j

: i! i ! ;
: j! j ! ;
: i@ i @ ;
: j@ j @ ;

: do immediate ( this needs redoing so it can be nested )
  ' j! ,
  ' i! ,
  here
;

: not ( a -- ~a )
  if 0 else 1 then
;

: >= ( a b -- bool )
  < not
;

: (++i)>=j
  i@ 1+ i! i@ j@ >=
;

: loop immediate
  ' (++i)>=j ,
  ' ?br ,
  here - ,
;

: break ( break out of a do ... loop )
  j@ i!
;

: gcd ( a b -- n ) ( greatest common divisor )
  begin
    dup
    if
      tuck mod 0
    else
      1
    then
  until
  drop
;

( =========================================================================== )

\ : vocabulary create pwd @reg , does> @ pwd !reg ;
\ vocabulary forth

finput ../fth/debug.4th    ( Debugging operations )
finput ../fth/rational.4th ( Real type )
finput ../fth/math.4th     ( Math functions )
finput ../fth/auto.4th     ( Auto generated constants )
finput ../fth/memory.4th   ( Memory allocation and manipulation )
finput ../fth/welcome.4th  ( Welcome and cursor control )


couple time operations

couple time operations

class Time 1.0

alias _PO = NATIVE::PerlObject
load Time::Duration # FIXME

############################
### DATE COMPONENT TYPES ###
############################

#> generic type for time components measured from zero
type _timeUnitMeasuredFromZero {
    isa Num
    satisfies $_ >= 0
}

#> generic type for time components measured from one
type _timeUnitMeasuredFromOne {
    isa Num
    satisfies $_ >= 1
}

#> generic type for minutes and seconds
type _timeUnit0to59 {
    isa Num
    satisfies $_ >= 0 && $_ <= 59
}

#> years, starting at year 0
alias Year = _timeUnitMeasuredFromZero

$months = [
    undefined,
    :January,
    :February,
    :March,
    :April,
    :May,
    :June,
    :July,
    :August,
    :September,
    :October,
    :November,
    :December
];

#> Month type accepting a month symbol or integer 1-12.
#| Yields a MonthSym.
type Month {
    transform func {
        need $num: Int | MonthSym
        if $num.*isa(Num)
            $num = $months[$num]
        return $num : MonthSym
    }
}

type MonthSym {
    isa Sym
    satisfies $months.contains($_)
}

#> day of the month, 1-31
alias Day = _timeUnitMeasuredFromOne

$weekdays = [
    undefined,
    :Monday,
    :Tuesday,
    :Wednesday,
    :Thursday,
    :Friday,
    :Saturday,
    :Sunday
]

#> Weekday type accepting a weekday symbol or integer 1-7, starting with Monday.
#| Yields a WeekdaySym.
type Weekday {
    transform func {
        need $num: Int | WeekdaySym
        if $num.*isa(Num)
            $num = $weekdays[$num]
        return $num : WeekdaySym
    }
}

type WeekdaySym {
    isa Sym
    satisfies $weekdays.contains($_)
}

#> hour 0-23
type Hour {
    isa Num
    satisfies $_ >= 0 && $_ <= 23
}

#> minute 0-59
alias Minute = _timeUnit0to59

#> second 0-59
alias Second = _timeUnit0to59

#> nanosecond >= 0
type Nanosecond {
    isa Int
    satisfies $_ >= 0
}

#> creates a new time given date components
init {
    want $year:         Year
    want $month:        Month
    want $day:          Day
    want $hour:         Hour
    want $minute:       Minute
    want $second:       Second
    want $nanosecond:   Nanosecond
    want $timeZone:     Str

    _PO.require("DateTime")

    # determine args to DateTime constructor
    $args = []
    $possible = [
        year:           $year,
        month:          $months.indexOf($month),
        day:            $day,
        hour:           $hour,
        minute:         $minute,
        second:         $second,
        nanosecond:     $nanosecond
    ]
    for ($arg, $val) in $possible {
        if !$val || $val == 0
            next
        $args.push($arg, $val)
    }

    # use current time if no options provided
    $init = "new"
    if $args.empty
        $init = "now"

    if $timeZone
        $args.push("time_zone", $timeZone)

    # create the underlying DateTime object
    @dt = _PO("DateTime", INIT: $init, args: $args) catch $e
        throw Error(:Bad, "sorry")

}

#######################
### DATE COMPONENTS ###
#######################

#> year
prop year {
    return Year(@dt.year!) : Year
}

#> month
prop month {
    return Month(@dt.month!) : MonthSym
}

prop monthName {
    return @month.name
}

#> day of the month, 1-31
prop day {
    return Day(@dt.day!) : Day
}

#> day of the week
prop weekday {
    return Weekday(@dt.day_of_week!) : WeekdaySym
}

#> string name of the day of the week
prop weekdayName {
    return @weekday.name
}

#################
### OPERATORS ###
#################

operator + {
    need $ehs: Duration
    $t = @copy!
    $t.dt.add_duration($ehs.dtd)
    return $t
}

operator - {
    need $rhs: Duration
    $t = @copy!
    $t.dt.subtract_duration($rhs.dtd)
    return $t
}

#####################
### MISCELLANEOUS ###
#####################

method copy {
    $t = Time.now!
    $t.dt = @dt.clone!
    return $t
}

method description {
    return @dt.ymd("-") + " "  + @dt.hms(":")
}

#> returns the current time
func now {
    return Time()
}

#> returns a time at the moment the current day started
func today {
    $t = Time()
    $t.dt.truncate(to: "day")
    return $t
}

#> returns a time at the start of tomorrow
func tomorrow {
    return @today! + Duration(days: 1)
}

class Time 1.0

alias _PO = NATIVE::PerlObject

############################
### DATE COMPONENT TYPES ###
############################

#> generic type for time components measured from zero
type _timeUnitMeasuredFromZero {
    isa Num
    satisfies $_ >= 0
}

#> generic type for time components measured from one
type _timeUnitMeasuredFromOne {
    isa Num
    satisfies $_ >= 1
}

#> generic type for minutes and seconds
type _timeUnit0to59 {
    isa Num
    satisfies $_ >= 0 && $_ <= 59
}

#> years, starting at year 0
alias Year = _timeUnitMeasuredFromZero

$months = [
    undefined,
    :January,
    :February,
    :March,
    :April,
    :May,
    :June,
    :July,
    :August,
    :September,
    :October,
    :November,
    :December
];

#> Month type accepting a month symbol or integer 1-12.
#| Yields a MonthSym.
type Month {
    transform func {
        need $num: Int | MonthSym
        if $num.*isa(Num)
            $num = $months[$num]
        return $num : MonthSym
    }
}

type MonthSym {
    isa Sym
    satisfies $months.contains($_)
}

#> day of the month, 1-31
alias Day = _timeUnitMeasuredFromOne

$weekdays = [
    undefined,
    :Monday,
    :Tuesday,
    :Wednesday,
    :Thursday,
    :Friday,
    :Saturday,
    :Sunday
]

#> Weekday type accepting a weekday symbol or integer 1-7, starting with Monday.
#| Yields a WeekdaySym.
type Weekday {
    transform func {
        need $num: Int | WeekdaySym
        if $num.*isa(Num)
            $num = $weekdays[$num]
        return $num : WeekdaySym
    }
}

type WeekdaySym {
    isa Sym
    satisfies $weekdays.contains($_)
}

#> hour 0-23
type Hour {
    isa Num
    satisfies $_ >= 0 && $_ <= 23
}

#> minute 0-59
alias Minute = _timeUnit0to59

#> second 0-59
alias Second = _timeUnit0to59

#> nanosecond >= 0
type Nanosecond {
    isa Int
    satisfies $_ >= 0
}

#> creates a new time given date components
init {
    want $year:         Year
    want $month:        Month
    want $day:          Day
    want $hour:         Hour
    want $minute:       Minute
    want $second:       Second
    want $nanosecond:   Nanosecond

    _PO.require("DateTime")

    # determine args to DateTime constructor
    $args = []
    $possible = [
        year:           $year,
        month:          $months.indexOf($month),
        day:            $day,
        hour:           $hour,
        minute:         $minute,
        second:         $second,
        nanosecond:     $nanosecond
    ]
    for ($arg, $val) in $possible {
        if !$val || $val == 0
            next
        $args.push($arg, $val)
    }

    # use current time if no options provided
    $init = "new"
    if $args.empty
        $init = "now"

    # create the underlying DateTime object
    @dt = _PO("DateTime", INIT: $init, args: $args) catch $e
        throw Error(:Bad, "sorry")

    # want @locale
    # want @timeZone
}

#######################
### DATE COMPONENTS ###
#######################

#> year
prop year {
    return Year(@dt.year!) : Year
}

#> month
prop month {
    return Month(@dt.month!) : MonthSym
}

prop monthName {
    return @month.name
}

#> day of the month, 1-31
prop day {
    return Day(@dt.day!) : Day
}

#> day of the week
prop weekday {
    return Weekday(@dt.day_of_week!) : WeekdaySym
}

#> string name of the day of the week
prop weekdayName {
    return @weekday.name
}

#################
### OPERATORS ###
#################

#####################
### MISCELLANEOUS ###
#####################

method description {
    return @dt.ymd("-") + " "  + @dt.hms(":")
}

#> returns the current time
func now {
    return Time()
}

#> returns a time at the moment the current day started
func today {
    $t = Time()
    $t.dt.truncate(to: "day")
    return $t
}


Rename to use dashes as language intented.

Found the error in my code, I was not properly dropping the choice index on pick-right and
pick-bottom. Now that I've put in the additional-constraints it looks extra hacky and I
may go to more consistent looking code instead of needing all these else branches.

First pass at additional constraints. Even with them cleared, at some point something
corrupts my stack, so I have to look into it.

3 constant width
21 constant goal
width 1- constant wm
width 1+ constant wp
width width * constant size

create choices  3 ,  4 ,  5 ,
                6 ,  7 ,  8 ,
                9 , 10 , 11 ,

variable picked size allot
variable additional-constraints size allot

: clear-picked
    size
    begin
        1- dup 0>= while
            dup picked + 0 swap C!
    repeat
    drop ;

: print-picked
    9 0 do
        i picked + C@ .
    loop ;

variable a size cells allot

: choice-search
    0
    begin
        dup size < while
            choices over cells + @
            rot tuck = if
                drop -1 exit
            endif
            swap 1+
    repeat
    2drop 0 ;

: reverse-cross-valid
    0
    wm wp * wm do
        a i cells + @ +
    wm +loop
    goal = ;

: cross-valid
    0
    size 0 do
        a i cells + @ +
    wp +loop
    goal = ;

: bottom-row-valid
    0
    size size width - do
        a i cells + @ +
    loop
    goal = ;

: bottom-right-valid
    bottom-row-valid if
        -1
    else
        cross-valid
    endif ;

0 VALUE pick-next-ref

: execute-predicate?
    dup 0<> if
        execute
    else
        drop -1
    endif ;

: pick-internal
    size 0 do
        dup cells a + choices i cells + @ swap !
        i picked + C@ 0= if
            dup cells additional-constraints + @ execute-predicate? if
                1 i picked + C!
                dup pick-next-ref execute
                0 i picked + C!
            endif
        endif
    loop
    drop ;

: pick-right
    0 over dup dup width mod - do
        a i cells + @ +
    loop
    goal swap -
    over over swap cells a + !
    choice-search if
        dup picked + C@ 0= if
            over cells additional-constraints + @ execute-predicate? if
                1 over picked + C!
                over pick-next-ref execute
                0 swap picked + C!
            else
                drop
            endif
            1 over picked + C!
            over pick-next-ref execute
            0 swap picked + C!
        else
            drop
        endif
    endif
    drop ;

: pick-bottom
    0 over dup width mod do
        a i cells + @ +
    width +loop
    goal swap -
    over over swap cells a + !
    choice-search if
        dup picked + C@ 0= if
            over cells additional-constraints + @ execute-predicate? if
                1 over picked + C!
                over pick-next-ref execute
                0 swap picked + C!
            else
                drop
            endif
        else
            drop
        endif
    endif
    drop ;

create solution-count 0 ,

: solution
    solution-count @ 1+ dup solution-count !
    ." --- Solution " . ." ---" CR
    size 0 do
        a i cells + @ .
        i 3 mod 2 = if CR endif
    loop ;

: print-right-internal
    dup width mod wm = if
        ." pick-right " .
    else
        ." pick-internal " .
    endif ;

: print-next
    dup . ." -> "
    dup size 1- = if
        drop ." solution"
    else
        dup width wm * >= if
            wm -
            print-right-internal
        else
            dup width dup 2 - * >= if
                width +
                ." pick-bottom " .
            else
                1+
                print-right-internal
            endif
        endif
    endif ;

: pick-right-internal
    dup width mod wm = if
        pick-right
    else
        pick-internal
    endif ;

: pick-next
    dup size 1- = if
        drop solution
    else
        dup width wm * >= if
            wm -
            pick-right-internal
        else
            dup width dup 2 - * >= if
                width +
                pick-bottom
            else
                1+
                pick-right-internal
            endif
        endif
    endif ;

' pick-next TO pick-next-ref

: init-board
    size 0 do
        i 1+ a i cells + !
    loop ;

: clear-constraints
    size 0 do
        0 additional-constraints i cells + !
    loop ;

clear-constraints
' reverse-cross-valid additional-constraints size width - width - 1+ cells + !
' bottom-right-valid additional-constraints size 1- cells + !

: solve-puzzle
    clear-picked init-board 0 solution-count !
    0 pick-internal ;

3 constant width
21 constant goal
width 1- constant wm
width 1+ constant wp
width width * constant size

create choices  3 ,  4 ,  5 ,
                6 ,  7 ,  8 ,
                9 , 10 , 11 ,

variable picked size allot

: clearPicked
    size
    begin
        1- dup 0>= while
            dup picked + 0 swap C!
    repeat
    drop ;

variable a size cells allot

: choiceSearch
    0
    begin
        dup size < while
            choices over cells + @
            rot tuck = if
                drop -1 exit
            endif
            swap 1+
    repeat
    2drop 0 ;

: reverseCrossInvalid
    0
    wm wp * wm do
        a i cells + @ +
    wm +loop
    goal = ;

: crossInvalid
    0
    size 0 do
        a i cells + @ +
    wp +loop
    goal = ;

: bottomRowInvalid
    0
    size size width - do
        a i cells + @ +
    loop
    goal = ;

: bottomRightInvalid
    bottomRowInvalid if
        -1
    else
        crossInvalid
    endif ;

0 VALUE pickNextRef

: pickInternal
    size 0 do
        dup cells a + choices i cells + @ swap !
        i picked + C@ 0= if
            1 i picked + C!
            dup pickNextRef execute
            0 i picked + C!
        endif
    loop
    drop ;

: pickRight
    0 over dup dup width mod - do
        a i cells + @ +
    loop
    goal swap -
    over over swap cells a + !
    choiceSearch if
        dup picked + C@ 0= if
            1 over picked + C!
            over pickNextRef execute
            0 swap picked + C!
        endif
    endif
    drop ;

: pickBottom
    0 over dup width mod do
        a i cells + @ +
    width +loop
    goal swap -
    over over swap cells a + !
    choiceSearch if
        dup picked + C@ 0= if
            1 over picked + C!
            over pickNextRef execute
            0 swap picked + C!
        endif
    endif
    drop ;

create solution_count 0 ,

: solution
    solution_count @ 1+ dup solution_count !
    ." --- Solution " . ." ---" CR
    size 0 do
        a i cells + @ .
        i 3 mod 2 = if CR endif
    loop ;

: pickNext
    dup ." pickNext " .
    dup size 1- = if
        drop ." -> solution" CR solution exit
    endif
    dup width wm * >= if
        wm -
    else
        dup width dup 2 - * >= if
            width + ." -> pickBottom " dup . CR pickBottom exit
        else
            1+
        endif
    endif
    dup width mod wm = if
        ." -> pickRight " dup . CR pickRight
    else
        ." -> pickInternal " dup . CR pickInternal
    endif ;

' pickNext TO pickNextRef

: initBoard
    9 0 do
        i 1+ a i cells + !
    loop ;

: solve-puzzle
    clearPicked initBoard 0 solution_count !
    0 pickInternal ;


time: reduce time-advance

time: reduce time-advance

Makes editing more responsive.
We don't need such high latency these days.

\ Device independant TIME handling.
\ These words are vectored to allow a composer to change the notion
\ of time in HMSL.
\
\ Author: Phil Burk
\ Copyright 1986 -  Phil Burk, Larry Polansky, David Rosenboom.
\ All Rights Reserved
\
\ MOD: PLB 10/14/87 Added calls to HARD.TIME.INIT and TERM
\ MOD: PLB 11/16/89 Add RATE->MICS/BEAT
\ MOD: PLB 11/17/89  Big changes.
\        Removed TIME-BASE  HARD.TIME@ SOFT.TIME@ .
\        TIME@ TIME! and TIME+! are now deferred!!
\        Default is ahead.time , time-advance set to zero.
\ MOD: PLB 2/9/90 Added VTIME.SAVE stuff from SES
\ MOD: PLB 3/18/90 Add DELAY
\ MOD: PLB 4/13/90 Change AO.REPEAT to SELF.CLOCK
\ MOD: PLB 6/7/90 Fixed Stack for delay.
\ MOD: PLB 1/2/91 Changed DELAY , no abort, BUMPS vtime with MAX
\ MOD: PLB 2/7/91 Set defaults for TIME@ TIME! and TIME+!
\ MOD: PLB 4/9/91 Set default for TIME@ to FALSE
\ MOD: PLB 7/1/91 Comment out SYS.INIT so that MIDI can INIT when ready.
\ MOD: PLB 2/18/92 Add SYS.TASK

ANEW TASK-TIME

defer TIME@
' false is time@
defer TIME!
' drop is time!
defer TIME+!
' drop is time+!

: TIME+1  ( -- , used by software clocks )
    1 time+!
;

\ This word is used to decide if it's time for an event.
\ It compares the time on the stack to the current time.
max-inline @ 12 max-inline !
: TIME> ( time1 time2 -- flag , use circular number system )
    - 0> both
;
: TIME< ( time1 time2 -- flag )
    - 0< both
;
max-inline !

: DOITNOW? ( atime -- flag , true if time is now or past)
     dup time-virtual !
     time@ time> not  ( careful with changing this word, subtle )
;

: VTIME@ ( -- virtual_time )
    time-virtual @
;

: VTIME! ( virtual_time -- )
    time-virtual !
;

: VTIME+! ( N -- )
    time-virtual +!
;

: AHEAD.TIME@ ( -- time , give time ahead of RTC )
      rtc.time@ time-advance @ +
;

: AHEAD.TIME! ( time -- , set ahead time )
      time-advance @ - 0 max rtc.time!
;

: ANOW  ( -- , set virtual time to be advance time )
    time@ vtime!
;

: RNOW ( -- , set virtual time to be real time )
    rtc.time@ vtime!
;

\ Reserve for self incrementing clock.
defer SELF.CLOCK ( function to call each cycle of HMSL scheduler)

: USE.SELF.TIMER  ( -- , advance time as HMSL scans )
    rtc.stop
    'c time+1 is self.clock
;

: USE.HARDWARE.TIMER ( -- , Use HARDWARE timer )
    rtc.start
    'c noop is self.clock
;

: USE.SOFTWARE.TIMER ( -- , Use SOFTWARE timer )
    rtc.stop
    'c noop is self.clock
;

: 0TIME  ( -- zero out timer variables )
    0 rtc.time!
    0 time-virtual !
;

32 constant VTIME_SMAX
CREATE VTIME-DATA vtime_smax cell* allot

stack.header vtime-stack

: VTIME.PUSH  ( vtime -- , push onto time stack )
    vtime-stack stack.push
;
: VTIME.POP ( -- vtime )
    vtime-stack stack.pop
;

: VTIME.SAVE  ( -- , save current virtual time , PUSH)
    vtime@ vtime.push
;
: VTIME.RESTORE ( -- , restore from stack , POP)
    vtime.pop vtime!
;

: VTIME.COPY ( -- , copy from vtime stack , COPY)
    vtime-stack stack.copy vtime!
;
: VTIME.DROP ( -- , drop from vtime stack )
    vtime-stack stack.drop
;

: TIME.INIT ( -- , initialize vectors )
    " TIME.INIT" debug.type
    0 time-current !
    rtc.init
    'c ahead.time! is time!
    'c ahead.time@ is time@
    'c rtc.time+!  is time+!
    'c noop is self.clock
    rtc.rate@ 6 / time-advance !
    rtc.rate@ 2* 3 / ticks/beat !
    anow
    vtime-data vtime_smax vtime-stack stack.setup
;

: TIME.TERM  ( -- )
    " TIME.TERM" debug.type
    rtc.term
;

: SYS.INIT sys.init time.init ;
: SYS.TERM time.term sys.term ;

: WATCH ( -- )
    BEGIN
        time@ . cr
        ?terminal
    UNTIL
;

: RATE->MICS/BEAT  ( ticks/second -- microseconds/beat )
    >r ticks/beat @ 1000000 r> */
;

: DELAY  ( ticks -- , delay N ticks and advance VTIME )
\ force VTIME to be N past now
    dup vtime@ rtc.time@ max + vtime!
    time@ +
    BEGIN dup time@ time<
    UNTIL drop
;

: ?DELAY  { ticks | flag -- flag , delay N ticks and advance VTIME }
\ force VTIME to be N past now
    ticks vtime@ rtc.time@ max + vtime!
    ticks time@ +
    BEGIN dup time@ time<
        ?terminal dup -> flag
        OR
    UNTIL
    drop
    flag
;

: SYS.TASK sys.task self.clock ;

\ Device independant TIME handling.
\ These words are vectored to allow a composer to change the notion
\ of time in HMSL.
\
\ Author: Phil Burk
\ Copyright 1986 -  Phil Burk, Larry Polansky, David Rosenboom.
\ All Rights Reserved
\
\ MOD: PLB 10/14/87 Added calls to HARD.TIME.INIT and TERM
\ MOD: PLB 11/16/89 Add RATE->MICS/BEAT
\ MOD: PLB 11/17/89  Big changes.
\        Removed TIME-BASE  HARD.TIME@ SOFT.TIME@ .
\        TIME@ TIME! and TIME+! are now deferred!!
\        Default is ahead.time , time-advance set to zero.
\ MOD: PLB 2/9/90 Added VTIME.SAVE stuff from SES
\ MOD: PLB 3/18/90 Add DELAY
\ MOD: PLB 4/13/90 Change AO.REPEAT to SELF.CLOCK
\ MOD: PLB 6/7/90 Fixed Stack for delay.
\ MOD: PLB 1/2/91 Changed DELAY , no abort, BUMPS vtime with MAX
\ MOD: PLB 2/7/91 Set defaults for TIME@ TIME! and TIME+!
\ MOD: PLB 4/9/91 Set default for TIME@ to FALSE
\ MOD: PLB 7/1/91 Comment out SYS.INIT so that MIDI can INIT when ready.
\ MOD: PLB 2/18/92 Add SYS.TASK

ANEW TASK-TIME

defer TIME@
' false is time@
defer TIME!
' drop is time!
defer TIME+!
' drop is time+!

: TIME+1  ( -- , used by software clocks )
    1 time+!
;

\ This word is used to decide if it's time for an event.
\ It compares the time on the stack to the current time.
max-inline @ 12 max-inline !
: TIME> ( time1 time2 -- flag , use circular number system )
    - 0> both
;
: TIME< ( time1 time2 -- flag )
    - 0< both
;
max-inline !

: DOITNOW? ( atime -- flag , true if time is now or past)
     dup time-virtual !
     time@ time> not  ( careful with changing this word, subtle )
;

: VTIME@ ( -- virtual_time )
    time-virtual @
;

: VTIME! ( virtual_time -- )
    time-virtual !
;

: VTIME+! ( N -- )
    time-virtual +!
;

: AHEAD.TIME@ ( -- time , give time ahead of RTC )
      rtc.time@ time-advance @ +
;

: AHEAD.TIME! ( time -- , set ahead time )
      time-advance @ - 0 max rtc.time!
;

: ANOW  ( -- , set virtual time to be advance time )
    time@ vtime!
;

: RNOW ( -- , set virtual time to be real time )
    rtc.time@ vtime!
;

\ Reserve for self incrementing clock.
defer SELF.CLOCK ( function to call each cycle of HMSL scheduler)

: USE.SELF.TIMER  ( -- , advance time as HMSL scans )
    rtc.stop
    'c time+1 is self.clock
;

: USE.HARDWARE.TIMER ( -- , Use HARDWARE timer )
    rtc.start
    'c noop is self.clock
;

: USE.SOFTWARE.TIMER ( -- , Use SOFTWARE timer )
    rtc.stop
    'c noop is self.clock
;

: 0TIME  ( -- zero out timer variables )
    0 rtc.time!
    0 time-virtual !
;

32 constant VTIME_SMAX
CREATE VTIME-DATA vtime_smax cell* allot

stack.header vtime-stack

: VTIME.PUSH  ( vtime -- , push onto time stack )
    vtime-stack stack.push
;
: VTIME.POP ( -- vtime )
    vtime-stack stack.pop
;

: VTIME.SAVE  ( -- , save current virtual time , PUSH)
    vtime@ vtime.push
;
: VTIME.RESTORE ( -- , restore from stack , POP)
    vtime.pop vtime!
;

: VTIME.COPY ( -- , copy from vtime stack , COPY)
    vtime-stack stack.copy vtime!
;
: VTIME.DROP ( -- , drop from vtime stack )
    vtime-stack stack.drop
;

: TIME.INIT ( -- , initialize vectors )
    " TIME.INIT" debug.type
    0 time-current !
    rtc.init
    'c ahead.time! is time!
    'c ahead.time@ is time@
    'c rtc.time+!  is time+!
    'c noop is self.clock
    rtc.rate@ time-advance !
    rtc.rate@ 2* 3 / ticks/beat !
    anow
    vtime-data vtime_smax vtime-stack stack.setup
;

: TIME.TERM  ( -- )
    " TIME.TERM" debug.type
    rtc.term
;

: SYS.INIT sys.init time.init ;
: SYS.TERM time.term sys.term ;

: WATCH ( -- )
    BEGIN
        time@ . cr
        ?terminal
    UNTIL
;

: RATE->MICS/BEAT  ( ticks/second -- microseconds/beat )
    >r ticks/beat @ 1000000 r> */
;

: DELAY  ( ticks -- , delay N ticks and advance VTIME )
\ force VTIME to be N past now
    dup vtime@ rtc.time@ max + vtime!
    time@ +
    BEGIN dup time@ time<
    UNTIL drop
;

: ?DELAY  { ticks | flag -- flag , delay N ticks and advance VTIME }
\ force VTIME to be N past now
    ticks vtime@ rtc.time@ max + vtime!
    ticks time@ +
    BEGIN dup time@ time<
        ?terminal dup -> flag
        OR
    UNTIL
    drop
    flag
;

: SYS.TASK sys.task self.clock ;