D/MOD definition

Wolfgang Allinger

2005-10-30 06:57:00 UTC

On 30 Oct 05 at group /comp/lang/forth in article

Post by SBC Dayton
I'm just getting into Pygmy and trying to add a double length
extension set. Wondering if some kind soul would list a non-assembler
definition for D/MOD.
Are high level definitions, such as for double length numbers,
available on the internet?
Appreciate it. JohnB

Maybe this will help you. It's in text format, however if you wan't it
as *.scr, email me.

--------------------------8x------------------------
\ LMATH99.SCR LONG math MUL & DIV ... ALL 16:15 14JUL99
\ Last changed screen # 005 ALL 10:54 21JUL99
\ COPYRIGHT 1988,1989,1990 by
\ Tetsuya Nakata "NA" & Wolfgang Allinger "ALL"
\ NA c/o Allinger & Partner Software Engineering GmbH
\ ALL c/o Ingenieurbuero Wolfgang Allinger; Brander Weg 6
\ 42699 SOLINGEN; Tel/FAX 0212/66811

\ donated to PUBLIC DOMAIN, no waranty, we don't even guarantee
\ this program not to be hallucination! USE IT ON YOUR OWN RISK!
\ ASSUME IT IS UNTESTED AND TEST IT YOURSELF !!!!!!!!
\ WE DON'T BE LIABLE FOR ANY RESULTS BY USING THIS PROGRAM!!!!
\ suffix "l m h L M H" -> low medium high word of numbers
\ Q stands for Quotient or Quadruple = 64bit whow!!!
\ R for Remainder t or T stands for Triple = 48bit

\ HISTORY ALL 10:51 21JUL99

\ V1.6/ALL990721 U*/MOD added
\ V1.5/ALL9907 improved comments on LMI metacompilable...
\ V1.5/ALL0393 new Adress/Phone; EXISTS? ccALL ... added
\ V1.5/ALL1192 TRUE CONSTANT ccALL ; w/ testroutines
\ V1.4/ALL0290 some comments corrected
\ V1.4/ALL0190 D/MOD DD/ DMOD floored!!!???!!! added
\ V1.4/NA0190 UQ*' (tud/) added
\ V1.3/ALL1289 D* DD* added, UDD* ... revised, lots from BDAM31
\ V1.2/NA0989 UDD* UQ* added
\ V1.1/ALL0189 signed division added
\ V1.0/NA1288 original release

( notes ALL 17:42 12JAN90)
\ NOTAM: this is one of ALLs most expensive programs,
\ because he is a " mathematisches Rindviech"
\ just like Felix Wankel, the inventor of
\ the rotary piston Wankel-Motor !!!

\ * mathematisches Rindviech: means one which is as clever
\ in mathmatics as a cow !!!! whow !!! that's the reason,
\ WE DON'T BE LIABLE FOR ANY RESULTS BY USING THIS PROGRAM
\ w/ KNUTHs ART of PROGRAMMING & ZECHs FORTH 83 and the
\ help of my partner Tetsuta Nakata and the patience of my
\ wife, I survived the development of this program! ALL1289

\ WARNING: some signed/unsigned STACK comment may be WRONG!
\ might be unsigned/signed mixed up @ 48bit, who cares?
\ but even LP F83 and plagiarists are wrong w/ un~ <-> signed!
\ MASTER LOAD SCREEN ALL 11:57 31MAR93
DECIMAL \ DEFAULT BASE

\ TRUE CONSTANT ccALL \ TRUE : w/ testroutines ...
\ FALSE: w/o test..., GOOD FOR METACOMP...

EXISTS? ccALL NOT .IF

: LMATH ; : -LMATH FORGET LMATH ;

8 45 THRU

.THEN

