DEC2BIN tests added

DEC2BIN tests added

\ KataDiversion tests, in Forth
\ running tests:
\   gforth KataDiversion_tests.fth -e bye

REQUIRE KataDiversion.fth

VARIABLE ASSERT-COUNT

: ASSERTS-INIT ( -- )
    0 ASSERT-COUNT ! ;

: ASSERTS-RESULT ( -- )
    ASSERT-COUNT @ . ." assertions successfully passed." CR ;

\ destructive assert-equal
: ASSERT-EQUAL-D ( n1 n2 -- )
    <> IF 1 ABORT" AssertEqual: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ non-destructive assert-equal
: ASSERT-EQUAL ( n1 n2 -- n1 n2 )
    2DUP ASSERT-EQUAL-D ;

\ destructive assert-true
: ASSERT-TRUE-D ( n -- )
    0 = IF 1 ABORT" AssertTrue: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ non-destructive assert-true
: ASSERT-TRUE ( n -- n )
    DUP ASSERT-TRUE-D ;

\ destructive assert-false
: ASSERT-False-D ( n -- )
    0 <> IF 1 ABORT" AssertFalse: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ non-destructive assert-false
: ASSERT-FALSE ( n -- n )
    DUP ASSERT-FALSE-D ;

\ ---- tests ----

ASSERTS-INIT

\ ?EMPTY
EMPTY         DEPTH 0 ASSERT-EQUAL-D
EMPTY EMPTY   DEPTH 0 ASSERT-EQUAL-D
0 EMPTY       DEPTH 0 ASSERT-EQUAL-D
1 2 3 4 EMPTY DEPTH 0 ASSERT-EQUAL-D

\ ?NEGATIVE
-1 ?NEG ASSERT-TRUE-D
 0 ?NEG ASSERT-TRUE-D
 1 ?NEG ASSERT-FALSE-D

\ ?MAX-NB
-1 ?MAX-NB  0   ASSERT-EQUAL-D
 0 ?MAX-NB  0   ASSERT-EQUAL-D
 1 ?MAX-NB  2   ASSERT-EQUAL-D
 2 ?MAX-NB  4   ASSERT-EQUAL-D
 3 ?MAX-NB  8   ASSERT-EQUAL-D

\ LOG2
 1 LOG2  0 ASSERT-EQUAL-D
 2 LOG2  1 ASSERT-EQUAL-D
 3 LOG2  1 ASSERT-EQUAL-D
 4 LOG2  2 ASSERT-EQUAL-D
 5 LOG2  2 ASSERT-EQUAL-D
 8 LOG2  3 ASSERT-EQUAL-D
42 LOG2  5 ASSERT-EQUAL-D

\ DEC2BIN

 0 DEC2BIN 0 ASSERT-EQUAL-D
 1 DEC2BIN 1 ASSERT-EQUAL-D
 2 DEC2BIN 0 ASSERT-EQUAL-D ( 2 -> 10 )
           1 ASSERT-EQUAL-D
11 DEC2BIN 1 ASSERT-EQUAL-D ( 11 -> 1011 )
           1 ASSERT-EQUAL-D
           0 ASSERT-EQUAL-D
           1 ASSERT-EQUAL-D

ASSERTS-RESULT
\ ---------

\ KataDiversion tests, in Forth
\ running tests:
\   gforth KataDiversion_tests.fth -e bye

REQUIRE KataDiversion.fth

VARIABLE ASSERT-COUNT

: ASSERTS-INIT ( -- )
    0 ASSERT-COUNT ! ;

: ASSERTS-RESULT ( -- )
    ASSERT-COUNT @ . ." assertions successfully passed." CR ;

\ destructive assert-equal
: ASSERT-EQUAL-D ( n1 n2 -- )
    <> IF 1 ABORT" AssertEqual: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ non-destructive assert-equal
: ASSERT-EQUAL ( n1 n2 -- n1 n2 )
    2DUP ASSERT-EQUAL-D ;

