urflibs/stdlib/50-string.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 ;; additional string operations
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10
  11 also-defs: string
  12
  13 ;; moved to C kernel
  14 (*
  15 : char-upper  ( ch -- ch )
  16   lo-byte dup [char] a [char] z bounds? if 32 - endif
  17 ;
  18
  19 : upper  ( addr count -- )
  20   for dup c@ [char] a [char] z bounds? if dup c@ 32 - over c! endif 1+ endfor drop
  21 ;
  22 *)
  23
  24 : -trailing  ( addr count -- addr count )
  25   a>r over >a
  26   begin
  27     dup 0>
  28   while  ( addr count )
  29     dup 1- c@a+ bl <= if 1- false else true endif
  30   until
  31   r>a
  32 ;
  33
  34 ;; adjust the character string at c-addr1 by n characters.
  35 ;; the resulting character string, specified by c-addr2 u2,
  36 ;; begins at c-addr1 plus n characters and is u1 minus n characters long.
  37 ;; doesn't check length, allows negative n.
  38 : /string  ( c-addr1 count n -- c-addr2 count )
  39   dup >r - swap r> + swap
  40 ;
  41
  42 ;; checks length, doesn't strip anything from an empty string
  43 : /char  ( c-addr1 u1 -- c-addr+1 u1-1 )
  44   1- dup -if drop 0 else swap 1+ swap endif
  45 ;
  46
  47 ;; checks length, doesn't strip anything from an empty string
  48 : /2chars  ( c-addr1 u1 -- c-addr+2 u1-2 )  /char /char ;
  49
  50 ;; moved to C kernel
  51 (*
  52 : (char-digit)  ( ch -- digit true // false )
  53   dup case
  54     [char] 0 [char] 9 bounds-of [char] 0 - true endof
  55     [char] A [char] Z bounds-of [char] A - 10 + true endof
  56     [char] a [char] z bounds-of [char] a - 10 + true endof
  57     otherwise 2drop false
  58   endcase
  59 ;
  60
  61 : digit  ( char base -- digit TRUE / FALSE )
  62   swap (char-digit) if  ( base digit )
  63     over 1 36 bounds? if  ( base digit )
  64       dup rot u< if true else drop false endif
  65     else ( base digit ) 2drop false
  66     endif
  67   else  ( base )  drop false
  68   endif
  69 ;
  70
  71 : digit?  ( ch base -- flag )  digit dup if nip endif ;
  72 *)
  73
  74 prev-defs
  75
  76
  77 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78 ;; additional string operations
  79 ;;
  80
  81 also-defs: string
  82
  83 : cc-cat-char  ( cc-str char -- )
  84   >r dup count + r> swap c! 1+!
  85 ;
  86
  87 : cc-cat  ( cc-str addr count -- )
  88   dup 0> if
  89     rot dup >r  ( addr count cc-str | cc-str )
  90     over >r     ( addr count cc-str | cc-str count )
  91     count + swap move  ( | cc-str count )
  92     r> r> +!
  93   else 2drop
  94   endif
  95 ;
  96
  97 : pad+char  ( ch -- )  pad swap cc-cat-char ;
  98 : pad+cc  ( addr count -- )  pad nrot cc-cat ;
  99
 100 ;; copy string to pad as cell-counted string
 101 : >pad  ( addr count -- )
 102   dup pad !
 103   pad 4+ swap move
 104 ;
 105
 106 : pad-cc@  ( -- addr count )  pad count ;
 107 : pad-len@ ( -- count )  pad @ ;
 108 : pad-len! ( count -- )  pad ! ;
 109
 110 : pad-char@  ( idx -- ch )  pad 4+ + c@ ;
 111
 112 : path-delimiter?  ( ch -- )
 113   $IF $SHITDOZE
 114     dup [char] / forth:= over [char] \ forth:= or swap [char] : forth:= or
 115   $ELSE
 116     [char] / forth:=
 117   $ENDIF
 118 ;
 119
 120 ;; leaves only path (or empty string)
 121 ;; leaves final path delimiter
 122 ;; UNTESTED!
 123 : pad-remove-name  ( -- )
 124   pad-len@ 1+
 125   begin 1- dup +while
 126     dup 1- pad-char@ path-delimiter?
 127   until 0 max pad-len!
 128 ;
 129
 130 : pad-remove-ext  ( -- )
 131   pad-len@
 132   begin 1- dup +while
 133     dup pad-char@
 134     dup [char] . forth:=
 135     if swap pad-len! true
 136     else path-delimiter? endif
 137   until drop
 138 ;
 139
 140 prev-defs