\ ==[ File:  FStrings.Scr  (26432 bytes) ]==CUT=HERE=========================
\ FORTH STRINGS                                     GTH 08/22/87

  This file provides a string handling/manipulation capability
in FORTH-83 or MasterFORTH.

  See ASCII text file FSTRINGS.TXT for the full narrative
description.

  Block 1 is the load block for the FORTH-83 version.

  Block 2 is the load block for a customized MasterFORTH
version which has the words COMPARE, SAME?, CFIND, CFIND<,
_CF+, _LEN, and _$>AL written in assembler.

  Any words beginning with an initial underscore "_" should be
"hidden".
\ LOAD BLOCK - FORTH-83 VERSION                     GTH 08/22/87

CR .( **** LOADING - WAIT ****)

\ Load FORTH-83 version words
 5 LOAD  6 LOAD  7 LOAD  8 LOAD

\ Load common FORTH-83 words
14 LOAD 15 LOAD 17 LOAD 18 LOAD 19 LOAD 20 LOAD 21 LOAD 22 LOAD
23 LOAD 24 LOAD 25 LOAD 26 LOAD 27 LOAD 28 LOAD 29 LOAD 30 LOAD
31 LOAD 32 LOAD 33 LOAD 34 LOAD 35 LOAD 36 LOAD 37 LOAD 38 LOAD
39 LOAD 40 LOAD 41 LOAD 42 LOAD 43 LOAD 44 LOAD 45 LOAD 47 LOAD

CR .( **** END LOAD ****)


\ LOAD BLOCK - MASTERFORTH VERSION                  GTH 08/22/87

CR .( **** LOADING - WAIT ****)

\ NOTE: ****** MasterFORTH assembler must be loaded! ******

\ Load MasterFORTH version assembler words
9 LOAD  10 LOAD 11 LOAD 12 LOAD 13 LOAD

\ Load common FORTH-83 words
14 LOAD 15 LOAD 17 LOAD 18 LOAD 19 LOAD 20 LOAD 21 LOAD 22 LOAD
23 LOAD 24 LOAD 25 LOAD 26 LOAD 27 LOAD 28 LOAD 29 LOAD 30 LOAD
31 LOAD 32 LOAD 33 LOAD 34 LOAD 35 LOAD 36 LOAD 37 LOAD 38 LOAD
39 LOAD 40 LOAD 41 LOAD 42 LOAD 43 LOAD 44 LOAD 45 LOAD 47 LOAD

CR .( **** END LOAD ****)
\ DOCUMENTATION                                     GTH 08/22/87

  PRONUNCIATION:  The suggested pronunciation for all visible
words (when not obvious) is given to the right of the word
itself.  For example:

