level1/21_math_compare.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 code: =  ( n0 n1 -- n0=n1? )
   8   pop   eax
   9   cp    eax,TOS
  10   sete  cl
  11   movzx TOS,cl
  12   urnext
  13 endcode
  14
  15 code: <>  ( n0 n1 -- n0<>n1? )
  16   pop   eax
  17   cp    eax,TOS
  18   setne cl
  19   movzx TOS,cl
  20   urnext
  21 endcode
  22
  23 code: <  ( n0 n1 -- n<n1? )
  24   pop   eax
  25   cmp   eax,TOS
  26   setl  cl
  27   movzx TOS,cl
  28   urnext
  29 endcode
  30
  31 code: >  ( n0 n1 -- n0>n1? )
  32   pop   eax
  33   cmp   eax,TOS
  34   setg  cl
  35   movzx TOS,cl
  36   urnext
  37 endcode
  38
  39 code: <=  ( n0 n1 -- n<=n1? )
  40   pop   eax
  41   cmp   eax,TOS
  42   setle cl
  43   movzx TOS,cl
  44   urnext
  45 endcode
  46
  47 code: >=  ( n0 n1 -- n0>=n1? )
  48   pop   eax
  49   cmp   eax,TOS
  50   setge cl
  51   movzx TOS,cl
  52   urnext
  53 endcode
  54
  55 code: U<  ( u0 u1 -- u0<u1? )
  56   pop   eax
  57   cmp   eax,TOS
  58   setb  cl
  59   movzx TOS,cl
  60   urnext
  61 endcode
  62
  63 code: U>  ( u0 u1 -- u0>u1? )
  64   pop   eax
  65   cmp   eax,TOS
  66   seta  cl
  67   movzx TOS,cl
  68   urnext
  69 endcode
  70
  71 code: U<=  ( u0 u1 -- u0<=u1? )
  72   pop   eax
  73   cmp   eax,TOS
  74   setbe cl
  75   movzx TOS,cl
  76   urnext
  77 endcode
  78
  79 code: U>=  ( u0 u1 -- u0>=u1? )
  80   pop   eax
  81   cmp   eax,TOS
  82   setae cl
  83   movzx TOS,cl
  84   urnext
  85 endcode
  86
  87
  88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  89 ;; same as NOT
  90 code: 0= ; ( n0 -- n=0? )
  91   test  TOS,TOS
  92   setz  cl
  93   movzx TOS,cl
  94   urnext
  95 endcode
  96
  97 ;; same as NOTNOT
  98 code: 0<>  ( n0 -- n<>0? )
  99   test  TOS,TOS
 100   setnz cl
 101   movzx TOS,cl
 102   urnext
 103 endcode
 104
 105 code: 0<  ( n0 -- n<0? )
 106   cp    TOS,0
 107   setl  cl
 108   movzx TOS,cl
 109   urnext
 110 endcode
 111
 112 code: 0>  ( n0 -- n>0? )
 113   cp    TOS,0
 114   setg  cl
 115   movzx TOS,cl
 116   urnext
 117 endcode
 118
 119 code: 0<=  ( n0 -- n<=0? )
 120   cp    TOS,0
 121   setle cl
 122   movzx TOS,cl
 123   urnext
 124 endcode
 125
 126 code: 0>=  ( n0 -- n>=0? )
 127   cp    TOS,0
 128   setge cl
 129   movzx TOS,cl
 130   urnext
 131 endcode
 132
 133
 134 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 135 ;; ooh...
 136 : BOUNDS  ( addr count -- addr+count addr )  over + swap ;
 137
 138 ;; n >= a and n < b
 139 ;; : WITHIN  ( n a b -- flag )  over - >r - r> u< ;
 140
 141 ;; n >= a and n < b
 142 code: WITHIN  ( n a b -- flag )
 143   pop   ebx
 144   pop   eax
 145   ld    edx,eax
 146   sub   TOS,ebx
 147   sub   edx,ebx
 148   sub   edx,TOS
 149   sbb   TOS,TOS
 150   neg   TOS      ;; because our "true" is 1, not -1
 151   urnext
 152 endcode
 153
 154 ;; u >= ua and u <= ub (unsigned compare)
 155 code: BOUNDS?  ( u ua ub -- flag )
 156   pop   ebx
 157   pop   edx
 158   cmp   edx,TOS
 159   ld    TOS,0
 160   jr    a,@f
 161   cmp   ebx,edx
 162   jr    a,@f
 163   inc   TOS
 164 @@:
 165   urnext
 166 endcode
 167
 168
 169 code: CLAMP  ( u ua ub -- u-clamped )
 170   pop   eax
 171   pop   ebx
 172   xchg  ebx,TOS
 173   ;; EAX: a
 174   ;; EBX: b
 175   ;; TOS: n
 176   cp    TOS,eax
 177   cmovl TOS,eax
 178   cp    TOS,ebx
 179   cmovg TOS,ebx
 180   urnext
 181 endcode
 182
 183 code: UCLAMP  ( u ua ub -- u-clamped )
 184   pop   eax
 185   pop   ebx
 186   xchg  ebx,TOS
 187   ;; EAX: a
 188   ;; EBX: b
 189   ;; TOS: n
 190   cp    TOS,eax
 191   cmovb TOS,eax
 192   cp    TOS,ebx
 193   cmova TOS,ebx
 194   urnext
 195 endcode
 196
 197
 198 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 199 ;; the following words are used in various CASE-OF
 200 ;;
 201
 202 code: (OF=)  ( n0 n1 -- n0 n0=n1 )
 203   ld    eax,[esp]
 204   cp    eax,TOS
 205   sete  cl
 206   movzx TOS,cl
 207   urnext
 208 endcode
 209 (hidden)
 210
 211 code: (OF<>)  ( n0 n1 -- n0 n0<>n1? )
 212   ld    eax,[esp]
 213   cp    eax,TOS
 214   setne cl
 215   movzx TOS,cl
 216   urnext
 217 endcode
 218 (hidden)
 219
 220 code: (OF<)  ( n0 n1 -- n0 n0<n1 )
 221   ld    eax,[esp]
 222   cmp   eax,TOS
 223   setl  cl
 224   movzx TOS,cl
 225   urnext
 226 endcode
 227 (hidden)
 228
 229 code: (OF>)  ( n0 n1 -- n0>n1? )
 230   ld    eax,[esp]
 231   cmp   eax,TOS
 232   setg  cl
 233   movzx TOS,cl
 234   urnext
 235 endcode
 236 (hidden)
 237
 238 code: (OF<=)  ( n0 n1 -- n<=n1? )
 239   ld    eax,[esp]
 240   cmp   eax,TOS
 241   setle cl
 242   movzx TOS,cl
 243   urnext
 244 endcode
 245 (hidden)
 246
 247 code: (OF>=)  ( n0 n1 -- n0>=n1? )
 248   ld    eax,[esp]
 249   cmp   eax,TOS
 250   setge cl
 251   movzx TOS,cl
 252   urnext
 253 endcode
 254 (hidden)
 255
 256 code: (OF-U<)  ( u0 u1 -- u0<u1? )
 257   ld    eax,[esp]
 258   cmp   eax,TOS
 259   setb  cl
 260   movzx TOS,cl
 261   urnext
 262 endcode
 263 (hidden)
 264
 265 code: (OF-U>)  ( u0 u1 -- u0>u1? )
 266   ld    eax,[esp]
 267   cmp   eax,TOS
 268   seta  cl
 269   movzx TOS,cl
 270   urnext
 271 endcode
 272 (hidden)
 273
 274 code: (OF-U<=)  ( u0 u1 -- u0<=u1? )
 275   ld    eax,[esp]
 276   cmp   eax,TOS
 277   setbe cl
 278   movzx TOS,cl
 279   urnext
 280 endcode
 281 (hidden)
 282
 283 code: (OF-U>=)  ( u0 u1 -- u0>=u1? )
 284   ld    eax,[esp]
 285   cmp   eax,TOS
 286   setae cl
 287   movzx TOS,cl
 288   urnext
 289 endcode
 290 (hidden)
 291
 292
 293 code: (OF-AND)  ( n0 n1 -- n0 n0&n1 )
 294   ld    eax,[esp]
 295   xchg  eax,TOS
 296   and   TOS,eax
 297   urnext
 298 endcode
 299 (hidden)
 300
 301 code: (OF-~AND)  ( n0 n1 -- n0&~n1 )
 302   not   TOS
 303   ld    eax,[esp]
 304   xchg  eax,TOS
 305   and   TOS,eax
 306   urnext
 307 endcode
 308 (hidden)
 309
 310 ;; n >= a and n < b
 311 code: (OF-WITHIN)  ( n a b -- a flag )
 312   pop   ebx
 313   ld    eax,[esp]
 314   ld    edx,eax
 315   sub   TOS,ebx
 316   sub   edx,ebx
 317   sub   edx,TOS
 318   sbb   TOS,TOS
 319   neg   TOS      ;; because our "true" is 1, not -1
 320   urnext
 321 endcode
 322 (hidden)
 323
 324 ;; u >= ua and u <= ub (unsigned compare)
 325 code: (OF-BOUNDS)  ( u ua ub -- n flag )
 326   pop   ebx
 327   ld    edx,[esp]
 328   cmp   edx,TOS
 329   ld    TOS,0
 330   jr    a,@f
 331   cmp   ebx,edx
 332   jr    a,@f
 333   inc   TOS
 334 @@:
 335   urnext
 336 endcode
 337 (hidden)