level1/24_math_double.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;; this is the only thing we need to print unsigned double numbers
   9 code: UDS/MOD  ( ud1 u1 --> ud2 u2 )
  10   ld    edi,TOS
  11   pop   eax
  12   pop   ebx
  13   ;; EDI=u1
  14   ;; EAX=ud1-high
  15   ;; EBX=ud1-low
  16   xor   edx,edx
  17   div   edi
  18   xchg  eax,ebx
  19   div   edi
  20   push  eax
  21   push  ebx
  22   ld    TOS,edx
  23   urnext
  24 endcode
  25
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;; this is the only thing (besides the one above) we need to print signed double numbers
  28 code: DABS  ( d -- |d| )
  29   pop   edx
  30   ;; ECX=d1-high
  31   ;; EDX=d1-low
  32   test  ecx,ecx
  33   jr    ns,@f
  34   not   ecx
  35   not   edx
  36   add   edx,1
  37   adc   ecx,0
  38 @@:
  39   ;; push ECX:EDX
  40   push  edx
  41   urnext
  42 endcode
  43
  44
  45 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  46 ;; rest of the double math
  47
  48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49 code: DNEGATE  ( d -- -d )
  50   pop   edx
  51   ;; ECX=d1-high
  52   ;; EDX=d1-low
  53   not   ecx
  54   not   edx
  55   add   edx,1
  56   adc   ecx,0
  57   ;; push ECX:EDX
  58   push  edx
  59   urnext
  60 endcode
  61
  62 code: DSGN  ( d -- -1/0/1 )
  63   pop   edx
  64   ld    eax,edx
  65   or    eax,TOS
  66   jr    z,@f
  67   test  TOS,TOS
  68   ld    TOS,1
  69   jr    ns,@f
  70   ld    TOS,-1
  71 @@:
  72   urnext
  73 endcode
  74
  75
  76 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  77 code: S>D  ( n -- d )
  78   ld    eax,TOS
  79   cdq
  80   push  eax
  81   ld    TOS,edx
  82   urnext
  83 endcode
  84
  85 code: U>D  ( u -- ud )
  86   push  TOS
  87   xor   TOS,TOS
  88   urnext
  89 endcode
  90
  91 ;; with overflow clamping
  92 code: D>U  ( ud -- u )
  93   test  TOS,TOS
  94   pop   TOS
  95   jr    z,@f
  96   ld    TOS,-1
  97 @@:
  98   urnext
  99 endcode
 100
 101 ;; with overflow clamping
 102 code: D>S  ( d -- n )
 103   pop   eax
 104   jecxz .poscheck
 105   ;; overflow or negative
 106   test  TOS,TOS
 107   jr    ns,.posoverflow
 108   ;; definitely negative
 109   inc   TOS
 110   jr    nz,.negoverflow
 111   test  eax,eax
 112   jr    s,.good
 113 .negoverflow:
 114   ld    TOS,0x80000000
 115   jr    .done
 116 .poscheck:
 117   ;; positive, check for positive overflow
 118   test  eax,eax
 119   jr    ns,.good
 120 .posoverflow:
 121   ;; positive overflow
 122   ld    eax,0x7fffffff
 123 .good:
 124   ld    TOS,eax
 125 .done:
 126   urnext
 127 endcode
 128
 129
 130 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 131 code: 2AND  ( d0lo d0hi d1lo d1hi -- d0lo&d1lo d0hi&d1hi )
 132   pop   eax
 133   and   [esp],TOS
 134   and   [esp+4],eax
 135   pop   TOS
 136   urnext
 137 endcode
 138
 139 code: 2OR  ( d0lo d0hi d1lo d1hi -- d0lo|d1lo d0hi|d1hi )
 140   pop   eax
 141   or    [esp],TOS
 142   or    [esp+4],eax
 143   pop   TOS
 144   urnext
 145 endcode
 146
 147 code: 2XOR  ( d0lo d0hi d1lo d1hi -- d0lo^d1lo d0hi^d1hi )
 148   pop   eax
 149   xor   [esp],TOS
 150   xor   [esp+4],eax
 151   pop   TOS
 152   urnext
 153 endcode
 154
 155
 156 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 157 code: DLSHIFT  ( u cnt -- )
 158   pop   edx
 159   pop   eax
 160   cmp   TOS,32
 161   jr    ae,.bigshift
 162   shld  edx,eax,cl
 163   shl   eax,cl
 164 .done:
 165   push  eax
 166   ld    TOS,edx
 167   urnext
 168 .bigshift:
 169   cmp   TOS,64
 170   jr    ae,.zero
 171   ld    edx,eax
 172   sub   TOS,32
 173   shl   edx,cl
 174   jr    .onlyhigh
 175 .zero:
 176   xor   edx,edx
 177 .onlyhigh:
 178   xor   eax,eax
 179   jr    .done
 180 endcode
 181
 182 code: DRSHIFT  ( u cnt -- )
 183   pop   edx
 184   pop   eax
 185 drshift_main:
 186   cmp   TOS,32
 187   jr    ae,.bigshift
 188   shrd  eax,edx,cl
 189   shr   edx,cl
 190 .done:
 191   push  eax
 192   ld    TOS,edx
 193   urnext
 194 .bigshift:
 195   cp    TOS,64
 196   jr    ae,.zero
 197   ld    eax,edx
 198   sub   TOS,32
 199   shr   eax,cl
 200   jr    .onlylow
 201 .zero:
 202   xor   eax,eax
 203 .onlylow:
 204   xor   edx,edx
 205   jr    .done
 206 endcode
 207
 208 code: DARSHIFT  ( u cnt -- )
 209   pop   edx
 210   pop   eax
 211   cmp   TOS,32
 212   jr    ae,.bigshift
 213   shrd  eax,edx,cl
 214   sar   edx,cl
 215 .done:
 216   push  eax
 217   ld    TOS,edx
 218   urnext
 219 .bigshift:
 220   or    edx,edx
 221   jr    ns,drshift_main
 222   ld    eax,edx
 223   xor   edx,edx
 224   dec   edx
 225   cp    TOS,64
 226   jr    ae,.minusone
 227   sub   TOS,32
 228   sar   eax,cl
 229   jr    .done
 230 .minusone:
 231   xor   eax,eax
 232   dec   eax
 233   jr    .done
 234 endcode
 235
 236
 237 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 238 code: UM*  ( u0 u1 -- ud )
 239   pop   eax
 240   xchg  eax,TOS
 241   mul   TOS
 242   push  eax
 243   mov   TOS,edx
 244   urnext
 245 endcode
 246
 247 code: UM/MOD  ( ud1 u1 -- umod ures )
 248   pop   edx
 249   pop   eax
 250   div   TOS
 251   push  edx
 252   mov   TOS,eax
 253   urnext
 254 endcode
 255
 256 code: UM/  ( ud1 u1 -- ures )
 257   pop   edx
 258   pop   eax
 259   div   TOS
 260   mov   TOS,eax
 261   urnext
 262 endcode
 263
 264 code: UMMOD  ( ud1 u1 -- umod )
 265   pop   edx
 266   pop   eax
 267   div   TOS
 268   mov   TOS,edx
 269   urnext
 270 endcode
 271
 272
 273 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 274 code: M*  ( n0 n1 -- d )
 275   pop   eax
 276   xchg  eax,TOS
 277   imul  TOS
 278   push  eax
 279   mov   TOS,edx
 280   urnext
 281 endcode
 282
 283 code: M/MOD  ( d1 n1 -- nmod nres )
 284   pop   edx
 285   pop   eax
 286   idiv  TOS
 287   push  edx
 288   mov   TOS,eax
 289   urnext
 290 endcode
 291
 292 code: M/  ( d1 n1 -- nres )
 293   pop   edx
 294   pop   eax
 295   idiv  TOS
 296   mov   TOS,eax
 297   urnext
 298 endcode
 299
 300 code: MMOD  ( d1 n1 -- nmod )
 301   pop   edx
 302   pop   eax
 303   idiv  TOS
 304   mov   TOS,edx
 305   urnext
 306 endcode
 307
 308
 309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 310 code: D2*  ( d -- d*2 )
 311   pop   edx
 312   ;; ECX=d1-high
 313   ;; EDX=d1-low
 314   shl   edx,1
 315   rcl   ecx,1
 316   ;; push ECX:EDX
 317   push  edx
 318   urnext
 319 endcode
 320
 321 code: D2/  ( d -- d/2 )
 322   pop   edx
 323   ;; ECX=d1-high
 324   ;; EDX=d1-low
 325   sar   ecx,1
 326   rcr   edx,1
 327   ;; push ECX:EDX
 328   push  edx
 329   urnext
 330 endcode
 331
 332 code: D2U/  ( d1 -- d/2 )
 333   pop   edx
 334   ;; ECX=d1-high
 335   ;; EDX=d1-low
 336   shr   ecx,1
 337   rcr   edx,1
 338   ;; push ECX:EDX
 339   push  edx
 340   urnext
 341 endcode
 342
 343
 344 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 345 code: D0=  ( d -- flag )
 346   pop   edx
 347   ;; ECX=d1-high
 348   ;; EDX=d1-low
 349   or    ecx,edx
 350   cp    ecx,1
 351   ;;  C: ECX==0
 352   ;; NC: ECX!=0
 353   ld    ecx,0
 354   adc   ecx,0
 355   urnext
 356 endcode
 357
 358 code: D0!=  ( d -- flag )
 359   pop   edx
 360   ;; ECX=d1-high
 361   ;; EDX=d1-low
 362   or    ecx,edx
 363   cp    ecx,1
 364   ;;  C: ECX==0
 365   ;; NC: ECX!=0
 366   ld    ecx,1
 367   sbb   ecx,0
 368   urnext
 369 endcode
 370
 371 code: D0<  ( d -- flag )
 372   pop   edx
 373   ;; ECX=d1-high
 374   ;; EDX=d1-low
 375   cp    ecx,0x80000000
 376   ;;  C: ECX>=0
 377   ;; NC: ECX<0
 378   ld    ecx,1
 379   sbb   ecx,0
 380   urnext
 381 endcode
 382
 383 code: D0>  ( d -- flag )
 384   pop   edx
 385   ;; ECX=d1-high
 386   ;; EDX=d1-low
 387   ld    eax,ecx
 388   or    eax,edx
 389   jr    z,@f
 390   cp    ecx,0x80000000
 391   ;;  C: ECX>=0
 392   ;; NC: ECX<0
 393   ld    ecx,0
 394   adc   ecx,0
 395 @@:
 396   urnext
 397 endcode
 398
 399 code: D0<=  ( d -- flag )
 400   pop   edx
 401   ;; ECX=d1-high
 402   ;; EDX=d1-low
 403   ld    eax,ecx
 404   or    eax,edx
 405   jr    z,@f
 406   cp    ecx,0x80000000
 407   ;;  C: ECX>=0
 408   ;; NC: ECX<0
 409   ld    ecx,1
 410   sbb   ecx,0
 411   urnext
 412 @@:
 413   ld    TOS,1
 414   urnext
 415 endcode
 416
 417 code: D0>=  ( d -- flag )
 418   pop   edx
 419   ;; ECX=d1-high
 420   ;; EDX=d1-low
 421   ld    eax,ecx
 422   or    eax,edx
 423   jr    z,@f
 424   cp    ecx,0x80000000
 425   ;;  C: ECX>=0
 426   ;; NC: ECX<0
 427   ld    ecx,0
 428   adc   ecx,0
 429   urnext
 430 @@:
 431   ld    TOS,1
 432   urnext
 433 endcode
 434
 435
 436 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 437 code: D+  ( d1 d2 -- d )
 438   pop   ebx
 439   pop   edx
 440   pop   eax
 441   ;; ECX=d2-high
 442   ;; EBX=d2-low
 443   ;; EDX=d1-high
 444   ;; EAX=d1-low
 445   add   eax,ebx
 446   adc   edx,ecx
 447   ;; push EDX:EAX
 448   push  eax
 449   ld    TOS,edx
 450   urnext
 451 endcode
 452
 453 code: D-  ( d1 d2 -- d )
 454   pop   ebx
 455   pop   edx
 456   pop   eax
 457   ;; ECX=d2-high
 458   ;; EBX=d2-low
 459   ;; EDX=d1-high
 460   ;; EAX=d1-low
 461   sub   eax,ebx
 462   sbb   edx,ecx
 463   ;; push EDX:EAX
 464   push  eax
 465   ld    TOS,edx
 466   urnext
 467 endcode
 468
 469
 470 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 471 code: D=  ( d1 d2 -- flag )
 472   pop   ebx
 473   pop   edx
 474   pop   eax
 475   ;; ECX=d2-high
 476   ;; EBX=d2-low
 477   ;; EDX=d1-high
 478   ;; EAX=d1-low
 479   sub   eax,ebx
 480   sbb   edx,ecx
 481   or    eax,edx
 482   jr    z,@f
 483   ld    TOS,0
 484   urnext
 485 @@:
 486   ld    TOS,1
 487   urnext
 488 endcode
 489
 490 code: D<>  ( d1 d2 -- flag )
 491   pop   ebx
 492   pop   edx
 493   pop   eax
 494   ;; ECX=d2-high
 495   ;; EBX=d2-low
 496   ;; EDX=d1-high
 497   ;; EAX=d1-low
 498   sub   eax,ebx
 499   sbb   edx,ecx
 500   or    eax,edx
 501   jr    z,@f
 502   ld    TOS,1
 503   urnext
 504 @@:
 505   ld    TOS,0
 506   urnext
 507 endcode
 508
 509 code: D<  ( d1 d2 -- flag )
 510   pop   ebx
 511   pop   edx
 512   pop   eax
 513   ;; ECX=d2-high
 514   ;; EBX=d2-low
 515   ;; EDX=d1-high
 516   ;; EAX=d1-low
 517   ;; d1-d2: d1<d2:C; d1>d2:nc
 518   sub   eax,ebx
 519   sbb   edx,ecx
 520   setl  cl
 521   movzx TOS,cl
 522   urnext
 523 endcode
 524
 525 code: D>  ( d1 d2 -- flag )
 526   pop   ebx
 527   pop   edx
 528   pop   eax
 529   ;; ECX=d2-high
 530   ;; EBX=d2-low
 531   ;; EDX=d1-high
 532   ;; EAX=d1-low
 533   ;; d2-d1
 534   sub   ebx,eax
 535   sbb   ecx,edx
 536   setl  cl
 537   movzx TOS,cl
 538   urnext
 539 endcode
 540
 541 code: DU<  ( ud1 ud2 -- flag )
 542   pop   ebx
 543   pop   edx
 544   pop   eax
 545   ;; ECX=d2-high
 546   ;; EBX=d2-low
 547   ;; EDX=d1-high
 548   ;; EAX=d1-low
 549   ;; d1-d2
 550   sub   eax,ebx
 551   sbb   edx,ecx
 552   setc  cl
 553   movzx TOS,cl
 554   urnext
 555 endcode
 556
 557 code: DU>  ( ud1 ud2 -- flag )
 558   pop   ebx
 559   pop   edx
 560   pop   eax
 561   ;; ECX=d2-high
 562   ;; EBX=d2-low
 563   ;; EDX=d1-high
 564   ;; EAX=d1-low
 565   ;; d2-d1
 566   sub   ebx,eax
 567   sbb   ecx,edx
 568   setc  cl
 569   movzx TOS,cl
 570   urnext
 571 endcode
 572
 573 code: DU<=  ( ud1 ud2 -- flag )
 574   pop   ebx
 575   pop   edx
 576   pop   eax
 577   ;; ECX=d2-high
 578   ;; EBX=d2-low
 579   ;; EDX=d1-high
 580   ;; EAX=d1-low
 581   sub   ebx,eax
 582   sbb   ecx,edx
 583   ld    TOS,1
 584   sbb   TOS,0
 585   urnext
 586 endcode
 587
 588 code: DU>=  ( ud1 ud2 -- flag )
 589   pop   ebx
 590   pop   edx
 591   pop   eax
 592   ;; ECX=d2-high
 593   ;; EBX=d2-low
 594   ;; EDX=d1-high
 595   ;; EAX=d1-low
 596   sub   eax,ebx
 597   sbb   edx,ecx
 598   ld    TOS,1
 599   sbb   TOS,0
 600   urnext
 601 endcode
 602
 603
 604 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 605 : DMAX  ( d1 d2 -- max[d1,d2] )  2over 2over d< if 2swap endif 2drop ;
 606 : DMIN  ( d1 d2 -- min[d1,d2] )  2over 2over d> if 2swap endif 2drop ;
 607 : 2ROT  ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 )  2>r 2swap 2r> 2swap ;
 608 : 2NROT ( x1 x2 x3 x4 x5 x6 -- x5 x6 x1 x2 x3 x4 )  2swap 2>r 2swap 2r> ;
 609
 610 : M+  ( d1|ud1 n -- d2|ud2 )  s>d d+ ;
 611
 612
 613 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 614 code: UDS*  ( ud1 u --> ud2 )
 615   ld    edi,TOS
 616   pop   ebx
 617   pop   ecx
 618   ld    eax,ecx
 619   mul   edi
 620   push  edx
 621   ld    ecx,eax
 622   ld    eax,ebx
 623   mul   edi
 624   pop   edx
 625   add   eax,edx
 626   push  ecx
 627   ld    TOS,eax
 628   urnext
 629 endcode
 630
 631
 632 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 633 ;; 32-bit sqrt (because why not?)
 634 : SQRT ( u -- u )
 635   0 0  16 for
 636     >r d2* d2* r> 2* >r
 637     r@ 2* 1+ 2dup u>= if - r> 1+ >r else drop endif r>
 638   endfor
 639   nip nip
 640 ;
 641
 642
 643 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 644 code: UD*UD  ( ud0lo ud0hi ud1lo ud1hi -- ud2lo ud2hi )
 645   push  TOS
 646   pop   ecx
 647   pop   ebx
 648   pop   edx
 649   pop   eax
 650   imul  ecx,eax
 651   imul  edx,ebx
 652   add   ecx,edx
 653   mul   ebx
 654   add   ecx,edx
 655   push  eax
 656   urnext
 657 endcode
 658
 659 alias UD*UD D*