\ destructive assert-true
: ASSERT-TRUE-D ( n -- )
    0 = IF 1 ABORT" AssertTrue: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ non-destructive assert-true
: ASSERT-TRUE ( n -- n )
    DUP ASSERT-TRUE-D ;

\ destructive assert-false
: ASSERT-False-D ( n -- )
    0 <> IF 1 ABORT" AssertFalse: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ non-destructive assert-false
: ASSERT-FALSE ( n -- n )
    DUP ASSERT-FALSE-D ;

\ ---- tests ----

ASSERTS-INIT

\ ?EMPTY
EMPTY         DEPTH 0 ASSERT-EQUAL-D
EMPTY EMPTY   DEPTH 0 ASSERT-EQUAL-D
0 EMPTY       DEPTH 0 ASSERT-EQUAL-D
1 2 3 4 EMPTY DEPTH 0 ASSERT-EQUAL-D

\ ?NEGATIVE
-1 ?NEG ASSERT-TRUE-D
 0 ?NEG ASSERT-TRUE-D
 1 ?NEG ASSERT-FALSE-D

\ ?MAX-NB
-1 ?MAX-NB  0   ASSERT-EQUAL-D
 0 ?MAX-NB  0   ASSERT-EQUAL-D
 1 ?MAX-NB  2   ASSERT-EQUAL-D
 2 ?MAX-NB  4   ASSERT-EQUAL-D
 3 ?MAX-NB  8   ASSERT-EQUAL-D

\ LOG2
 1 LOG2  0 ASSERT-EQUAL-D
 2 LOG2  1 ASSERT-EQUAL-D
 3 LOG2  1 ASSERT-EQUAL-D
 4 LOG2  2 ASSERT-EQUAL-D
 5 LOG2  2 ASSERT-EQUAL-D
 8 LOG2  3 ASSERT-EQUAL-D
42 LOG2  5 ASSERT-EQUAL-D

ASSERTS-RESULT
\ ---------


from NetBSD via Tim Weiss, tim at zetaflops dot net: deal with FS block sizes larger than 8K testing: krw

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

\	$OpenBSD: bootblk.fth,v 1.2 2003/08/26 19:55:21 drahn 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
\

2000 buffer: cur-block		\ Why do dynamic allocation?
-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
   fs_SIZEOF <  if
      ." Superblock bsize < size of superblock" cr
      abort
   then
   ffs_oldcompat
   boot-debug?  if ." ufs-open complete" cr then
;

: ufs-close ( -- )
   boot-ihandle dup -1 <>  if
      cif-close -1 to boot-ihandle
   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
;

h# 5000 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" 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


retrofit Safe Mode loader menu item actions

The menu item is now made completely independent with the ACPI item - most
modern systems seem to require ACPI and become even more "unsafe"
without it.
Safe Mode no longer disables APIC for the same reason.
kbdmux is not disabled as this feature has proven itself stable.

New actions:
- SMP is disabled in the Safe Mode now
- eventtimers are forced to periodic mode (some real and virtual systems
  seem to have problems otherwise)
- geom extra vigorous integrity checking is disabled, this is to
  facilitate migration from previous versions

Possible short term to do:
- make SMP switch a separate menu item
- restore APIC switch as a separate menu item

Longer term to do:
- turn various tweaks into separate menu items in a Safe Mode sub-menu

Please consider adding a safety tweak to Safe Mode when introducing
new major features or changes that may cause instabilities.

Discussed with:	jhb, scottl, Devin Teske
MFC after:	3 weeks (stable/9 only)


Emulate CR and TYPE at the forth level.

Emulate CR and TYPE at the forth level.

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

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

\ Copyright (c) 2016, Robert Sexton.  All rights reserved.
\ Covered by the terms of the supplied Licence.txt file

only forth definitions

