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, David Rosenboom
   7 \
   8 \ Permission to use, copy, modify, and/or distribute this
   9 \ software for any purpose with or without fee is hereby granted.
  10 \
  11 \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  12 \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  13 \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  14 \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  15 \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  16 \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  17 \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  18 \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  19
  20 anew task-math.fth
  21 decimal
  22
  23 : FM/MOD { dl dh nn | dlp dhp nnp rem quo -- rem quo , floored }
  24     dl dh dabs -> dhp -> dlp
  25     nn abs -> nnp
  26     dlp dhp nnp um/mod -> quo -> rem
  27     dh 0<
  28     IF  \ negative dividend
  29         nn 0<
  30         IF   \ negative divisor
  31             rem negate -> rem
  32         ELSE  \ positive divisor
  33             rem 0=
  34             IF
  35                 quo negate -> quo
  36             ELSE
  37                 quo 1+ negate -> quo
  38                 nnp rem - -> rem
  39             THEN
  40         THEN
  41     ELSE  \ positive dividend
  42         nn 0<
  43         IF  \ negative divisor
  44             rem 0=
  45             IF
  46                 quo negate -> quo
  47             ELSE
  48                 nnp rem - negate -> rem
  49                 quo 1+ negate -> quo
  50             THEN
  51         THEN
  52     THEN
  53     rem quo
  54 ;
  55
  56 : SM/REM { dl dh nn | dlp dhp nnp rem quo -- rem quo , symmetric }
  57     dl dh dabs -> dhp -> dlp
  58     nn abs -> nnp
  59     dlp dhp nnp um/mod -> quo -> rem
  60     dh 0<
  61     IF  \ negative dividend
  62         rem negate -> rem
  63         nn 0>
  64         IF   \ positive divisor
  65             quo negate -> quo
  66         THEN
  67     ELSE  \ positive dividend
  68         nn 0<
  69         IF  \ negative divisor
  70             quo negate -> quo
  71         THEN
  72     THEN
  73     rem quo
  74 ;
  75
  76
  77 : /MOD ( a b -- rem quo )
  78     >r s>d r> sm/rem
  79 ;
  80
  81 : MOD ( a b -- rem )
  82     /mod drop
  83 ;
  84
  85 : */MOD ( a b c -- rem a*b/c , use double precision intermediate value )
  86     >r m*
  87     r> sm/rem
  88 ;
  89 : */ ( a b c -- a*b/c , use double precision intermediate value )
  90     */mod
  91     nip
  92 ;