Groups > comp.lang.forth > #37758 > unrolled thread

How I learned my computer arithmetic

Started by	lehs <skydda.barnen@gmail.com>
First post	2015-03-30 08:18 -0700
Last post	2015-05-05 16:41 -0700
Articles	20 on this page of 22 — 3 participants

Back to article view | Back to comp.lang.forth

  How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-03-30 08:18 -0700
    Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-03-30 08:42 -0700
      Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-02 13:31 -0700
        Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-03 08:20 -0700
          Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-04 11:55 -0700
    Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-03-30 08:48 -0700
    Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-05 11:57 -0700
    Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-09 14:05 -0700
      Re: How I learned my computer arithmetic "Alex McDonald" <blog@rivadpm.com> - 2015-04-09 15:06 -0700
        Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-10 00:25 -0700
    Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-10 04:21 -0700
    Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-10 12:47 -0700
      Re: How I learned my computer arithmetic Paul Rubin <no.email@nospam.invalid> - 2015-04-10 12:58 -0700
        Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-10 13:03 -0700
          Re: How I learned my computer arithmetic Paul Rubin <no.email@nospam.invalid> - 2015-04-10 13:18 -0700
            Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-10 13:24 -0700
    Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-11 01:30 -0700
      Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-11 01:32 -0700
      Re: How I learned my computer arithmetic Paul Rubin <no.email@nospam.invalid> - 2015-04-11 09:41 -0700
    Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-11 01:34 -0700
    Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-04-11 02:55 -0700
    Re: How I learned my computer arithmetic lehs <skydda.barnen@gmail.com> - 2015-05-05 16:41 -0700

Page 1 of 2 [1] 2 Next page →

#37758 — How I learned my computer arithmetic

From	lehs <skydda.barnen@gmail.com>
Date	2015-03-30 08:18 -0700
Subject	How I learned my computer arithmetic
Message-ID	<0fb1b397-e6c4-4ced-b83d-77f85526d5bd@googlegroups.com>

Some month ago I wrote about big integers in Forth. I had made words for big integer arithmetic on a big integer stack, but I realized it was too slow.

I have reorganized the extension and now plus and minus are about 10 times faster, division 15 times faster and multiplication about 30 times faster.

From the beginning my ambition was to learn Forth arithmetic on number strings ("0"=ASC 48 etc) but thought it was slow. Then I made a minor change while using digital bytes as a base in byte-strings. But only got about 2 times faster operations that way. I wasn't really inspired to optimize the arithmetic routines because stored that way, with most significant bytes i low mem, is awkward (at least) in Forth. So what I did now was to reverse the order of the data and using cells as base. That is, in the first version with ascii-strings I used 10 as a base, in the second version the base 2^8 - and now the optimal(?) base 2^32 or 2^64 depending on the computer.

I would be very pleased if you tested the words on your systems and told me if it is possible to load and run. It should be possible to make it run on any ANS Forth 94.

The system is very simple to handle:

B 31803578137508173058713085713753154260872480672408768467489

put the number on tos on the B-stack where all arithmetic is made.

B+, B-, B* and B/MOD is what I got so far and works as it should in Forth.

B<, B= and B0= ***DOES NOT CHANGE THE B-STACK*** and put flags on the parameter stack.

BDUP, BDROP,... are totally analogous

There is an extra stack X in some analogy with the R-stack:

>X, X, Y, Z, X>, XDROP, XDUP, XOVER and so far. That because of the need to store intermediate results, since there is no big variables.

[toc] | [next] | [standalone]

#37759

From	lehs <skydda.barnen@gmail.com>
Date	2015-03-30 08:42 -0700
Message-ID	<50535bba-b8c2-44d5-a583-1e53c2a08982@googlegroups.com>
In reply to	#37758

BASE @ HEX

\ LOCAL PARAMETERS AND VARIABLES BY EXTRA STACKS FOR SINGLE NUMBERS
\ Make FORTH programming much more easy and can be eliminated after