\ ==============
\ *T SAPI polled serial driver
\ ==============
\ *P This driver provides polled serial comms for Cortex-M3 CPUs
\ ** using the internal UARTs via the SAPI call layer.   This is
\ ** The simplest implementation level.
\ ** It doesn't use the CR or TYPE calls, but rather emulates them.

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

target

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

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

target

\ CODE (seremitfc)	\ char base --
\ This is a system call.

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

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

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

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

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

external

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

\ Non-UARTs.
: seremit10 #10 (seremit)  ;
: sertype10	#10 (sertype)  ;
: sercr10	#10 (sercr)  ;
: serkey?10	#10 (serkey?)  ;
: serkey10	#10 (serkey)  ;
create Console10 ' serkey10 , ' serkey?10 , ' seremit10 , ' sertype10 , ' sercr10 ,

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

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

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

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

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

decimal

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

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

\ Copyright (c) 2016, Robert Sexton.  All rights reserved.
\ Covered by the terms of the supplied Licence.txt file

only forth definitions

\ ==============
\ *T SAPI polled serial driver
\ ==============
\ *P This driver provides polled serial comms for Cortex-M3 CPUs
\ ** using the internal UARTs via the SAPI call layer.   This is
\ ** The simplest implementation level.

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

target

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

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

target

\ CODE (seremitfc)	\ char base --
\ This is a system call.

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

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

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

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

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

external

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

\ Non-UARTs.
: seremit10 #10 (seremit)  ;
: sertype10	#10 (sertype)  ;
: sercr10	#10 (sercr)  ;
: serkey?10	#10 (serkey?)  ;
: serkey10	#10 (serkey)  ;
create Console10 ' serkey10 , ' serkey?10 , ' seremit10 , ' sertype10 , ' sercr10 ,

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

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

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

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

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

decimal


?TWO-ADJACENT-1-BITS added (not finished)

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

\ log2 (integer)
: LOG2 ( n -- log2_n ) DUP 1 < IF 1 ABORT" Log2 need a positive value."
                               ELSE DUP 1 = IF 0
                                            ELSE
                                                1 >R
                                                BEGIN ( n |R: i=1)
                                                    DUP DUP 2 I ** - 2 *
                                                    ( n n 2*[n-2**i])
                                                    R> 1 + >R ( … |R: i+1)
                                                    > ( n n>2*[n-2**i] )
                                                UNTIL
                                                R> 1 -
                                            THEN
                               THEN NIP ;

\ decimal to binary
\ e.g. : ( 11 -- 1 0 1 1 )
: DEC2BIN ( n -- n1 n2 n3 … ) DUP DUP 0 <> IF
                                        LOG2 2 SWAP ** >R ( n |R: X=2 ** n.log2 )
                                        BEGIN
                                            DUP I - 0 >= IF 1 SWAP I - ( 1 n-X )
                                                         ELSE 0 SWAP   ( 0 n )
                                                         THEN
                                            I 1 =
                                            R> 2 / >R ( … | X/2 )
                                        UNTIL
                                        R> 2DROP
                                   THEN
                                ;

\ -- 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 ) ( FIXME ) DUP DEC2BIN ( n n_bin )
                                                 0 >R
                                                 BEGIN
                                                   1 = IF I 1 = IF R> EMPTY 0 -1 >R
                                                                ELSE R> DROP 1 >R -1
                                                                THEN
                                                       ELSE 0 >R -1
                                                       THEN
                                                 UNTIL
                                                 R> ;

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

\ log2 (integer)
: LOG2 ( n -- log2_n ) DUP 1 < IF 1 ABORT" Log2 need a positive value."
                               ELSE DUP 1 = IF 0
                                            ELSE
                                                1 >R
                                                BEGIN ( n |R: i=1)
                                                    DUP DUP 2 I ** - 2 *
                                                    ( n n 2*[n-2**i])
                                                    R> 1 + >R ( … |R: i+1)
                                                    > ( n n>2*[n-2**i] )
                                                UNTIL
                                                R> 1 -
                                            THEN
                               THEN NIP ;

