level0/syssrc/math-double.f

   1 ;; Native x86 GNU/Linux Forth System, Direct Threaded Code
   2 ;; double math words
   3 ;;
   4 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   5 ;;
   6 ;; This program is free software: you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation, version 3 of the License ONLY.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 code: S>D  ( n -- d )
  20   ld    eax,TOS
  21   cdq
  22   push  eax
  23   ld    TOS,edx
  24   urnext
  25 endcode
  26
  27 code: U>D  ( u -- ud )
  28   push  TOS
  29   xor   TOS,TOS
  30   urnext
  31 endcode
  32
  33 ;; with overflow clamping
  34 code: D>U  ( ud -- u )
  35   pop   eax
  36   jcxz  .done
  37   ld    eax,0xffffffff
  38 .done:
  39   urnext
  40 endcode
  41
  42 code: D>S  ( d -- n )
  43   pop   eax
  44   jcxz  .poscheck
  45   ; overflow or negative
  46   test  TOS,0x80000000
  47   jr    z,.posoverflow
  48   ; definitely negative
  49   inc   TOS
  50   jr    nz,.negoverflow
  51   cp    eax,0x80000000
  52   jr    nc,.good
  53 .negoverflow:
  54   ld    TOS,0x80000000
  55   urnext
  56 .poscheck:
  57   ; positive, check for positive overflow
  58   cp    eax,0x80000000
  59   jr    c,.good
  60 .posoverflow:
  61   ; positive overflow
  62   ld    TOS,0x7fffffff
  63   urnext
  64 .good:
  65   ld    TOS,eax
  66   urnext
  67 endcode
  68
  69
  70 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  71 code: UM*  ( u0 u1 -- ud )
  72   pop   eax
  73   xchg  eax,TOS
  74   mul   TOS
  75   push  eax
  76   mov   TOS,edx
  77   urnext
  78 endcode
  79
  80 code: UM/MOD  ( ud1 u1 -- umod ures )
  81   pop   edx
  82   pop   eax
  83   or    TOS,TOS
  84   jr    z,@f
  85   div   TOS
  86   push  edx
  87   mov   TOS,eax
  88   urnext
  89 @@:
  90   push  TOS
  91   urnext
  92 endcode
  93
  94 code: UM/  ( ud1 u1 -- ures )
  95   pop   edx
  96   pop   eax
  97   or    TOS,TOS
  98   jr    z,@f
  99   div   TOS
 100   mov   TOS,eax
 101   urnext
 102 @@:
 103   push  TOS
 104   urnext
 105 endcode
 106
 107 code: UMMOD  ( ud1 u1 -- umod )
 108   pop   edx
 109   pop   eax
 110   or    TOS,TOS
 111   jr    z,@f
 112   div   TOS
 113   mov   TOS,edx
 114   urnext
 115 @@:
 116   push  TOS
 117   urnext
 118 endcode
 119
 120
 121 code: M*  ( n0 n1 -- d )
 122   pop   eax
 123   xchg  eax,TOS
 124   imul  TOS
 125   push  eax
 126   mov   TOS,edx
 127   urnext
 128 endcode
 129
 130 code: M/MOD  ( d1 n1 -- nmod nres )
 131   pop   edx
 132   pop   eax
 133   or    TOS,TOS
 134   jr    z,@f
 135   idiv  TOS
 136   push  edx
 137   mov   TOS,eax
 138   urnext
 139 @@:
 140   push  TOS
 141   urnext
 142 endcode
 143
 144 code: M/  ( d1 n1 -- nres )
 145   pop   edx
 146   pop   eax
 147   or    TOS,TOS
 148   jr    z,@f
 149   idiv  TOS
 150   mov   TOS,eax
 151   urnext
 152 @@:
 153   push  TOS
 154   urnext
 155 endcode
 156
 157 code: MMOD  ( d1 n1 -- nmod )
 158   pop   edx
 159   pop   eax
 160   or    TOS,TOS
 161   jr    z,@f
 162   idiv  TOS
 163   mov   TOS,edx
 164   urnext
 165 @@:
 166   push  TOS
 167   urnext
 168 endcode
 169
 170
 171 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 172 code: D2*  ( d -- d*2 )
 173   pop   edx
 174   ;; ECX=d1-high
 175   ;; EDX=d1-low
 176   shl   edx,1
 177   rcl   ecx,1
 178   ;; push ECX:EDX
 179   push  edx
 180   urnext
 181 endcode
 182
 183 code: D2/  ( d -- d/2 )
 184   pop   edx
 185   ;; ECX=d1-high
 186   ;; EDX=d1-low
 187   sar   ecx,1
 188   rcr   edx,1
 189   ;; push ECX:EDX
 190   push  edx
 191   urnext
 192 endcode
 193
 194 code: D2U/  ( d1 -- d/2 )
 195   pop   edx
 196   ;; ECX=d1-high
 197   ;; EDX=d1-low
 198   shr   ecx,1
 199   rcr   edx,1
 200   ;; push ECX:EDX
 201   push  edx
 202   urnext
 203 endcode
 204
 205 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 206 code: DNEGATE  ( d -- -d )
 207   pop   edx
 208   ;; ECX=d1-high
 209   ;; EDX=d1-low
 210   xor   ecx,0xffffffff
 211   xor   edx,0xffffffff
 212   add   edx,1
 213   adc   ecx,0
 214   ;; push ECX:EDX
 215   push  edx
 216   urnext
 217 endcode
 218
 219 code: DABS  ( d -- |d| )
 220   pop   edx
 221   ;; ECX=d1-high
 222   ;; EDX=d1-low
 223   test  ecx,0x80000000
 224   jr    z,@f
 225   xor   ecx,0xffffffff
 226   xor   edx,0xffffffff
 227   add   edx,1
 228   adc   ecx,0
 229 @@:
 230   ;; push ECX:EDX
 231   push  edx
 232   urnext
 233 endcode
 234
 235 code: DSGN  ( d -- -1/0/1 )
 236   pop   edx
 237   ld    eax,edx
 238   or    eax,TOS
 239   jr    nz,@f
 240   urnext
 241 @@:
 242   test  TOS,0x80000000
 243   jr    nz,@f
 244   ld    TOS,1
 245   urnext
 246 @@:
 247   ld    TOS,-1
 248   urnext
 249 endcode
 250
 251
 252 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 253 code: D0=  ( d -- flag )
 254   pop   edx
 255   ;; ECX=d1-high
 256   ;; EDX=d1-low
 257   or    ecx,edx
 258   cp    ecx,1
 259   ;;  C: ECX==0
 260   ;; NC: ECX!=0
 261   ld    ecx,0
 262   adc   ecx,0
 263   urnext
 264 endcode
 265
 266 code: D0!=  ( d -- flag )
 267   pop   edx
 268   ;; ECX=d1-high
 269   ;; EDX=d1-low
 270   or    ecx,edx
 271   cp    ecx,1
 272   ;;  C: ECX==0
 273   ;; NC: ECX!=0
 274   ld    ecx,1
 275   sbb   ecx,0
 276   urnext
 277 endcode
 278
 279 code: D0<  ( d -- flag )
 280   pop   edx
 281   ;; ECX=d1-high
 282   ;; EDX=d1-low
 283   cp    ecx,0x80000000
 284   ;;  C: ECX>=0
 285   ;; NC: ECX<0
 286   ld    ecx,1
 287   sbb   ecx,0
 288   urnext
 289 endcode
 290
 291 code: D0>  ( d -- flag )
 292   pop   edx
 293   ;; ECX=d1-high
 294   ;; EDX=d1-low
 295   ld    eax,ecx
 296   or    eax,edx
 297   jr    z,@f
 298   cp    ecx,0x80000000
 299   ;;  C: ECX>=0
 300   ;; NC: ECX<0
 301   ld    ecx,0
 302   adc   ecx,0
 303 @@:
 304   urnext
 305 endcode
 306
 307 code: D0<=  ( d -- flag )
 308   pop   edx
 309   ;; ECX=d1-high
 310   ;; EDX=d1-low
 311   ld    eax,ecx
 312   or    eax,edx
 313   jr    z,@f
 314   cp    ecx,0x80000000
 315   ;;  C: ECX>=0
 316   ;; NC: ECX<0
 317   ld    ecx,1
 318   sbb   ecx,0
 319   urnext
 320 @@:
 321   ld    TOS,1
 322   urnext
 323 endcode
 324
 325 code: D0>=  ( d -- flag )
 326   pop   edx
 327   ;; ECX=d1-high
 328   ;; EDX=d1-low
 329   ld    eax,ecx
 330   or    eax,edx
 331   jr    z,@f
 332   cp    ecx,0x80000000
 333   ;;  C: ECX>=0
 334   ;; NC: ECX<0
 335   ld    ecx,0
 336   adc   ecx,0
 337   urnext
 338 @@:
 339   ld    TOS,1
 340   urnext
 341 endcode
 342
 343
 344 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 345 code: D+  ( d1 d2 -- d )
 346   pop   ebx
 347   pop   edx
 348   pop   eax
 349   ;; ECX=d2-high
 350   ;; EBX=d2-low
 351   ;; EDX=d1-high
 352   ;; EAX=d1-low
 353   add   eax,ebx
 354   adc   edx,ecx
 355   ;; push EDX:EAX
 356   push  eax
 357   ld    TOS,edx
 358   urnext
 359 endcode
 360
 361 code: D-  ( d1 d2 -- d )
 362   pop   ebx
 363   pop   edx
 364   pop   eax
 365   ;; ECX=d2-high
 366   ;; EBX=d2-low
 367   ;; EDX=d1-high
 368   ;; EAX=d1-low
 369   sub   eax,ebx
 370   sbb   edx,ecx
 371   ;; push EDX:EAX
 372   push  eax
 373   ld    TOS,edx
 374   urnext
 375 endcode
 376
 377
 378 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 379 code: D=  ( d1 d2 -- flag )
 380   pop   ebx
 381   pop   edx
 382   pop   eax
 383   ;; ECX=d2-high
 384   ;; EBX=d2-low
 385   ;; EDX=d1-high
 386   ;; EAX=d1-low
 387   sub   eax,ebx
 388   sbb   edx,ecx
 389   or    eax,edx
 390   jr    z,@f
 391   ld    TOS,0
 392   urnext
 393 @@:
 394   ld    TOS,1
 395   urnext
 396 endcode
 397
 398 code: D<>  ( d1 d2 -- flag )
 399   pop   ebx
 400   pop   edx
 401   pop   eax
 402   ;; ECX=d2-high
 403   ;; EBX=d2-low
 404   ;; EDX=d1-high
 405   ;; EAX=d1-low
 406   sub   eax,ebx
 407   sbb   edx,ecx
 408   or    eax,edx
 409   jr    z,@f
 410   ld    TOS,1
 411   urnext
 412 @@:
 413   ld    TOS,0
 414   urnext
 415 endcode
 416
 417 code: D<  ( d1 d2 -- flag )
 418   pop   ebx
 419   pop   edx
 420   pop   eax
 421   ;; ECX=d2-high
 422   ;; EBX=d2-low
 423   ;; EDX=d1-high
 424   ;; EAX=d1-low
 425   ;; d1-d2: d1<d2:C; d1>d2:nc
 426   sub   eax,ebx
 427   sbb   edx,ecx
 428   setl  cl
 429   movzx TOS,cl
 430   urnext
 431 endcode
 432
 433 code: D>  ( d1 d2 -- flag )
 434   pop   ebx
 435   pop   edx
 436   pop   eax
 437   ;; ECX=d2-high
 438   ;; EBX=d2-low
 439   ;; EDX=d1-high
 440   ;; EAX=d1-low
 441   ;; d2-d1
 442   sub   ebx,eax
 443   sbb   ecx,edx
 444   setl  cl
 445   movzx TOS,cl
 446   urnext
 447 endcode
 448
 449 code: DU<  ( ud1 ud2 -- flag )
 450   pop   ebx
 451   pop   edx
 452   pop   eax
 453   ;; ECX=d2-high
 454   ;; EBX=d2-low
 455   ;; EDX=d1-high
 456   ;; EAX=d1-low
 457   ;; d1-d2
 458   sub   eax,ebx
 459   sbb   edx,ecx
 460   setc  cl
 461   movzx TOS,cl
 462   urnext
 463 endcode
 464
 465 code: DU>  ( ud1 ud2 -- flag )
 466   pop   ebx
 467   pop   edx
 468   pop   eax
 469   ;; ECX=d2-high
 470   ;; EBX=d2-low
 471   ;; EDX=d1-high
 472   ;; EAX=d1-low
 473   ;; d2-d1
 474   sub   ebx,eax
 475   sbb   ecx,edx
 476   setc  cl
 477   movzx TOS,cl
 478   urnext
 479 endcode
 480
 481 code: DU<=  ( ud1 ud2 -- flag )
 482   pop   ebx
 483   pop   edx
 484   pop   eax
 485   ;; ECX=d2-high
 486   ;; EBX=d2-low
 487   ;; EDX=d1-high
 488   ;; EAX=d1-low
 489   sub   ebx,eax
 490   sbb   ecx,edx
 491   ld    TOS,1
 492   sbb   TOS,0
 493   urnext
 494 endcode
 495
 496 code: DU>=  ( ud1 ud2 -- flag )
 497   pop   ebx
 498   pop   edx
 499   pop   eax
 500   ;; ECX=d2-high
 501   ;; EBX=d2-low
 502   ;; EDX=d1-high
 503   ;; EAX=d1-low
 504   sub   eax,ebx
 505   sbb   edx,ecx
 506   ld    TOS,1
 507   sbb   TOS,0
 508   urnext
 509 endcode
 510
 511
 512 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 513 : DMAX  ( d1 d2 -- max[d1,d2] )
 514   2over 2over d< if 2swap 2drop endif
 515 ;
 516
 517 : DMIN   ( d1 d2 -- min[d1,d2] )
 518   2over 2over d> if 2swap 2drop endif
 519 ;
 520
 521 : M+  ( d1|ud1 n -- d2|ud2 )
 522   s>d d+
 523 ;
 524
 525
 526 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 527 code: UDS*  ( ud1 u --> ud2 )
 528   ld    edi,TOS
 529   pop   ebx
 530   pop   ecx
 531   ld    eax,ecx
 532   mul   edi
 533   push  edx
 534   ld    ecx,eax
 535   ld    eax,ebx
 536   mul   edi
 537   pop   edx
 538   add   eax,edx
 539   push  ecx
 540   ld    TOS,eax
 541   urnext
 542 endcode