: CFIND< ( char addr n -- addr' | 0 )           \ "c-find-back"

  DESCRIPTION:  The functional descriptions of the words
immediately follow the words themselves.

  STACK DIAGRAMS:  The effect upon the data stack is often
shown via a stack diagram.  This uses the symbology:
    "ds: <stack picture here>"
  If needed, a return stack diagram is also shown.  The
representation is the same except that "rs:" is used.
\ DOCUMENTATION                                     GTH 08/22/87

  In showing the stack pictures via "ds:" or "rs:" and,
occasionally, for the initial stack picture as well the
following compressed symbols are used:

  SYMBOL    MEANING
  s1 or s   string1 (or string) reference
  a1 or a   string1 address (or general data address)
  l1 or l   string1 (or string) length or general length
  s2, etc.  same as above except for string2
  i         string index (or general character array index)
  n         number
  t | f     TRUE or FALSE flag
  ...       indicates lower stack contents unchanged

\ Memory lexicographic compare                      GTH 08/22/87

: COMPARE ( a1 a2 n -- status )
\ Compares a1-a2, (a1+1)-(a2+1), ... (a1+n-1)-(a2+n-1)
\ as required returning -1, 0, or +1 depending on lexicographic
\ order.  If n=0, then 0 (i.e., =) is returned.
  DUP 0= IF >R 2DROP R> EXIT THEN  \ handle NULL case
  \ Iterate over a2 ... a2+n-1
  ROT 0 SWAP 2SWAP
  OVER + SWAP DO                   \ ds: 0 a1
    DUP C@ I C@ 2DUP =
    IF 2DROP 1+
    ELSE < ROT DROP                \ ds: a1 a1<a2flag
      IF -1 ELSE 1 THEN SWAP LEAVE
    THEN
  LOOP DROP ;
\ Memory pattern match                              GTH 08/22/87

: SAME? ( a1 a2 n -- t | f )
\ Compares a1-a2, (a1+1)-(a2+1), ... (a1+n-1)-(a2+n-1)
\ as required returning -1 if all "n" bytes match, else returns
\ 0.  Note that this operator is not strictly required since one
\ may define SAME? as
\     : SAME? COMPARE 0= ;
\ It is included primarily for reasons of speed.
  DUP 0= IF 2DROP DROP -1 EXIT THEN  \ handle NULL case
  \ Iterate over a2 ... a2+n-1
  ROT -1 SWAP 2SWAP OVER + SWAP DO   \ ds: -1 a1
    DUP C@ I C@ =
    IF 1+                            \ same
    ELSE 2DROP 0 0 LEAVE THEN        \ not the same
  LOOP DROP ;
\ Memory character/byte FIND                        GTH 08/22/87
: CFIND ( c a1 n -- a2 | 0 )                    \ "c-find"
\ Searches a1, a1+1, ..., a1+n-1 for c returning first
\ address of match or 0 if no match.  NOTE: n=0 returns 0.
  DUP 0= IF >R 2DROP R> EXIT THEN  \ handle NULL case
  OVER + 0 SWAP ROT DO             \ ds: c 0
    OVER I C@ =
    IF DROP I LEAVE THEN
  LOOP SWAP DROP ;
: CFIND< ( c a1 n -- a2 | 0 )                   \ "c-find-back"
\ Same as CFIND except search is high-to-low memory.
  DUP 0= IF >R 2DROP R> EXIT THEN  \ handle NULL case
  OVER + 1- 0 ROT ROT DO           \ ds: c 0
    OVER I C@ =            ( NOTE: memory search begins at )
    IF DROP I LEAVE THEN   (       a1+n-1                  )
  -1 +LOOP SWAP DROP ;
\ Memory interface routines - internal              GTH 08/22/87
: _CF+ ( a -- a+countfield )
\ Adds size of string count field in bytes.
\ Factored out to provide ease of conversion to machines
\ not having stack word size of 16 bits.
  2+ ;

: _LEN ( s -- l )
\ Returns the length of a string.
  @ ;

: _$>AL ( s -- a l )
\ Converts from string reference to data address, length.
\ Factored out to interface with lower level memory operators.
  DUP 2+ SWAP @ ;  \ NOTE: modify "2+" if machine word size <>
                   \       2 bytes.
\ MasterFORTH memory lexicographic compare          GTH 08/22/87

CODE COMPARE ( a1 a2 n -- status )
\ Compares a1-a2, (a1+1)-(a2+1), ... (a1+n-1)-(a2+n-1)
\ as required returning -1, 0, or +1 depending on lexicographic
\ order.  If n=0, then 0 (i.e., =) is returned.
  SI DX MOV CX POP DI POP SI POP DX PUSH ( save IP)
  AX AX XOR  \ assume equal, i.e. return 0 & set flags
  REPE BYTE CMPS 2 L# JE
  1 L# JNS AX DEC 2 L# JU       \ return -1
1 L:       AX INC               \ return +1
2 L:                            \ common jump
     SI POP ( restore IP) AX PUSH NEXT END-CODE



\ MasterFORTH memory pattern match                  GTH 08/22/87

CODE SAME? ( a1 a2 n -- t | f )
\ Compares a1-a2, (a1+1)-(a2+1), ... (a1+n-1)-(a2+n-1)
\ as required returning -1 if all "n" bytes match, else returns
\ 0.  Note that this operator is not strictly required since one
\ may define SAME? as
\     : SAME? COMPARE 0= ;
\ It is included primarily for reasons of speed.
  SI DX MOV CX POP DI POP SI POP DX PUSH ( save IP)
  AX AX XOR   \ assume not equal, i.e. return 0 & set flags
  REPE BYTE CMPS 1 L# JNE
  AX DEC                             \ return -1
1 L:                                 \ common jump
  SI POP ( restore IP) AX PUSH NEXT END-CODE

\ MasterFORTH memory character/byte (forward) FIND  GTH 08/22/87

CODE CFIND ( c a1 n -- a2 | 0 )                 \ "c-find"
\ Searches a1, a1+1, ..., a1+n-1 for c returning first
\ address of match or 0 if no match.  NOTE: n=0 returns 0.
  CX POP DI POP AX POP
  3 L# JCXZ
  REPNE BYTE SCAS 1 L# JE
  DI DI XOR 2 L# JU              \ return 0
1 L: DI DEC                      \ return address
2 L: DI PUSH NEXT                \ common jump
3 L: CX PUSH NEXT END-CODE       \ handle NULL case




\ MasterFORTH memory character/byte (backward) FIND GTH 08/22/87

CODE CFIND< ( c a1 n -- a2 | 0 )                \ "c-find-back"
\ Same as CFIND except search is high-to-low memory.
  CX POP BX POP AX POP
  3 L# JCXZ
  CX BX ADD
1 L: BX DEC
  AL 0 [BX] CMP
  1 L# LOOPNE 2 L# JE            \ return address
  BX BX XOR                      \ return 0
2 L: BX PUSH NEXT                \ common jump
3 L: CX PUSH NEXT END-CODE       \ handle NULL case



\ MasterFORTH memory interface routines - internal  GTH 08/22/87
CODE _CF+ ( a -- a+countfield )
\ Adds size of string count field in bytes.
\ Factored out to provide ease of conversion to machines
\ not having stack word size of 16 bits.
  AX POP 2 # AX ADD AX PUSH NEXT END-CODE  \ same as: 2+

CODE _LEN ( s -- l )
\ Returns the length of a string.
  BX POP 0 [BX] PUSH NEXT END-CODE         \ same as: @

CODE _$>AL ( s -- a l )
\ Converts from string reference to data address, length.
\ Factored out to interface with lower level memory operators.
  BX POP BX AX MOV 2 # AX ADD           \ same as: DUP 2+ SWAP @
  AX PUSH 0 [BX] PUSH NEXT END-CODE
\ Internal data                                     GTH 08/22/87

\ NOTE:  Careful consideration should be given to the memory
\ allocated for the maximum literal string size below since it
\ could represent a permanent loss of available dictionary
\ space.  Ideally, the "_BUFFER" area would be dynamically
\ allocated as needed.  This method of implementation would, of
\ course, be specific to a given Forth system.

1024 CONSTANT  _MAX$             \ maximum literal string size

CREATE _BUFFER _MAX$ _CF+ ALLOT  \ string temporary hold buffer




\ Internal routines                                 GTH 08/22/87

: _LOOP> ( s -- a-high a-low )
\ Sets loop indices for low-to-high core string data loop.
  _$>AL OVER + SWAP ;

: _LOOP< ( s -- a-low a-high-1 )
\ Sets loop indices for high-to-low core string data loop.
  _$>AL OVER + 1- ;

: _'INPC ( i -- a )
\ Returns address for offset index in the input stream.
  BLK @ DUP IF BLOCK ELSE DROP TIB THEN + ;



\ String literals                                   GTH 08/22/87

\ : $LIT ( -- string )                                \ "s-lit"
\ Two string literal primitives are provided - "$LIT" for
\ interpretation and "[$LIT]" for colon definitions - otherwise
\ their actions are the same.
\ The string in the input stream following $LIT (or [$LIT]) is
\ delimited by the first following non-blank character.  The
\ string is defined by all characters immediately following the
\ delimiting character until a subsequent delimiter is
\ encountered in the input stream.  The delimiter, itself, may
\ also be included in the string by using two successive
\ delimiters to represent a single delimiter.  For example:
\    $LIT "The double quote character is """
\
\ The code word for $LIT is on the next screen:
\ String literals                                   GTH 08/22/87

: $LIT ( -- string )  \ interpretive string literal
  \ Bypass leading blanks, if any.
  32 >IN @ BEGIN 2DUP _'INPC C@ = WHILE 1+ REPEAT SWAP DROP
  DUP _'INPC C@ >R                     \ rs: delimiter
  1+ _BUFFER _CF+ BEGIN                \ ds: >IN' _BUFFER'
    OVER _'INPC DUP C@ R@ =
    IF 1+ C@ R@ =                      \ delim = current char
      IF R@ OVER C! 1+ SWAP 2+ SWAP 0  \ consecutive delimiters
      ELSE -1 THEN                     \ single delimiter, done
    ELSE                               \ delim <> current char
      C@ OVER C! 1+ SWAP 1+ SWAP 0 THEN \ update & continue
  UNTIL R> DROP                        \ ds: >IN' _BUFFER'
  0 _BUFFER _CF+ 0 D- DROP _BUFFER !   \ set string size
  1+ >IN ! _BUFFER ;            \ adjust >IN & return reference
\ String literals                                   GTH 08/22/87

: $, ( string -- )                            \ "s-comma"
\ Compiles a string into the dictionary.
  HERE OVER _LEN _CF+ DUP ALLOT CMOVE ;

: ,$ ( -- )                                   \ "comma-s"
\ Compiles the following word string into the dictionary.
  $LIT $, ;

: [$LIT] ( -- string )                        \ "bracket-s-lit"
\ Compiled string literal
  COMPILE BRANCH HERE 0 ,  \ forward branch around string
  HERE ,$ HERE ROT ! [COMPILE] LITERAL ; IMMEDIATE


\ String literals                                   GTH 08/22/87

: _KEY ( string t|f -- )       \ Primary "KEY" word.
  >R DUP _CF+ 0 SWAP BEGIN     \ ds: s 0 a ; rs: t|f
    KEY DUP 13 = NOT WHILE
    R@ IF DUP EMIT THEN OVER C! 1+ SWAP 1+ SWAP
  REPEAT 2DROP                 \ ds: s size ; rs: t|f
  SWAP ! R> DROP ;

: $KEY ( string -- )                                \ "s-key"
\ Reads keyboard characters into "string" until <RETURN>.
  0 _KEY ;

: $$KEY ( string -- )                               \ "s-s-key"
\ Same as $KEY except input echoed back to console.
  -1 _KEY ;
\ String variables                                  GTH 08/22/87

: $ALLOT ( number -- )                              \ "s-allot"
\ Reserves "number" characters in the dictionary for a string
\ and sets string to NULL.
  0 , ALLOT ;

\ String variables are "CREATE"d just as are normal Forth
\ variables, and the character space required is assigned
\ via "$ALLOT".  For example, to create a string variable
\ capable of storing (at most) 37 characters, one might code:
\
\   CREATE STRING-VAR 37 $ALLOT
\                or
\   37 CREATE STRING-VAR $ALLOT

\ String import/export                              GTH 08/22/87

: $IMPORT ( addr length string -- )                \ "s-import"
\ Imports a string from addr, length.
  2DUP ! _CF+ SWAP CMOVE ;

: $EXPORT ( string addr -- )                       \ "s-export"
\ Exports a string to addr.
  >R _$>AL R> SWAP CMOVE ;







\ String reference                                  GTH 08/22/87

: $LEN ( string -- length )                        \ "s-length"
\ Returns the length of string.
  _LEN ;

: $. ( string -- )                                 \ "s-dot"
\ Prints a string.
  _$>AL TYPE ;







\ Basic string manipulation                         GTH 08/22/87

: $NULL ( string -- )                             \ "s-null"
\ Forces a string to NULL.
  0 SWAP ! ;

: $$+ ( string1 string2 -- )                      \ "s-s-plus"
\ Adds (concatenates) string1 onto string2.
  DUP >R _$>AL + SWAP       \ ds: (a2+l2) s1 ; rs: s1
  _$>AL >R SWAP R@          \ ds: a1 (a2+l2) l1 ; rs: s2 l1
  CMOVE R> R> +! ;





\ String-character fetch/store                      GTH 08/22/87

: $C! ( char string index -- )                    \ "s-c-store"
\ Stores "char" in "string" at position "index".
  + _CF+ C! ;

: $C@ ( string index -- char )                    \ "s-c-fetch"
\ Fetches "char" from position "index" in "string".
  + _CF+ C@ ;







\ String-string fetch/store                         GTH 08/22/87

: $$! ( string1 string2 -- )                      \ "s-s-store"
\ Stores string1 in string2.  Original contents of string2 are
\ lost.
  OVER _LEN _CF+ CMOVE ;

: $$@ ( string1 string2 index length --)          \ "s-s-fetch"
\ "string2" is built/fetched using the "string1" substring
\ starting at position "index" for "length" characters.
  ROT 2DUP !      \ set length of s2
                               \ ds: s1 i l s2
  2SWAP + _CF+                 \ ds: l s2 (a1+i)
  SWAP _CF+ ROT                \ ds: (a1+i) a2 l
  CMOVE ;         \ set body of s2

\ String-character insertion                        GTH 08/22/87

: $CINS ( char string index -- )                    \ "s-c-ins"
\ Inserts "char" in "string" with "char" at position "index".
\ Remaining characters, if any, are moved right.
  OVER 1 SWAP +!  \ increment string length by one
  DUP ROT _$>AL               \ ds: c i i a l
  ROT - >R + DUP DUP 1+ R>    \ ds: c (a+i) (a+i) (a+i+1) (l-i)
  CMOVE> C! ;     \ "open" string for character & insert it







\ String-string insertion                           GTH 08/22/87

: $$INS ( string1 string2 index -- )                \ "s-s-ins"
\ Inserts "string1" into "string2" starting at position "index"
\ of "string2".  Remaining characters, if any, are moved right.
  OVER >R DUP ROT _$>AL       \ ds: s1 i i a2 l2 ; rs: s2
  ROT - >R + >R               \ ds: s1 ; rs: s2 (l2-i) (a2+i)
  _$>AL DUP ROT R@ ROT        \ ds: l1 a1 (a2+i) l1
  R@ OVER + R> SWAP R>        \ ds: ... (a2+i) (a2+i+l1) (l2-i)
  CMOVE>        \ "open" s2;    ds: l1 a1 (a2+i) l1 ; rs: s2
  CMOVE         \ "insert" s1;  ds: l1 ; rs: s2
  R> +! ;       \ update length of s2




\ String deletions                                  GTH 08/22/87

: $|TRIM  ( string number -- )                 \ "s-left-trim"
\ Deletes "number" characters from the left/start of "string".
  OVER >R >R _$>AL                \ ds: a l ; rs: s n
  OVER R@ + ROT ROT R@ -          \ ds: (a+n) a (l-n)
  CMOVE    \ move characters back to delete
  R> NEGATE R>                    \ ds: -n s
  +! ;     \ adjust string length

: $TRIM|  ( string number -- )                 \ "s-trim-right"
\ Deletes "number" characters from the right/end of "string".
  NEGATE SWAP +! ;



\ String deletions                                  GTH 08/22/87

: $|SPACES ( string -- )                     \ "s-left-spaces"
\ Trims leading spaces from string.
  DUP _LEN 0= IF DROP EXIT THEN  \ handle NULL case
  DUP 32 0 ROT _LOOP> DO             \ ds: s 32 0
    OVER I C@ = IF 1+ ELSE LEAVE THEN
  LOOP SWAP DROP                     \ ds: s 0|number
  DUP IF $|TRIM ELSE 2DROP THEN ;







\ String deletions                                  GTH 08/22/87

: $SPACES| ( string -- )                     \ "s-spaces-right"
\ Trims trailing spaces from string.
  DUP _LEN 0= IF DROP EXIT THEN  \ handle NULL case
  DUP 32 0 ROT _LOOP< DO             \ ds: s 32 0
    OVER I C@ = IF 1+ ELSE LEAVE THEN
  -1 +LOOP SWAP DROP                 \ ds: s 0|number
  DUP IF $TRIM| ELSE 2DROP THEN ;







\ String deletions                                  GTH 08/22/87

: $DEL ( string index number -- )                     \ "s-del"
\ Deletes "number" characters from "string" starting at
\ position "index".
  >R DUP >R OVER          \ ds: s i s ; rs: n i
  _$>AL ROT -             \ ds: s a (l-i)
  SWAP R> +               \ ds: s (l-i) (a+i) ; rs: n
  DUP R@ + SWAP           \ ds: s (l-i) (a+i+n) (a+i) ; rs: n
  ROT R@ -                \ ds: s (a+i+n) (a+i) (l-i-n) : rs: n
  CMOVE   \ move characters back to delete
  R> NEGATE SWAP          \ ds: -n s
  +! ;    \ adjust string length



\ String replacements                               GTH 08/22/87

: $$REP ( string1 string2 index -- )                \ "s-s-rep"
\ Replaces current substring in "string2" with "string1"
\ starting at position "index" of "string2".
  + _CF+ SWAP                     \ ds: (a2+i) s1
  _$>AL ROT SWAP                  \ ds: a1 (a2+i) l1
  CMOVE ;   \ "move" s1 into s2 at appropriate index








\ String rotations                                  GTH 08/22/87
: $<ROT ( string -- )                          \ "s-left-rote"
\ Rotates a string left one character.
  _$>AL 1- OVER C@ >R             \ ds: a (l-1) ; rs: C@(a)
  2DUP OVER 1+ ROT ROT            \ ds: ... (a+1) a (l-1)
  CMOVE   \ shift back one character
  + R> SWAP                       \ ds: C@(a) (a+l-1)
  C! ;    \ update rightmost character

: $>ROT ( string -- )                          \ "s-right-rote"
\ Rotates a string right one character.
  _$>AL 1- 2DUP + C@ >R           \ ds: a (l-1) ; rs: C@(a+l-1)
  OVER DUP 1+ ROT                 \ ds: a a (a+1) (l-1)
  CMOVE>  \ shift forward one character
  R> SWAP                         \ ds: C@(a+l-1) a
  C! ;    \ update leftmost character
\ String rotations                                  GTH 08/22/87

: $<<ROT ( string number -- )              \ "s-many-left-rote"
\ Rotates "string" left "number" characters.
  OVER _LEN MOD  \ ensure 0 <= number < l
  >R _$>AL                          \ ds: a l ; rs: n
  OVER _BUFFER R@                   \ ds: ... a _BUFFER n
  CMOVE    \ move left part of string to _BUFFER
  R@ - 2DUP OVER R@ + ROT ROT       \ ds: a (l-n) (a+n) a (l-n)
  CMOVE    \ move right part of string into left part
  + _BUFFER SWAP R>                 \ ds: _BUFFER (a+l-n) n
  CMOVE ;  \ move _BUFFER to right part of string




\ String rotations                                  GTH 08/22/87

: $>>ROT ( string number -- )             \ "s-many-right-rote"
\ Rotates "string" right "number" characters.
  OVER _LEN MOD  \ ensure 0 <= number < l
  >R _$>AL R@ -                     \ ds: a (l-n) ; rs: n
  2DUP + _BUFFER R@                 \ ds: ... (a+l-n) _BUFFER n
  CMOVE    \ move right part of string to _BUFFER
  OVER DUP R@ + ROT                 \ ds: a a (a+n) (l-n)
  CMOVE>   \ move left part of string into right part
  _BUFFER SWAP R>                   \ ds: _BUFFER a n
  CMOVE ;  \ move _BUFFER to left part of string




\ String comparisons                                GTH 08/22/87

: $$COMPARE ( string1 string2 -- status )       \ "s-s-compare"
\ Returns -1, 0, or +1 depending on whether string1 is
\ lexicographically less than, equal to, or greater than
\ string2, respectively.
  SWAP _$>AL ROT _$>AL ROT 2DUP - >R MIN
  \ ds: a1 a2 MIN(l1,l2) ; rs: (l2-l1)
  COMPARE
  R> OVER 0= IF  \ if can't be decided within MIN chars
    DUP IF 0< IF 1 ELSE -1 THEN THEN SWAP
  THEN
  DROP ;



\ String comparisons                                GTH 08/22/87

: $$= ( string1 string2 -- t | f )   \ "s-s-equal"
\ Returns -1 if string1 =  string2, else returns 0.
$$COMPARE 0= ;

: $$< ( string1 string2 -- t | f )   \ "s-s-less-than"
\ Returns -1 if string1 <  string2, else returns 0.
$$COMPARE 0< ;

: $$<= ( string1 string2 -- t | f )  \ "s-s-less-than-or-equal"
\ Returns -1 if string1 <= string2, else returns 0.
$$COMPARE 0> NOT ;



\ String comparisons                                GTH 08/22/87

: $$> ( string1 string2 -- t | f )         \ "s-s-greater-than"
\ Returns -1 if string1 >  string2, else returns 0.
$$COMPARE 0> ;

: $$>= ( string1 string2 -- t | f) \ "s-s-greater-than-or-equal"
\ Returns -1 if string1 >= string2, else returns 0.
$$COMPARE 0< NOT ;

: $$<> ( string1 string2 -- t | f )        \ "s-s-not-equal"
\ Returns -1 if string1 <> string2, else returns 0.
$$COMPARE 0= NOT ;



\ String pattern matching - internal routines       GTH 08/22/87

: _$CFIND ( char string direction -- index | -1 )
\ Searches for leftmost or rightmost occurrence of "char"
\ in "string".  Returns -1 if not found.
  >R _$>AL OVER R> SWAP >R              \ ds: c a l dir ; rs: a
  IF CFIND ELSE CFIND< THEN R> OVER     \ ds: addr|0 a addr|0
  IF SWAP 0 ROT 0 D- DROP ELSE 2DROP -1 THEN ;








\ String pattern matching                           GTH 08/22/87

: $CFIND ( char string -- index | -1 )        \ "s-c-find"
\ Searches for leftmost occurrence of "char" in "string".
\ Returns "index" if found, else returns -1.
  -1 _$CFIND ;

: $CFIND< ( char string -- index | -1 )       \ "s-c-find-back"
\ Searches for rightmost occurrence of "char" in "string".
\ Returns "index" if found, else returns -1.
  0 _$CFIND ;





\ String pattern matching                           GTH 08/22/87

: $$FIND ( string1 string2 index length -- index | -1 )
                                                   \ "s-s-find"
\ Searches for the first occurrence of the string1 substring
\ starting at "index" for "length" characters in string2.
\ Returns index if found, else returns -1.
  ROT >R >R                          \ ds: s1 i ; rs: s2 l
  + _CF+ -1 SWAP R> R>               \ ds: -1 (a1+i) l s2
  \ Iterate over a2 ... (a2+l2-l+1)
  _$>AL OVER >R + OVER - 1+ R@ DO    \ ds: -1 (a1+i) l ; rs: a2
    2DUP I SWAP SAME?
    IF 2DROP I SWAP 0 LEAVE THEN  \ match found
  LOOP 2DROP                         \ ds: -1|addr ; rs: a2
  R> OVER -1 = NOT                   \ ds: -1|addr a2 0>=flag
  IF 0 SWAP OVER D- THEN DROP ;
\ String set operators                              GTH 08/22/87
: $CMEM ( char string -- t | f )                    \ "s-c-mem"
\ Returns -1 if "char" is in "string", else returns 0.
  $CFIND 0< NOT ;
: $$VER ( string1 string2 -- index | -1 )           \ "s-s-ver"
\ Verifies that string2 contains only those characters in
\ string1 by returning a -1.  Otherwise the index of the first
\ character in string2 not contained in string1 is returned.
  DUP _LEN 0= IF 2DROP -1 EXIT THEN  \ string2 = NULL
  >R _$>AL -1                        \ ds: a1 l1 -1 ; rs: s2
  \ Iterate over a2 ... a2+l2-1
  R> DUP _CF+ >R _LOOP> DO           \ ds: a1 l1 -1 ; rs: a2
    I C@ 2OVER CFIND
    0= IF DROP I LEAVE THEN          \ set TOS to index?
  LOOP >R 2DROP R> R> OVER -1 = NOT  \ ds: -1|addr a2 fail-flag
  IF 0 SWAP OVER D- THEN DROP ;
\ String translation                                GTH 08/22/87
: $>UPPER ( string -- )                          \ "s-to-upper"
\ Converts any lower-case characters in "string" to upper-case.
  DUP _LEN 0= IF DROP EXIT THEN  \ handle NULL case
  _LOOP> DO
    I DUP C@ DUP 96 > OVER 123 < AND
    IF 32 - SWAP C! ELSE 2DROP THEN
  LOOP ;

: $>LOWER ( string -- )                          \ "s-to-lower"
\ Converts any upper-case characters in "string" to lower-case.
  DUP _LEN 0= IF DROP EXIT THEN  \ handle NULL case
  _LOOP> DO
    I DUP C@ DUP 64 > OVER 91 < AND
    IF 32 + SWAP C! ELSE 2DROP THEN
  LOOP ;
\ String encoding/decoding                          GTH 08/22/87

\ String & index variables for $CONVERT
VARIABLE _CVT$    VARIABLE _CVTNDX

: $CONVERT ( string index -- )                    \ "s-convert"
\ Defines a string and index within the string to be used for
\ subsequent string-to-number or number-to-string conversions.
  _CVTNDX ! _CVT$ ! ;







\ String encoding/decoding                          GTH 08/22/87

: $<N ( number -- )                                \ "s-from-n"
\ Converts "number" to the appropriate ASCII representation
\ character and inserts it into the string and index defined
\ by the last call to $CONVERT.  Note that successive calls to
\ $<N "builds" the number string in reverse sequence.
\ For example, the code:
\
\     CREATE SNUMBER 10 $ALLOT
\     SNUMBER 0 $CONVERT 1 $<N 2 $<N 3 $<N
\
\ would build the image "321" in string SNUMBER.
  DUP 9 > IF 7 + THEN 48 +  \ convert to ASCII
  _CVT$ @ _CVTNDX @ $CINS ;

\ String encoding/decoding                          GTH 08/22/87

\ : $>N ( -- number | -1 )                           \ "s-to-n"
\ Converts the character at the string/index position defined
\ by the last call to $CONVERT to a number if possible.  An
\ error (i.e., -1) is returned if the character is non-numeric
\ (i.e., does not lie between 0..BASE-1).  The index position
\ established in the call to $CONVERT is always incremented
\ after a call to $>N.
\
\ The code word for $>N is on the next screen:
\




\ String encoding/decoding                          GTH 08/22/87

: $>N ( -- number | -1 )                             \ "s-to-n"
  _CVT$ @ _CVTNDX @ $C@       \ fetch character
  1 _CVTNDX +!                \ update index
                              \ ds: char
  96 OVER < OVER 123 < AND
  IF 87 - ELSE                \ "a" <= char <= "z"
  64 OVER < OVER  91 < AND
  IF 55 - ELSE                \ "A" <= char <= "Z"
  47 OVER < OVER  58 < AND
  IF 48 - ELSE                \ "0" <= char <= "9"
    DROP -1 EXIT              \ invalid char
  THEN THEN THEN              \ ds: number
  BASE @ OVER > NOT           \ char < BASE ?
  IF DROP -1 THEN ;