level0/urforth0_w_math_base.asm

   1 ;; Native x86 GNU/Linux Forth System, Direct Threaded Code
   2 ;;
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;;
   5 ;; This program is free software: you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation, version 3 of the License ONLY.
   8 ;;
   9 ;; This program is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;; GNU General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU General Public License
  15 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 urword_code "BSWAP-WORD",bswap_word
  20 ;; ( u -- u )
  21 ;; swap bytes of the low word
  22 ;; high word is untouched
  23   xchg  cl,ch
  24   urnext
  25 urword_end
  26
  27
  28 urword_code "BSWAP-DWORD",bswap_dword
  29 ;; ( u -- u )
  30 ;; swap all dword bytes
  31   bswap TOS
  32   urnext
  33 urword_end
  34
  35
  36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37 urword_code "CELLS",cells
  38 ;; ( count -- count*4 )
  39   shl   TOS,2
  40   urnext
  41 urword_end
  42
  43 urword_code "+CELLS",addcells
  44 ;; ( addr count -- addr+count*4 )
  45   shl   TOS,2
  46   pop   eax
  47   add   TOS,eax
  48   urnext
  49 urword_end
  50
  51 urword_code "-CELLS",subcells
  52 ;; ( addr count -- addr-count*4 )
  53   shl   TOS,2
  54   pop   eax
  55   sub   eax,TOS
  56   ld    TOS,eax
  57   urnext
  58 urword_end
  59
  60 urword_code "CELL+",cellinc
  61 ;; ( count -- count+4 )
  62   add   TOS,4
  63   urnext
  64 urword_end
  65
  66 urword_code "CELL-",celldec
  67 ;; ( count -- count-4 )
  68   sub   TOS,4
  69   urnext
  70 urword_end
  71
  72
  73 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  74 urword_code "1+",1inc
  75 ;; ( n -- n+1 )
  76   inc   TOS
  77   urnext
  78 urword_end
  79
  80 urword_code "1-",1dec
  81 ;; ( n -- n-1 )
  82   dec   TOS
  83   urnext
  84 urword_end
  85
  86 urword_code "2+",2inc
  87 ;; ( n -- n+2 )
  88   add   TOS,2
  89   urnext
  90 urword_end
  91
  92 urword_code "2-",2dec
  93 ;; ( n -- n-2 )
  94   sub   TOS,2
  95   urnext
  96 urword_end
  97
  98 urword_code "4+",4inc
  99 ;; ( n -- n+4 )
 100   add   TOS,4
 101   urnext
 102 urword_end
 103
 104 urword_code "4-",4dec
 105 ;; ( n -- n-4 )
 106   sub   TOS,4
 107   urnext
 108 urword_end
 109
 110 urword_code "8+",8inc
 111 ;; ( n -- n+8 )
 112   add   TOS,8
 113   urnext
 114 urword_end
 115
 116 urword_code "8-",8dec
 117 ;; ( n -- n-8 )
 118   sub   TOS,8
 119   urnext
 120 urword_end
 121
 122
 123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 124 urword_code "NOT",not
 125 ;; ( n -- !n )
 126   cmp   TOS,1
 127   ;  C: TOS == 0
 128   ; NC: TOS != 0
 129   mov   TOS,0
 130   adc   TOS,0
 131   urnext
 132 urword_end
 133
 134 urword_code "NOTNOT",notnot
 135 ;; ( n -- !!n )
 136   cmp   TOS,1
 137   ;  C: TOS == 0
 138   ; NC: TOS != 0
 139   mov   TOS,1
 140   sbb   TOS,0
 141   urnext
 142 urword_end
 143
 144 urword_code "BITNOT",bitnot
 145 ;; ( n -- ~n )
 146   xor   TOS,0xffffffff
 147   urnext
 148 urword_end
 149
 150 urword_code "AND",and
 151 ;; ( n0 n1 -- n0&n1 )
 152   pop   eax
 153   xchg  eax,TOS
 154   and   TOS,eax
 155   urnext
 156 urword_end
 157
 158 urword_code "OR",or
 159 ;; ( n0 n1 -- n0|n1 )
 160   pop   eax
 161   xchg  eax,TOS
 162   or    TOS,eax
 163   urnext
 164 urword_end
 165
 166 urword_code "XOR",xor
 167 ;; ( n0 n1 -- n0^n1 )
 168   pop   eax
 169   xchg  eax,TOS
 170   xor   TOS,eax
 171   urnext
 172 urword_end
 173
 174
 175 urword_code "LOGAND",land
 176 ;; ( n0 n1 -- n0&&n1 )
 177   pop   eax
 178   or    al,al
 179   setnz al
 180   or    cl,cl
 181   setnz cl
 182   and   cl,al
 183   and   ecx,0xff
 184   urnext
 185 urword_end
 186
 187 urword_code "LOGOR",lor
 188 ;; ( n0 n1 -- n0||n1 )
 189   pop   eax
 190   or    TOS,eax
 191   or    TOS,TOS
 192   setnz cl
 193   and   ecx,0xff
 194   urnext
 195 urword_end
 196
 197
 198 urword_code "LSHIFT",lshift
 199 ;; ( n0 n1 -- n0<<n1 )
 200   pop   eax
 201   cmp   TOS,32
 202   jnc   fword_shl_zero
 203   ; assume that TOS is in ECX
 204   shl   eax,cl
 205   mov   TOS,eax
 206   urnext
 207 fword_shl_zero:
 208   xor   TOS,TOS
 209   urnext
 210 urword_end
 211
 212 urword_code "RSHIFT",rshift
 213 ;; ( n0 n1 -- n0>>n1 )
 214   pop   eax
 215   cmp   TOS,32
 216   jnc   .zero
 217   ; assume that TOS is in ECX
 218   shr   eax,cl
 219   mov   TOS,eax
 220   urnext
 221 .zero:
 222   xor   TOS,TOS
 223   urnext
 224 urword_end
 225
 226 urword_code "ARSHIFT",arshift
 227 ;; ( n0 n1 -- n0>>n1 )
 228   pop   eax
 229   cmp   TOS,32
 230   jnc   .toobig
 231   ; assume that TOS is in ECX
 232   sar   eax,cl
 233   mov   TOS,eax
 234   urnext
 235 .toobig:
 236   mov   TOS,-1
 237   cmp   eax,0x80000000
 238   adc   TOS,0
 239   urnext
 240 urword_end
 241
 242
 243 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 244 urword_code "LROTATE",lrotate
 245 ;; ( n0 n1 -- n0 rol n1 )
 246   pop   eax
 247   and   cl,31
 248   rol   eax,cl
 249   ld    TOS,eax
 250   urnext
 251 urword_end
 252
 253 urword_code "RROTATE",rrotate
 254 ;; ( n0 n1 -- n0 ror n1 )
 255   pop   eax
 256   and   cl,31
 257   ror   eax,cl
 258   ld    TOS,eax
 259   urnext
 260 urword_end
 261
 262 urword_code "LROTATE-WORD",lrotate_word
 263 ;; ( n0 n1 -- n0 rol n1 )
 264   pop   eax
 265   and   cl,31
 266   rol   ax,cl
 267   ld    TOS,eax
 268   urnext
 269 urword_end
 270
 271 urword_code "RROTATE-WORD",rrotate_word
 272 ;; ( n0 n1 -- n0 ror n1 )
 273   pop   eax
 274   and   cl,31
 275   ror   ax,cl
 276   ld    TOS,eax
 277   urnext
 278 urword_end
 279
 280 urword_code "LROTATE-BYTE",lrotate_byte
 281 ;; ( n0 n1 -- n0 rol n1 )
 282   pop   eax
 283   and   cl,31
 284   rol   al,cl
 285   ld    TOS,eax
 286   urnext
 287 urword_end
 288
 289 urword_code "RROTATE-BYTE",rrotate_byte
 290 ;; ( n0 n1 -- n0 ror n1 )
 291   pop   eax
 292   and   cl,31
 293   ror   al,cl
 294   ld    TOS,eax
 295   urnext
 296 urword_end
 297
 298
 299 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 300 urword_code "+",add
 301 ;; ( n0 n1 -- n0+n1 )
 302   pop   eax
 303   add   TOS,eax
 304   urnext
 305 urword_end
 306
 307 urword_code "-",sub
 308 ;; ( n0 n1 -- n0-n1 )
 309   pop   eax
 310   ; EAX=n0
 311   ; TOS=n1
 312   sub   eax,TOS
 313   mov   TOS,eax
 314   urnext
 315 urword_end
 316
 317
 318 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 319 urword_code "2*",2imul
 320 ;; ( n -- n*2 )
 321   shl   TOS,1
 322   urnext
 323 urword_end
 324
 325 urword_code "2/",2idiv
 326 ;; ( n -- n/2 )
 327   sar   TOS,1
 328   urnext
 329 urword_end
 330
 331
 332 urword_code "2U*",2umul
 333 ;; ( n -- n*2 )
 334   shl   TOS,1
 335   urnext
 336 urword_end
 337
 338 urword_code "2U/",2udiv
 339 ;; ( n -- n/2 )
 340   shr   TOS,1
 341   urnext
 342 urword_end
 343
 344
 345 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 346 urword_code "NEGATE",negate
 347 ;; ( n -- -n )
 348   neg   TOS
 349   urnext
 350 urword_end
 351
 352 urword_code "ABS",abs
 353 ;; ( n -- |n| )
 354   test  TOS,0x80000000
 355   jz    @f
 356   neg   TOS
 357 @@:
 358   urnext
 359 urword_end
 360
 361
 362 urword_code "UMIN",umin
 363 ;; ( u0 u1 -- umin )
 364   pop   eax
 365   ; EAX=u0
 366   ; TOS=u1
 367   cp    eax,TOS
 368   cmovc TOS,eax
 369   urnext
 370 urword_end
 371
 372 urword_code "UMAX",umax
 373 ;; ( u0 u1 -- umax )
 374   pop   eax
 375   ; EAX=u0
 376   ; TOS=u1
 377   cp    TOS,eax
 378   cmovc TOS,eax
 379   urnext
 380 urword_end
 381
 382 urword_code "MIN",min
 383 ;; ( n0 n1 -- nmin )
 384   pop   eax
 385   ; EAX=u0
 386   ; TOS=u1
 387   cp    TOS,eax
 388   cmovg TOS,eax
 389   urnext
 390 urword_end
 391
 392 urword_code "MAX",max
 393 ;; ( n0 n1 -- nmax )
 394   pop   eax
 395   ; EAX=u0
 396   ; TOS=u1
 397   cp    TOS,eax
 398   cmovl TOS,eax
 399   urnext
 400 urword_end
 401
 402
 403 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 404 urword_code "C>S",c2s
 405 ;; ( n-8-bit -- n )
 406   movsx TOS,cl
 407   urnext
 408 urword_end
 409
 410 urword_code "C>U",c2u
 411 ;; ( u-8-bit -- u )
 412   movzx TOS,cl
 413   urnext
 414 urword_end
 415
 416 urword_code "S>C",s2c
 417 ;; ( n -- n-8-bit )
 418 ;; with clamping
 419   test  TOS,0x80000000
 420   jr    nz,.negative
 421   cp    TOS,0x80
 422   jr    c,.done
 423   ld    TOS,0x7f
 424   jr    .done
 425 .negative:
 426   cp    TOS,0xffffff80
 427   jr    nc,.done
 428   ld    TOS,0x80
 429 .done:
 430   movsx TOS,cl
 431   urnext
 432 urword_end
 433
 434 urword_code "U>C",u2c
 435 ;; ( u -- u-8-bit )
 436 ;; with clamping
 437   cp    TOS,0x100
 438   jr    c,.done
 439   mov   cl,0xff
 440 .done:
 441   movzx TOS,cl
 442   urnext
 443 urword_end