CELL NEGATE CONSTANT -CELL

CREATE xst HERE , S0 @ R0 @ - U2/ ALLOT ALIGN
CREATE yst HERE , S0 @ R0 @ - U2/ ALLOT ALIGN
CREATE zst HERE , S0 @ R0 @ - U2/ ALLOT ALIGN

: >x	( x -- )  CELL xst +! xst @ ! ;
: x> 	( -- x )  xst @ @ -CELL xst +! ;
: x 	( -- x )  xst @ @ ;
: x! 	( n -- )  xst @ ! ;
: x+! 	( n -- )  xst @ +! ;
: >y 	( y -- )  CELL yst +! yst @ ! ;
: y> 	( -- y )  yst @ @ -CELL yst +! ;
: y 	( -- y )  yst @ @ ;
: y! 	( n -- )  yst @ ! ;
: y+! 	( n -- )  yst @ +! ;
: >z 	( z -- )  CELL zst +! zst @ ! ;
: z> 	( -- z )  zst @ @ -CELL zst +! ;
: z 	( -- z )  zst @ @ ;
: z! 	( n -- )  zst @ ! ;
: z+! 	( n -- )  zst @ +! ;
: drop 	( ad -- )  CELL NEGATE SWAP +! ;
: drops ( ad n -- )  CELLS NEGATE SWAP +! ;
: empty? ( ad -- f )  DUP @ = ;
: depth	( ad -- n ) DUP @ SWAP - CELL / ;
: clx xst DUP ! ;
: cly yst DUP ! ;
: clz zst DUP ! ;
: st! ( -- ) clx cly clz ; st!
: .x xst depth IF x> RECURSE DUP . >x THEN ;
: .y yst depth IF y> RECURSE DUP . >y THEN ;
: .z zst depth IF z> RECURSE DUP . >z THEN ;
: drop-all xst drop yst drop zst drop ;
: .s ." x: " .x CR ." y: " .y CR ." z: " .z ;

\ Miscellanous

: LOG~ \ n -- #binary digits
  0 >x BEGIN 1 x+! U2/ ?DUP 0= UNTIL x> ;

   8 CELL * CONSTANT BITS
    BITS 1- CONSTANT BITS-1
BITS-1 LOG~ CONSTANT LBITS

: 2/MOD \ n -- r q
  DUP 1 AND SWAP U2/ ;

: 4/MOD \ n -- r q
  DUP 3 AND SWAP 2 RSHIFT ;

: 8/MOD \ n -- r q
  DUP 7 AND SWAP 3 RSHIFT ;

: BITS/MOD \ n -- r q
  DUP BITS-1 AND SWAP LBITS RSHIFT ;

: 256/MOD \ n -- r q
  DUP 0FF AND SWAP 8 RSHIFT ;

: U.R \ n t --
  >R 0 <# #S #>
  R> OVER - SPACES TYPE ;

VARIABLE RND 

: RESET_SEED 0ABCDEF1 RND ! ; RESET_SEED

: RAND \ -- u
  RND @ 08088405 * 1+ DUP RND ! ;

: RANDOM \ u1 -- u2
  RAND UM* NIP ;


\ CASE-OF STRUCTURE

VARIABLE CSP
6 CONSTANT L-CAS#
CREATE S-CSP L-CAS# CELLS ALLOT ALIGN
S-CSP CSP !

: +CSP ( -- p )  CSP @ DUP CELL+ CSP ! ;
: -CSP ( -- )  CSP @ 1 CELLS - CSP ! ;
: !CSP ( -- )  SP@ +CSP ! ;
: CSP@ ( -- )  CSP @ 1 CELLS - @ ;

: CASE ( -- )  !CSP ; IMMEDIATE
: ENDOF ( -- )  [COMPILE] ELSE ; IMMEDIATE

: OF ( -- )  POSTPONE OVER POSTPONE =
  [COMPILE] IF POSTPONE DROP ; IMMEDIATE

