git.gag.com Git - debian/pforth/blob - fth/math.fth

   1 \ @(#) math.fth 98/01/26 1.2
   2 \ Extended Math routines
   3 \ FM/MOD SM/REM
   4 \
   5 \ Author: Phil Burk
   6 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
   7 \
   8 \ The pForth software code is dedicated to the public domain,
   9 \ and any third party may reproduce, distribute and modify
  10 \ the pForth software code or any derivative works thereof
  11 \ without any compensation or license.  The pForth software
  12 \ code is provided on an "as is" basis without any warranty
  13 \ of any kind, including, without limitation, the implied
  14 \ warranties of merchantability and fitness for a particular
  15 \ purpose and their equivalents under the laws of any jurisdiction.
  16
  17 anew task-math.fth
  18 decimal
  19
  20 : FM/MOD { dl dh nn | dlp dhp nnp rem quo -- rem quo , floored }
  21     dl dh dabs -> dhp -> dlp
  22     nn abs -> nnp
  23     dlp dhp nnp um/mod -> quo -> rem
  24     dh 0<
  25     IF  \ negative dividend
  26         nn 0<
  27         IF   \ negative divisor
  28             rem negate -> rem
  29         ELSE  \ positive divisor
  30             rem 0=
  31             IF
  32                 quo negate -> quo
  33             ELSE
  34                 quo 1+ negate -> quo
  35                 nnp rem - -> rem
  36             THEN
  37         THEN
  38     ELSE  \ positive dividend
  39         nn 0<
  40         IF  \ negative divisor
  41             rem 0=
  42             IF
  43                 quo negate -> quo
  44             ELSE
  45                 nnp rem - negate -> rem
  46                 quo 1+ negate -> quo
  47             THEN
  48         THEN
  49     THEN
  50     rem quo
  51 ;
  52
  53 : SM/REM { dl dh nn | dlp dhp nnp rem quo -- rem quo , symmetric }
  54     dl dh dabs -> dhp -> dlp
  55     nn abs -> nnp
  56     dlp dhp nnp um/mod -> quo -> rem
  57     dh 0<
  58     IF  \ negative dividend
  59         rem negate -> rem
  60         nn 0>
  61         IF   \ positive divisor
  62             quo negate -> quo
  63         THEN
  64     ELSE  \ positive dividend
  65         nn 0<
  66         IF  \ negative divisor
  67             quo negate -> quo
  68         THEN
  69     THEN
  70     rem quo
  71 ;
  72
  73
  74 : /MOD ( a b -- rem quo )
  75     >r s>d r> sm/rem
  76 ;
  77
  78 : MOD ( a b -- rem )
  79     /mod drop
  80 ;
  81
  82 : */MOD ( a b c -- rem a*b/c , use double precision intermediate value )
  83     >r m*
  84     r> sm/rem
  85 ;
  86 : */ ( a b c -- a*b/c , use double precision intermediate value )
  87     */mod
  88     nip
  89 ;