urflibs/init/bootstrap/10-mem-utils.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrAsm Forth Engine!
   4 ;; GPLv3 ONLY
   5 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;; memory utilities
   9 ;;
  10
  11 : C@A ( -- byte )  0 C@A+ ;
  12 : W@A ( -- word )  0 W@A+ ;
  13 : @A ( -- value )  0 @A+ ;
  14
  15 : C!A ( byte -- )  0 C!A+ ;
  16 : W!A ( word -- )  0 W!A+ ;
  17 : !A ( value -- )  0 !A+ ;
  18
  19 : 1+  ( a -- a+1 )  1 + ;
  20 : 2+  ( a -- a+2 )  2 + ;
  21 : 4+  ( a -- a+2 )  4 + ;
  22 : 1-  ( a -- a-1 )  1 - ;
  23 : 2-  ( a -- a-2 )  2 - ;
  24 : 4-  ( a -- a-2 )  4 - ;
  25
  26 : 0=  ( n -- n==0 )  0 = ;
  27 : 0<>  ( n -- n<>0 )  0 <> ;
  28 : 0<  ( n -- n==0 )  0 < ;
  29 : 0<=  ( n -- n==0 )  0 <= ;
  30 : 0>  ( n -- n<>0 )  0 > ;
  31 : 0>=  ( n -- n<>0 )  0 >= ;
  32
  33 : NOTNOT  ( a -- !!a ) NOT NOT ;
  34
  35 ;; yay, ABS without branches! because i can, lol
  36 \ a + (a>>31) ^ (a>>31)
  37 : ABS  ( a -- |a| )  DUP -31 ASH DUP ROT + XOR ;
  38 : SIGN?  ( n -- -1|0|1 )  DUP -31 ASH SWAP 0> 1 AND + ;
  39 : NEGATE  ( n -- -n )  BITNOT 1+ ;
  40
  41 : LSHIFT  ( n count -- n )  DUP 0< " invalid shift amount" ?ERROR LSH ;
  42 : RSHIFT  ( n count -- n )  DUP 0< " invalid shift amount" ?ERROR NEGATE LSH ;
  43 : ARSHIFT ( n count -- n )  DUP 0< " invalid shift amount" ?ERROR NEGATE ASH ;
  44
  45 ALIAS LSHIFT SHL
  46 ALIAS RSHIFT SHR
  47 ALIAS LSHIFT SAL
  48 ALIAS ARSHIFT SAR
  49
  50 : LO-WORD  ( a -- a&0xffff )  0xffff AND ;
  51 : HI-WORD  ( a -- [a>>16]&0xffff ) -16 LSH LO-WORD ;
  52
  53 : LO-BYTE  ( a -- a&0xff )  0xff AND ;
  54 : HI-BYTE  ( a -- [a>>8]&0xff )  -8 LSH LO-BYTE ;
  55
  56 \ : ~AND  ( a b -- a&~b )  BITNOT AND ;
  57
  58 \ : SWAP!  ( addr value -- )  SWAP ! ;
  59 \ : ~AND!  ( value addr -- )  DUP @ ROT ~AND SWAP! ;
  60 \ : OR!    ( value addr -- )  DUP @ ROT OR SWAP! ;
  61 \ : XOR!   ( value addr -- )  DUP @ ROT XOR SWAP! ;
  62 : 0!     ( addr -- )  0 SWAP! ;
  63 : 1!     ( addr -- )  1 SWAP! ;
  64 : +!     ( n addr -- )  DUP @ ROT + SWAP! ;
  65 : -!     ( n addr -- )  DUP @ ROT - SWAP! ;
  66 : 1+!    ( addr -- )  1 SWAP +! ;
  67 : 1-!    ( addr -- )  1 SWAP -! ;
  68
  69 : BCOUNT  ( addr -- addr+1 count )  DUP 1+ SWAP C@ ;
  70 : COUNT   ( addr -- addr+4 count )  DUP 4+ SWAP @ ;
  71
  72 : HEX  ( -- )  16 BASE ! ;
  73 : DECIMAL  ( -- )  10 BASE ! ;
  74 : OCTAL  ( -- )  8 BASE ! ;
  75 : BINARY  ( -- )  2 BASE ! ;
  76
  77 : WITHIN  ( value a b -- value>=a&&value<b )
  78   OVER - >R - R> U<
  79 ;
  80
  81 : UWITHIN  ( value a b -- value>=a&&value<b )
  82   ROT DUP >R SWAP U< R> ROT U>= AND
  83 ;
  84
  85 ;; unsigned
  86 : BOUNDS?  ( value a b -- value>=a&&value<=b )
  87   ROT DUP >R SWAP U<= R> ROT U>= AND
  88 ;
  89
  90
  91 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92 ;; additional stack ops
  93 ;;
  94 : NIP  ( a b -- b )  SWAP DROP ;
  95 : TUCK  ( a b -- b a b )  SWAP OVER ;