: ENDCASE \ --
  POSTPONE DROP
  BEGIN SP@ CSP@ = 0=
  WHILE [COMPILE] THEN
  REPEAT -CSP ; IMMEDIATE


\ BIG INTEGERS BASED ON CELL "DIGITS"

\ main stack
\ pointer stack in HIGH mem towards LOW mem
\ array stack in LOW mem towards HIGH mem

0A000 CONSTANT MAXV
MAXV CELL + ALLOCATE THROW ALIGNED CONSTANT V$0
V$0 MAXV + CONSTANT V0
VARIABLE VP

\ extra stack
08000 CONSTANT MAXX
MAXX CELL + ALLOCATE THROW ALIGNED CONSTANT X$0
X$0 MAXX + CONSTANT X0
VARIABLE XP

\ extra pad
02000 DUP ALLOCATE THROW CONSTANT PAD1 
PAD1 + CELL- CONSTANT PAD2

\ 02000 ALLOCATE THROW ALIGNED CONSTANT PAD2

: REZ \ a n -- a' n'	Delete leading zero ascii 48
  DUP 1 =
  IF EXIT
  THEN OVER C@ 030 =
  IF 1- SWAP 1+ SWAP RECURSE
  THEN ;

: PAD1$ \ -- a n	Get string
  PAD1 CELL+ PAD1 @ ;

: A>  0F AND ;		\ Ascii number to binary number
: >A  030 OR ;		\ Reverse
: VST!  V0 CELL - VP ! V$0 VP @ ! ;

VST! 	\ Initialize stack för dynamical numbers

: NEXT ( -- a )  VP @ @ ;
: FIRST ( -- a )  VP @ CELL + @ ;	\ big on tos
: SECOND ( -- a )  VP @ 2 CELLS + @ ;	\ big on second
: THIRD ( -- a )  VP @ 3 CELLS + @ ;	\ big on third
: VP+ ( -- )  -CELL VP +! ;		\ stack pointer

: TOV \ ad --		ad of number array to stack
  VP+ VP @ ! ;

: BEMPTY ( -- f )  NEXT V$0 = ;
: LEN1 ( -- n )  NEXT FIRST - ;		\ get length to first
: LEN2 ( -- n )  FIRST SECOND - ;
: LEN3 ( -- n )  SECOND THIRD - ;
: TOP$ ( -- a n )  FIRST LEN1 ;
: SEC$ ( -- a n )  SECOND LEN2 ;
: THI$ ( -- a n )  THIRD LEN3 ;

: VDIGIT \ b --		Put "digit" on stack
  NEXT TUCK ! CELL+ TOV ;

: VPUSH \ a n --	Put string on stack
  REZ >x NEXT x OVER + TOV x> CMOVE ;

: BPUSH \ a n --	Put any number array on stack
  NEXT OVER ALIGNED		\ a n nxt na
  2DUP + CELL- 0!		\ a n nxt na 
  OVER + TOV			\ a n nxt
  SWAP CMOVE ;			\ 

: BDUPALL \ v -- v u	Allocate array of same size
  NEXT LEN1 + TOV ;

: BPUSHA \ a n --	Put aligned number array on stack
  NEXT 2>R 2R@ SWAP CMOVE
  2R> + TOV ;

: BDROP  CELL VP +! ;
: BDUP  TOP$ BPUSHA ;
: VDUP  TOP$ VPUSH ;
: BOVER  SEC$ BPUSHA ;
: BOOVER  THI$ BPUSHA ;

: XST!  X0 CELL - XP ! X$0 XP @ ! ; XST!	\ Xtra stack
: XP+ ( -- )  -CELL XP +! ;
: TOX ( a -- )  XP+ XP @ ! ; 
: XNEXT ( -- ad )  XP @ @ ;
: XFIRST ( -- ad )  XP @ CELL+ @ ;
: XSECOND ( -- ad )  XP @ 2 CELLS + @ ;
: XTHIRD ( -- ad )  XP @ 3 CELLS + @ ;
: XLEN ( -- n )  XNEXT XFIRST - ;
: XPUSH ( a n -- ) REZ >x XNEXT x OVER + TOX x> CMOVE ;

