src/lib_6_strings.4th

   1 \ Strings
   2
   3 : CMOVE ( src dest length -- )
   4
   5         DUP 0<= IF
   6                 DROP DROP DROP
   7                 EXIT
   8         THEN
   9
  10         -ROT OVER -         ( length src (dest-src) )
  11         -ROT DUP ROT + SWAP ( (dest-src) (src+length) src )
  12
  13         DO
  14                 I @         ( (dest-src) i@ )
  15                 OVER I +    ( (dest-src) i@ (dest-src+i) )
  16                 !           ( (dest-src) )
  17         LOOP
  18
  19         DROP
  20 ;
  21
  22 : CMOVE> ( src dest length -- )
  23         DUP 0<= IF
  24                 DROP DROP DROP
  25                 EXIT
  26         THEN
  27
  28         -ROT OVER -         ( length src (dest-src) )
  29         -ROT DUP ROT + 1-   ( (dest-src) src (src+length-1) )
  30
  31         DO
  32                 I @
  33                 OVER I +
  34                 !
  35         -1 +LOOP
  36
  37         DROP
  38 ;
  39
  40 : COMPILING? STATE @ 0<> ;
  41
  42 ( In compile mode, word compiles everything until the next
  43   double quote as a litstring.  Otherwise, dynamically allocates
  44   memory and stores string there, returning address and length. )
  45 : S" IMMEDIATE ( -- addr len )
  46         COMPILING? IF
  47                 ['] LITSTRING ,   ( compile LITSTRING )
  48                 HERE          ( save the address of the length word on the stack )
  49                 0 ,             ( dummy length - we don't know what it is yet )
  50         ELSE
  51                 HERE    ( save the starting address on the stack )
  52         THEN
  53
  54         BEGIN
  55                 >IN @ #IB @ >= IF      \ End of IB?
  56                         QUERY-INPUT    \ Get next line
  57                 THEN
  58
  59                 IB >IN @ + @ 1 >IN +!  \ Get char from IB
  60
  61                 DUP [CHAR] " <>
  62         WHILE
  63                 ,              ( copy character )
  64         REPEAT
  65         DROP            ( drop the double quote character at the end )
  66
  67         COMPILING? IF
  68                 DUP             ( get the saved address of the length word )
  69                 HERE SWAP -   ( calculate the length )
  70                 1-              ( subtract 1 (because we measured from the start of the length word) )
  71                 SWAP !          ( and back-fill the length location )
  72         ELSE
  73                 DUP HERE SWAP -
  74         THEN
  75 ;
  76
  77 ( Compile-mode word which compiles everything until the
  78   next double quote as a litstring and appends a TYPE. )
  79 : ." IMMEDIATE
  80         [COMPILE] S"
  81         ['] TYPE ,
  82 ;
  83
  84 ( Interpret-mode word which prints everything until the next
  85   right-paren to the terminal. )
  86 : .(
  87         BEGIN
  88                 >IN @ #IB @ >= IF      \ End of IB?
  89                         QUERY-INPUT    \ Get next line
  90                 THEN
  91
  92                 IB >IN @ + @ 1 >IN +!  \ Get char from IB
  93
  94                 DUP [CHAR] ) = IF
  95                         DROP    ( drop the double quote character )
  96                         EXIT    ( return from this function )
  97                 THEN
  98                 EMIT
  99         AGAIN
 100 ;
 101
 102 ( Converts address of counted string into address of
 103   start of string and length of string. )
 104 : COUNT ( addr1 -- addr2 n )
 105         DUP 1+ SWAP @ ;
 106
 107 ( Compares two strings, returns 0 if identical. )
 108 : COMPARE ( addr1 n1 addr2 n2 -- res )
 109     rot 2dup <> if
 110         2drop 2drop 1 exit
 111     then
 112
 113     drop
 114
 115     0 do
 116         2dup i + @ swap i + @ <> if
 117             unloop 2drop 1 exit
 118         then
 119     loop
 120
 121     2drop 0
 122 ;
 123
 124 ( Converts a string to lower case. )
 125 : TOLOWER ( addr n -- )
 126     0 do
 127         dup i + @ dup dup ( addr char char char )
 128         [char] A >=
 129         swap [char] Z <= and if
 130             [char] A - [char] a +
 131             over i + !
 132         else
 133             drop
 134         then
 135     loop
 136
 137     drop
 138 ;
 139
 140 ( Abort if flag is true. )
 141 : ABORT" IMMEDIATE  ( flag -- )
 142         [COMPILE] S"
 143
 144         ['] rot ,
 145         [COMPILE] if
 146                 s" Aborted: " ['] lit , , ['] lit , , ['] swap ,
 147                 ['] type ,
 148                 ['] type ,
 149                 ['] cr ,
 150                 ['] abort ,
 151         [COMPILE] else
 152                 ['] 2drop ,
 153         [COMPILE] then
 154 ;