\ ==[  File:  MFStrings.Scr  (27381 bytes) ]=================================
( MULTI-FORTH STRINGS                                  MDG Feb 1988 )

                   (      MULTI-FORTH STRINGS     )
                   ( Multi-Forth Coded Adaptation )
                   (              of              )
                   (       George T. Hawkins'     )
                   (    FORTH-83 STRINGS PACKAGE  )
                   (              for             )
                   (      Run-Time Efficiency     )
                   (              by              )
                   (       Marcus D. Gabriel      )
                   (         February 1988        )
                   (                              )

( NOTE: The Multi-Forth Assembler must be compiled before compiling )
(       Multi-Forth Strings.                                        )

(   This file provides a string handling/manipulation capability    )
( in coded Multi-Forth where appropriate, otherwise high level      )
( Multi-Forth is used.                                              )

\ DOCUMENTATION                                     GTH 08/22/87

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

\   Any words beginning with an initial underscore "_" should be
\ "hidden." ( These words should be AXE'd, MDG Feb 1988. )

\   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.
\   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

FORTH

DECIMAL

2048 MINIMUM.OBJECT
1024 MINIMUM.VOCAB

ANEW MFSTRINGS

\ Memory lexicographic compare                      GTH 08/22/87

CODE COMPARE ( a1 a2 n -- status )  \ -1 | 0 |+1 for 1<2 | 1=2 | 1>2
\ 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.
( Modified by MDG Feb 1988 )
  D0 POP,  A1 POP,  A0 GET,
  SP () LONG CLR,            \ clear the flag to 0
  D0 LONG TST,
  NE IF,                     \ if n=0, then 0
    BEGIN,
      A1 A0 BYTE CMPM,       \ compare (a1+i)-(a2+i) and postincrement
    EQ WHILE,
      D0 01 WORD SUBQ,
      NE IF,  ROT ROT        \ if n=0, then 0 (i.e., skip to NEXT )
    REPEAT,
        PL IF,  SP () 01 LONG ADDQ,  \ flag =  1
        ELSE,   SP () 01 LONG SUBQ,  \ flag = -1
        THEN,
      THEN,
  THEN,
NEXT END-CODE

\ Memory pattern match                              GTH 08/22/87

CODE SAME? ( a1 a2 n -- t | f )  \ -1 | 0 for 1=2 | 1<>2
\ 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.
( Modified by MDG Feb 1988 )
  D0 POP,  A1 POP,  A0 GET,
  SP () LONG CLR,            \ clear the flag to 0
  BEGIN,
    D0 01 WORD SUBQ,
  PL WHILE,
    A1 A0 BYTE CMPM,         \ compare (a1+i)-(a2+i) and postincrement
    EQ IF,  ROT ROT          \ if not equal, then 0*
  REPEAT,
      SP () 01 LONG SUBQ,    \ flag = -1, i.e., same
    THEN,                    \ * skip to here if not equal
NEXT END-CODE

\ Memory character/byte 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.
( Modified by MDG Feb 1988 )
  D0 POP,  A0 POP,  D1 GET,
  SP () LONG CLR,            \ clear the flag to 0
  D0 LONG TST,
  NE IF,                     \ if n=0, then 0
    BEGIN,
      A0 )+ D1 BYTE CMP,     \ compare c-(a1+i), postincrement (a1+i)
    NE WHILE,
      D0 01 WORD SUBQ,
      NE IF,  ROT ROT        \ if n=0, then 0 (i.e., skip to NEXT )
    REPEAT,
        A0 PUT,
        SP () 01 LONG SUBQ,  \ put a2 on the stack, c found
      THEN,
  THEN,
NEXT END-CODE

CODE CFIND< ( c a1 n -- a2 | 0 )                   \ "c-find-back"
\ Same as CFIND except search is high-to-low memory.
( Modified by MDG Feb 1988 )
  D0 POP,  A0 POP,  D1 GET,
  SP () LONG CLR,            \ clear the flag to 0
  D0 LONG TST,
  NE IF,                     \ if n=0, then 0
    D0 A0 LONG ADDA,         \ NOTE: memory search begins at a1+n-1
    BEGIN,
      A0 -) D1 BYTE CMP,     \ predecrement a=(a1+n-i), compare c-a
    NE WHILE,
      D0 01 WORD SUBQ,
      NE IF,  ROT ROT        \ if n=0, then 0 (i.e., skip to NEXT )
    REPEAT,
        A0 PUT,              \ put a2 on the stack, c found
      THEN,
  THEN,