\ decimal to binary
\ e.g. : ( 11 -- 1 0 1 1 )
: DEC2BIN ( n -- n1 n2 n3 … ) DUP DUP 0 <> IF
                                        LOG2 2 SWAP ** >R ( n |R: X=2 ** n.log2 )
                                        BEGIN
                                            DUP I - 0 >= IF 1 SWAP I - ( 1 n-X )
                                                         ELSE 0 SWAP   ( 0 n )
                                                         THEN
                                            I 1 =
                                            R> 2 / >R ( … | X/2 )
                                        UNTIL
                                        R> 2DROP
                                   THEN
                                ;

\ -- kata

\ test if the given N has two adjacent 1 bits
\ e.g. : 1011 -> -1
\        1001 -> 0
: ?TWO-ADJACENT-1-BITS ( n -- bool ) ( TODO ) ;

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


Clean up the comments.

Clean up the comments.

\ Code to support runtime/dynamic into the C side via SAPI.
\
\ In the MPE environment, VALUEs work very well for this.
\ values are defined at compile time and can be updated at runtime.

\ ************************************************************************
\ ************************************************************************
\ Secondary support functions
\ ************************************************************************
\ ************************************************************************

\ *********************************************
\ Accessors - Tightly tied the data structure
\ *********************************************
: dy.val           @ ;
: dy.size    #4 + w@ ;
: dy.count   #6 + w@ ;
: dy.type    #8 + c@ ;
: dy.namelen #9 + c@ ;
: dy.name   #12 +  @ ;

\ Return the recordlength.  Its the first thing.
: dy-recordlen getsharedvars @ ;

\ Retrieve the string.
: dy-string ( addr -- caddr n )
  dup dy.name swap dy.namelen
;

\ Create a constant from scratch by laying down some assembly
\ A key trick is that we have to lay down a pointer to
\ the first character of the defintion after we finish
\ See the definition above for the template
: make-const \ n s-addr c --
	here 4+ >r \ This should point to the newly-created header.
	makeheader \