: BXPUSH ( a n -- ) >x XNEXT x OVER + TOX x> CMOVE ; 
: XDROP  CELL XP +! ;
: XEMPTY ( -- f )  XNEXT X$0 = ;

: >X ( v -- )  TOP$ BXPUSH BDROP ;
: X! ( v -- v )  TOP$ BXPUSH ;
: X  ( -- v )  XFIRST XNEXT OVER - BPUSHA ;
: X> ( -- v )  X XDROP ;

: Y  \ -- v	Y is the second value on X-stack
  XSECOND XFIRST OVER - BPUSHA ;

: Z  ( -- v )  XTHIRD XSECOND OVER - BPUSHA ;
: V>X ( v -- )  TOP$ BDROP XPUSH ;
: VX  ( -- v )  XFIRST XNEXT OVER - VPUSH ;
: VX> ( -- v )  VX XDROP ;

: VY  \ -- v
  XSECOND XFIRST OVER - VPUSH ;

: BNIP  >X BDROP X> ;
: BSWAP  >X >X Y X> XDROP ;
: VSWAP  V>X V>X VY VX> XDROP ;
: BROT  >X BSWAP X> BSWAP ;
: BTUCK  BSWAP BOVER ;

: REZTOP  TOP$ XPUSH BDROP X> ; 	\ Clean leading asczeros
: REBZTOP  ( TOP$ BXPUSH BDROP X> ) ; 	\ Clean leading zero bytes
: VZERO  [CHAR] 0 NEXT TUCK C! 1+ TOV ;
: BZERO 0 VDIGIT ;			\ Small BigIntegers
: BONE  1 VDIGIT ;
: BTWO  2 VDIGIT ;
: BTHREE 3 VDIGIT ;
: BTEN  0A VDIGIT ;

: BYTE1@ \ v -- v | -- b  Get least significant byte of TOS
  FIRST C@ ;

: BYTE2@ \ v -- v | -- b  Least sign byte on second number
  SECOND C@ ;

: <VTOP BEGIN LEN1 2 <
           IF EXIT THEN NEXT 1- C@ 0=	\ ????
        WHILE -1 VP @ +! 
        REPEAT ;

: <TOP BEGIN LEN1 CELL > 0=
          IF EXIT THEN NEXT CELL- @ 0=
       WHILE -CELL VP @ +! 
       REPEAT ;

: V< \ -- f	Compare numbers as asc strings
  REZTOP <VTOP VSWAP REZTOP <VTOP VSWAP
  LEN2 LEN1 2DUP <
  IF 2DROP TRUE EXIT
  THEN DUP >z > 
  IF zst drop FALSE EXIT
  THEN FIRST NEXT 1- 
  DO I z - C@ I C@ 2DUP = 0=
     IF zst drop < IF TRUE ELSE FALSE THEN UNLOOP EXIT
     THEN 2DROP -1
  +LOOP zst drop FALSE ;

: V= \ u v -- u v | -- f
  V< IF FALSE EXIT THEN
  VSWAP V< IF VSWAP FALSE EXIT THEN VSWAP TRUE ;

0400 CONSTANT 1K

: V2/  \ v -- v/2
\ Divide asc number by 2
  NEXT FIRST >x 0 >y
  BEGIN x C@ OVER x >
  WHILE A> 2/MOD y> + >A x C!
     NEGATE 5 AND >y 1 x+!
  REPEAT REZTOP <VTOP 2DROP xst drop yst drop ;

: V>BYTE \ u -- v | -- f b
\ Divide asc-string by 256 leaving rest b. f TRUE if v=0
  xst depth FALSE >y 9 1
  DO NEXT 1- C@ 1 AND >x V2/ VZERO V= BDROP
     IF TRUE y! LEAVE THEN
  LOOP xst depth SWAP - 0 TUCK
  DO 2* x> + LOOP y> SWAP ;

