Source code in the forth programming language

\ Rosetta Code Binary Strings Demo in Forth
\ Portions of this code are found at http://forth.sourceforge.net/mirror/toolbelt-ext/index.html

\ String words created in this code:
\       STR<    STR>    STR=    COMPARESTR      SUBSTR  STRPAD  CLEARSTR
\       =""     ="      STRING: MAXLEN  REPLACE-CHAR    COPYSTR WRITESTR
\       ,"      APPEND-CHAR     STRING, PLACE   CONCAT  APPEND  C+!  ENDSTR
\       COUNT   STRLEN

: STRLEN  ( addr -- length)  c@ ;        \ alias the "character fetch" operator

: COUNT   ( addr --  addr+1 length)      \ Standard word. Shown for explanation
          dup  strlen swap 1+ swap ;     \ returns the address+1 and the length byte on the stack

: ENDSTR  ( str -- addr)                 \ calculate the address at the end of a string
          COUNT + ;

: C+!     ( n addr -- )                  \ primitive: increment a byte at addr by n
          DUP C@ ROT + SWAP C! ;

: APPEND  ( addr1 length addr2 -- )      \ Append addr1 length to addr2
          2dup 2>r  endstr swap move 2r> c+! ;

: CONCAT  ( string1 string2 -- )          \ concatenate counted string1 to counted string2
           >r  COUNT  R> APPEND ;

: PLACE  ( addr1 len addr2 -- )           \ addr1 and length, placed at addr2 as counted string
           2dup 2>r  char+  swap  move  2r> c! ;

: STRING, ( addr len -- )                 \ compile a string at the next available memory (called 'HERE')
            here  over char+  allot  place ;

: APPEND-CHAR  ( char string -- )         \ append char to string
           dup >r  count dup 1+ r> c! + c! ;

: ,"       [CHAR] " PARSE  STRING, ;      \ Parse input stream until '"' and compile into memory


: WRITESTR ( string -- )                  \ output a counted string with a carriage return
           count  type CR ;

: COPYSTR  ( string1 string3 -- )         \ String cloning and copying COPYSTR
           >r  count  r> PLACE ;

: REPLACE-CHAR ( char1 char2 string -- )  \ replace all char2 with char1 in string
          count                           \ get string's address and length
          BOUNDS                          \ calc start and end addr of string for do-loop
          DO                              \ do a loop from start address to end address
             I C@ OVER =                  \ fetch the char at loop index compare to CHAR2
             IF
                OVER I C!                 \ if its equal, store CHAR1 into the index address
             THEN
          LOOP
          2drop ;                         \ drop the chars off the stack


 256 constant maxlen                      \ max size of byte counted string in this example

: string:   CREATE    maxlen ALLOT ;      \ simple string variable constructor


: ="      ( string -- )                   \ String variable assignment operator (compile time only)
          [char] " PARSE  ROT  PLACE ;

: =""     ( string -- )  0 swap c! ;      \ empty a string, set count to zero


: clearstr ( string -- )                  \ erase a string variables contents, fill with 0
           maxlen erase ;


  string: strpad                           \ general purpose storage buffer

: substr  ( string1 start length -- strpad) \ Extract a substring of string and return an output string
          >r >r                             \ push start,length
          count                             \ compute addr,len 
          r> 1- /string                     \ pop start, subtract 1, cut string 
          drop r>                           \ drop existing length, pop new length
          strpad place                      \ place new stack string in strpad
          strpad ;                          \ return address of strpad

\ COMPARE takes the 4 inputs from the stack (addr1 len1  addr2 len2 )
\ and returns a flag for equal (0) , less-than (1)  or greater-than (-1) on the stack

  : comparestr ( string1 string2 -- flag)  \ adapt for use with counted strings
              count rot count compare ;

\ now it's simple to make new operators
  : STR=   ( string1 string2 -- flag)
             comparestr  0= ;

  : STR>   ( string1 string2 -- flag)
             comparestr -1 = ;

  : STR<   ( string1 string2 -- flag)
             comparestr 1 = ;


\ Rosetta Code Binary String tasks Console Tests

