For greater precision when the integer portion of the parameter for DSQRT is no bigger than an unsigned single (0-65535), the following word can be used to take an integer with a fraction and convert it to a 64 bit fixed point number, consisting of two Forth double numbers, where the integer portion is only 16 bits.
Code:
: FIXED ( U NUM DEN -- UT U )
DUP>R 0 -ROT UM/MOD SWAP
0 SWAP R@ UM/MOD SWAP
0 SWAP R> UM/MOD NIP
SWAP 2SWAP SWAP ;
In the stack comments, UT means unsigned triple.
Here is a word to 'clean up' sloppy fractions.
Code:
: MFIX ( U U2 U3 -- U4 U5 U3 )
>R 0 R@ UM/MOD UNDER+ R> ;
And an appropriate version of .RESULT
Code:
: .RESULT ( UD -- )
256. UMD* 1 D.R ." ."
3 0
DO
1000. UMD* <# # # # #> TYPE
LOOP
2DROP ;
UMD* multiplies two double numbers and produces a quadruple number.
.RESULT first multiplies the double number result by the double number 256. to produce a quadruple number result. The top double number is the integer portion of the result.
As with the other version of .RESULT , the DO LOOP extracts and displays the fractional portion three decimal places at a time.
Here is the source for UMD* used in this version of .RESULT
Code:
: UMD* ( UD1 UD2 -- UQ )
// UD1 - B A UD2 - D C
ROT 2DUP UM* // B D C A AC
>R >R 2OVER // B D C A B D
ROT UM* >R >R // B D C B
UM* >R >R UM* // BD
0 R> R> R> // BDL BDH. L H L
SWAP >R 0 TUCK // BDL BDH. L. L.
D+ D+ 0 // BDL BDH+ CY.
R> R> 0 TUCK // BDL BDH+ CY. H. H.
D+ D+ // BDL BDH+ CY+ CY2
R> R> D+ ;
Here is the source for DSQRT . It does not round.
Code:
CODE DSQRT ( UQ -- UD )
TYA $FF ,X STA 8 # LDY
BEGIN
N 1- ,Y STA DEY
0< UNTIL
$20 # LDY
BEGIN
1 ,X LDA
0= WHILE
0 ,X LDA 1 ,X STA
3 ,X LDA 0 ,X STA
2 ,X LDA 3 ,X STA
5 ,X LDA 2 ,X STA
4 ,X LDA 5 ,X STA
7 ,X LDA 4 ,X STA
6 ,X LDA 7 ,X STA
DEY DEY DEY DEY
0= UNTIL
POPTWO JMP
THEN
BEGIN
6 ,X ASL 7 ,X ROL
4 ,X ROL 5 ,X ROL
2 ,X ROL 3 ,X ROL
0 ,X ROL 1 ,X ROL
N ROL N 1+ ROL
N 2+ ROL N 3 + ROL
$FF ,X ROL
6 ,X ASL 7 ,X ROL
4 ,X ROL 5 ,X ROL
2 ,X ROL 3 ,X ROL
0 ,X ROL 1 ,X ROL
N ROL N 1+ ROL
N 2+ ROL N 3 + ROL
$FF ,X ROL
N 4 + ASL N 5 + ROL
N 6 + ROL N 7 + ROL
N 1- ROL SEC
N 4 + ROL N 5 + ROL
N 6 + ROL N 7 + ROL
N 1- ROL SEC
N LDA N 4 + SBC
N 1+ LDA N 5 + SBC
N 2+ LDA N 6 + SBC
N 3 + LDA N 7 + SBC
$FF ,X LDA N 1- SBC
CS IF
N LDA N 4 + SBC N STA
N 1+ LDA N 5 + SBC N 1+ STA
N 2+ LDA N 6 + SBC N 2+ STA
N 3 + LDA N 7 + SBC N 3 + STA
$FF ,X LDA N 1- SBC $FF ,X STA
N 4 + LDA 2 # ORA N 4 + STA
THEN
N 1- LSR
N 7 + ROR N 6 + ROR
N 5 + ROR N 4 + ROR DEY
0= NOT WHILE // TOO FAR TO
REPEAT // BRANCH BACK
N 4 + LDA 6 ,X STA
N 5 + LDA 7 ,X STA
N 6 + LDA 4 ,X STA
N 7 + LDA 5 ,X STA
POPTWO JMP
END-CODE