Porposed new test for D< bug

Porposed new test for D< bug

\ To test the ANS Forth Double-Number word set and double number extensions

\ This program was written by Gerry Jackson in 2006, with contributions from
\ others where indicated, and is in the public domain - it can be distributed
\ and/or modified in any way but please retain this notice.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

\ The tests are not claimed to be comprehensive or correct
\ ------------------------------------------------------------------------------
\ Version 0.11  7 April 2015 2VALUE tested
\         0.6   1 April 2012 Tests placed in the public domain.
\               Immediate 2CONSTANTs and 2VARIABLEs tested
\         0.5   20 November 2009 Various constants renamed to avoid
\               redefinition warnings. <true> and <false> replaced
\               with TRUE and FALSE
\         0.4   6 March 2009 { and } replaced with T{ and }T
\               Tests rewritten to be independent of word size and
\               tests re-ordered
\         0.3   20 April 2007 ANS Forth words changed to upper case
\         0.2   30 Oct 2006 Updated following GForth test to include
\               various constants from core.fr
\         0.1   Oct 2006 First version released
\ ------------------------------------------------------------------------------
\ The tests are based on John Hayes test program for the core word set

\ Words tested in this file are:
\     2CONSTANT 2LITERAL 2VARIABLE D+ D- D. D.R D0< D0= D2* D2/
\     D< D= D>S DABS DMAX DMIN DNEGATE M*/ M+ 2ROT DU<
\ Also tests the interpreter and compiler reading a double number
\ ------------------------------------------------------------------------------
\ Assumptions and dependencies:
\     - tester.fr or ttester.fs has been included prior to this file
\     - core words and core extension words have been tested
\ ------------------------------------------------------------------------------
\ Constant definitions

DECIMAL
0 INVERT        CONSTANT 1SD
1SD 1 RSHIFT    CONSTANT MAX-INTD   \ 01...1
MAX-INTD INVERT CONSTANT MIN-INTD   \ 10...0
MAX-INTD 2/     CONSTANT HI-INT     \ 001...1
MIN-INTD 2/     CONSTANT LO-INT     \ 110...1

\ ------------------------------------------------------------------------------
TESTING interpreter and compiler reading a double number

T{ 1. -> 1 0 }T
T{ -2. -> -2 -1 }T
T{ : RDL1 3. ; RDL1 -> 3 0 }T
T{ : RDL2 -4. ; RDL2 -> -4 -1 }T

\ ------------------------------------------------------------------------------
TESTING 2CONSTANT

T{ 1 2 2CONSTANT 2C1 -> }T
T{ 2C1 -> 1 2 }T
T{ : CD1 2C1 ; -> }T
T{ CD1 -> 1 2 }T
T{ : CD2 2CONSTANT ; -> }T
T{ -1 -2 CD2 2C2 -> }T
T{ 2C2 -> -1 -2 }T
T{ 4 5 2CONSTANT 2C3 IMMEDIATE 2C3 -> 4 5 }T
T{ : CD6 2C3 2LITERAL ; CD6 -> 4 5 }T

\ ------------------------------------------------------------------------------
\ Some 2CONSTANTs for the following tests

1SD MAX-INTD 2CONSTANT MAX-2INT  \ 01...1
0   MIN-INTD 2CONSTANT MIN-2INT  \ 10...0
MAX-2INT 2/  2CONSTANT HI-2INT   \ 001...1
MIN-2INT 2/  2CONSTANT LO-2INT   \ 110...0

\ ------------------------------------------------------------------------------
TESTING DNEGATE

T{ 0. DNEGATE -> 0. }T
T{ 1. DNEGATE -> -1. }T
T{ -1. DNEGATE -> 1. }T
T{ MAX-2INT DNEGATE -> MIN-2INT SWAP 1+ SWAP }T
T{ MIN-2INT SWAP 1+ SWAP DNEGATE -> MAX-2INT }T

\ ------------------------------------------------------------------------------
TESTING D+ with small integers

T{  0.  5. D+ ->  5. }T
T{ -5.  0. D+ -> -5. }T
T{  1.  2. D+ ->  3. }T
T{  1. -2. D+ -> -1. }T
T{ -1.  2. D+ ->  1. }T
T{ -1. -2. D+ -> -3. }T
T{ -1.  1. D+ ->  0. }T

TESTING D+ with mid range integers

T{  0  0  0  5 D+ ->  0  5 }T
T{ -1  5  0  0 D+ -> -1  5 }T
T{  0  0  0 -5 D+ ->  0 -5 }T
T{  0 -5 -1  0 D+ -> -1 -5 }T
T{  0  1  0  2 D+ ->  0  3 }T
T{ -1  1  0 -2 D+ -> -1 -1 }T
T{  0 -1  0  2 D+ ->  0  1 }T
T{  0 -1 -1 -2 D+ -> -1 -3 }T
T{ -1 -1  0  1 D+ -> -1  0 }T
T{ MIN-INTD 0 2DUP D+ -> 0 1 }T
T{ MIN-INTD S>D MIN-INTD 0 D+ -> 0 0 }T

TESTING D+ with large double integers

T{ HI-2INT 1. D+ -> 0 HI-INT 1+ }T
T{ HI-2INT 2DUP D+ -> 1SD 1- MAX-INTD }T
T{ MAX-2INT MIN-2INT D+ -> -1. }T
T{ MAX-2INT LO-2INT D+ -> HI-2INT }T
T{ HI-2INT MIN-2INT D+ 1. D+ -> LO-2INT }T
T{ LO-2INT 2DUP D+ -> MIN-2INT }T

\ ------------------------------------------------------------------------------
TESTING D- with small integers

T{  0.  5. D- -> -5. }T
T{  5.  0. D- ->  5. }T
T{  0. -5. D- ->  5. }T
T{  1.  2. D- -> -1. }T
T{  1. -2. D- ->  3. }T
T{ -1.  2. D- -> -3. }T
T{ -1. -2. D- ->  1. }T
T{ -1. -1. D- ->  0. }T

TESTING D- with mid-range integers

T{  0  0  0  5 D- ->  0 -5 }T
T{ -1  5  0  0 D- -> -1  5 }T
T{  0  0 -1 -5 D- ->  1  4 }T
T{  0 -5  0  0 D- ->  0 -5 }T
T{ -1  1  0  2 D- -> -1 -1 }T
T{  0  1 -1 -2 D- ->  1  2 }T
T{  0 -1  0  2 D- ->  0 -3 }T
T{  0 -1  0 -2 D- ->  0  1 }T
T{  0  0  0  1 D- ->  0 -1 }T
T{ MIN-INTD 0 2DUP D- -> 0. }T
T{ MIN-INTD S>D MAX-INTD 0 D- -> 1 1SD }T

TESTING D- with large integers

T{ MAX-2INT MAX-2INT D- -> 0. }T
T{ MIN-2INT MIN-2INT D- -> 0. }T
T{ MAX-2INT HI-2INT  D- -> LO-2INT DNEGATE }T
T{ HI-2INT  LO-2INT  D- -> MAX-2INT }T
T{ LO-2INT  HI-2INT  D- -> MIN-2INT 1. D+ }T
T{ MIN-2INT MIN-2INT D- -> 0. }T
T{ MIN-2INT LO-2INT  D- -> LO-2INT }T

\ ------------------------------------------------------------------------------
TESTING D0< D0=