NEXT END-CODE

\ 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.
( Modified by MDG Feb 1988 )
  SP () 04 LONG ADDQ,
NEXT END-CODE

CODE _LEN ( s -- l )
\ Returns the length of a string.
( Modified by MDG Feb 1988 )
  A0 GET,  A0 () PUT,
NEXT END-CODE

CODE _$>AL ( s -- a l )
\ Converts from string reference to data address, length.
\ Factored out to interface with lower level memory operators.
( Modified MDG Feb 1988 )  \ NOTE: modify "2+" if machine word size <>
  A0 GET,                  \       2 bytes.
  SP () 04 LONG ADDQ,  A0 () 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.

( Multi-Forth Dynamic Allocation of Internal Data   MDG Feb 1988 )

GLOBAL MAX$  512 TO MAX$         \ "max-s", maximum literal string size
GLOBAL _BUFFER.HANDLE            \ handle to temporary buffer
GLOBAL _BUFFER                   \ string temporary holding buffer

: ALLOT.BUFFER ( -- t | f )      \ t=successful & f=unsuccessful
\ Dynamically allocates a string temporary holding buffer capable of
\ storing a maximum literal string length determined by the global variable
\ MAX$.  Returns a true flag if the buffer is successfully allocated,
\ otherwise a false flag is returned.
  MAX$ _CF+ FROM.HEAP TO _BUFFER.HANDLE
  _BUFFER.HANDLE ?DUP
  IF  @ TO _BUFFER  TRUE  ELSE  FALSE  THEN ;

: DEALLOT.BUFFER ( -- )
\ Deallocates the string temporary holding buffer allocated by 
\ ALLOT.BUFFER.
  _BUFFER.HANDLE ?DUP
  IF  TO.HEAP  0 TO _BUFFER.HANDLE  0 TO _BUFFER  THEN ;

\ Internal routines                                 GTH 08/22/87

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

CODE _$ADDR  ( -- s )                             ( MDG Feb 1988 )
\ Skips over the following in-line string literal, leaving
\ the string reference on the stack.
\ High Level Equivalent:  R@ DUP _LEN _CF+ =CELLS R> + >R
  IP PUSH,                        \ push the string reference onto the TOS
  IP )+ D0 LONG MOVE,             \ get string length and postincrement
                                  \   beyond the count field
  D0 01 LONG ADDQ,                \ add 1 to the string length and mask
  D0 -2 LONG ANDI,                \   the result with -2 to obtain a
                                  \   cell address if not one
  D0 IP LONG ADDA,                \ finish incrementing the IP beyound
NEXT END-CODE                     \    the string

( Additional Routines of Generic Value              MDG Feb 1988 )

CODE LOWER ( a l -- )                             ( MDG Feb 1988 )
\ Converts uppercase characters to lowercase.  Any uppercase ASCII
\ alpha characters in the string at address a for l bytes are
\ conveted to lowercase ASCII alpha characters.
  D0 POP,  A0 POP,  D0 01 LONG SUBQ,
  PL IF,
    BEGIN,  
      A0 )+ 64 ( "@" ) BYTE CMPI,              \ compare to ASCII @
      GT IF,  
        -1 A0 I) 91 ( "[" ) BYTE CMPI,         \ compare to ASCII [
        LT IF,  -1 A0 I) 32 BYTE ADDI,  THEN,  \ lower case
      THEN,
    D0 LOOP,
  THEN,
NEXT END-CODE

CODE CHARACTER  ( number -- character )           ( MDG Feb 1988 )
\ Converts "number" to the appropriate ASCII representation
\ "character" and places it on the TOS.
  SP () 09 LONG CMPI,
  GT IF,  SP () 07 LONG ADDQ,  THEN,
  SP () 48 LONG ADDI,
