dsforth/math_hlev.zas

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; "high-level" math words
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4
   5 ;; convert normal singed number to double
   6 $FORTH_CODE_WORD S->D
   7 ;; AberSoft
   8 ;; ( n -- d )
   9   pop   de
  10   ld    hl,0
  11   ld    a,d
  12   and   #80
  13   jr    z,s2d0
  14   dec   hl
  15 s2d0:
  16   jp    i_pushde
  17 $FORTH_END_CODE_WORD S->D
  18
  19 $FORTH_WORD +-
  20 ;; AberSoft
  21 ;; ( n1 n2 -- n3 )
  22 ;; apply the sign of n2 to n1, which is left as n3
  23   0< 0BRANCH pm0
  24   NEGATE
  25 pm0:
  26   ;S
  27 $FORTH_END_WORD +-
  28
  29 $FORTH_WORD D+-
  30 ;; AberSoft
  31 ;; ( d1 n -- d2 )
  32 ;; apply the sign of n to the double number d1, leaving it as d2
  33   0< 0BRANCH dpm0
  34   DNEGATE
  35 dpm0:
  36   ;S
  37 $FORTH_END_WORD D+-
  38
  39 $FORTH_WORD ABS
  40 ;; AberSoft
  41 ;; ( n -- n )
  42   DUP +- ;S
  43 $FORTH_END_WORD ABS
  44
  45 $FORTH_WORD DABS
  46 ;; AberSoft
  47 ;; ( d -- d )
  48   DUP D+- ;S
  49 $FORTH_END_WORD DABS
  50
  51 $FORTH_WORD MIN
  52 ;; AberSoft
  53 ;; ( n1 n2 -- n )
  54   2DUP > 0BRANCH min0
  55   SWAP
  56 min0:
  57   DROP
  58   ;S
  59 $FORTH_END_WORD MIN
  60
  61 $FORTH_WORD MAX
  62 ;; AberSoft
  63 ;; ( n1 n2 -- n )
  64   2DUP < 0BRANCH max0
  65   SWAP
  66 max0:
  67   DROP
  68   ;S
  69 $FORTH_END_WORD MAX
  70
  71 $FORTH_WORD UMIN
  72 ;; k8
  73 ;; ( u1 u2 -- u )
  74   2DUP U> 0BRANCH umin0
  75   SWAP
  76 umin0:
  77   DROP
  78   ;S
  79 $FORTH_END_WORD UMIN
  80
  81 $FORTH_WORD UMAX
  82 ;; k8
  83 ;; ( u1 u2 -- u )
  84   2DUP U< 0BRANCH umax0
  85   SWAP
  86 umax0:
  87   DROP
  88   ;S
  89 $FORTH_END_WORD UMAX
  90
  91
  92 $FORTH_WORD M*
  93 ;; AberSoft
  94 ;; ( nl n2 -- d )
  95   2DUP XOR >R ABS SWAP ABS U* R> D+- ;S
  96 $FORTH_END_WORD M*
  97
  98 $FORTH_WORD M/
  99 ;; AberSoft
 100 ;; ( d n1 -- rem quot )
 101 ;; the remainder takes its sign from the dividend
 102   OVER >R >R DABS R@ ABS U/MOD R> R@ XOR +- SWAP R> +- SWAP ;S
 103 $FORTH_END_WORD M/
 104
 105 $FORTH_WORD *
 106 ;; AberSoft
 107 ;; ( nl n2 -- n )
 108   M* DROP ;S
 109 $FORTH_END_WORD *
 110
 111 $FORTH_WORD /MOD
 112 ;; AberSoft
 113 ;; ( n1 n2 -- rem quot )
 114   >R S->D R> M/ ;S
 115 $FORTH_END_WORD /MOD
 116
 117 $FORTH_WORD /
 118 ;; AberSoft
 119 ;; ( n1 n2 -- quot )
 120   /MOD SWAP DROP ;S
 121 $FORTH_END_WORD /
 122
 123 $FORTH_WORD MOD
 124 ;; AberSoft
 125 ;; ( n1 n2 -- rem )
 126   /MOD DROP ;S
 127 $FORTH_END_WORD MOD
 128
 129 $FORTH_WORD */MOD
 130 ;; AberSoft
 131 ;; ( n1 n2 n3 -- rem quot )
 132 ;; n1*n2/n3, with 31-bit intermediate value
 133   >R M* R> M/ ;S
 134 $FORTH_END_WORD */MOD
 135
 136 $FORTH_WORD */
 137 ;; AberSoft
 138 ;; ( n1 n2 n3 -- quot )
 139 ;; n1*n2/n3, with 31-bit intermediate value
 140   */MOD SWAP DROP ;S
 141 $FORTH_END_WORD */
 142
 143 $FORTH_WORD M/MOD
 144 ;; AberSoft
 145 ;; ( ud1 u2 -- rem ud4 )
 146   >R 0 R@ U/MOD R> SWAP >R U/MOD R> ;S
 147 $FORTH_END_WORD M/MOD