T{ 0. D0< -> FALSE }T
T{ 1. D0< -> FALSE }T
T{ MIN-INTD 0 D0< -> FALSE }T
T{ 0 MAX-INTD D0< -> FALSE }T
T{ MAX-2INT  D0< -> FALSE }T
T{ -1. D0< -> TRUE }T
T{ MIN-2INT D0< -> TRUE }T

T{ 1. D0= -> FALSE }T
T{ MIN-INTD 0 D0= -> FALSE }T
T{ MAX-2INT  D0= -> FALSE }T
T{ -1 MAX-INTD D0= -> FALSE }T
T{ 0. D0= -> TRUE }T
T{ -1. D0= -> FALSE }T
T{ 0 MIN-INTD D0= -> FALSE }T

\ ------------------------------------------------------------------------------
TESTING D2* D2/

T{ 0. D2* -> 0. D2* }T
T{ MIN-INTD 0 D2* -> 0 1 }T
T{ HI-2INT D2* -> MAX-2INT 1. D- }T
T{ LO-2INT D2* -> MIN-2INT }T

T{ 0. D2/ -> 0. }T
T{ 1. D2/ -> 0. }T
T{ 0 1 D2/ -> MIN-INTD 0 }T
T{ MAX-2INT D2/ -> HI-2INT }T
T{ -1. D2/ -> -1. }T
T{ MIN-2INT D2/ -> LO-2INT }T

\ ------------------------------------------------------------------------------
TESTING D< D=

T{  0.  1. D< -> TRUE  }T
T{  0.  0. D< -> FALSE }T
T{  1.  0. D< -> FALSE }T
T{ -1.  1. D< -> TRUE  }T
T{ -1.  0. D< -> TRUE  }T
T{ -2. -1. D< -> TRUE  }T
T{ -1. -2. D< -> FALSE }T
T{ -1. MAX-2INT D< -> TRUE }T
T{ MIN-2INT MAX-2INT D< -> TRUE }T
T{ MAX-2INT -1. D< -> FALSE }T
T{ MAX-2INT MIN-2INT D< -> FALSE }T
T{ MAX-2INT 2DUP -1. D+ D< -> FALSE }T
T{ MIN-2INT 2DUP  1. D+ D< -> TRUE  }T
T{ MAX-INTD S>D 2DUP 1. D+ D< -> TRUE }T

T{ -1. -1. D= -> TRUE  }T
T{ -1.  0. D= -> FALSE }T
T{ -1.  1. D= -> FALSE }T
T{  0. -1. D= -> FALSE }T
T{  0.  0. D= -> TRUE  }T
T{  0.  1. D= -> FALSE }T
T{  1. -1. D= -> FALSE }T
T{  1.  0. D= -> FALSE }T
T{  1.  1. D= -> TRUE  }T

T{ 0 -1 0 -1 D= -> TRUE  }T
T{ 0 -1 0  0 D= -> FALSE }T
T{ 0 -1 0  1 D= -> FALSE }T
T{ 0  0 0 -1 D= -> FALSE }T
T{ 0  0 0  0 D= -> TRUE  }T
T{ 0  0 0  1 D= -> FALSE }T
T{ 0  1 0 -1 D= -> FALSE }T
T{ 0  1 0  0 D= -> FALSE }T
T{ 0  1 0  1 D= -> TRUE  }T

T{ MAX-2INT MIN-2INT D= -> FALSE }T
T{ MAX-2INT 0. D= -> FALSE }T
T{ MAX-2INT MAX-2INT D= -> TRUE }T
T{ MAX-2INT HI-2INT  D= -> FALSE }T
T{ MAX-2INT MIN-2INT D= -> FALSE }T
T{ MIN-2INT MIN-2INT D= -> TRUE }T
T{ MIN-2INT LO-2INT  D=  -> FALSE }T
T{ MIN-2INT MAX-2INT D= -> FALSE }T

\ ------------------------------------------------------------------------------
TESTING 2LITERAL 2VARIABLE

T{ : CD3 [ MAX-2INT ] 2LITERAL ; -> }T
T{ CD3 -> MAX-2INT }T
T{ 2VARIABLE 2V1 -> }T
T{ 0. 2V1 2! -> }T
T{ 2V1 2@ -> 0. }T
T{ -1 -2 2V1 2! -> }T
T{ 2V1 2@ -> -1 -2 }T
T{ : CD4 2VARIABLE ; -> }T
T{ CD4 2V2 -> }T
T{ : CD5 2V2 2! ; -> }T
T{ -2 -1 CD5 -> }T
T{ 2V2 2@ -> -2 -1 }T
T{ 2VARIABLE 2V3 IMMEDIATE 5 6 2V3 2! -> }T
T{ 2V3 2@ -> 5 6 }T
T{ : CD7 2V3 [ 2@ ] 2LITERAL ; CD7 -> 5 6 }T
T{ : CD8 [ 6 7 ] 2V3 [ 2! ] ; 2V3 2@ -> 6 7 }T

\ ------------------------------------------------------------------------------
TESTING DMAX DMIN

T{  1.  2. DMAX -> 2. }T
T{  1.  0. DMAX -> 1. }T
T{  1. -1. DMAX -> 1. }T
T{  1.  1. DMAX -> 1. }T
T{  0.  1. DMAX -> 1. }T
T{  0. -1. DMAX -> 0. }T
T{ -1.  1. DMAX -> 1. }T
T{ -1. -2. DMAX -> -1. }T

T{ MAX-2INT HI-2INT  DMAX -> MAX-2INT }T
T{ MAX-2INT MIN-2INT DMAX -> MAX-2INT }T
T{ MIN-2INT MAX-2INT DMAX -> MAX-2INT }T
T{ MIN-2INT LO-2INT  DMAX -> LO-2INT  }T

T{ MAX-2INT  1. DMAX -> MAX-2INT }T
T{ MAX-2INT -1. DMAX -> MAX-2INT }T
T{ MIN-2INT  1. DMAX ->  1. }T
T{ MIN-2INT -1. DMAX -> -1. }T

T{  1.  2. DMIN ->  1. }T
T{  1.  0. DMIN ->  0. }T
T{  1. -1. DMIN -> -1. }T
T{  1.  1. DMIN ->  1. }T
T{  0.  1. DMIN ->  0. }T
T{  0. -1. DMIN -> -1. }T
T{ -1.  1. DMIN -> -1. }T
T{ -1. -2. DMIN -> -2. }T

T{ MAX-2INT HI-2INT  DMIN -> HI-2INT  }T
T{ MAX-2INT MIN-2INT DMIN -> MIN-2INT }T
T{ MIN-2INT MAX-2INT DMIN -> MIN-2INT }T
T{ MIN-2INT LO-2INT  DMIN -> MIN-2INT }T

T{ MAX-2INT  1. DMIN ->  1. }T
T{ MAX-2INT -1. DMIN -> -1. }T
T{ MIN-2INT  1. DMIN -> MIN-2INT }T
T{ MIN-2INT -1. DMIN -> MIN-2INT }T

\ ------------------------------------------------------------------------------
TESTING D>S DABS

T{  1234  0 D>S ->  1234 }T
T{ -1234 -1 D>S -> -1234 }T
T{ MAX-INTD  0 D>S -> MAX-INTD }T
T{ MIN-INTD -1 D>S -> MIN-INTD }T