: NTH ( n -- b/0 )  1+ VP @ SWAP CELLS + 
  DUP V0 = IF DROP 0 ELSE @ THEN ;

: LEN# \ n -- m 
  DUP NTH SWAP 1- NTH ?DUP
  IF SWAP ELSE V$0 SWAP THEN - ;

: BDEPTH \ -- n 
  040 0					\ Depth of stack
  DO I NTH 0= IF I LEAVE THEN LOOP ;

: V>B  \ Convert asc-number to digital Bignumber
  PAD 1K 2DUP + PAD
  DO V>BYTE I C!
     IF DROP I PAD - 1+ LEAVE THEN
  LOOP BDROP BPUSH ;

: S>B \ -- v | n --	Convert single to big
  0 <# #S #> VPUSH V>B ;

: B>S  \ u -- | -- n	Conv big to single
  FIRST @ BDROP ;

: D>B \ -- v | d --
  <# #S #> VPUSH V>B ;

: B>D  \ u -- | -- d
  TOP$ 5 < IF @ 0 ELSE 2@ SWAP THEN BDROP ;

: D256*  \ ud -- 256ud
  OVER 8 LSHIFT ROT FF000000 AND 018 RSHIFT
  ROT 8 LSHIFT OR ;

: V  BL PARSE VPUSH ; 		\ 'V 12345' Put asc numb on TOS
: B  V V>B ;			\ Put BigInt on TOS 
: CL VST! XST! st! S0 @ SP! ;	\ Clear stacks

: .V  BDEPTH ?DUP	\ Print asc numb stack
  IF 0 DO I NTH I LEN# TYPE CR LOOP THEN ;

: .BYTES BDEPTH ?DUP	\ Print byte string stack
  IF 0 DO I NTH I LEN# 0
          DO I OVER + C@ BASE @ >x
             HEX 0 <# # # #> TYPE SPACE x> BASE !
          LOOP DROP CR
       LOOP
  THEN ;

: B+_S>=F \ u v -- u+v		u >= v
  LEN2 NEXT OVER LEN1 - DUP VP @ +! ERASE
  0 >x NEXT FIRST 
  DO I OVER - @ I @ 0 TUCK D+ x> 0 D+ >x I ! CELL
  +LOOP DROP x> ?DUP IF NEXT CELL VP @ +! ! THEN ;

: B+ \ u v -- u+v		Adding BigInt
  LEN2 LEN1 < 0=
  IF B+_S>=F
  ELSE BSWAP B+_S>=F 
  THEN BNIP ;

: B< \ u v -- u v | -- f	OBS! Bigstack remains
  LEN2 LEN1 2DUP U<
  IF 2DROP TRUE EXIT
  THEN DUP PAD1 ! U>
  IF FALSE EXIT
  THEN FIRST >x SECOND >y 0 >z 0 PAD1 @ CELL -
  DO y I + @ x I + @ 2DUP = 0=
     IF drop-all U< IF TRUE ELSE FALSE THEN UNLOOP EXIT
     THEN 2DROP -CELL
  +LOOP drop-all FALSE ;

: B= \ u v -- u v | -- f
  B< IF FALSE EXIT THEN
  BSWAP B< IF BSWAP FALSE EXIT THEN BSWAP TRUE ;

: B0= \ v -- v | -- f
  LEN1 CELL - FIRST @ OR 0= ;

: GTX? \ v -- v | -- f	Greater Than X-value?
  LEN1 XLEN 2DUP <
  IF 2DROP FALSE EXIT THEN >
  IF TRUE EXIT THEN FALSE 0 XLEN CELL -
  DO FIRST I + @ XFIRST I + @ 2DUP <
     IF 2DROP LEAVE THEN >
     IF 0= LEAVE THEN -CELL
  +LOOP ;