\ summary and stack effects ALL 15:32 14JUL99
\ Forth-83 standard: x( are LMI metacompilable
\ * x( w w -- w )
\ UM* x( u u -- ud ) \ the primitives !!!
\ UM/MOD x( ud u -- urem uquot ) \ the primitives !!!
\ 2/ x( n -- n/2 )
\ / x( n n -- quot )
\ MOD x( n n -- rem )
\ /MOD x( n n -- rem quot )
\ */MOD x( n1 n2 n3 -- rem quot ) \ n1*n2/n3, 32bit intern
\ */ x( n1 n2 n3 -- quot ) \ n1*n2/n3, 32bit intern

\ non standard:
\ M* x( n n -- d )
\ MU/MOD ( ud u -- urem udquot )

\ summary and stack effects ALL 10:54 21JUL99
\ in here:
\ D* ( ud u -- ud ) \ bad name in PCF3.2, UDM* is better
\ DD* ( d1 d2 -- d ) \ 32bit*32bit= 32bit
\ UDD* ( ud1 ud2 -- ud ) \ 32bit*32bit= 32bit
\ UM/ ( ud u -- u )
\ UDM/ ( ud u -- ud )
\ UD2/ ( ud -- ud/2 )
\ U*/ ( u1 u2 u3 -- u ) \ u1*u2/u3, 32bit intern
\ U*/MOD ( u1 u2 u3 -- urem uquot )
\ UDM*/MOD ( ud1 u2 u3 -- urem udquot ) \ 32b*16b/16b= 32bit
\ UDM*/ ( ud1 u2 u3 -- udquot ) \ 32bit*16bit/16bit= 32bit

\ t* ( ud u -- ut ) \ 32bit*16bit= 48bit
\ t/ ( ut u -- udquot ) \ 48bit/16bit= 32bit

\ summary and stack effects ALL 16:17 14JUL99
\ x( are LMI metacompilable
\ UD/MOD ( ud1 ud2 -- udrem udquot ) \ NA/KNUTH
\ UD/ ( ud1 ud2 -- udquot ) \ "
\ UDMOD ( ud1 ud2 -- udrem ) \ "

\ M/MOD x( d n -- rem quot ) \ floored !!!!
\ D/MOD ( d1 d2 -- drem dquot ) \ FLOORED !!!!
\ DD/ ( d1 d2 -- dquot ) \ FLOORED !!!!
\ DMOD ( d1 d2 -- drem ) \ FLOORED !!!!

\ UDDM* ( ud1 ud2 -- uq ) \ 32bit*32bit= 64bit
\ UTM* ( ut u -- uq ) \ 48bit*16bit= 64bit
\ tud/ ( t ud -- ud ) \ 48bit/32bit= 32bit
\ udnd*/ ( ud1 u2 ud3 -- udquot ) \ 32b*16b/32b= 32bit

( summary and stack effects ALL 14:36 01JAN90)

\ D10* ( ud -- ud*10 )
\ D100* ( ud -- ud*100 )
\ 10* ( n -- n*10 )
\ 100* ( n -- n*100 )

\ D10/ ( ud -- ud/10 ) \ KNUTH art of programming V2,4.4.9
\ 10/ ( u -- u/10 )

( summary and stack effects ALL 18:22 12FEB90)

\ ?D<SWAP ( d1 d2 -- d2 d1 if d1<d2 | d1 d2 )
\ ?D>SWAP ( d1 d2 -- d2 d1 if d1>d2 | d1 d2 )

\ d*48b ( d1 d2 -- t ) \ d1*d2 MUST FIT IN 48 BIT !!!!!

\ d*/48b ( d dMUL dDIV -- d ) \ d*dMUL MUST FIT IN 48 BIT !!

\ DSIZE ( d -- n ) \ ERMITTELT DIE STELLEN ANZAHL

( .SH nice horizontal HEX stack dump ALL 20:27 10NOV92)
EXISTS? ccALL NOT .IF
: .sh ESC? DROP BASE @ >R HEX DEPTH ?DUP
IF ." { --" \ "(" didn't work w/ MC2.2
0
DO
DEPTH I - 1- PICK
0 <# # # # # BL HOLD #> TYPE
LOOP ." }"
ELSE ." <empty>"
THEN CR R> BASE ! ;

VARIABLE %SH : .SH %SH PERFORM ; \ rename .SH -> .sh before
: +SH ['] .sh %SH ! ; : -SH ['] NOOP %SH ! ; +SH
.ELSE : .sh .SH ; .THEN

( MU/MOD ALL 12:34 27DEC89)

EXISTS? MU/MOD NOT .IF

: MU/MOD ( ud u -- urem udquot )
UM/MOD ( -- L R{0.H/n} Q{0.H/n} )
R> SWAP >R ( -- L R0.H/n n )
UM/MOD ( -- urem quot )
R> ; ( -- urem quotl quoth ) .THEN

( d* ALL 16:01 28DEC89)

: D* ( ud u -- ud ) \ bad name in PCF3.2, UDM* is better

DUP ROT * ( -- L n H*n )
-ROT UM* ( -- H*n dL*n )
ROT + ; ( -- d )

( dd* udd* from ZECH Forth 83 ALL 15:25 28DEC89)

: DD* ( d1 d2 -- d3 ) \ ZECH named it D*

Post by SBC Dayton
R SWAP >R ( -- 1L 2L ; R-- 2H 1H )

2DUP UM* ( -- 1L 2L d3" )
ROT ( -- 1L d3" 2L )
R> * ( -- 1L d3" 2L*1H ; R-- 2H )
+ ( -- 1L d3' )
ROT R> ( -- d3' 1L 2H )
* + ; ( -- d3 )

: UDD* ( ud1 ud2 -- ud3 ) \ ZECH named it UD*

Post by SBC Dayton
R SWAP >R 2DUP UM* ROT R> \ see DD*

UM* DROP + \ unsigned 2L*1H
ROT R> UM* DROP + ; \ unsigned 1L*2H ( -- ud3 )

\ um/ udm/ ud2/ u*/ Unsigned /16 BIT Division ALL 10:48 21JUL99

: UM/ ( ud u -- u ) UM/MOD NIP ;

: UDM/ ( ud u -- udquot ) MU/MOD ( -- urem udq ) ROT DROP ;

EXISTS? UD2/ NOT .IF \ make PCF compatible to F31kernel...

: UD2/ ( ud -- ud/2 ) 2 UDM/ ; .THEN

: U*/MOD ( u1 u2 u3 -- urem u1*u2/u3 ) -ROT UM* ROT UM/MOD ;
: U*/ ( u1 u2 u3 -- u1*u2/u3 ) U*/MOD NIP ;

( udm*/mod udm*/ 32 BIT SCALING ALL 19:41 30DEC89)

\ UDM*/MOD from ZECH Forth 83
: UDM*/MOD ( ud1 u2 u3 -- urem udquot ) \ 32b*16b/16b= 32bit

Post by SBC Dayton
R DUP >R ( -- ud1 u2 ; R-- u3 u2 )

SWAP >R ( -- u1L u2 ; R-- u3 u2 u1H )
UM* 0 R> R> ( -- ud 0 u1H u2 ; R-- u3 )
UM* D+ ( -- uL uM uH )
R@ ( -- uL uM uH u3 )
UM/MOD ( -- uL R MH/u3=QH )
R> SWAP >R ( -- uL R u3 ; R-- QH )
UM/MOD R> ; ( -- R QL QH )

: UDM*/ ( ud1 u2 u3 -- udquot ) \ 32bit*16bit/16bit= 32bit
UDM*/MOD ROT DROP ;

\ testing UDM*/MOD ALL 11:49 31MAR93
HEX
EXISTS? ccALL .IF
ccALL .IF

: z. .sh 3DROP 4 SPACES ;

: T0 BASE @ HEX >R ." TEST UDM*/MOD" CR
FFFF.FFFF 8000 8000 UDM*/MOD z. ." =0000 FFFF FFFF" CR
FFFF.FFFF 1234 5678 UDM*/MOD z. ." =2294 6DE9 35E4" CR
0000.FFFF 4321 0001 UDM*/MOD z. ." =0000 BCDF 4320" CR
0000.FFFB 4321 8765 UDM*/MOD z. ." =3809 7EEA 0000" CR
8765.FFFE 8765 FFFF UDM*/MOD z. ." =6E0F 7CD9 479C" CR
R> BASE !
.SH ; .THEN .THEN DECIMAL

( t* Unsigned Long Multiplication ALL 12:18 15JAN89)

: t* ( ud u -- ut ) \ 32 bit*16 bit = 48 bit
DUP ROT ( udL udH u -- udL u u udH )
UM* ( -- udL u udH*uL udH*uH )

Post by SBC Dayton
R >R ( -- udL u ; R-- udH*uL udH*uH )

UM* ( -- udL*uL udL*uH )
0 R> R> ( -- udL*uL udL*uH 0 udH*uL udH*uH )
D+ ( -- utL utM utH )
;

( t/ Unsigned Long Division ALL 14:27 03JAN90)

: t/ ( ut u -- udquot ) \ 48 bit/16 bit = 32 bit
DUP >R ( -- L M H u ; R-- u )
UM/MOD ( -- L R MH/u=QH )
-ROT R> ( -- QH L R u )
UM/MOD ( -- QH R QL )
NIP SWAP ; ( -- QL QH )

\ FFFF FFFF 8000 8000 t/ -> overflow !!!! korrekt !!!!!!!!!
\ -- FFFF 0001 0001 -> > 32 bit!!!!!

( 32bit/16bit Unsigned Narrow Division ALL 14:32 03JAN90)

: (udm/mod) ( ud1 u2 -- udrem udquot ) \ REM =< 16bit !!!
MU/MOD ( -- uREM udQUOT )
ROT 0 2SWAP ; ( -- udREM udQUOT ) \ rem fits in 16 bit

( 32bit/32bit Unsigned Wide Division ALL 19:42 28DEC89)
\ based on the concept of D.Knuth/N.Grossman by NA1288

: (ud/mod) ( ud1 ud2 -- udrem udquot ) \ QUOT =< 16bit !!!
2DUP >R >R ( ud1 ud2 -- ud1 ud2 ; R-- ud2 )
2OVER >R >R ( -- ud1 ud2 ; R-- ud2 ud1 )
DUP 1+ ( -- ud1 ud2 u2H+1 )
0 1 ROT ( -- ud1 ud2 1.0000h u2H+1 )
UM/MOD NIP ( -- ud1 ud2 uk=10000h/{u2H+1} )
DUP >R ( -- ud1 ud2 uk ; R-- ud2 ud1 uk )
D* ( -- ud1 uwL uwH )

Post by SBC Dayton
R >R ( -- ud1 ; R-- ud2 ud1 uk uwH uwL )

DUP 0 R> R@ ( -- ud1 u1H 0 uwL uwH ; R-- ud2 ud1 uk uwH )
UDM*/ ( -- ud1 u1H*uwL/uwH )
D- ( -- ud1-u1H*uwL/uwH )

( Unsigned Wide Division ALL 14:31 03JAN90)

( -- ud1-u1h*uwL/uwh ; R-- ud2 ud1 uk uwh )
R> R> SWAP ( -- ud1-u1h*uwL/uwh uk uwh )
UDM*/ ( -- udQ )
NIP ( -- uQL ) \ uQ:xx -> uQ
DUP ( -- uQL uQL )
R> R> ( -- uQL uQL ud1 ; R-- ud2 )
ROT ( -- uQL ud1 uQL )
R> R> ( -- uQL ud1 uQL ud2 )
ROT ( -- uQL ud1 ud2 uQL )
D* ( -- uQL ud1 ud2*uQL )
D- ( -- uQL uRL uRh )
ROT 0 ; ( -- udrem udquot ) \ quot fits in 16 bit

( 32bit/32bit Unsigned Wide Division ALL 19:41 28DEC89)
\ based on the concept of D.Knuth/N.Grossman by NA1288

: (ud/) ( ud1 ud2 -- udquot ) \ QUOT =< 16bit !!!
DUP 1+ ( -- ud1 ud2 u2H+1 )
0 1 ROT ( -- ud1 ud2 1.0000h u2H+1 )
UM/MOD NIP ( -- ud1 ud2 uk=10000h/{u2H+1} )
DUP >R ( -- ud1 ud2 uk ; R-- uk )
D* ( -- ud1 uwL uwH )

Post by SBC Dayton
R >R ( -- ud1 ; R-- uk uwH uwL )

DUP 0 R> R@ ( -- ud1 u1H 0 uwL uwH ; R-- uk uwH )
UDM*/ ( -- ud1 u1H*uwL/uwH )
D- ( -- ud1-u1h*uwL/uwh ; R-- uk uwh )
R> R> SWAP ( -- ud1-u1h*uwL/uwh uk uwh )
UDM*/ NIP 0 ; ( -- udQ ) \ uQ:xx -> 00:uQ = udQ

( ud/mod ud/ udmod Unsigned ALL 14:35 03JAN90)

\ based on the concept of D.Knuth/N.Grossman, by NA1289

: UD/MOD ( ud1 ud2 -- udrem udquot )
?DUP IF (ud/mod) ELSE (udm/mod) THEN ;

\ : (udm/mod) MU/MOD ROT 0 2SWAP ;

: UD/ ( ud1 ud2 -- udquot )
?DUP IF (ud/) ELSE MU/MOD ROT DROP THEN ;

: UDMOD ( ud1 ud2 -- udrem ) UD/MOD 2DROP ;

\ testing UD/MOD ALL 11:50 31MAR93
EXISTS? ccALL .IF ccALL .IF HEX
: x. .sh 4DROP 4 SPACES ;

: T1 BASE @ HEX >R ." TEST UD/MOD " CR
FFFF.FFFF 8001.8000 UD/MOD x. ." =7FFF 7FFE 0001 0000" CR \
7FFF.7FFF 7654.5678 UD/MOD x. ." =2987 09AB 0001 0000" CR \
0000.FFFF 4321.0001 UD/MOD x. ." =FFFF 0000 0000 0000" CR \
FFFF.8FFB 0000.8765 UD/MOD x. ." =60D3 0000 E408 0001" CR \
7FFF.FFFE 0001.8000 UD/MOD x. ." =7FFE 0000 5555 0000" CR \
7FFF.FFFE 0000.0011 UD/MOD x. ." =0007 0000 8787 0787" CR \
8000.FFFF 0001.8000 UD/MOD x. ." =7FFF 0001 5555 0000" CR \
8000.FFFF 0000.8000 UD/MOD x. ." =7FFF 0000 0001 0001" CR \
R> BASE ! .SH ;
DECIMAL .THEN .THEN

\ testing UD/ ALL 11:50 31MAR93
EXISTS? ccALL .IF ccALL .IF HEX
: y. .sh 2DROP 4 SPACES ;

: T2 BASE @ HEX >R ." TEST UD/ " CR
FFFF.FFFF 8001.8000 UD/ y. ." =0001 0000" CR \
7FFF.7FFF 7654.5678 UD/ y. ." =0001 0000" CR \
0000.FFFF 4321.0001 UD/ y. ." =0000 0000" CR \
FFFF.8FFB 0000.8765 UD/ y. ." =E408 0001" CR \
7FFF.FFFE 0001.8000 UD/ y. ." =5555 0000" CR \
7FFF.FFFE 0000.0011 UD/ y. ." =8787 0787" CR \
8000.FFFF 0001.8000 UD/ y. ." =5555 0000" CR \
8000.FFFF 0000.8000 UD/ y. ." =0001 0001" CR \
R> BASE ! .SH ;
DECIMAL .THEN .THEN

( m/mod signed Division from Laxen/Perry ALL 15:15 12JAN90)
\ floored = rounded to smallest #, Srem = Sn !!!
EXISTS? M/MOD NOT .IF
: M/MOD ( d n --- rem quot ) \ comments by ALL1289
?DUP IF
DUP >R 2DUP XOR >R >R ( -- L H ; R-- n Sdxn n )
DABS R@ ABS UM/MOD ( -- uR uQ )
R> 0< IF SWAP NEGATE SWAP THEN ( -- nR uQ ; R-- n Sdxn )
R> 0< IF ( -- nR uQ ; R-- n )
NEGATE OVER ( -- nR -Q nR ; R-- n )
IF 1- R@ ROT \ nR<>0 ! ( -- -Q-1 n nR ; R-- n )
- SWAP THEN ( -- n-nR nQ ; R-- n )
THEN ( R-- n )
R> DROP ( -- nR nQ )
THEN ; .THEN

\ testing M/MOD ALL 11:51 31MAR93
EXISTS? ccALL .IF ccALL .IF
: T. 6 .R SPACE 6 .R SPACE ;

: T6 BASE @ DECIMAL >R ." TEST M/MOD " CR
1. 1 M/MOD T. ." = 1 0" CR \
-1. -1 M/MOD T. ." = 1 0" CR \
3. -2 M/MOD T. ." = -2 -1" CR \
-4. 3 M/MOD T. ." = -2 2" CR \
9. -4 M/MOD T. ." = -3 -3" CR \
10. 4 M/MOD T. ." = 2 2" CR \
10. -4 M/MOD T. ." = -3 -2" CR \
-10. 4 M/MOD T. ." = -3 2" CR \
-10. -4 M/MOD T. ." = 2 -2" CR \
R> BASE ! .SH ; .THEN .THEN

( d/mod signed Double Division by ALL ALL 17:18 12JAN90)
\ floored = quot rounded to smallest #, Srem = Sd2 !!!
: D/MOD ( d1 d2 -- drem dquot )
2DUP >R >R ( R-- d2H d2L )
DUP >R DABS 2SWAP DUP >R ( R-- d2H d2L sign2 sign1 )
DABS 2SWAP
UD/MOD ( ud1 ud2 -- udrem udquot )
2OVER D0<> IF \ remainder <>0 !!!
R> R@ XOR ( -- udrem udquot Squot ; R-- d2 sign2 )
0< IF NOT SWAP NOT SWAP THEN ( -- udrem dQfloored )
2SWAP R> 0< IF DNEGATE ( -drem ) THEN ( -- dQ drem )
R> R> ( -- dQ dR d2 ) 2SWAP D- 2SWAP ( -- d2--dR dQ )
ELSE \ remainder =0 !!!
R> R> XOR R> R> 2DROP 0< IF DNEGATE THEN ( -- 0 0 dQ )
THEN ;

( dd/ dmod signed Double Division by ALL ALL 17:22 12JAN90)

: DD/ ( d1 d2 -- dquot ) D/MOD 2SWAP 2DROP ;

: DMOD ( d1 d2 -- drem ) D/MOD 2DROP ;

\ testing D/MOD ALL 11:51 31MAR93
EXISTS? ccALL .IF ccALL .IF
: t. 10 D.R SPACE 10 D.R SPACE ;

: T5 BASE @ DECIMAL >R ." TEST D/MOD " CR
1. 1. D/MOD t. ." = 1 0" CR \
-1. -1. D/MOD t. ." = 1 0" CR \
3. -2. D/MOD t. ." = -2 -1" CR \
-4. 3. D/MOD t. ." = -2 2" CR \
9. -4. D/MOD t. ." = -3 -3" CR \
10. 4. D/MOD t. ." = 2 2" CR \
10. -4. D/MOD t. ." = -3 -2" CR \
-10. 4. D/MOD t. ." = -3 2" CR \
-10. -4. D/MOD t. ." = 2 -2" CR \
R> BASE ! .SH ; .THEN .THEN

( UDDM* unsigned 32*32bit=64bit ALL 15:01 03JAN90)

: UDDM* ( ud1 ud2 -- uq )
2OVER >R >R >R ( -- ud1 ud2L ; R-- ud1 ud2h )
t* ( -- {d1*d2L}L {d1*d2L}M {d1*d2L}M )
( -- Q1 Q2 Q3 )
R> R> R> ( -- Q1 Q2 Q3 ud2h ud1 )
ROT ( -- Q1 Q2 Q3 ud1 ud2h )
t* ( -- Q1 Q2 Q3 Q2' Q3' Q4 )

Post by SBC Dayton
R >R ( -- Q1 Q2 Q3 Q2' ; R-- Q4 Q3' )

0 D+ ( -- Q1 Q2 Q3 )
0 R> R> ( -- Q1 Q2 Q3 0 Q3' Q4 )
D+ ( -- Q1 Q2 Q3 Q4 ) \ 64bit TOS=MSB
;

( UTM* Unsigned VERY Long Multiplication ALL 17:17 11JAN90)

: UTM* ( ut u -- uq ) ( 48 bit*16 bit = 64 bit )

\ ut=ABC ( -- C B A u )

SWAP >R DUP >R ( -- C B u ; R-- A u )
t* 0 ( -- uq0 uq1 uq2' 0 )
R> R> ( -- uq0 uq1 uq2' 0 u A )
UM* ( -- uq0 uq1 uq2' 0 ud )
D+ ( -- uq0 uq1 uq2 uq3 )
;

( tud/ Unsigned Wide Division ALL 16:44 03JAN90)

: (tud/) ( ut ud -- udquot ) \ NA0190 super 48/32bit routine

DUP 1+ 0 1 ROT UM/MOD NIP ( -- ut ud uk=10000h/{udH+1} )
DUP >R ( -- ut ud uk ; R-- uk )
D* >R >R ( -- ut ; R-- uk uwH uwL )
2DUP DUP 0 ( -- ut utM utH utH 0 )
R> R> 2DUP >R >R ( -- ut utM utH utH 0 uwL uwH )
UDM*/ ( -- ut utM utH utH*uwL/uwH)
D- ( -- ut udx=utH*10000H+utM-utH*uwL/uwH )
R> R@ ( -- ut udx uwL uwH ; R-- uk uwH )
UDM*/ ( -- ut udx*uwL/uwH )

( --> Unsigned Wide Division ALL 16:47 03JAN90)

( -- ut udx*uwL/uwH ; R-- uk uwH ) \ now comes t d - !!!

ROT >R 2OVER 2OVER DU< IF D- R> 1- \ borrow from MSB
ELSE D- R> THEN \ no borrow

( -- ut-udx*uwL/uwH ; R-- uk uwH )

R> R> SWAP >R ( -- ut-udx*uwL/uwH uk ; R-- uwH )
UTM* ( -- {ut-udx*uwL/uwH}*uk ; R-- uwH )
( -- qINTERMEDIATE=64bit !!!! )
R> t/ ( uQUOTL t uwH -- uQUOTL ud )
ROT DROP ( -- udquot )
;

\ tud/ unsigned 48b/32b=32bit ALL 11:52 31MAR93
EXISTS? ccALL .IF ccALL .IF HEX

: tw 03F4.1200 000A 0008.5A48 ;
: TW tw (tud/) D. ." RESULT w/ HP16C: 0001.32F6 " CR ;

: tx FFFE.DCC0 919F 1234.5678 ;
: TX tx (tud/) D. ." RESULT w/ HP16C: 0007.FFDA " CR ;

: ty FFFF.FFFF 1234 1234.5678 ;
: TY ty (tud/) D. ." RESULT w/ HP16C: 0001.0009 " CR ;

: tz FFFF.EDCC 0919 1234.5678 ;
: TZ tz (tud/) D. ." RESULT w/ HP16C: 0000.7FFD " CR ;
DECIMAL .THEN .THEN

( tud/ unsigned 48b/32b=32bit ALL 14:28 31DEC89)

: tud/ ( C B A E D -- udquot ) \ tABC udDE
\ ." tud/" CR
?DUP IF \ D>0
2 PICK 4 PICK OR 5 PICK OR ( -- C B A D E ?A|B|C )
0= IF 3DROP EXIT THEN \ tABC=0, ( -- 0 0 )
ROT ?DUP IF -ROT (tud/) ( C B A E D -- udquot )
ELSE ( ." ud/" CR) UD/ \ A=0 ( C B E D -- udquot )
THEN
ELSE \ D=0
?DUP IF ( ." t/" CR) t/ \ E>0 ( C B A E -- udquot )
ELSE 3DROP -1 -1 \ DE=0
THEN
THEN ;

\ testing tud/ ALL 11:52 31MAR93
EXISTS? ccALL .IF ccALL .IF HEX
: w. .sh 2DROP 4 SPACES ;
: T3 BASE @ HEX >R ." TEST tud/ " CR
FFFF.FFFF 8000 8000.0000 tud/ w. ." =0001 0001" CR \ ok
FFFF.FFFF 1234 1234.5678 tud/ w. ." =0009 0001" CR \ ~
7FFF.FFFF 1234 1234.5678 tud/ w. ." =0002 0001" CR \ ~
8765.4321 0009 0000.0010 tud/ w. ." =5432 9876" CR \ ok
0000.FFFB 0000 0000.0123 tud/ w. ." =00E1 0000" CR \ ok
8765.FFFE 8765 0000.FFFF tud/ w. ." =0ECC 8766" CR \ ok
0000.0000 0000 0000.0000 tud/ w. ." =FFFF FFFF" CR \ ok
0000.0000 0000 1234.5678 tud/ w. ." =0000 0000" CR \ ok
FFFF.EDCC 0919 1234.5678 tud/ w. ." =7FFD 0000" CR \ ~
FFFE.DCC0 919F 1234.5678 tud/ w. ." =FFDA 0007" CR \ ~
R> BASE ! .SH ; DECIMAL .THEN .THEN

( udnd*/ 32b*16b/32b, 48b intermediate ALL 19:27 30DEC89)

: udnd*/ ( ud1 u2 ud3 -- udquot ) \ 32b*16b/32b= 32bit

Post by SBC Dayton
R >R t* ( ud1 ud2 -- t ; R-- ud3 )

R> R> tud/ ; ( t ud3 -- ud1*u2/ud3 )

\ testing udnd*/ ALL 11:52 31MAR93
EXISTS? ccALL .IF ccALL .IF HEX
: v. .sh 2DROP 4 SPACES ;

: T4 BASE @ HEX >R ." TEST udnd*/ " CR
FFFF.FFFF 8000 8000.0000 udnd*/ v. ." =FFFF 0000" CR \ ok
FFFF.FFFF 1234 1234.5678 udnd*/ v. ." =FFFB 0000" CR \ ~
7FFF.FFFF 1234 1234.5678 udnd*/ v. ." =7FFD 0000" CR \ ~
0000.FFFF 4321 0000.0001 udnd*/ v. ." =BCDF 4320" CR \ ok
0000.FFFB 4321 0123.8765 udnd*/ v. ." =003A 0000" CR \ ok
8765.FFFE 8765 0000.FFFF udnd*/ v. ." =7CD9 479C" CR \ ok
R> BASE !
.SH ; DECIMAL .THEN .THEN

( d10* d100* ALL 15:09 01JAN90)

: D10* ( ud -- ud*10 ) 2DUP D2* D2* D+ D2* ;
: 10* ( n -- n*10 ) DUP 2* 2* + 2* ;

( d10/ 10/ ALL 17:28 11JAN90)

: UD8/ ( ud -- ud/8 ) UD2/ D2/ D2/ ; \ SRL 3

: UD16/ ( ud -- ud/16 ) UD2/ UD8/ ; \ SRL 4

: UD256/ ( ud -- ud/256 ) \ SRL 8
SPLIT -ROT >< SWAP >< 255 AND OR SWAP ;

: U2/ ( u -- u2/ ) -1 SHIFT ; \ SRL 1

( d10/ 10/ ALL 17:29 11JAN90)

\ KNUTH art of programming V2,4.4.9,
\ slow in HLL, but very fast in ASM !!!!

\ algorithm: n=n/2, n=n+n/2, n=n+n/16, n=n+n/256
\ n=n+n/65536 \ only w/ 32bit, not needed w/ 16bit
\ n=n/8 \ XYZZY

: D10/ ( ud -- ud/10 ) UD2/ 2DUP UD2/ D+ 2DUP UD16/ D+
2DUP UD256/ D+ DUP 0 D+ UD8/ ;

: 10/ ( u -- u/10 ) U2/ DUP U2/ + DUP -4 SHIFT +
DUP >< 255 AND + -3 SHIFT ;

( ?d<swap ?d>swap ALL 19:40 13FEB89)

: ?D<SWAP ( d1 d2 -- d2 d1 if d1<d2 | d1 d2 )
2OVER 2OVER D< IF 2SWAP THEN ;

: ?D>SWAP ( d1 d2 -- d2 d1 if d1>d2 | d1 d2 )
2OVER 2OVER D> IF 2SWAP THEN ;

( d*48b d*/48b w/ 48bit intermediate ALL 17:33 11JAN90)

\ d1 , d2 MAY BE >16bit, BUT d1 * d1 MUST FIT IN 48BIT!!!!!!

: d*48b ( d1 d2 -- t )
UDDM* ( ud1 ud2 -- uq ) \ 32bit*32bit= 64bit
DROP ; ( -- t ) \ 64 bit -> 48 bit

\ d * dMUL MUST FIT IN 48 BIT !!!

: d*/48b ( d dMUL dDIV -- d )

Post by SBC Dayton
R >R d*48b ( -- t )

R> R> ( -- t dDIV )
tud/ ;

( dsize ALL 20:06 14JUN89)

: DSIZE ( d -- n ) \ ERMITTELT DIE STELLEN ANZAHL

DABS
1 -ROT ( -- 1 d )
BEGIN 10 UDM/ 2DUP D0> WHILE
ROT 1+ -ROT
REPEAT 2DROP ;

-------------------------------------x8--------------------------

Sorry, the last screen contains DSIZE, it's comment in english
should read \ returns the number of decimal places

Bye from Germany

Wolfgang

--
FORTHing @ work | *Cheap* ...pick any
Dipl.-Ing. Wolfgang Allinger | *Fast* *Good* ... *two* of them
Germany ------------------------------------
## KreuzPunkt XP2 R ## | reply address set