T{  1. DABS -> 1. }T
T{ -1. DABS -> 1. }T
T{ MAX-2INT DABS -> MAX-2INT }T
T{ MIN-2INT 1. D+ DABS -> MAX-2INT }T

\ ------------------------------------------------------------------------------
TESTING M+ M*/

T{ HI-2INT   1 M+ -> HI-2INT   1. D+ }T
T{ MAX-2INT -1 M+ -> MAX-2INT -1. D+ }T
T{ MIN-2INT  1 M+ -> MIN-2INT  1. D+ }T
T{ LO-2INT  -1 M+ -> LO-2INT  -1. D+ }T

\ To correct the result if the division is floored, only used when
\ necessary i.e. negative quotient and remainder <> 0

: ?FLOORED [ -3 2 / -2 = ] LITERAL IF 1. D- THEN ;

T{  5.  7 11 M*/ ->  3. }T
T{  5. -7 11 M*/ -> -3. ?FLOORED }T    \ FLOORED -4.
T{ -5.  7 11 M*/ -> -3. ?FLOORED }T    \ FLOORED -4.
T{ -5. -7 11 M*/ ->  3. }T
T{ MAX-2INT  8 16 M*/ -> HI-2INT }T
T{ MAX-2INT -8 16 M*/ -> HI-2INT DNEGATE ?FLOORED }T  \ FLOORED SUBTRACT 1
T{ MIN-2INT  8 16 M*/ -> LO-2INT }T
T{ MIN-2INT -8 16 M*/ -> LO-2INT DNEGATE }T
T{ MAX-2INT MAX-INTD MAX-INTD M*/ -> MAX-2INT }T
T{ MAX-2INT MAX-INTD 2/ MAX-INTD M*/ -> MAX-INTD 1- HI-2INT NIP }T
T{ MIN-2INT LO-2INT NIP DUP NEGATE M*/ -> MIN-2INT }T
T{ MIN-2INT LO-2INT NIP 1- MAX-INTD M*/ -> MIN-INTD 3 + HI-2INT NIP 2 + }T
T{ MAX-2INT LO-2INT NIP DUP NEGATE M*/ -> MAX-2INT DNEGATE }T
T{ MIN-2INT MAX-INTD DUP M*/ -> MIN-2INT }T

\ ------------------------------------------------------------------------------
TESTING D. D.R

\ Create some large double numbers
MAX-2INT 71 73 M*/ 2CONSTANT DBL1
MIN-2INT 73 79 M*/ 2CONSTANT DBL2

: D>ASCII  ( D -- CADDR U )
   DUP >R <# DABS #S R> SIGN #>    ( -- CADDR1 U )
   HERE SWAP 2DUP 2>R CHARS DUP ALLOT MOVE 2R>
;

DBL1 D>ASCII 2CONSTANT "DBL1"
DBL2 D>ASCII 2CONSTANT "DBL2"

: DOUBLEOUTPUT
   CR ." You should see lines duplicated:" CR
   5 SPACES "DBL1" TYPE CR
   5 SPACES DBL1 D. CR
   8 SPACES "DBL1" DUP >R TYPE CR
   5 SPACES DBL1 R> 3 + D.R CR
   5 SPACES "DBL2" TYPE CR
   5 SPACES DBL2 D. CR
   10 SPACES "DBL2" DUP >R TYPE CR
   5 SPACES DBL2 R> 5 + D.R CR
;

T{ DOUBLEOUTPUT -> }T

\ ------------------------------------------------------------------------------
TESTING 2ROT DU< (Double Number extension words)

T{ 1. 2. 3. 2ROT -> 2. 3. 1. }T
T{ MAX-2INT MIN-2INT 1. 2ROT -> MIN-2INT 1. MAX-2INT }T

T{  1.  1. DU< -> FALSE }T
T{  1. -1. DU< -> TRUE  }T
T{ -1.  1. DU< -> FALSE }T
T{ -1. -2. DU< -> FALSE }T

T{ MAX-2INT HI-2INT  DU< -> FALSE }T
T{ HI-2INT  MAX-2INT DU< -> TRUE  }T
T{ MAX-2INT MIN-2INT DU< -> TRUE }T
T{ MIN-2INT MAX-2INT DU< -> FALSE }T
T{ MIN-2INT LO-2INT  DU< -> TRUE }T

\ ------------------------------------------------------------------------------
TESTING 2VALUE

T{ 1111 2222 2VALUE 2VAL -> }T
T{ 2VAL -> 1111 2222 }T
T{ 3333 4444 TO 2VAL -> }T
T{ 2VAL -> 3333 4444 }T
T{ : TO-2VAL TO 2VAL ; 5555 6666 TO-2VAL -> }T
T{ 2VAL -> 5555 6666 }T

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

DOUBLE-ERRORS SET-ERROR-COUNT

CR .( End of Double-Number word tests) CR

\ To test the ANS Forth Double-Number word set and double number extensions

\ This program was written by Gerry Jackson in 2006, with contributions from
\ others where indicated, and is in the public domain - it can be distributed
\ and/or modified in any way but please retain this notice.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

\ The tests are not claimed to be comprehensive or correct
\ ------------------------------------------------------------------------------
\ Version 0.11  7 April 2015 2VALUE tested
\         0.6   1 April 2012 Tests placed in the public domain.
\               Immediate 2CONSTANTs and 2VARIABLEs tested
\         0.5   20 November 2009 Various constants renamed to avoid
\               redefinition warnings. <true> and <false> replaced
\               with TRUE and FALSE
\         0.4   6 March 2009 { and } replaced with T{ and }T
\               Tests rewritten to be independent of word size and
\               tests re-ordered
\         0.3   20 April 2007 ANS Forth words changed to upper case
\         0.2   30 Oct 2006 Updated following GForth test to include
\               various constants from core.fr
\         0.1   Oct 2006 First version released
\ ------------------------------------------------------------------------------
\ The tests are based on John Hayes test program for the core word set

\ Words tested in this file are:
\     2CONSTANT 2LITERAL 2VARIABLE D+ D- D. D.R D0< D0= D2* D2/
\     D< D= D>S DABS DMAX DMIN DNEGATE M*/ M+ 2ROT DU<
\ Also tests the interpreter and compiler reading a double number
\ ------------------------------------------------------------------------------
\ Assumptions and dependencies:
\     - tester.fr or ttester.fs has been included prior to this file
\     - core words and core extension words have been tested
\ ------------------------------------------------------------------------------
\ Constant definitions

DECIMAL
0 INVERT        CONSTANT 1SD
1SD 1 RSHIFT    CONSTANT MAX-INTD   \ 01...1
MAX-INTD INVERT CONSTANT MIN-INTD   \ 10...0
MAX-INTD 2/     CONSTANT HI-INT     \ 001...1
MIN-INTD 2/     CONSTANT LO-INT     \ 110...1

\ ------------------------------------------------------------------------------
TESTING interpreter and compiler reading a double number

T{ 1. -> 1 0 }T
T{ -2. -> -2 -1 }T
T{ : RDL1 3. ; RDL1 -> 3 0 }T
T{ : RDL2 -4. ; RDL2 -> -4 -1 }T

\ ------------------------------------------------------------------------------
TESTING 2CONSTANT