: +X>=Y? \ v -- | -- f		Add v to X and compare with Y
  X> B+ X> B< >X >X 0=
  DUP IF XDROP XDROP THEN ;	\ 2 XDROP when equal or greater

: B~ \ u v -- |u-v| | -- f
  B< IF BSWAP TRUE >z ELSE FALSE >z THEN
  FIRST >x SECOND >y FALSE >z
  LEN1 0
  DO y I + @ z + x I + @ 2DUP U< z! z
     IF 1 SWAP 0 D- DROP ELSE - THEN y I + ! CELL
  +LOOP LEN2 LEN1
  DO y I + @ DUP 0= x! x z AND
     IF DROP -1 ELSE z + 0 z! THEN y I + !
     z 0= IF LEAVE THEN CELL
  +LOOP drop-all z> BDROP <TOP ;

: B- \ u v -- u-v
  B~ IF ABORT" Negative Big!" THEN ;

: |B-| \ u v -- |u-v|
  B~ DROP ;

: BSL \ n i -- n1 n0	Big shift left, n < 2^BITS
  2DUP BITS SWAP - RSHIFT -ROT LSHIFT ;

: BLEFT  \ v -- u | n -- 	 	Big shift left
  BITS/MOD OVER 0= 
  IF NIP FIRST DUP ROT CELLS DUP >x + LEN1 CMOVE> 
     x VP @ +! FIRST x> ERASE EXIT
  THEN CELLS >y				\ i  y=4[n/32]
  y FIRST DUP >x + 			\ i F+4[n/32]  x=FIRST
  x OVER LEN1 DUP >z CMOVE>		\ i F+4[n/32]  z=LEN1
  x y ERASE
  z> OVER + DUP x! SWAP 0 >z		\ i F+4[n/32]+LEN1 F+4[n/32]
  ?DO I @ OVER BSL z> OR I ! >z CELL +LOOP
  z x ! x CELL+ VP @ ! DROP drop-all <TOP ;

: BRIGHT \ v -- u | n -- 
  8 /MOD >y >x 
  NEXT 0! NEXT FIRST
  DO y I + W@ x RSHIFT SP@ C@ I C! DROP
  LOOP NEXT y - y> ERASE
  <TOP xst drop ;

: B1AND \ v -- v s
  FIRST @ 1 AND VDIGIT ;

: BEVEN \ v -- v | -- f
  FIRST @ 1 AND 0= ;

: BODD \ v -- v | -- f
  BEVEN 0= ;

: B1OR \ v -- v'
  FIRST @ 1 OR FIRST ! ;

: B2/MOD \ v -- r k 
  B1AND BSWAP 1 BRIGHT ;

: MSB@ \ v -- v | -- c
  NEXT CELL- NEXT 1-
  DO I C@ ?DUP IF LEAVE THEN -1 +LOOP ;

: Z# \ v -- v | -- n
  0 >x NEXT
  BEGIN 1- DUP C@ 0=
  WHILE 1 x+! 
  REPEAT DROP x> ;

: BLOG~ \ v -- v | -- n		8(len-1)+log(byte0)+1
  LEN1 Z# - 1- 3 LSHIFT MSB@ LOG~ + ;

: BLOG \ v -- | -- n	\ Integer part of 2-logarithm
  BLOG~ 1- BDROP ;

: B1+ BONE B+ ;
: B1- BONE B- ;
: B2+ BTWO B+ ;

: B2* \ v -- 2v
  1 BLEFT ;

: B2/ \ v -- v/2
  1 BRIGHT ;

: B256* \ v -- 256v
  TOP$ OVER 1+ SWAP CMOVE>
  VP @ 1+! 0 FIRST C! ;

: LAST!> \ n --
  NEXT CELL- ! CELL VP @ +! ;