NEXT END-CODE

: BEGINNING.OF  ( <name> ( -- addr )              ( MDG Feb 1988 )
\ Give the Direct Threaded Code ( DTC ) field of <name> .
  [COMPILE] ' 4- ;

\ 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 """

UNIQUE.MSG OFF

: $LIT ( -- string )  \ interpretive string literal
( Modified by MDG Feb 1988 )
  BL  LOCALS|  DELEM  |  _BUFFER _CF+
  \ Bypass leading blanks, if any.
  >IN @  BEGIN  DELEM OVER _'INPC  C@ = WHILE  1+  REPEAT
  DUP _'INPC C@ TO DELEM  1+ SWAP         \ ds: >IN' _BUFFER'
  BEGIN
    OVER _'INPC  DUP C@ DELEM =
    IF  1+ C@ DELEM =                     \ delim = current char
      IF    DELEM OVER C!                 \ consecutive delimiters
            1+ SWAP 2+ SWAP  FALSE        \   update & continue
      ELSE  TRUE  THEN                    \ single delimiter, done
    ELSE                                  \ delim <> current char
      C@ OVER C!  1+ SWAP 1+ SWAP  FALSE  \ update & continue
    THEN
  UNTIL                                   \ ds: >IN'' _BUFFER''
  _BUFFER _CF+ - _BUFFER !                \ set string size
  1+ >IN !  _BUFFER ;                     \ adjust >IN & return reference

UNIQUE.MSG ON

: $, ( string -- )                            \ "s-comma"
\ Compiles a string into the dictionary.
( Modified by MDG Feb 1988 )
  HERE OVER _LEN _CF+ =CELLS DUP ALLOT CMOVE ;

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

: [$LIT] ( -- string )                        \ "bracket-s-lit"
\ Compiled string literal
( Modified by MDG Feb 1988 )
  COMPILE _$ADDR               \ forward branch around string
  ,$ ; IMMEDIATE

: $KEY ( string -- )                                \ "s-key"
\ Inputs interactively from the console to the string until <RET>
\ without echoing back to the console.
( Incomplete as of Feb 1988, MDG )
( Still echoing back to console. )
  DUP _CF+ MAX$ IEXPECT CNT @ 1- ( eliminate linefeed ) SWAP ! ;

: $$KEY ( string -- )                               \ "s-s-key"
\ Same as $KEY except input echoed back to the console.
( Modified by MDG Feb 1988 )
  DUP _CF+ MAX$ IEXPECT  CNT @ 1- ( eliminate linefeed ) SWAP ! ;

\ 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.
( Modified by MDG Feb 1988 )
  >R  _$>AL  R> DUP _$>AL
  LOCALS|  LEN2  ADDR2  S2  LEN1  ADDR1  |
  ADDR1  ADDR2 LEN2 +  LEN1  CMOVE
  LEN1 S2 +! ;

\ 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@ ;

: $$! ( 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.
( Modified by MDG Feb 1988 )
  LOCALS|  LEN  INDEX  S2  S1  |
  LEN S2 !                                \ set length of s2
  S1 _CF+ INDEX +  S2 _CF+  LEN  CMOVE ;

\ 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.
( Modified by MDG Feb 1988 )
  OVER _CF+  LOCALS|  ADDR  INDEX  S  CHAR  |
  \ "open" string for character & insert it
  ADDR INDEX +  DUP 1+  S _LEN INDEX -  CMoVE>
  CHAR  ADDR INDEX +  C!
  \ increment string length by one
  1 S +! ;

: $$INS ( string1 string2 index -- )                \ "s-s-ins"
\ Inserts "string1" into "string2" starting at position "index"
\ of "string2".  Remaining characters, if any, are moved right.
( Modified by MDG Feb 1988 )
  >R >R  _$>AL  R> DUP _$>AL  R>
  LOCALS|  INDEX  LEN2  ADDR2  S2  LEN1  ADDR1  |
  ADDR2 INDEX +  DUP LEN1 +  LEN2 INDEX -  CMOVE>     \ "open" s2
  ADDR1  ADDR2 INDEX +  LEN1  CMOVE                   \ "insert" s1
  LEN1 S2 +! ;                                        \ 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".
( Modified by MDG Feb 1988 )
  OVER _$>AL  LOCALS|  LEN  ADDR  N  S  |
  ADDR N +  ADDR  LEN N -  CMOVE  \ move characters back to delete
  N NEGATE S +! ;

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

: $|SPACES ( string -- )                     \ "s-left-spaces"
\ Trims leading spaces from string.
( Modified by MDG Feb 1988 )
  DUP _$>AL  LOCALS|  LEN  ADDR  S  |
  LEN 0= IF  EXIT  THEN                 \ handle NULL case
  S  0                                  \ ds: s 0; 0 spaces to date
  ADDR LEN +  ADDR  DO
    BL IC@ = IF  1+  ELSE  LEAVE  THEN
  LOOP                                  \ ds: s 0|number
  ?DUP IF  $|TRIM  ELSE  DROP  THEN ;

: $SPACES| ( string -- )                     \ "s-spaces-right"
\ Trims trailing spaces from string.
( Modified by MDG Feb 1988 )
  DUP _$>AL  LOCALS|  LEN  ADDR  S |
  LEN 0= IF  EXIT  THEN                 \ handle NULL case
  S  0                                  \ ds: s 0; 0 spaces to date
  ADDR  ADDR LEN + 1-  DO
    BL IC@ = IF  1+  ELSE  LEAVE  THEN
  -1 +LOOP                               \ ds: s 0|number
  ?DUP IF  $TRIM|  ELSE  DROP  THEN ;

: $DEL ( string index number -- )                     \ "s-del"
\ Deletes "number" characters from "string" starting at
\ position "index".
( Modified by MDG Feb 1988 )
  LOCALS|  N  INDEX  S  |
  S _CF+ INDEX + N +  S _CF+ INDEX +  S _LEN INDEX - N -  CMOVE
  N NEGATE S +! ;

\ 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".
( Modified by MDG Feb 1988 )
  >R >R  _$>AL  R> _CF+  R>
  LOCALS|  INDEX  ADDR2  LEN1  ADDR1  |
  ADDR1  ADDR2 INDEX +  LEN1  CMOVE ;

\ String rotations                                  GTH 08/22/87

: $<ROT ( string -- )                          \ "s-left-rote"
\ Rotates a string left one character.
( Modified by MDG Feb 1988 )
  _$>AL  1-  OVER C@  LOCALS|  CHAR  LEN-1  ADDR  |
  ADDR 1+  ADDR  LEN-1  CMOVE  \ shift back one character
  CHAR  ADDR LEN-1 +  C! ;     \ update rightmost character

: $>ROT ( string -- )                          \ "s-right-rote"
\ Rotates a string right one character.
( Modified by MDG Feb 1988 )
  _$>AL  1-  2DUP + C@  LOCALS|  CHAR  LEN-1  ADDR  |
  ADDR  ADDR 1+  LEN-1  CMOVE>  \ shift forward one character
  CHAR ADDR C! ;                \ update leftmost character

: $<<ROT ( string number -- )              \ "s-many-left-rote"
\ Rotates "string" left "number" characters.
( Modified by MDG Feb 1988 )
  OVER _LEN MOD ( ensure 0 <= number < l )  SWAP _$>AL
  LOCALS|  LEN  ADDR  N  |
  \ move left part of string to _BUFFER
  ADDR _BUFFER N CMOVE
  \ move right part of string into left part
  ADDR N +  ADDR  LEN N -  CMOVE
  \ move _BUFFER to right part of string
  _BUFFER  ADDR LEN + N -  N CMOVE ;

: $>>ROT ( string number -- )             \ "s-many-right-rote"
\ Rotates "string" right "number" characters.
( Modified by MDG Feb 1988 )
  OVER _LEN MOD ( ensure 0 <= number < l )  SWAP _$>AL
  LOCALS|  LEN  ADDR  N  |
  \ move right part of string to _BUFFER
  ADDR LEN + N -  _BUFFER  N  CMOVE
  \ move left part of string into right part
  ADDR  ADDR N +  LEN N -  CMOVE>
  \ move _BUFFER to left part of string
  _BUFFER ADDR N CMOVE ;

\ String comparisons                                GTH 08/22/87

( String Comparison Subroutine                      MDG Feb 1988 )

( NOTE:  The words $$COMPARE , $$= , $$< , $$<= , $$> , $$>= ,   )
(        and  $$<>  must all be compiled within plus or minus    )
(        32K of the subsoutine _$$COMPARE since all of these     )
(        words call this subrouutine with the BSR, insrtuction.  )

CODE _$$COMPARE  ( -- )                           ( MDG Feb 1988 )
\ See $$COMPARE .
\ NOTE:  This subroutine must be called, not executed, and it 
\        expects s1 in A0 and s2 in A1, returning a flag in D0.
  D0 LONG CLR,                         \ clear flag to 0, s1 = s2
  A0 () D1 LONG MOVE,                  \ load s1 length
  A0 A1 LONG CMPM,                     \ compare (s2-s1) length
  NE IF,                               \ for s1 length <> s2 lengths
    PL IF,  D0 01 LONG SUBQ,           \   flag to -1 for s1 < s2
    ELSE,   D0 01 LONG ADDQ,           \   flag to  1 for s1 > s2
            -4 A1 I) D1 LONG MOVE,     \   load s2 length, minimum count
    THEN,
  THEN,  D1 LONG TST,
  NE IF,                               \ if count = 0, then flag
    BEGIN,     A1 A0 BYTE CMPM,        \ compare (a1+i)-(a2+i) and
    EQ WHILE,  D1 01 WORD SUBQ,        \   postincrement
               NE IF,  ROT ROT         \ if count = 0, then flag*
    REPEAT,      PL IF,  01 D0 MOVEQ,  \ set flag =  1
                 ELSE,   -1 D0 MOVEQ,  \ set flag = -1
                 THEN,
               THEN,                   \ * skip to here if count = 0
  THEN,
RTS, END-CODE

CODE $$COMPARE ( string1 string2 -- flag )       \ "s-s-compare"
\ Returns -1, 0, or +1 depending on whether string1 is
\ lexicographically less than, equal to, or greater than
\ string2, respectively.
( Modified by MDG Feb 1988 )
  A1 POP,  A0 GET,
    BEGINNING.OF _$$COMPARE BSR,
  D0 PUT,
NEXT END-CODE

CODE $$= ( string1 string2 -- t | f )   \ "s-s-equal"
\ Returns -1 if string1 =  string2, else returns 0.
( Modified by MDG Feb 1988 )
  A1 POP,  A0 GET,  SP () LONG CLR,  \ clear flag to zero
    BEGINNING.OF _$$COMPARE BSR,
  D0 LONG TST,
  EQ IF,  SP () 01 LONG SUBQ,  THEN,
NEXT END-CODE

CODE $$< ( string1 string2 -- t | f )   \ "s-s-less-than"
\ Returns -1 if string1 < string2, else returns 0.
( Modified by MDG Feb 1988 )
  A1 POP,  A0 GET,  SP () LONG CLR,  \ clear flag to zero
    BEGINNING.OF _$$COMPARE BSR,
  D0 LONG TST,
  LT IF,  SP () 01 LONG SUBQ,  THEN,
NEXT END-CODE

CODE $$<= ( string1 string2 -- t | f )  \ "s-s-less-than-or-equal"
\ Returns -1 if string1 <= string2, else returns 0.
( Modified by MDG Feb 1988 )
  A1 POP,  A0 GET,  SP () LONG CLR,  \ clear flag to zero
    BEGINNING.OF _$$COMPARE BSR,
  D0 LONG TST,
  LE IF,  SP () 01 LONG SUBQ,  THEN,
NEXT END-CODE

CODE $$> ( string1 string2 -- t | f )         \ "s-s-greater-than"
\ Returns -1 if string1 > string2, else returns 0.
( Modified by MDG Feb 1988 )
  A1 POP,  A0 GET,  SP () LONG CLR,  \ clear flag to zero
    BEGINNING.OF _$$COMPARE BSR,
  D0 LONG TST,
  GT IF,  SP () 01 LONG SUBQ,  THEN,
NEXT END-CODE

CODE $$>= ( string1 string2 -- t | f) \ "s-s-greater-than-or-equal"
\ Returns -1 if string1 >= string2, else returns 0.
( Modified by MDG Feb 1988 )
  A1 POP,  A0 GET,  SP () LONG CLR,  \ clear flag to zero
    BEGINNING.OF _$$COMPARE BSR,
  D0 LONG TST,
  GE IF,  SP () 01 LONG SUBQ,  THEN,
NEXT END-CODE

CODE $$<> ( string1 string2 -- t | f )        \ "s-s-not-equal"
\ Returns -1 if string1 <> string2, else returns 0.
( Modified by MDG Feb 1988 )
  A1 POP,  A0 GET,  SP () LONG CLR,  \ clear flag to zero
    BEGINNING.OF _$$COMPARE BSR,
  D0 LONG TST,
  NE IF,  SP () 01 LONG SUBQ,  THEN,
NEXT END-CODE

\ 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.
( Modified by MDG Feb 1988 )
  SWAP _$>AL  LOCALS|  LEN  ADDR  DIR  CHAR  |
  CHAR ADDR LEN  DIR IF  CFIND  ELSE  CFIND<  THEN  \ ds: addr'|0
  ?DUP IF  ADDR -  ELSE  TRUE  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 ;

: $$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.
( Modified by MDG Feb 1988 )
  ROT >R >R >R  _CF+ R> +  R>  R> _$>AL
  LOCALS|  LEN2  ADDR2  LEN  ADDR1+INDEX  |
  0                                     \ 0 for not found, return TRUE
  ADDR2 LEN2 + LEN - 1+  ADDR2          \ Iterate over a2 . . . (a2+l2-l+1)
  DO
    ADDR1+INDEX I LEN SAME?
    IF  DROP  I  LEAVE  THEN
  LOOP                                  \ ds: 0|addr2'
  ?DUP IF  ADDR2 -  ELSE  TRUE  THEN ;

\ 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.
( Modified by MDG Feb 1988 )
  >R  _$>AL  R> _$>AL
  LOCALS|  LEN2  ADDR2  LEN1  ADDR1  |
  LEN2 0= IF  TRUE  EXIT  THEN       \ string2 = NULL
  0                                  \ 0 for TRUE = verified
  ADDR2 LEN2 +  ADDR2                \ Iterate over a2 ... a2+l2-1
  DO
    IC@ ADDR1 LEN1 CFIND
    0= IF  DROP  I  LEAVE  THEN
  LOOP                               \ ds: 0|addr2'
  ?DUP IF  ADDR2 -  ELSE  TRUE  THEN ;

\ String translation                                GTH 08/22/87

: $>UPPER ( string -- )                          \ "s-to-upper"
\ Converts any lower-case characters in "string" to upper-case.
( Modified by MDG Feb 1988 )
  _$>AL UPPER ;

: $>LOWER ( string -- )                          \ "s-to-lower"
\ Converts any upper-case characters in "string" to lower-case.
( Modified by MDG Feb 1988 )
  _$>AL LOWER ;

\ 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.
  CHARACTER _CVT$ @ _CVTNDX @ $CINS ;

: $>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.
( Modified by MDG Feb 1988 )
  _CVT$ @ _CVTNDX @ $C@  1 _CVTNDX +!  \ fetch character and update index
  BASE @ DIGIT NOT IF  TRUE  THEN ;

\ Hide the underscored "_" words
{
AXE _CF+          AXE _LEN          AXE _$>AL          AXE _BUFFER.HANDLE
AXE _BUFFER       AXE _$$COMPARE    AXE _$ADDR         AXE _'INPC
AXE _$CFIND       AXE _CVT$         AXE _CVTNDX
}