T{ 1 2 2CONSTANT 2C1 -> }T
T{ 2C1 -> 1 2 }T
T{ : CD1 2C1 ; -> }T
T{ CD1 -> 1 2 }T
T{ : CD2 2CONSTANT ; -> }T
T{ -1 -2 CD2 2C2 -> }T
T{ 2C2 -> -1 -2 }T
T{ 4 5 2CONSTANT 2C3 IMMEDIATE 2C3 -> 4 5 }T
T{ : CD6 2C3 2LITERAL ; CD6 -> 4 5 }T

\ ------------------------------------------------------------------------------
\ Some 2CONSTANTs for the following tests

1SD MAX-INTD 2CONSTANT MAX-2INT  \ 01...1
0   MIN-INTD 2CONSTANT MIN-2INT  \ 10...0
MAX-2INT 2/  2CONSTANT HI-2INT   \ 001...1
MIN-2INT 2/  2CONSTANT LO-2INT   \ 110...0

\ ------------------------------------------------------------------------------
TESTING DNEGATE

T{ 0. DNEGATE -> 0. }T
T{ 1. DNEGATE -> -1. }T
T{ -1. DNEGATE -> 1. }T
T{ MAX-2INT DNEGATE -> MIN-2INT SWAP 1+ SWAP }T
T{ MIN-2INT SWAP 1+ SWAP DNEGATE -> MAX-2INT }T

\ ------------------------------------------------------------------------------
TESTING D+ with small integers

T{  0.  5. D+ ->  5. }T
T{ -5.  0. D+ -> -5. }T
T{  1.  2. D+ ->  3. }T
T{  1. -2. D+ -> -1. }T
T{ -1.  2. D+ ->  1. }T
T{ -1. -2. D+ -> -3. }T
T{ -1.  1. D+ ->  0. }T

TESTING D+ with mid range integers

T{  0  0  0  5 D+ ->  0  5 }T
T{ -1  5  0  0 D+ -> -1  5 }T
T{  0  0  0 -5 D+ ->  0 -5 }T
T{  0 -5 -1  0 D+ -> -1 -5 }T
T{  0  1  0  2 D+ ->  0  3 }T
T{ -1  1  0 -2 D+ -> -1 -1 }T
T{  0 -1  0  2 D+ ->  0  1 }T
T{  0 -1 -1 -2 D+ -> -1 -3 }T
T{ -1 -1  0  1 D+ -> -1  0 }T
T{ MIN-INTD 0 2DUP D+ -> 0 1 }T
T{ MIN-INTD S>D MIN-INTD 0 D+ -> 0 0 }T

TESTING D+ with large double integers

T{ HI-2INT 1. D+ -> 0 HI-INT 1+ }T
T{ HI-2INT 2DUP D+ -> 1SD 1- MAX-INTD }T
T{ MAX-2INT MIN-2INT D+ -> -1. }T
T{ MAX-2INT LO-2INT D+ -> HI-2INT }T
T{ HI-2INT MIN-2INT D+ 1. D+ -> LO-2INT }T
T{ LO-2INT 2DUP D+ -> MIN-2INT }T

\ ------------------------------------------------------------------------------
TESTING D- with small integers

T{  0.  5. D- -> -5. }T
T{  5.  0. D- ->  5. }T
T{  0. -5. D- ->  5. }T
T{  1.  2. D- -> -1. }T
T{  1. -2. D- ->  3. }T
T{ -1.  2. D- -> -3. }T
T{ -1. -2. D- ->  1. }T
T{ -1. -1. D- ->  0. }T

TESTING D- with mid-range integers

T{  0  0  0  5 D- ->  0 -5 }T
T{ -1  5  0  0 D- -> -1  5 }T
T{  0  0 -1 -5 D- ->  1  4 }T
T{  0 -5  0  0 D- ->  0 -5 }T
T{ -1  1  0  2 D- -> -1 -1 }T
T{  0  1 -1 -2 D- ->  1  2 }T
T{  0 -1  0  2 D- ->  0 -3 }T
T{  0 -1  0 -2 D- ->  0  1 }T
T{  0  0  0  1 D- ->  0 -1 }T
T{ MIN-INTD 0 2DUP D- -> 0. }T
T{ MIN-INTD S>D MAX-INTD 0 D- -> 1 1SD }T

TESTING D- with large integers

T{ MAX-2INT MAX-2INT D- -> 0. }T
T{ MIN-2INT MIN-2INT D- -> 0. }T
T{ MAX-2INT HI-2INT  D- -> LO-2INT DNEGATE }T
T{ HI-2INT  LO-2INT  D- -> MAX-2INT }T
T{ LO-2INT  HI-2INT  D- -> MIN-2INT 1. D+ }T
T{ MIN-2INT MIN-2INT D- -> 0. }T
T{ MIN-2INT LO-2INT  D- -> LO-2INT }T

\ ------------------------------------------------------------------------------
TESTING D0< D0=

T{ 0. D0< -> FALSE }T
T{ 1. D0< -> FALSE }T
T{ MIN-INTD 0 D0< -> FALSE }T
T{ 0 MAX-INTD D0< -> FALSE }T
T{ MAX-2INT  D0< -> FALSE }T
T{ -1. D0< -> TRUE }T
T{ MIN-2INT D0< -> TRUE }T

T{ 1. D0= -> FALSE }T
T{ MIN-INTD 0 D0= -> FALSE }T
T{ MAX-2INT  D0= -> FALSE }T
T{ -1 MAX-INTD D0= -> FALSE }T
T{ 0. D0= -> TRUE }T
T{ -1. D0= -> FALSE }T
T{ 0 MIN-INTD D0= -> FALSE }T

\ ------------------------------------------------------------------------------
TESTING D2* D2/

T{ 0. D2* -> 0. D2* }T
T{ MIN-INTD 0 D2* -> 0 1 }T
T{ HI-2INT D2* -> MAX-2INT 1. D- }T
T{ LO-2INT D2* -> MIN-2INT }T

T{ 0. D2/ -> 0. }T
T{ 1. D2/ -> 0. }T
T{ 0 1 D2/ -> MIN-INTD 0 }T
T{ MAX-2INT D2/ -> HI-2INT }T
T{ -1. D2/ -> -1. }T
T{ MIN-2INT D2/ -> LO-2INT }T

\ ------------------------------------------------------------------------------
TESTING D< D=

T{  0.  1. D< -> TRUE  }T
T{  0.  0. D< -> FALSE }T
T{  1.  0. D< -> FALSE }T
T{ -1.  1. D< -> TRUE  }T
T{ -1.  0. D< -> TRUE  }T
T{ -2. -1. D< -> TRUE  }T
T{ -1. -2. D< -> FALSE }T
T{ -1. MAX-2INT D< -> TRUE }T
T{ MIN-2INT MAX-2INT D< -> TRUE }T
T{ MAX-2INT -1. D< -> FALSE }T
T{ MAX-2INT MIN-2INT D< -> FALSE }T
T{ MAX-2INT 2DUP -1. D+ D< -> FALSE }T
T{ MIN-2INT 2DUP  1. D+ D< -> TRUE  }T

T{ -1. -1. D= -> TRUE  }T
T{ -1.  0. D= -> FALSE }T
T{ -1.  1. D= -> FALSE }T
T{  0. -1. D= -> FALSE }T
T{  0.  0. D= -> TRUE  }T
T{  0.  1. D= -> FALSE }T
T{  1. -1. D= -> FALSE }T
T{  1.  0. D= -> FALSE }T
T{  1.  1. D= -> TRUE  }T