\ 1. String creation and destruction (when needed and if there's no garbage collection or similar mechanism)

\ RAW Forth can manually create a binary string with the C, operator.
\ C, takes a byte off the stack and writes it into the next available memory address
\ then increments the Forth internal memory pointer by 1 byte.
\ 'binary_string'  drops it's address on the stack. Nothing more. (ie: pointer to the string)

HEX ok
    create binary_string   9 c,  1 c, 2 c, 3 c, 4 c, 5 c, 
                           0A c, 0B c, 0C c, 0FF c,        \ 1st byte is length
ok

\ test what we created using the DUMP utility

 binary_string count dump
 25EC:7365  01 02 03 04 05 0A 0B 0C  FF 04 44 55 4D 50 00 20  ..........DUMP.
 ok


\ Alternatively we can create static string variables using our constructor 
    string: buffer1  ok
    string: buffer2  ok
  
DECIMAL  ok
  
\ 2. String assignment 

\ create string constants with assignments(static, counted strings)  ok
     create string1  ," Now is the time for all good men to come to the aid"
     create string2  ," Right now!"  ok

\ assign text to string variables with syntacic sugar
     buffer1 =" This text will go into the memory allocated for buffer1"  ok
     buffer2 =""  ok

\ or use S" and PLACE
     S" The rain in Spain..." buffer2 PLACE ok
 
\ Test the assignments  
     string2 writestr Right now!
 ok
     string1 writestr Now is the time for all good men to come to the aid
 ok
     buffer1 writestr This text will go into the memory allocated for buffer1
 ok
     buffer2 writestr The rain in Spain...
 ok


\ destroy string contents. Fill string with zero
     buffer1 clearstr  ok
     buffer1 40 dump
25EC:7370  00 00 00 00 00 00 00 00  00 00 00 00 00 00 00 00  ................
25EC:7380  00 00 00 00 00 00 00 00  00 00 00 00 00 00 00 00  ................
25EC:7390  00 00 00 00 00 00 00 00  00 00 00 00 00 00 00 00  ................
 ok

\ 3. String comparison. ( the '.'  prints the top of the stack in these examples)
     buffer1 =" ABCDEFG"  ok
     buffer2 =" ABCDEFG"  ok
   
     buffer1 buffer2 STR= .  ( should be -1, TRUE flag) -1  ok

     string1 buffer1 str> .  ( should be  0) 0  ok
     string1 buffer1 str< .  ( should be -1) -1  ok


\ 4. String cloning and copying
     string1 buffer1 COPYSTR  ok

     string1 writestr Now is the time for all good men to come to the aid  ok
     buffer1 writestr Now is the time for all good men to come to the aid  ok


\ 5. Check if a string is empty
     buffer1 len . 55  ok
     buffer1 =""           \ assign null string  ok
     buffer1 len . 0  ok



\ 6. Append a byte to a string
     buffer2 =" Append this"  ok
     buffer2 writestr Append this
 ok
     char !  buffer2 APPEND-CHAR  ok
     buffer2 writestr Append this!
 ok
hex  ok
     0A buffer2 APPEND-CHAR     \ append a raw carriage return  ok
     0D buffer2 APPEND-CHAR     \ append a raw line-feed  ok
  ok
     buffer2 writestr Append this!

 ok
\ we see the extra line before OK so Appending binary chars worked

 decimal ok

\ 7. Extract a substring from a string. Result placed in a temp buffer automagically

     string1 writestr Now is the time for all good men to come to the aid ok

     string1 5 11 substr writestr is the time ok


\ 8. Replace every occurrence of a byte (or a string) in a string with another string
\    BL is a system constant for "Blank" ie the space character (HEX 020)

     buffer1 =" This*string*is*full*of*stars*"  ok
  ok
     BL  char *  buffer1 REPLACE-CHAR  ok
     buffer1 writestr This string is full of stars
 ok


\ 9. Join strings
     buffer1 =" James "  ok
     buffer2 =" Alexander"  ok
     buffer2 buffer1 CONCAT  ok
  ok
     buffer1 writestr James Alexander
 ok