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