T{ 0 -1 0 -1 D= -> TRUE  }T
T{ 0 -1 0  0 D= -> FALSE }T
T{ 0 -1 0  1 D= -> FALSE }T
T{ 0  0 0 -1 D= -> FALSE }T
T{ 0  0 0  0 D= -> TRUE  }T
T{ 0  0 0  1 D= -> FALSE }T
T{ 0  1 0 -1 D= -> FALSE }T
T{ 0  1 0  0 D= -> FALSE }T
T{ 0  1 0  1 D= -> TRUE  }T

T{ MAX-2INT MIN-2INT D= -> FALSE }T
T{ MAX-2INT 0. D= -> FALSE }T
T{ MAX-2INT MAX-2INT D= -> TRUE }T
T{ MAX-2INT HI-2INT  D= -> FALSE }T
T{ MAX-2INT MIN-2INT D= -> FALSE }T
T{ MIN-2INT MIN-2INT D= -> TRUE }T
T{ MIN-2INT LO-2INT  D=  -> FALSE }T
T{ MIN-2INT MAX-2INT D= -> FALSE }T

\ ------------------------------------------------------------------------------
TESTING 2LITERAL 2VARIABLE

T{ : CD3 [ MAX-2INT ] 2LITERAL ; -> }T
T{ CD3 -> MAX-2INT }T
T{ 2VARIABLE 2V1 -> }T
T{ 0. 2V1 2! -> }T
T{ 2V1 2@ -> 0. }T
T{ -1 -2 2V1 2! -> }T
T{ 2V1 2@ -> -1 -2 }T
T{ : CD4 2VARIABLE ; -> }T
T{ CD4 2V2 -> }T
T{ : CD5 2V2 2! ; -> }T
T{ -2 -1 CD5 -> }T
T{ 2V2 2@ -> -2 -1 }T
T{ 2VARIABLE 2V3 IMMEDIATE 5 6 2V3 2! -> }T
T{ 2V3 2@ -> 5 6 }T
T{ : CD7 2V3 [ 2@ ] 2LITERAL ; CD7 -> 5 6 }T
T{ : CD8 [ 6 7 ] 2V3 [ 2! ] ; 2V3 2@ -> 6 7 }T

\ ------------------------------------------------------------------------------
TESTING DMAX DMIN

T{  1.  2. DMAX -> 2. }T
T{  1.  0. DMAX -> 1. }T
T{  1. -1. DMAX -> 1. }T
T{  1.  1. DMAX -> 1. }T
T{  0.  1. DMAX -> 1. }T
T{  0. -1. DMAX -> 0. }T
T{ -1.  1. DMAX -> 1. }T
T{ -1. -2. DMAX -> -1. }T

T{ MAX-2INT HI-2INT  DMAX -> MAX-2INT }T
T{ MAX-2INT MIN-2INT DMAX -> MAX-2INT }T
T{ MIN-2INT MAX-2INT DMAX -> MAX-2INT }T
T{ MIN-2INT LO-2INT  DMAX -> LO-2INT  }T

T{ MAX-2INT  1. DMAX -> MAX-2INT }T
T{ MAX-2INT -1. DMAX -> MAX-2INT }T
T{ MIN-2INT  1. DMAX ->  1. }T
T{ MIN-2INT -1. DMAX -> -1. }T

T{  1.  2. DMIN ->  1. }T
T{  1.  0. DMIN ->  0. }T
T{  1. -1. DMIN -> -1. }T
T{  1.  1. DMIN ->  1. }T
T{  0.  1. DMIN ->  0. }T
T{  0. -1. DMIN -> -1. }T
T{ -1.  1. DMIN -> -1. }T
T{ -1. -2. DMIN -> -2. }T

T{ MAX-2INT HI-2INT  DMIN -> HI-2INT  }T
T{ MAX-2INT MIN-2INT DMIN -> MIN-2INT }T
T{ MIN-2INT MAX-2INT DMIN -> MIN-2INT }T
T{ MIN-2INT LO-2INT  DMIN -> MIN-2INT }T

T{ MAX-2INT  1. DMIN ->  1. }T
T{ MAX-2INT -1. DMIN -> -1. }T
T{ MIN-2INT  1. DMIN -> MIN-2INT }T
T{ MIN-2INT -1. DMIN -> MIN-2INT }T

\ ------------------------------------------------------------------------------
TESTING D>S DABS

T{  1234  0 D>S ->  1234 }T
T{ -1234 -1 D>S -> -1234 }T
T{ MAX-INTD  0 D>S -> MAX-INTD }T
T{ MIN-INTD -1 D>S -> MIN-INTD }T

T{  1. DABS -> 1. }T
T{ -1. DABS -> 1. }T
T{ MAX-2INT DABS -> MAX-2INT }T
T{ MIN-2INT 1. D+ DABS -> MAX-2INT }T

\ ------------------------------------------------------------------------------
TESTING M+ M*/

T{ HI-2INT   1 M+ -> HI-2INT   1. D+ }T
T{ MAX-2INT -1 M+ -> MAX-2INT -1. D+ }T
T{ MIN-2INT  1 M+ -> MIN-2INT  1. D+ }T
T{ LO-2INT  -1 M+ -> LO-2INT  -1. D+ }T

\ To correct the result if the division is floored, only used when
\ necessary i.e. negative quotient and remainder <> 0

: ?FLOORED [ -3 2 / -2 = ] LITERAL IF 1. D- THEN ;

T{  5.  7 11 M*/ ->  3. }T
T{  5. -7 11 M*/ -> -3. ?FLOORED }T    \ FLOORED -4.
T{ -5.  7 11 M*/ -> -3. ?FLOORED }T    \ FLOORED -4.
T{ -5. -7 11 M*/ ->  3. }T
T{ MAX-2INT  8 16 M*/ -> HI-2INT }T
T{ MAX-2INT -8 16 M*/ -> HI-2INT DNEGATE ?FLOORED }T  \ FLOORED SUBTRACT 1
T{ MIN-2INT  8 16 M*/ -> LO-2INT }T
T{ MIN-2INT -8 16 M*/ -> LO-2INT DNEGATE }T
T{ MAX-2INT MAX-INTD MAX-INTD M*/ -> MAX-2INT }T
T{ MAX-2INT MAX-INTD 2/ MAX-INTD M*/ -> MAX-INTD 1- HI-2INT NIP }T
T{ MIN-2INT LO-2INT NIP DUP NEGATE M*/ -> MIN-2INT }T
T{ MIN-2INT LO-2INT NIP 1- MAX-INTD M*/ -> MIN-INTD 3 + HI-2INT NIP 2 + }T
T{ MAX-2INT LO-2INT NIP DUP NEGATE M*/ -> MAX-2INT DNEGATE }T
T{ MIN-2INT MAX-INTD DUP M*/ -> MIN-2INT }T

\ ------------------------------------------------------------------------------
TESTING D. D.R

\ Create some large double numbers
MAX-2INT 71 73 M*/ 2CONSTANT DBL1
MIN-2INT 73 79 M*/ 2CONSTANT DBL2

: D>ASCII  ( D -- CADDR U )
   DUP >R <# DABS #S R> SIGN #>    ( -- CADDR1 U )
   HERE SWAP 2DUP 2>R CHARS DUP ALLOT MOVE 2R>