: CELL*X \ -- n*v ; X: v -- v | n --
  BZERO 0 >x XNEXT XFIRST 
  DO DUP I @ UM* x> 0 D+ >x LAST!> CELL +LOOP
  x> NEXT CELL- ! DROP <TOP ;

: BS* \ v -- n*v | n --
  >X CELL*X XDROP ;

: BDUPS* \ v -- v n*v | n -- 
  BZERO 0 >x FIRST SECOND 
  DO DUP I @ UM* x> 0 D+ >x LAST!> CELL +LOOP 
  x> NEXT CELL- ! DROP <TOP ; 

: 32BLEFT \ v -- w
  TOP$ OVER CELL+ SWAP CMOVE>
  CELL VP @ +! 0 FIRST ! ;

: B* \ u v -- u*v
  LEN1 LEN2 < IF BSWAP THEN
  >X BZERO SECOND FIRST CELL- 
  DO 32BLEFT I @ CELL*X B+ -CELL +LOOP
  BNIP XDROP <TOP ;

: BS/MOD \ v -- q | n -- r  		v=nq+r
  >x BDUPALL NEXT CELL- 0!
  0 0 LEN1 CELL-
  DO I SECOND + @ SWAP x UM/MOD I FIRST + ! -CELL +LOOP <TOP
  xst drop BNIP ;

\ 2^sXn+1=2*2^sXn-[2^sXn]^2*N/2^[2s]
\ K=T*X/2^[2n]
: B/MOD \ u v -- r k 				Newtons method
  B< IF BDROP BZERO EXIT THEN
  LEN1 5 < IF B>S BS/MOD S>B BSWAP EXIT THEN
  BLOG~ >x >X BDUP BLOG~ 2/ 6 + >y 
  x 1- BONE BLEFT X B= BDROP BDROP
  IF y 2* x> - BONE BLEFT
  ELSE y 2* x> - DUP >x BONE BLEFT x>
     IF 6 S>B B* 5 BS/MOD DROP THEN		\ X0
     BEGIN BDUP B2* BOVER BDUP B* X B*
        y 2* BRIGHT B- B= BNIP 
     UNTIL
  THEN B* y> 2* BRIGHT
  BEGIN BSWAP BOVER X B* B<
  WHILE BDROP BSWAP B1-
  REPEAT B- BSWAP XDROP ;

: B/ \ u v -- u/v
  B/MOD BNIP ;

: BMOD \ u v -- rest 
  B/MOD BDROP ;

: B>V$ \ b -- b | -- a n
  PAD2 PAD1 ! BDUP 0A 
  BEGIN DUP BS/MOD >A PAD1 @ C! -1 PAD1 +! B0= UNTIL 
  DROP BDROP 1 PAD1 +! PAD1 @ PAD2 OVER - 1+ ;

: B>V  \ b -- b v
  B>V$ VPUSH ;

: B. \ b -- b
  B>V$ TYPE SPACE ;

: .B  BEMPTY 0=
  IF B. CR >X RECURSE X> THEN ;

: .X  XEMPTY 0=
  IF X> B. CR RECURSE >X THEN ;

: X>. XEMPTY 0= IF X> B. BDROP RECURSE THEN ;

: B** \ B A -- B^A
  >X BZERO >X BONE
  BEGIN BOVER B*
    BONE +X>=Y?
  UNTIL BNIP ;

BASE !

From	"Alex McDonald" <blog@rivadpm.com>
Date	2015-04-09 15:06 -0700
Message-ID	<mg6t3n$e55$1@dont-email.me>
In reply to	#38071

From	Paul Rubin <no.email@nospam.invalid>
Date	2015-04-10 12:58 -0700
Message-ID	<87h9sndaco.fsf@jester.gateway.sonic.net>
In reply to	#38100

How I learned my computer arithmetic

Contents

#37758 — How I learned my computer arithmetic

#37759

#37850

#37884

#37939

#37760

#37972

#38071

#38072

#38075

#38077

#38100

#38101

#38103

#38105

#38106

#38116

#38117

#38127

#38118