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 ( Compile-mode word which compiles everything until the next
  41   double quote as a litstring. )
  42 : S" IMMEDIATE          ( -- addr len )
  43         ['] LITSTRING ,   ( compile LITSTRING )
  44         HERE          ( save the address of the length word on the stack )
  45         0 ,             ( dummy length - we don't know what it is yet )
  46
  47         BEGIN
  48                 >IN @ #IB @ >= IF      \ End of IB?
  49                         QUERY-INPUT    \ Get next line
  50                 THEN
  51
  52                 IB >IN @ + @ 1 >IN +!  \ Get char from IB
  53
  54                 DUP [CHAR] " <>
  55         WHILE
  56                 C,              ( copy character )
  57         REPEAT
  58         DROP            ( drop the double quote character at the end )
  59         DUP             ( get the saved address of the length word )
  60         HERE SWAP -   ( calculate the length )
  61         1-              ( subtract 1 (because we measured from the start of the length word) )
  62         SWAP !          ( and back-fill the length location )
  63 ;
  64
  65 ( Compile-mode word which compiles everything until the
  66   next double quote as a litstring and appends a TYPE. )
  67 : ." IMMEDIATE
  68         [COMPILE] S"
  69         ['] TYPE ,
  70 ;
  71
  72 ( Interpret-mode word which prints everything until the next
  73   right-paren to the terminal. )
  74 : .(
  75         BEGIN
  76                 >IN @ #IB @ >= IF      \ End of IB?
  77                         QUERY-INPUT    \ Get next line
  78                 THEN
  79
  80                 IB >IN @ + @ 1 >IN +!  \ Get char from IB
  81
  82                 DUP [CHAR] ) = IF
  83                         DROP    ( drop the double quote character )
  84                         EXIT    ( return from this function )
  85                 THEN
  86                 EMIT
  87         AGAIN
  88 ;
  89
  90 ( Converts address of counted string into address of
  91   start of string and length of string. )
  92 : COUNT ( addr1 -- addr2 n )
  93         DUP 1+ SWAP @ ;
  94
  95 ( Abort if flag is true. )
  96 : ABORT" IMMEDIATE  ( flag -- )
  97         [COMPILE] S"
  98
  99         ['] rot ,
 100         [COMPILE] if
 101                 s" Aborted: " ['] lit , , ['] lit , , ['] swap ,
 102                 ['] type ,
 103                 ['] type ,
 104                 ['] cr ,
 105                 ['] abort ,
 106         [COMPILE] else
 107                 ['] 2drop ,
 108         [COMPILE] then
 109 ;