;

DBL1 D>ASCII 2CONSTANT "DBL1"
DBL2 D>ASCII 2CONSTANT "DBL2"

: DOUBLEOUTPUT
   CR ." You should see lines duplicated:" CR
   5 SPACES "DBL1" TYPE CR
   5 SPACES DBL1 D. CR
   8 SPACES "DBL1" DUP >R TYPE CR
   5 SPACES DBL1 R> 3 + D.R CR
   5 SPACES "DBL2" TYPE CR
   5 SPACES DBL2 D. CR
   10 SPACES "DBL2" DUP >R TYPE CR
   5 SPACES DBL2 R> 5 + D.R CR
;

T{ DOUBLEOUTPUT -> }T

\ ------------------------------------------------------------------------------
TESTING 2ROT DU< (Double Number extension words)

T{ 1. 2. 3. 2ROT -> 2. 3. 1. }T
T{ MAX-2INT MIN-2INT 1. 2ROT -> MIN-2INT 1. MAX-2INT }T

T{  1.  1. DU< -> FALSE }T
T{  1. -1. DU< -> TRUE  }T
T{ -1.  1. DU< -> FALSE }T
T{ -1. -2. DU< -> FALSE }T

T{ MAX-2INT HI-2INT  DU< -> FALSE }T
T{ HI-2INT  MAX-2INT DU< -> TRUE  }T
T{ MAX-2INT MIN-2INT DU< -> TRUE }T
T{ MIN-2INT MAX-2INT DU< -> FALSE }T
T{ MIN-2INT LO-2INT  DU< -> TRUE }T

\ ------------------------------------------------------------------------------
TESTING 2VALUE

T{ 1111 2222 2VALUE 2VAL -> }T
T{ 2VAL -> 1111 2222 }T
T{ 3333 4444 TO 2VAL -> }T
T{ 2VAL -> 3333 4444 }T
T{ : TO-2VAL TO 2VAL ; 5555 6666 TO-2VAL -> }T
T{ 2VAL -> 5555 6666 }T

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

DOUBLE-ERRORS SET-ERROR-COUNT

CR .( End of Double-Number word tests) CR


Update copyright.

Update copyright.


Remove ELF check.  It is broken and since the PROM checks the loaded executable
anyway, it's not worth fixing.  Bump version number.

ok deraadt@

\	$OpenBSD: bootblk.fth,v 1.7 2010/02/27 22:23:16 kettenis 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

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

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

   nip					( addr )
;

: do-boot ( bootfile -- )
   ." OpenBSD IEEE 1275 Bootblock 1.3" 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.6 2010/02/26 23:03:50 deraadt Exp $
