urflibs/init/stdlib.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrForth/C Forth Engine!
   4 ;; Copyright (C) 2023 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7
   8
   9 : USERVAR  ( val -- )  \ name
  10   (USER-VAR-USED) @
  11   DUP CELL+  (USER-VAR-ADDR) (USER-VAR-SIZE) + U>= " too many user vars" ?ERROR
  12   DUP ROT SWAP!
  13   DUP CELL+ (USER-VAR-USED) !
  14   CREATE , DOES> @
  15 ;
  16
  17 : 2>R  ( lo hi -- | lo hi )  R> ROT >R SWAP >R >R ;
  18 : 2R>  ( | lo hi -- lo hi )  R> R> R> SWAP ROT >R ;
  19 : 2R@  ( | lo hi -- lo hi | lo hi )  2 RPICK 1 RPICK ;
  20 : 2RDROP  R> RDROP RDROP >R ;
  21
  22
  23 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24 ;; working with double (64-bit) numbers
  25 ;;
  26
  27 ;; convert single number do double number
  28 : S>D  ( n -- nl nh )  DUP 0< IF -1 ELSE 0 ENDIF ;
  29 : U>D  ( n -- nl nh )  0 ;
  30 : D>S  ( lo hi -- lo )  DROP ;
  31
  32 : DNEGATE  ( lo hi -- lo hi )  BITNOT SWAP BITNOT SWAP 1 0 D+ ;
  33
  34 : D<>  ( lo0 hi0 lo1 hi1 -- bool )  D= NOT ;
  35 : D>=  ( lo0 hi0 lo1 hi1 -- bool )  D< NOT ;
  36 : D>   ( lo0 hi0 lo1 hi1 -- bool )  D<= NOT ;
  37
  38 : DU>=  ( lo0 hi0 lo1 hi1 -- bool )  DU< NOT ;
  39 : DU>   ( lo0 hi0 lo1 hi1 -- bool )  DU<= NOT ;
  40
  41 : D0<  ( lo hi -- bool )  NIP 0< ;
  42 : D0>  ( lo hi -- bool )  NIP 0> ;
  43 : D0=  ( lo hi -- bool )  OR 0= ;
  44 : D0<>  ( lo hi -- bool )  OR 0<> ;
  45
  46 : D2*  ( lo hi -- lo hi )  2DUP D+ ;
  47 : D2/  ( lo hi -- lo hi )  DUP >R -1 ASH  SWAP -1 LSH R> 1 AND IF 0x8000_0000 OR ENDIF SWAP ;
  48
  49 : DABS ( lo hi -- lo hi )  DUP 0< IF DNEGATE ENDIF ;
  50
  51 : DMAX  ( d1 d2 -- max[d1,d2] )  2over 2over d< if 2swap endif 2drop ;
  52 : DMIN  ( d1 d2 -- min[d1,d2] )  2over 2over d> if 2swap endif 2drop ;
  53 : 2ROT  ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 )  2>r 2swap 2r> 2swap ;
  54 : 2NROT ( x1 x2 x3 x4 x5 x6 -- x5 x6 x1 x2 x3 x4 )  2swap 2>r 2swap 2r> ;
  55
  56 : M+  ( d1|ud1 n -- d2|ud2 )  S>D D+ ;
  57
  58
  59 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60 ;; some standard words
  61 ;;
  62
  63 : SP@  ( -- n ) 0 MTASK:STATE-SP@ ;
  64 : SP!  ( n -- ) 0 MTASK:STATE-SP! ;
  65
  66 : RP@  ( -- n ) r> 0 MTASK:STATE-RP@ SWAP >r ;
  67 : RP!  ( n -- ) r> SWAP 0 MTASK:STATE-RP! >r ;
  68
  69 ALIAS SP@ DEPTH
  70
  71 ;; this is The Word that should be used for vocabulary searches
  72 ;; this does namespace resolution
  73 ;; if "a:b" is not a known word, try to search "b" in dictionary "a"
  74 ;; things like "a:b:c" are allowed too
  75 ;; returns `1` if cfa is immediate, or `-1` if it is a normal word
  76 : WFIND  ( addr count -- cfa -1 // cfa 1 // false )
  77   FIND-WORD IF
  78     DUP COMPILER:IMMEDIATE-WORD? IF 1 ELSE -1 ENDIF
  79   ELSE FALSE
  80   ENDIF
  81 ;
  82
  83
  84 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  85 ;; additional string operations
  86 ;;
  87 ALSO-DEFS: STRING
  88
  89 : CHAR-UPPER  ( ch -- ch )
  90   0xff AND DUP [CHAR] a [CHAR] z BOUNDS? IF 32 - ENDIF
  91 ;
  92
  93 : UPPER  ( addr count -- )
  94   FOR DUP C@ [CHAR] a [CHAR] z BOUNDS? IF DUP C@ 32 - OVER C! ENDIF 1+ ENDFOR DROP
  95 ;
  96
  97 : -TRAILING  ( addr count -- addr count )
  98   A>R OVER >A
  99   BEGIN
 100     DUP 0>
 101   WHILE  ( addr count )
 102     DUP 1- C@A+ BL <= IF 1- FALSE ELSE TRUE ENDIF
 103   UNTIL
 104   R>A
 105 ;
 106
 107 ;; adjust the character string at c-addr1 by n characters.
 108 ;; the resulting character string, specified by c-addr2 u2,
 109 ;; begins at c-addr1 plus n characters and is u1 minus n characters long.
 110 ;; doesn't check length, allows negative n.
 111 : /STRING  ( c-addr1 count n -- c-addr2 count )
 112   DUP >R - SWAP R> + SWAP
 113 ;
 114
 115 ;; checks length, doesn't strip anything from an empty string
 116 : /CHAR  ( c-addr1 u1 -- c-addr+1 u1-1 )
 117   DUP 0<= IF DROP 0 ELSE SWAP 1+ SWAP 1- ENDIF
 118 ;
 119
 120 ;; checks length, doesn't strip anything from an empty string
 121 : /2CHARS  ( c-addr1 u1 -- c-addr+2 u1-2 )
 122   DUP 1 <= IF DROP 0 ELSE SWAP 2+ SWAP 2- ENDIF
 123 ;
 124
 125 : (CHAR-DIGIT)  ( ch -- digit true // false )
 126   DUP CASE
 127     [CHAR] 0 [CHAR] 9 BOUNDS-OF [CHAR] 0 - TRUE ENDOF
 128     [CHAR] A [CHAR] Z BOUNDS-OF [CHAR] A - 10 + TRUE ENDOF
 129     [CHAR] a [CHAR] z BOUNDS-OF [CHAR] a - 10 + TRUE ENDOF
 130     OTHERWISE 2DROP FALSE
 131   ENDCASE
 132 ;
 133
 134 : DIGIT  ( char base -- digit TRUE / FALSE )
 135   SWAP (CHAR-DIGIT) IF  ( base digit )
 136     OVER 1 36 BOUNDS? IF  ( base digit )
 137       DUP ROT U< IF TRUE ELSE DROP FALSE ENDIF
 138     ELSE ( base digit ) 2DROP FALSE
 139     ENDIF
 140   ELSE  ( base )  DROP FALSE
 141   ENDIF
 142 ;
 143
 144 : DIGIT?  ( ch base -- flag )  DIGIT DUP IF NIP ENDIF ;
 145
 146 PREV-DEFS
 147
 148
 149 ;; +- ( n1 n2 -- n3 )
 150 ;; Apply the sign of n2 to n1, which is left as n3.
 151 : +-
 152   SWAP 0< IF ABS NEGATE ELSE ABS ENDIF
 153 ;
 154
 155 ;; -1, 0 or 1
 156 : MEMCMP  ( addr1 addr2 size -- n )
 157   A>R  >R 0 NROT R>  ( 0 a1 a2 sz | rega )
 158   FOR  ( 0 a1 a2 | rega )
 159     OVER >A C@A OVER >A C@A -
 160     ?DUP IF  ( 0 a1 a2 sgn )  >R DROP R> NROT BREAK  ENDIF
 161     1+ SWAP 1+ SWAP
 162   ENDFOR 2DROP
 163   R>A  SIGN?
 164 ;
 165
 166 ;; -1, 0 or 1
 167 : MEMCMP-CI  ( addr1 addr2 size -- n )
 168   A>R  >R 0 NROT R>  ( 0 a1 a2 sz | rega )
 169   FOR  ( 0 a1 a2 | rega )
 170     OVER >A C@A STRING:CHAR-UPPER OVER >A C@A STRING:CHAR-UPPER -
 171     ?DUP IF  ( 0 a1 a2 sgn )  >R DROP R> NROT BREAK  ENDIF
 172     1+ SWAP 1+ SWAP
 173   ENDFOR 2DROP
 174   R>A  SIGN?
 175 ;
 176
 177 : UCMP  ( a b -- -1|0|1 )
 178   2DUP U< IF 2DROP -1
 179   ELSE U> IF 1
 180   ELSE 0
 181   ENDIF ENDIF
 182 ;
 183
 184 : COMPARE  ( c-addr1 u1 c-addr2 u2 -- n )
 185   rot 2dup 2>r umin memcmp ?dup ifnot 2r> swap ucmp else 2rdrop endif
 186 ;
 187
 188 : COMPARE-CI  ( c-addr1 u1 c-addr2 u2 -- n )
 189   rot 2dup 2>r umin memcmp-ci ?dup ifnot 2r> swap ucmp else 2rdrop endif
 190 ;
 191
 192 : FILL  ( addr count byte -- )
 193   A>R ROT >A
 194   SWAP FOR DUP C!A +1>A ENDFOR DROP
 195   R>A
 196 ;
 197
 198 : FILL-CELLS  ( addr count u32 -- )
 199   A>R ROT >A
 200   SWAP FOR DUP !A +4>A ENDFOR DROP
 201   R>A
 202 ;
 203
 204 : BLANKS  ( addr count -- )  BL FILL ;
 205 : ERASE  ( addr count -- )  0 FILL ;
 206 : ERASE-CELLS  ( addr count -- )  0 FILL-CELLS ;
 207
 208 : CMOVE-CELLS  ( source dest count -- )
 209   A>R
 210   FOR  ( source dest )
 211     SWAP DUP >A CELL+ SWAP     ( source+1 dest ) -- source in A
 212     @A SWAP DUP >A CELL+ SWAP  ( source+1 dest+1 c ) -- dest in A
 213     !A
 214   ENDFOR 2DROP
 215   R>A
 216 ;
 217
 218 : CMOVE  ( source dest count -- )
 219   \ ." CMOVE: from=" ROT DUP U. NROT
 220   \ ." to=" OVER U.
 221   \ ." count=" DUP U.
 222   \ CR
 223   \ FOR
 224   \   OVER C@ OVER C! 1+ SWAP 1+ SWAP
 225   \ ENDFOR 2DROP
 226   A>R
 227   FOR  ( source dest )
 228     SWAP DUP >A 1+ SWAP      ( source+1 dest ) -- source in A
 229     C@A SWAP DUP >A 1+ SWAP  ( source+1 dest+1 c ) -- dest in A
 230     C!A
 231   ENDFOR 2DROP
 232   R>A
 233 ;
 234
 235 : CMOVE>  ( source dest count -- )
 236   \ ." CMOVE>: from=" ROT DUP U. NROT
 237   \ ." to=" OVER U.
 238   \ ." count=" DUP U.
 239   \ CR
 240   A>R
 241   >R SWAP R@ + SWAP R@ + R>
 242   FOR  ( source+count dest+count )
 243     SWAP 1- DUP >A SWAP      ( source-1 dest ) -- source-1 in A
 244     C@A SWAP 1- DUP >A SWAP  ( source-1 dest-1 c ) -- dest-1 in A
 245     C!A
 246   ENDFOR 2DROP
 247   R>A
 248 ;
 249
 250 ;; uses CMOVE or CMOVE> (i.e. works like libc `memmove`)
 251 ;; negative length does nothing (i.e. you cannot MOVE more that 2GB of data)
 252 : MOVE  ( from to len -- )
 253   DUP 0> IF
 254     >R
 255     2DUP U< IF  ;; from < to: may need to use CMOVE> (copy backwards)
 256       R> CMOVE>
 257     ELSE  ;; from > to: use CMOVE (normal forward copy)
 258       R> CMOVE
 259     ENDIF
 260   ELSE DROP 2DROP
 261   ENDIF
 262 ;
 263
 264
 265 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 266 ;; additional string operations
 267 ;;
 268
 269 ALSO-DEFS: STRING
 270
 271 : CC-CAT-CHAR  ( cc-str char -- )
 272   >R DUP COUNT + R> SWAP C! 1+!
 273 ;
 274
 275 : CC-CAT  ( cc-str addr count -- )
 276   DUP 0> IF
 277     ROT DUP >R  ( addr count cc-str | cc-str )
 278     OVER >R     ( addr count cc-str | cc-str count )
 279     COUNT + SWAP MOVE  ( | cc-str count )
 280     R> R> +!
 281   ELSE 2DROP
 282   ENDIF
 283 ;
 284
 285 : PAD+CHAR  ( ch -- )  PAD SWAP CC-CAT-CHAR ;
 286 : PAD+CC  ( addr count -- )  PAD NROT CC-CAT ;
 287
 288 ;; copy string to PAD as cell-counted string
 289 : >PAD  ( addr count -- )
 290   DUP PAD !
 291   PAD 4+ SWAP MOVE
 292 ;
 293
 294 : PAD-CC@  ( -- addr count )  PAD COUNT ;
 295 : PAD-LEN@ ( -- count )  PAD @ ;
 296 : PAD-LEN! ( count -- )  PAD ! ;
 297
 298 : PAD-CHAR@  ( idx -- ch )  PAD 4+ + C@ ;
 299
 300 : PATH-DELIMITER?  ( ch -- )
 301   $IF $SHITDOZE
 302     DUP [CHAR] / FORTH:= OVER [CHAR] \ FORTH:= OR SWAP [CHAR] : FORTH:= OR
 303   $ELSE
 304     [CHAR] / FORTH:=
 305   $ENDIF
 306 ;
 307
 308 ;; leaves only path (or empty string)
 309 ;; leaves final path delimiter
 310 ;; UNTESTED!
 311 : PAD-REMOVE-NAME  ( -- )
 312   PAD-LEN@ 1+
 313   BEGIN 1- DUP +WHILE
 314     DUP 1- PAD-CHAR@ PATH-DELIMITER?
 315   UNTIL 0 MAX PAD-LEN!
 316 ;
 317
 318 : PAD-REMOVE-EXT  ( -- )
 319   PAD-LEN@
 320   BEGIN 1- DUP +WHILE
 321     DUP PAD-CHAR@
 322     DUP [CHAR] . FORTH:=
 323     IF SWAP PAD-LEN! TRUE
 324     ELSE PATH-DELIMITER? ENDIF
 325   UNTIL DROP
 326 ;
 327
 328 PREV-DEFS
 329
 330
 331 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 332 ;; wordlist utilities
 333 ;;
 334
 335 : (.-VOCID-NAME)  ( vocid -- )
 336   COMPILER:(VOCOFS-HEADER) + @
 337   ?DUP IF ID-COUNT XTYPE
 338   ELSE ." <unnamed>"
 339   ENDIF
 340 ; (HIDDEN)
 341
 342 : SHOW-WORDLISTS  ( -- )
 343   ." === WORDLISTS ===\n"
 344   (VSP@) FOR
 345     2 SPACES I 0 .R ." : " I (VSP-AT@) (.-VOCID-NAME) CR
 346   ENDFOR
 347   ." CONTEXT: " CONTEXT @ (.-VOCID-NAME) CR
 348   ." CURRENT: " CURRENT @ (.-VOCID-NAME) CR
 349 ;
 350
 351
 352 80 VALUE WORDS-WIDTH
 353
 354 $IF HAS-WORD("LOCALS:")
 355 : VOCID-WORDS ( vocid -- )
 356   LOCALS: iter cols
 357   VOC-LATEST
 358   TO :iter  0 TO :cols
 359   BEGIN :iter WHILE
 360     :iter LFA->NFA @ COMPILER:(WFLAG-SMUDGE) COMPILER:(WFLAG-HIDDEN) OR  AND
 361     IFNOT
 362       :iter LFA->NFA ID-COUNT  ( addr count )
 363       :cols OVER + 1+ DUP TO :cols  ( addr count cols )
 364       WORDS-WIDTH > IF DUP 1+ TO :cols CR ENDIF SPACE XTYPE
 365     ENDIF
 366     :iter @ TO :iter
 367   REPEAT CR
 368 ;
 369 $ELSE
 370 : VOCID-WORDS ( vocid -- )
 371   VOC-LATEST >R 0  ( cols | vocid )
 372   BEGIN R@ WHILE
 373     R@ LFA->NFA @ COMPILER:(WFLAG-SMUDGE) COMPILER:(WFLAG-HIDDEN) OR  AND
 374     IFNOT
 375       R@ LFA->NFA ID-COUNT    ( cols addr count )
 376       ROT OVER + 1+           ( addr count newcols )
 377       DUP WORDS-WIDTH > IF DROP DUP 1+ CR ENDIF
 378       NROT SPACE XTYPE
 379     ENDIF
 380     R> @ >R  ;; move to the previous LFA
 381   REPEAT RDROP DROP ENDCR
 382 ;
 383 $ENDIF
 384
 385 : WORDS ( -- )  CONTEXT @ VOCID-WORDS ;
 386
 387
 388 : 2@  ( n -- lo hi )  DUP @ SWAP 4+ @ SWAP ;
 389 : 2!  ( lo hi n -- )  2DUP ! NIP 4+ ! ;
 390 : @EXECUTE  ( addr )  @ EXECUTE-TAIL ;
 391 : @EXECUTE-TAIL  ( addr )  RDROP @ EXECUTE-TAIL ;
 392 \ for MINIOOF and such
 393 : (NOTIMPL)  ( )  " not implemented" ERROR ;
 394
 395 : (SELF@)  ( -- self-value )  (SELF) @ ;
 396 : (SELF!)  ( self-value -- )  (SELF) ! ;
 397
 398
 399 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 400 ;; enums
 401 ;;
 402
 403 SIMPLE-VOCABULARY (ENUM-INTERNAL) (HIDDEN)
 404 ALSO-DEFS: (ENUM-INTERNAL)
 405
 406 ;; etypes
 407 0 CONSTANT (BIT) (HIDDEN)
 408 1 CONSTANT (INC) (HIDDEN)
 409
 410 : (ADVANCE)  ( etype evalue -- etype enextvalue )
 411   OVER (BIT) = IF ?DUP IF 2U* ELSE 1 ENDIF
 412   ELSE 1+
 413   ENDIF
 414 ; (HIDDEN)
 415
 416 : DEF:  ( etype evalue -- etype enextvalue )  \ name
 417   DUP CONSTANT (ADVANCE)
 418 ;
 419
 420 : }  ( etype evalue -- )
 421   2DROP PREVIOUS
 422 ;
 423
 424 : SET      ( etype evalue newvalue -- etype newvalue )  NIP ;
 425 : SET-BIT  ( etype evalue newbit -- etype 1<<newbit )  NIP 1 SWAP LSH ;
 426 : -SET     ( etype evalue delta -- etype evalue-delta ) - ;
 427 : +SET     ( etype evalue delta -- etype evalue+delta ) + ;
 428
 429 PREV-DEFS
 430
 431 : ENUM{  ( -- etype enextvalue )  FORTH:(ENUM-INTERNAL):(INC) 0 ALSO (ENUM-INTERNAL) ;
 432 : ENUM-FROM{  ( start-value -- etype enextvalue )  FORTH:(ENUM-INTERNAL):(INC) SWAP ALSO (ENUM-INTERNAL) ;
 433 : BITMASK-ENUM{  ( -- etype enextvalue )  FORTH:(ENUM-INTERNAL):(BIT) 1 ALSO (ENUM-INTERNAL) ;
 434
 435
 436 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 437 ;; handle utils
 438 ;;
 439
 440 ALSO-DEFS: HANDLE
 441
 442 : NEW-ALLOC  ( size typeid -- stx )
 443   HANDLE:NEW SWAP OVER HANDLE:SIZE!
 444 ;
 445
 446 : NEW-INIT  ( addr size typeid -- stx )
 447   HANDLE:NEW  ( addr size stx )
 448   2DUP HANDLE:SIZE!
 449   DUP >R SWAP CMOVE R>
 450 ;
 451
 452 PREV-DEFS