\ This is what a constant looks like after emerging from the compiler.
\ ( 0002:0270 4CF8047D Lx.} )  str r7, [ r12, # $-04 ]!
\ ( 0002:0274 004F .O )        ldr r7, [ PC, # $00 ] ( @$20278=$7D04F84C )
\ ( 0002:0276 7047 pG )        bx LR

	$7D04F84C , \  str r7, [ r12, # $-04 ]!
	$4f00 w,    \  ldr r7, [ PC, # $00 ]
	$4770 w,    \ bx LR
	, 	        \ Lay down the payload

	r> ,        \ lay down the link field for the next word - required
	;

\ Dump out an entry as a set of constants
: dy-print \ c-addr --
     S" $" type
     DUP dy.val .    \ Fetch the value

     DUP dy.type [CHAR] V = \ check the type

     IF
     	S" VALUE "
     ELSE
     	S" CONSTANT "
     THEN
     TYPE \ Display the result
     DUP dy.size . S" x" DUP dy.count .
     dy-string TYPE
     CR
   ;

\ Take a pointer to a dynamic link record, and add a constant to the dictionary
: dy-create \ addr --
	DUP \ addr addr
	dy.val \ c-addr n
	SWAP dy-string \ n c-addr b
    make-const
    ;

\ Given a record address and a string, figure out
\ if thats the one we're looking for
: dy-compare ( caddr n addr -- n )
  dy-string compare
;

\ Find the record in the list to go with a string
: dy-find ( c-addr n -- addr|0 )
  getsharedvars dy-recordlen + \ Skip over the empty first record
  >R \ Put it onto the return stack
  BEGIN
   R@ dy.val 0<>
  WHILE
   2DUP R@ dy-compare
   \ If we find it, clean the stack and leave the address on R
   0= IF 2DROP R> EXIT THEN
   R> dy-recordlen + >R
  REPEAT
  \ If we fall out, there will be a string caddr/n on the stack
  2DROP R> DROP
  0 \ Leave behind a zero to indicate failure
;

\ Walk the table and make the constants.
: dy-populate
  getsharedvars dy-recordlen + \ Skip over the empty first record
  BEGIN
     dup dy.val 0<>
  WHILE
     dup dy-create
     dy-recordlen +
  REPEAT
  2DROP R> DROP 0
  ;

\ Code to support runtime/dynamic into the C side via SAPI.

\ ************************************************************************
\ ************************************************************************
\ Secondary support functions
\ ************************************************************************
\ ************************************************************************

\ *********************************************
\ Accessors - Tightly tied the data structure
\ *********************************************
: dy.val           @ ;
: dy.size    #4 + w@ ;
: dy.count   #6 + w@ ;
: dy.type    #8 + c@ ;
: dy.namelen #9 + c@ ;
: dy.name   #12 +  @ ;

\ Return the recordlength.  Its the first thing.
: dy-recordlen getsharedvars @ ;

\ Retrieve the string.
: dy-string ( addr -- caddr n )
  dup dy.name swap dy.namelen
;

\ Heres some assembly code to use as a template.
\ I experimented a bit, and the simplest thing in the MPE
\ Forth environment is to lay down the assembly
((
CODE rawconstant
	str tos, [ psp, # -4 ] ! \ register push
    ldr tos, L$1
	bx lr
L$1: str tos, [ psp, # -4 ] ! \ 32-bit dummy instruction
END-CODE
))

\ Create a constant from scratch by laying down some assembly
\ A key trick is that we have to lay down a pointer to
\ the first character of the defintion after we finish
\ See the definition above for the template
: make-const \ n s-addr c --
	here 4+ >r \ This should point to the newly-created header.
	makeheader \

\ ( 0002:0270 4CF8047D Lx.} )  str r7, [ r12, # $-04 ]!
\ ( 0002:0274 004F .O )        ldr r7, [ PC, # $00 ] ( @$20278=$7D04F84C )
\ ( 0002:0276 7047 pG )        bx LR

	$7D04F84C , \  str r7, [ r12, # $-04 ]!
	$4f00 w,    \  ldr r7, [ PC, # $00 ]
	$4770 w,    \ bx LR
	, 	        \ Lay down the payload

	r> ,        \ lay down the link field for the next word - required
	;

\ Dump out an entry as a set of constants
: dy-print \ c-addr --
     S" $" type
     DUP dy.val .    \ Fetch the value

     DUP dy.type [CHAR] V = \ check the type

     IF
     	S" VALUE "
     ELSE
     	S" CONSTANT "
     THEN
     TYPE \ Display the result
     DUP dy.size . S" x" DUP dy.count .
     dy-string TYPE
     CR
   ;

\ Take a pointer to a dynamic link record, and add a constant to the dictionary
: dy-create \ addr --
	DUP \ addr addr
	dy.val \ c-addr n
	SWAP dy-string \ n c-addr b
    make-const
    ;

\ Given a record address and a string, figure out
\ if thats the one we're looking for
: dy-compare ( caddr n addr -- n )
  dy-string compare
;

\ Find the record in the list to go with a string
: dy-find ( c-addr n -- addr|0 )
  getsharedvars dy-recordlen + \ Skip over the empty first record
  >R \ Put it onto the return stack
  BEGIN
   R@ dy.val 0<>
  WHILE
   2DUP R@ dy-compare
   \ If we find it, clean the stack and leave the address on R
   0= IF 2DROP R> EXIT THEN
   R> dy-recordlen + >R
  REPEAT
  \ If we fall out, there will be a string caddr/n on the stack
  2DROP R> DROP
  0 \ Leave behind a zero to indicate failure
;

\ Walk the table and make the constants.
: dy-populate
  getsharedvars dy-recordlen + \ Skip over the empty first record
  BEGIN
     dup dy.val 0<>
  WHILE
     dup dy-create
     dy-recordlen +
  REPEAT
  2DROP R> DROP 0
  ;