\	$NetBSD: bootblk.fth,v 1.3 2001/08/15 20:10:24 eeh Exp $
\
\	IEEE 1275 Open Firmware Boot Block
\
\	Parses disklabel and UFS and loads the file called `ofwboot'
\
\
\	Copyright (c) 1998 Eduardo Horvath.
\	All rights reserved.
\
\	Redistribution and use in source and binary forms, with or without
\	modification, are permitted provided that the following conditions
\	are met:
\	1. Redistributions of source code must retain the above copyright
\	   notice, this list of conditions and the following disclaimer.
\	2. Redistributions in binary form must reproduce the above copyright
\	   notice, this list of conditions and the following disclaimer in the
\	   documentation and/or other materials provided with the distribution.
\	3. All advertising materials mentioning features or use of this software
\	   must display the following acknowledgement:
\	     This product includes software developed by Eduardo Horvath.
\	4. The name of the author may not be used to endorse or promote products
\	   derived from this software without specific prior written permission
\
\	THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
\	IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
\	OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
\	IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
\	INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
\	NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
\	DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
\	THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
\	(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
\	THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
\

offset16
hex
headers

false value boot-debug?

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

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

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

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

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

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

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

\
\ Support routines
\

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

\ Move string into buffer

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

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

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

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

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

\
\ BSD FFS parameters
\

fload	assym.fth.h

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

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

\
\ Cylinder group macros
\

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

\
\ Block and frag position macros
\

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

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

\
\ File stuff
\

niaddr /w* constant narraysize

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

\ Identify inode type

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

h# 6000 constant loader-base

\
\ Elf support -- find the load addr
\

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

\
\ Finally we finish it all off
\

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

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

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

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

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

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

   nip					( addr )
;

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

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

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


A helper word for clearing the cal values.

(( Clock Code ))

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

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

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

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

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

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

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

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

: _NVRAMLOAD ( -- )
\ *G Pull the needle maximums from flash.
  $C 0 do I ud@ needle_max I + !   4 +loop
;

: NVRAM! ( -- )
\ *G Save the contents of the needle cal values.
 0 UDPAGE_ERASE
 needle_max
 $C 0 do dup I + @  I ud!  4 +loop
 drop
;

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

idata \ Has to match an odn.
create NEEDLE_MAX #850 , #850 , #850 ,
cdata

((
: interp-next drop 1 ;
: interp-reset drop ." Reset" ;

))

: RANGECHECK ( max n -- n or zero ) 2dup <= if 2drop 0 else swap drop then ;

: INTER-BUMP (  max old interp -- new )
\ *G Get the next value from the interpolator, and
\ ** reset the interpolator if it wraps around to zero.
  >R R@ interp-next  \ Get the max
  + rangecheck
  dup 0= if R> interp-reset else R> drop then
  ;

: NFETCH ( odn off -- max old )
\ *G Combine the current value with the maximum.
  >R R@ \ stash the offset.
  +  @ \ Calculate the offset address, get the current val.
  needle_max R> + @
  swap
;

: ++NEEDLE_S \ Called every time.
    odn_hms 0 odn.s nfetch ( max old )
	interp_hms interp.a inter-bump ( new )
	odn_hms odn.s !
	;

: ++NEEDLE_M ( -- )
\ *G Every time we roll the seconds, bump the minutes and the hour
	odn_hms 0 odn.m nfetch ( max old )
	interp_hms interp.b inter-bump
	odn_hms odn.m !

	odn_hms 0 odn.h nfetch ( max old )
	interp_hms interp.c inter-bump
	odn_hms odn.h !
	;

: ++NEEDLE_DS ; \ Called every time.
: ++NEEDLE_DM ; \ Every time we roll the seconds.

: _USE ( odn-addr -- )
  dup odn.s w@ pwm0!
  dup odn.m w@ pwm1!
      odn.h w@ pwm2!
  ;

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

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

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

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

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

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

_timer1 $24 + equ QUAD-IN

\ The Quadrature encoder produces two per detent.
: QUAD@ ( -- n ) \ Fetch and zero
  quad-in @off
  [asm sxth tos, tos asm]
  [asm asr .s tos, tos, # 1 asm] \ Divide by two,
  ;

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

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

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

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

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

  drop

;

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

\ : foo 0 do hms advancetime loop ;

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

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

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

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

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

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

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

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

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

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

\ -----------------------------------------------
\ State numbers.  These are defined x4 so that
\ we can just use the state number as an index
\ into a table of words.
\ -----------------------------------------------
0 4 * equ _s_init
1 4 * equ _s_b1
2 4 * equ _s_1sec

3 4 * equ _s_set_h
4 4 * equ _s_pendset_m
5 4 * equ _s_setmin

6 4 * equ _s_pendcal0
7 4 * equ _s_cal0
8 4 * equ _s_pendcalh
9 4 * equ _s_calh
10 4 * equ _s_pendcalm
11 4 * equ _s_calm
12 4 * equ _s_pendcals
13 4 * equ _s_cals

4 equ downcount_1s
16 equ downcount_3s

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

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

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

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

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

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

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

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

: shPendCalS true buttonup? if _s_calm uistate ! then ;
: shCalS true   buttondown? if _s_init uistate ! exit then ;
\ -------------------------------------------------
\ Helpers
\ -------------------------------------------------
: helpODNClear ( -- ) \ Set them all to zero
  odn_ui odn bounds do I off 4 +loop ;

create StateHandlers
' shInit ,
' shB1 ,
' sh1sec ,

' shSetH ,
' shPendSetM ,  ' shSetMin ,

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

\ -------------------------------------------------
\ Setting the time.
\ -------------------------------------------------
variable adj_i \ THe working index into the points array.

udata
create adj_points #50 cells allot \ 100 16-bit words.
create interp_set  _interp_set allot
cdata

\ Generate a list of points.
: MAKE-SET-LIST ( max steps )
  2dup
  >R  (interp_init) swap interp_set swap R> call3--

  \ Since zero is first, do the w! first.
  swap drop   0 swap \ Keep a running counter.
  0 do
    dup I adj_points[]! \ Save the existing value
    interp_set interp-next +
  loop
  drop
  ;

: ADJ_POINTS[]! ( data index -- ) 2* adj_points + w! ;
: ADJ_POINTS[]@ ( index -- n )    2* adj_points + w@ ;

(( Clock Code ))

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

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

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

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

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

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

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

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

: _NVRAMLOAD ( -- )
\ *G Pull the needle maximums from flash.
  $C 0 do I ud@ needle_max I + !   4 +loop
;

: NVRAM! ( -- )
\ *G Save the contents of the needle cal values.
 0 UDPAGE_ERASE
 needle_max
 $C 0 do dup I + @  I ud!  4 +loop
 drop
;

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

idata \ Has to match an odn.
create NEEDLE_MAX #850 , #850 , #850 ,
cdata

((
: interp-next drop 1 ;
: interp-reset drop ." Reset" ;

))

: RANGECHECK ( max n -- n or zero ) 2dup <= if 2drop 0 else swap drop then ;

: INTER-BUMP (  max old interp -- new )
\ *G Get the next value from the interpolator, and
\ ** reset the interpolator if it wraps around to zero.
  >R R@ interp-next  \ Get the max
  + rangecheck
  dup 0= if R> interp-reset else R> drop then
  ;

: NFETCH ( odn off -- max old )
\ *G Combine the current value with the maximum.
  >R R@ \ stash the offset.
  +  @ \ Calculate the offset address, get the current val.
  needle_max R> + @
  swap
;

: ++NEEDLE_S \ Called every time.
    odn_hms 0 odn.s nfetch ( max old )
	interp_hms interp.a inter-bump ( new )
	odn_hms odn.s !
	;

: ++NEEDLE_M ( -- )
\ *G Every time we roll the seconds, bump the minutes and the hour
	odn_hms 0 odn.m nfetch ( max old )
	interp_hms interp.b inter-bump
	odn_hms odn.m !

	odn_hms 0 odn.h nfetch ( max old )
	interp_hms interp.c inter-bump
	odn_hms odn.h !
	;

: ++NEEDLE_DS ; \ Called every time.
: ++NEEDLE_DM ; \ Every time we roll the seconds.

: _USE ( odn-addr -- )
  dup odn.s w@ pwm0!
  dup odn.m w@ pwm1!
      odn.h w@ pwm2!
  ;

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

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

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

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

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

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

_timer1 $24 + equ QUAD-IN

\ The Quadrature encoder produces two per detent.
: QUAD@ ( -- n ) \ Fetch and zero
  quad-in @off
  [asm sxth tos, tos asm]
  [asm asr .s tos, tos, # 1 asm] \ Divide by two,
  ;

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

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

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

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

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

  drop

;

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

\ : foo 0 do hms advancetime loop ;

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

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

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

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

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

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

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

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

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

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

\ -----------------------------------------------
\ State numbers.  These are defined x4 so that
\ we can just use the state number as an index
\ into a table of words.
\ -----------------------------------------------
0 4 * equ _s_init
1 4 * equ _s_b1
2 4 * equ _s_1sec

3 4 * equ _s_set_h
4 4 * equ _s_pendset_m
5 4 * equ _s_setmin

6 4 * equ _s_pendcal0
7 4 * equ _s_cal0
8 4 * equ _s_pendcalh
9 4 * equ _s_calh
10 4 * equ _s_pendcalm
11 4 * equ _s_calm
12 4 * equ _s_pendcals
13 4 * equ _s_cals

4 equ downcount_1s
16 equ downcount_3s

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

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

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

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

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

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

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

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

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

create StateHandlers
' shInit ,
' shB1 ,
' sh1sec ,

' shSetH ,
' shPendSetM ,  ' shSetMin ,

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

\ -------------------------------------------------
\ Setting the time.
\ -------------------------------------------------
variable adj_i \ THe working index into the points array.

udata
create adj_points #50 cells allot \ 100 16-bit words.
create interp_set  _interp_set allot
cdata

\ Generate a list of points.
: MAKE-SET-LIST ( max steps )
  2dup
  >R  (interp_init) swap interp_set swap R> call3--

  \ Since zero is first, do the w! first.
  swap drop   0 swap \ Keep a running counter.
  0 do
    dup I adj_points[]! \ Save the existing value
    interp_set interp-next +
  loop
  drop
  ;

: ADJ_POINTS[]! ( data index -- ) 2* adj_points + w! ;
: ADJ_POINTS[]@ ( index -- n )    2* adj_points + w@ ;


Code to set the time.

Code to set the time.

(( App Startup ))

0 value JT \ The Jumptable

\ -------------------------------------------
\ The word that sets everything up.
\ This runs before the intro banner, after
\ Init-multi.
\ -------------------------------------------
: StartApp
	hex
	init-dp @ dp ! \ Set the dictionary pointer so that we can function.
	\ I have no idea why I am doing this instead of the compilation system.

	1 getruntimelinks to jt
	." StartApp!"

	4 [ SCSSCR _SCS + ] literal  ! \ Set deepsleep

;

\ ------------------------------------------
\ Application code
\ ------------------------------------------
struct tod
 1 field h
 1 field m
 1 field s
end-struct

udata
create hms tod allot
create dhms tod allot
cdata

: +CAP ( n max -- n ) >R 1 + dup r> = if drop 0 then ;

: ADVANCE ( tod -- )
  dup s c@ #60 +cap  2dup swap s c! \ Advance the seconds.  base n --
  if drop exit then

  dup m c@ #60 +cap  2dup swap m c! \ advance minutes
  if drop exit then

  dup h c@ #24 +cap  2dup swap h c! \ advance minutes

  2drop
;

: DADVANCE ( tod -- )
  dup s c@ #100 +cap  2dup swap s c! \ Advance the seconds.  base n --
  if drop exit then

  dup m c@ #100 +cap  2dup swap m c! \ advance minutes
  if drop exit then

  dup h c@ #10 +cap  2dup swap h c! \ advance minutes

  2drop
;

\ ----------------------------------------------
\ Tools for writing to the LCD
\ ----------------------------------------------
: LCD#! ( n -- ) jt LCD_# @ swap call1-- ;
: LCD$! ( addr -- ) jt LCD_Wr @ swap call1-- ;

variable thecount

(( Sample code for demonstrating messages ))
: wakestart 1 $10 wakereq drop ; \ Request a wake
: wakestop  1   0 wakereq drop ; \ No more, please.

: COUNT-WORD
  wakestart
  begin
    pause
    thecount dup  @ 1+ dup lcd#! swap !
    stop
  again
;

: COUNT-WORDd
  begin
    pause self msg? if get-message drop \ We don't care who sent it.
     case
       0 of wakestop endof
       1 of wakestart endof
     endcase
     then

    thecount dup @ 1+ dup lcd#! swap !
    stop
  again
;

\ --------------------------------------------------------------------
\ Keeping time.
\ --------------------------------------------------------------------
task TOPTASK

: TOPLCDOUT hms dup h c@ #100 * swap m c@ +  lcd#! ;

: TOPWORD
  0 $10 wakereq drop \ The first Second.
  begin
   pause
   toplcdout
   hms advance
   2 $10 wakereq drop \ Relative step
  again
;

\ --------------------------------------------------------------------
\ Decimal Time
\ --------------------------------------------------------------------

task BOTTASK

: BOTWORD
  1 err interp-next wakereq drop
  begin
   pause
   dhms dadvance
   botlcd dms$ drop lcd$!
   3 err interp-next wakereq drop
  again
;

: BOTLCD dhms
  dup h c@  #10000 *
  over m c@   #100 * +
  swap s c@ + ;

\ Include the terminating null.
: dms$ base @ >R decimal s>d <# 0 hold # # $20 hold  # # $20 hold # #> R> base !  ;

: interp-next ( addr -- ) \ A fixed version.  Returns amount to step
  dup @ \ err
  #103 - dup 1 > if swap ! #13 exit then
  \ Otherwise, we need to adjust
  #125 + swap ! #14
;

: CLOCKSTART
  ['] topword toptask initiate
  ['] botword bottask initiate
;

variable err

: COUNT-DT
  0 err interp-next wakereq drop \ Don't keep the return code.
  begin
    pause
    thecount dup  @ 1 #9999 +cap dup lcd#! swap !
    2   err interp-next wakereq drop \ Don't keep the return code.
  again
;

\ ---------------------------------------------------------------
\ Setting the time.
\ ---------------------------------------------------------------

: *HMS->S  ( addr -- n ) dup h c@ #3600 * over m c@ #60 * + swap s c@ + ;
: *DHMS->S ( addr -- n ) dup h c@ #10000 * over m c@ #100 * + swap s c@ + ;

\ Stash things in the struct.
: ->*HMS ( h m s addr -- )  dup >R s c! R@ m c! R> h c! ;

: S->DS ( seconds -- seconds )
  dup #108 / #125 * \ First pass
  swap #108 mod  #125 * #108 / +
;

: DS->DHMS ( n -- h m s )
  dup #10000 / swap #10000 mod
  dup   #100 / swap   #100 mod
 ;

: SETBOTH ( h m s -- )
  hms ->*hms
  hms *hms->s
  s->ds ds->dhms
  dhms ->*hms
;

((
task foo
' count-word foo initiate

))

(( App Startup ))

0 value JT \ The Jumptable

\ -------------------------------------------
\ The word that sets everything up.
\ This runs before the intro banner, after
\ Init-multi.
\ -------------------------------------------
: StartApp
	hex
	init-dp @ dp ! \ Set the dictionary pointer so that we can function.
	\ I have no idea why I am doing this instead of the compilation system.

	1 getruntimelinks to jt
	." StartApp!"

	4 [ SCSSCR _SCS + ] literal  ! \ Set deepsleep

;

\ ------------------------------------------
\ Application code
\ ------------------------------------------
struct tod
 1 field h
 1 field m
 1 field s
end-struct

udata
create hms tod allot
create dhms tod allot
cdata

: +CAP ( n max -- n ) >R 1 + dup r> = if drop 0 then ;

: ADVANCE ( tod -- )
  dup s c@ #60 +cap  2dup swap s c! \ Advance the seconds.  base n --
  if drop exit then

  dup m c@ #60 +cap  2dup swap m c! \ advance minutes
  if drop exit then

  dup h c@ #24 +cap  2dup swap h c! \ advance minutes

  2drop
;

: DADVANCE ( tod -- )
  dup s c@ #100 +cap  2dup swap s c! \ Advance the seconds.  base n --
  if drop exit then

  dup m c@ #100 +cap  2dup swap m c! \ advance minutes
  if drop exit then

  dup h c@ #10 +cap  2dup swap h c! \ advance minutes

  2drop
;

\ ----------------------------------------------
\ Tools for writing to the LCD
\ ----------------------------------------------
: LCD#! ( n -- ) jt LCD_# @ swap call1-- ;
: LCD$! ( addr -- ) jt LCD_Wr @ swap call1-- ;

variable thecount

(( Sample code for demonstrating messages ))
: wakestart 1 $10 wakereq drop ; \ Request a wake
: wakestop  1   0 wakereq drop ; \ No more, please.

: COUNT-WORD
  wakestart
  begin
    pause
    thecount dup  @ 1+ dup lcd#! swap !
    stop
  again
;

: COUNT-WORDd
  begin
    pause self msg? if get-message drop \ We don't care who sent it.
     case
       0 of wakestop endof
       1 of wakestart endof
     endcase
     then

    thecount dup @ 1+ dup lcd#! swap !
    stop
  again
;

\ --------------------------------------------------------------------
\ Keeping time.
\ --------------------------------------------------------------------
task TOPTASK

: TOPLCDOUT hms dup h c@ #100 * swap m c@ +  lcd#! ;

: TOPWORD
  0 $10 wakereq drop \ The first Second.
  begin
   pause
   toplcdout
   hms advance
   2 $10 wakereq drop \ Relative step
  again
;

\ --------------------------------------------------------------------
\ Decimal Time
\ --------------------------------------------------------------------

task BOTTASK

: BOTWORD
  1 err interp-next wakereq drop
  begin
   pause
   dhms dadvance
   botlcd dms$ drop lcd$!
   3 err interp-next wakereq drop
  again
;

: BOTLCD dhms
  dup h c@  #10000 *
  over m c@   #100 * +
  swap s c@ + ;

\ Include the terminating null.
: dms$ base @ >R decimal s>d <# 0 hold # # $20 hold  # # $20 hold # #> R> base !  ;

: interp-next ( addr -- ) \ A fixed version.  Returns amount to step
  dup @ \ err
  #103 - dup 1 > if swap ! #13 exit then
  \ Otherwise, we need to adjust
  #125 + swap ! #14
;

: CLOCKSTART
  ['] topword toptask initiate
  ['] botword bottask initiate
;

variable err

: COUNT-DT
  0 err interp-next wakereq drop \ Don't keep the return code.
  begin
    pause
    thecount dup  @ 1 #9999 +cap dup lcd#! swap !
    2   err interp-next wakereq drop \ Don't keep the return code.
  again
;

((
task foo
' count-word foo initiate

))