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