urflibs/init/stdlib.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrAsm Forth Engine!
   4 ;; GPLv3 ONLY
   5 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7
   8 : USERVAR  ( val -- )  \ name
   9   (USER-VAR-USED) @
  10   DUP CELL+  (USER-VAR-ADDR) (USER-VAR-SIZE) + U>= " too many user vars" ?ERROR
  11   DUP ROT SWAP!
  12   DUP CELL+ (USER-VAR-USED) !
  13   CREATE , DOES> @
  14 ;
  15
  16 : 2>R  ( lo hi -- | lo hi )  R> ROT >R SWAP >R >R ;
  17 : 2R>  ( | lo hi -- lo hi )  R> R> R> SWAP ROT >R ;
  18 : 2R@  ( | lo hi -- lo hi | lo hi )  2 RPICK 1 RPICK ;
  19 : 2RDROP  R> RDROP RDROP >R ;
  20
  21
  22 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;; working with double (64-bit) numbers
  24 ;;
  25
  26 ;; convert single number do double number
  27 : S>D  ( n -- nl nh )  DUP 0< IF -1 ELSE 0 ENDIF ;
  28 : U>D  ( n -- nl nh )  0 ;
  29 : D>S  ( lo hi -- lo )  DROP ;
  30
  31 : DNEGATE  ( lo hi -- lo hi )  BITNOT SWAP BITNOT SWAP 1 0 D+ ;
  32
  33 : D<>  ( lo0 hi0 lo1 hi1 -- bool )  D= NOT ;
  34 : D>=  ( lo0 hi0 lo1 hi1 -- bool )  D< NOT ;
  35 : D>   ( lo0 hi0 lo1 hi1 -- bool )  D<= NOT ;
  36
  37 : DU>=  ( lo0 hi0 lo1 hi1 -- bool )  DU< NOT ;
  38 : DU>   ( lo0 hi0 lo1 hi1 -- bool )  DU<= NOT ;
  39
  40 : D0<  ( lo hi -- bool )  NIP 0< ;
  41 : D0>  ( lo hi -- bool )  NIP 0> ;
  42 : D0=  ( lo hi -- bool )  OR 0= ;
  43 : D0<>  ( lo hi -- bool )  OR 0<> ;
  44
  45 : D2*  ( lo hi -- lo hi )  2DUP D+ ;
  46 : D2/  ( lo hi -- lo hi )  DUP >R -1 ASH  SWAP -1 LSH R> 1 AND IF 0x8000_0000 OR ENDIF SWAP ;
  47
  48 : DABS ( lo hi -- lo hi )  DUP 0< IF DNEGATE ENDIF ;
  49
  50 : DMAX  ( d1 d2 -- max[d1,d2] )  2over 2over d< if 2swap endif 2drop ;
  51 : DMIN  ( d1 d2 -- min[d1,d2] )  2over 2over d> if 2swap endif 2drop ;
  52 : 2ROT  ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 )  2>r 2swap 2r> 2swap ;
  53 : 2NROT ( x1 x2 x3 x4 x5 x6 -- x5 x6 x1 x2 x3 x4 )  2swap 2>r 2swap 2r> ;
  54
  55 : M+  ( d1|ud1 n -- d2|ud2 )  S>D D+ ;
  56
  57
  58 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59 ;; some standard words
  60 ;;
  61
  62 : :NONAME  ( -- cfa )
  63   COMPILER:(CREATE-NAMELESS)
  64   COMPILER:(CTLID-COLON)
  65   ]  ;; turn on the compiler
  66   COMPILER:(TRACE-COLON)  ;; call tracer
  67 ;
  68
  69 : DEPTH  ( -- data-stack-depth )
  70   MTASK:ACTIVE-STATE MTASK:STATE-SP@
  71 ;
  72
  73 ;; this is The Word that should be used for vocabulary searches
  74 ;; this does namespace resolution
  75 ;; if "a:b" is not a known word, try to search "b" in dictionary "a"
  76 ;; things like "a:b:c" are allowed too
  77 ;; returns `1` if cfa is immediate, or `-1` if it is a normal word
  78 : WFIND  ( addr count -- cfa -1 // cfa 1 // false )
  79   FIND-WORD IF
  80     DUP COMPILER:IMMEDIATE-WORD? IF 1 ELSE -1 ENDIF
  81   ELSE FALSE
  82   ENDIF
  83 ;
  84
  85
  86 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87 ;; additional string operations
  88 ;;
  89 ALSO STRING DEFINITIONS
  90
  91 : NCOUNT  ( addr -- addr+4 bcount )
  92   DUP C@ SWAP CELL+ SWAP
  93 ;
  94
  95 : CAT-CHAR  ( addr count char -- addr count+ )
  96   >R 2DUP + R> SWAP C!
  97   1+
  98 ;
  99
 100 : CAT  ( addr count addr1 count1 -- addr count+count1 )
 101   ?DUP IF
 102     OVER + SWAP DO
 103       I C@ CAT-CHAR
 104     LOOP
 105   ELSE
 106     DROP
 107   ENDIF
 108 ;
 109
 110 ;; copy string to PAD (count is not set)
 111 : TO-PAD  ( addr count -- pad+1 count )
 112   PAD 1+ 0 2SWAP CAT
 113 ;
 114
 115 : CHAR-UPPER  ( ch -- ch )
 116   0xff AND DUP [CHAR] a [CHAR] z BOUNDS? IF 32 - ENDIF
 117 ;
 118
 119 : UPPER  ( addr count -- )
 120   FOR DUP C@ [CHAR] a [CHAR] z BOUNDS? IF DUP C@ 32 - OVER C! ENDIF 1+ ENDFOR DROP
 121 ;
 122
 123 : -TRAILING  ( addr count -- addr count )
 124   A>R OVER >A
 125   BEGIN
 126     DUP 0>
 127   WHILE  ( addr count )
 128     DUP 1- C@A+ BL <= IF 1- FALSE ELSE TRUE ENDIF
 129   UNTIL
 130   R>A
 131 ;
 132
 133 ;; adjust the character string at c-addr1 by n characters.
 134 ;; the resulting character string, specified by c-addr2 u2,
 135 ;; begins at c-addr1 plus n characters and is u1 minus n characters long.
 136 ;; doesn't check length, allows negative n.
 137 : /STRING  ( c-addr1 count n -- c-addr2 count )
 138   DUP >R - SWAP R> + SWAP
 139 ;
 140
 141 ;; checks length, doesn't strip anything from an empty string
 142 : /CHAR  ( c-addr1 u1 -- c-addr+1 u1-1 )
 143   DUP 0<= IF DROP 0 ELSE SWAP 1+ SWAP 1- ENDIF
 144 ;
 145
 146 ;; checks length, doesn't strip anything from an empty string
 147 : /2CHARS  ( c-addr1 u1 -- c-addr+2 u1-2 )
 148   DUP 1 <= IF DROP 0 ELSE SWAP 2+ SWAP 2- ENDIF
 149 ;
 150
 151 : (CHAR-DIGIT)  ( ch -- digit true // false )
 152   DUP CASE
 153     [CHAR] 0 [CHAR] 9 BOUNDS-OF [CHAR] 0 - TRUE ENDOF
 154     [CHAR] A [CHAR] Z BOUNDS-OF [CHAR] A - 10 + TRUE ENDOF
 155     [CHAR] a [CHAR] z BOUNDS-OF [CHAR] a - 10 + TRUE ENDOF
 156     OTHERWISE 2DROP FALSE
 157   ENDCASE
 158 ;
 159
 160 : DIGIT  ( char base -- digit TRUE / FALSE )
 161   SWAP (CHAR-DIGIT) IF  ( base digit )
 162     OVER 1 36 BOUNDS? IF  ( base digit )
 163       DUP ROT U< IF TRUE ELSE DROP FALSE ENDIF
 164     ELSE ( base digit ) 2DROP FALSE
 165     ENDIF
 166   ELSE  ( base )  DROP FALSE
 167   ENDIF
 168 ;
 169
 170 : DIGIT?  ( ch base -- flag )  DIGIT DUP IF NIP ENDIF ;
 171
 172 PREVIOUS DEFINITIONS
 173
 174
 175 ;; +- ( n1 n2 -- n3 )
 176 ;; Apply the sign of n2 to n1, which is left as n3.
 177 : +-
 178   SWAP 0< IF ABS NEGATE ELSE ABS ENDIF
 179 ;
 180
 181 ;; -1, 0 or 1
 182 : MEMCMP  ( addr1 addr2 size -- n )
 183   A>R  >R 0 NROT R>  ( 0 a1 a2 sz | rega )
 184   FOR  ( 0 a1 a2 | rega )
 185     OVER >A C@A OVER >A C@A -
 186     ?DUP IF  ( 0 a1 a2 sgn )  >R DROP R> NROT BREAK  ENDIF
 187     1+ SWAP 1+ SWAP
 188   ENDFOR 2DROP
 189   R>A  SIGN?
 190 ;
 191
 192 ;; -1, 0 or 1
 193 : MEMCMP-CI  ( addr1 addr2 size -- n )
 194   A>R  >R 0 NROT R>  ( 0 a1 a2 sz | rega )
 195   FOR  ( 0 a1 a2 | rega )
 196     OVER >A C@A STRING:CHAR-UPPER OVER >A C@A STRING:CHAR-UPPER -
 197     ?DUP IF  ( 0 a1 a2 sgn )  >R DROP R> NROT BREAK  ENDIF
 198     1+ SWAP 1+ SWAP
 199   ENDFOR 2DROP
 200   R>A  SIGN?
 201 ;
 202
 203 : UCMP  ( a b -- -1|0|1 )
 204   2DUP U< IF 2DROP -1
 205   ELSE U> IF 1
 206   ELSE 0
 207   ENDIF ENDIF
 208 ;
 209
 210 : COMPARE  ( c-addr1 u1 c-addr2 u2 -- n )
 211   rot 2dup 2>r umin memcmp ?dup ifnot 2r> swap ucmp else 2rdrop endif
 212 ;
 213
 214 : COMPARE-CI  ( c-addr1 u1 c-addr2 u2 -- n )
 215   rot 2dup 2>r umin memcmp-ci ?dup ifnot 2r> swap ucmp else 2rdrop endif
 216 ;
 217
 218 : FILL  ( addr count byte -- )
 219   A>R ROT >A
 220   SWAP FOR DUP I C!A+ ENDFOR DROP
 221   R>A
 222 ;
 223
 224 : BLANKS  ( addr count -- )  BL FILL ;
 225 : ERASE  ( addr count -- )  0 FILL ;
 226
 227 : CMOVE  ( source dest count -- )
 228   \ ." CMOVE: from=" ROT DUP U. NROT
 229   \ ." to=" OVER U.
 230   \ ." count=" DUP U.
 231   \ CR
 232   \ FOR
 233   \   OVER C@ OVER C! 1+ SWAP 1+ SWAP
 234   \ ENDFOR 2DROP
 235   A>R
 236   FOR  ( source dest )
 237     SWAP DUP >A 1+ SWAP      ( source+1 dest ) -- source in A
 238     C@A SWAP DUP >A 1+ SWAP  ( source+1 dest+1 c ) -- dest in A
 239     C!A
 240   ENDFOR 2DROP
 241   R>A
 242 ;
 243
 244 : CMOVE>  ( source dest count -- )
 245   \ ." CMOVE>: from=" ROT DUP U. NROT
 246   \ ." to=" OVER U.
 247   \ ." count=" DUP U.
 248   \ CR
 249   A>R
 250   >R SWAP R@ + SWAP R@ + R>
 251   FOR  ( source+count dest+count )
 252     SWAP 1- DUP >A SWAP      ( source-1 dest ) -- source-1 in A
 253     C@A SWAP 1- DUP >A SWAP  ( source-1 dest-1 c ) -- dest-1 in A
 254     C!A
 255   ENDFOR 2DROP
 256   R>A
 257 ;
 258
 259 ;; uses CMOVE or CMOVE> (i.e. works like libc `memmove`)
 260 ;; negative length does nothing (i.e. you cannot MOVE more that 2GB of data)
 261 : MOVE  ( from to len -- )
 262   DUP 0> IF
 263     >R
 264     2DUP U< IF  ;; from < to: may need to use CMOVE> (copy backwards)
 265       R> CMOVE>
 266     ELSE  ;; from > to: use CMOVE (normal forward copy)
 267       R> CMOVE
 268     ENDIF
 269   ELSE DROP 2DROP
 270   ENDIF
 271 ;
 272
 273
 274 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 275 ;; wordlist utilities
 276 ;;
 277
 278 : (.-VOCID-NAME)  ( vocid -- )
 279   COMPILER:(VOCOFS-HEADER) + @
 280   ?DUP IF STRING:NCOUNT XTYPE
 281   ELSE ." <unnamed>"
 282   ENDIF
 283 ; (HIDDEN)
 284
 285 : SHOW-WORDLISTS  ( -- )
 286   ." === WORDLISTS ===\n"
 287   (VSP@) FOR
 288     2 SPACES I 0 .R ." : " I (VSP-AT@) (.-VOCID-NAME) CR
 289   ENDFOR
 290   ." CONTEXT: " CONTEXT @ (.-VOCID-NAME) CR
 291   ." CURRENT: " CURRENT @ (.-VOCID-NAME) CR
 292 ;
 293
 294
 295 80 VALUE WORDS-WIDTH
 296
 297 : VOCID-WORDS ( vocid -- )
 298   LOCALS: iter cols
 299   VOC-LATEST
 300   TO :iter  0 TO :cols
 301   BEGIN
 302     :iter
 303   WHILE
 304     :iter LFA->NFA @ COMPILER:(WFLAG-SMUDGE) COMPILER:(WFLAG-HIDDEN) OR  AND
 305     IFNOT
 306       :iter LFA->NFA STRING:NCOUNT  ;; ( addr count )
 307       :cols OVER + 1+ DUP TO :cols  ;; ( addr count cols )
 308       WORDS-WIDTH > IF DUP 1+ TO :cols CR ENDIF SPACE XTYPE
 309     ENDIF
 310     :iter @ TO :iter
 311   REPEAT CR
 312 ;
 313
 314 : WORDS ( -- )  CONTEXT @ VOCID-WORDS ;
 315
 316
 317 : 2@  ( n -- lo hi )  DUP @ SWAP 4+ @ SWAP ;
 318 : 2!  ( lo hi n -- )  2DUP ! NIP 4+ ! ;
 319 : @EXECUTE  ( addr )  @ EXECUTE-TAIL ;
 320 : @EXECUTE-TAIL  ( addr )  RDROP @ EXECUTE-TAIL ;
 321 \ for MINIOOF and such
 322 : (NOTIMPL)  ( )  " not implemented" ERROR ;