(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

(FILECREATED "20-Aug-2021 20:44:50" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>CMLSTRING.;2
 29739  

      previous date%: "16-May-90 14:45:59" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>CMLSTRING.;1)


(* ; "
Copyright (c) 1985-1987, 1990, 2021 by Venue & Xerox Corporation.
")

(PRETTYCOMPRINT CMLSTRINGCOMS)

(RPAQQ CMLSTRINGCOMS

       (
        (* ;; "run-time support ")


        (FUNCTIONS CL::SIMPLE-STRING= CL::SIMPLE-STRING-EQUAL)
        (FUNCTIONS %%STRING-BASE-COMPARE %%STRING-BASE-COMPARE-EQUAL %%STRING-UPCASE 
               %%STRING-DOWNCASE)
        
        (* ;; "User entry points ")


        (FUNCTIONS CL:MAKE-STRING CL:NSTRING-CAPITALIZE CL:NSTRING-DOWNCASE CL:NSTRING-UPCASE STRING
               CL:STRING-CAPITALIZE CL:STRING-DOWNCASE STRING-EQUAL CL:STRING-GREATERP 
               CL:STRING-LEFT-TRIM CL:STRING-LESSP CL:STRING-NOT-EQUAL CL:STRING-NOT-GREATERP 
               CL:STRING-NOT-LESSP CL:STRING-RIGHT-TRIM CL:STRING-TRIM CL:STRING-UPCASE CL:STRING/= 
               CL:STRING< CL:STRING<= CL:STRING= CL:STRING> CL:STRING>=)
        (OPTIMIZERS CL:STRING= STRING-EQUAL)
        
        (* ;; "Internal macros  ")


        (DECLARE%: DONTCOPY DOEVAL@COMPILE (FUNCTIONS WITH-ONE-STRING WITH-ONE-STRING-ONLY 
                                                  WITH-STRING WITH-TWO-UNPACKED-STRINGS 
                                                  %%UNPACK-STRING %%ADJUST-FOR-OFFSET %%CHECK-BOUNDS
                                                  %%PARSE-STRING-ARGS %%STRING-LENGTH))
        
        (* ;; "Compiler options")


        (PROP FILETYPE CMLSTRING)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))))



(* ;; "run-time support ")



(CL:DEFUN CL::SIMPLE-STRING=
 (STRING1 STRING2)
   [LET ((END1 (%%STRING-LENGTH
 STRING1))
         (END2 (%%STRING-LENGTH
 STRING2)))
        (CL:IF (EQ END1 END2)
            (LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2)
                 (%%UNPACK-STRING
 STRING1 BASE1 OFFSET1 TYPENUMBER1)
                 (%%UNPACK-STRING
 STRING2 BASE2 OFFSET2 TYPENUMBER2)
                 (CL:IF (NOT (EQ 0 OFFSET1))
                     (SETQ END1 (+ END1 OFFSET1)))
                 (CL:IF (NOT (EQ 0 OFFSET2))
                     (SETQ END2 (+ END2 OFFSET2)))
                 (EQ END1 (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 OFFSET1 END1
                                 OFFSET2 END2))))])

(CL:DEFUN CL::SIMPLE-STRING-EQUAL
 (STRING1 STRING2)
   [LET ((END1 (%%STRING-LENGTH
 STRING1))
         (END2 (%%STRING-LENGTH
 STRING2)))
        (CL:IF (EQ END1 END2)
            (LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2)
                 (%%UNPACK-STRING
 STRING1 BASE1 OFFSET1 TYPENUMBER1)
                 (%%UNPACK-STRING
 STRING2 BASE2 OFFSET2 TYPENUMBER2)
                 (CL:IF (NOT (EQ 0 OFFSET1))
                     (SETQ END1 (+ END1 OFFSET1)))
                 (CL:IF (NOT (EQ 0 OFFSET2))
                     (SETQ END2 (+ END2 OFFSET2)))
                 (EQ END1 (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
                                 OFFSET1 END1 OFFSET2 END2))))])

(CL:DEFUN %%STRING-BASE-COMPARE
 (BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2)

   (* ;; "Return index into base1 of first inequality ")


   (* ;; "Can use eq for character comparisons because they are immediate datatypes. Can use eq for numeric equality since Indices are always in the fixnum range")


   (CL:IF (EQ START1 START2)
       (CL:DO ((INDEX START1 (CL:1+ INDEX))
               (ENDINDEX (MIN END1 END2)))
              ([OR (EQ INDEX ENDINDEX)
                   (NOT (EQ (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
                            (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX]
               INDEX))
       (CL:DO [(INDEX1 START1 (CL:1+ INDEX1))
               (INDEX2 START2 (CL:1+ INDEX2))
               (ENDINDEX (MIN END1 (+ START1 (- END2 START2]
              ([OR (EQ INDEX1 ENDINDEX)
                   (NOT (EQ (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX1)
                            (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX2]
               INDEX1))))

(CL:DEFUN %%STRING-BASE-COMPARE-EQUAL
 (BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 
                                                 END2)

   (* ;; "Return index into base1 of first case insensitive  inequality ")


   (* ;; "Can use eq for character comparisons because they are immediate datatypes. ")


   (* ;; "Char-upcase has been expanded out and simplified below.")


   (CL:IF (EQ START1 START2)
       (CL:DO ((INDEX START1 (CL:1+ INDEX))
               (ENDINDEX (MIN END1 END2)))
              ([OR (EQ INDEX ENDINDEX)
                   (NOT (EQ (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)))
                            (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX]
               INDEX))
       (CL:DO [(INDEX1 START1 (CL:1+ INDEX1))
               (INDEX2 START2 (CL:1+ INDEX2))
               (ENDINDEX (MIN END1 (+ START1 (- END2 START2]
              ([OR (EQ INDEX1 ENDINDEX)
                   (NOT (EQ (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX1)))
                            (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX2]
               INDEX1))))

(CL:DEFUN %%STRING-UPCASE
 (STRING
 START END)

   (* ;; "Assumes string is a string. Start and end define a subsequence. Destructively upcases string and returns it ")


   (LET ((BASE (%%ARRAY-BASE STRING))
         (OFFSET (%%ARRAY-OFFSET STRING))
         (TYPENUMBER (%%ARRAY-TYPE-NUMBER STRING)))
        (%%ADJUST-FOR-OFFSET
 START END OFFSET)
        (CL:DO ((INDEX START (CL:1+ INDEX)))
               ((EQ INDEX END)
                STRING)
            (%%ARRAY-WRITE (CL:CHAR-UPCASE (%%ARRAY-READ BASE TYPENUMBER INDEX))
                   BASE TYPENUMBER INDEX))))

(CL:DEFUN %%STRING-DOWNCASE
 (STRING
 START END)

   (* ;; "Assumes string is a string. Start and end define a subsequence. Destructively downcases string and returns it ")


   (LET ((BASE (%%ARRAY-BASE STRING))
         (OFFSET (%%ARRAY-OFFSET STRING))
         (TYPENUMBER (%%ARRAY-TYPE-NUMBER STRING)))
        (%%ADJUST-FOR-OFFSET
 START END OFFSET)
        (CL:DO ((INDEX START (CL:1+ INDEX)))
               ((EQ INDEX END)
                STRING)
            (%%ARRAY-WRITE (CL:CHAR-DOWNCASE (%%ARRAY-READ BASE TYPENUMBER INDEX))
                   BASE TYPENUMBER INDEX))))



(* ;; "User entry points ")



(CL:DEFUN CL:MAKE-STRING
 (SIZE &KEY (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P)
                                   FATP)
   "Makes a simple string"
   (LET ((STRING
 (MAKE-VECTOR SIZE :ELEMENT-TYPE 'CL:STRING-CHAR :FATP FATP)))
        (CL:IF INITIAL-ELEMENT-P (FILL-ARRAY STRING INITIAL-ELEMENT))
        STRING))

(CL:DEFUN CL:NSTRING-CAPITALIZE
 (STRING
 &KEY START END)
   "Given a string, returns it with the first letter of every word in uppercase and all other letters in lowercase. A word is defined to be a sequence of alphanumeric characters delimited by non-alphanumeric characters"
   [WITH-ONE-STRING-ONLY
 STRING START END (CL:DO ((INDEX START (CL:1+ INDEX))
                                                      (ALPHA-P NIL)
                                                      (WAS-ALPHA-P NIL ALPHA-P)
                                                      CHAR)
                                                     ((EQ INDEX END)
                                                      STRING)
                                                  (SETQ CHAR (CL:CHAR STRING INDEX))
                                                  (SETQ ALPHA-P (CL:ALPHANUMERICP CHAR))
                                                  (CL:SETF (CL:CHAR STRING INDEX)
                                                         (CL:IF (AND ALPHA-P (NOT WAS-ALPHA-P))
                                                             (CL:CHAR-UPCASE CHAR)
                                                             (CL:CHAR-DOWNCASE CHAR))))])

(CL:DEFUN CL:NSTRING-DOWNCASE
 (STRING
 &KEY START END)
   "Given a string, returns that string with all uppercase alphabetic characters converted to lowercase."
   (WITH-ONE-STRING-ONLY
 STRING START END (%%STRING-DOWNCASE
 STRING START END)))

(CL:DEFUN CL:NSTRING-UPCASE
 (STRING
 &KEY START END)
   "Given a string, returns that string with all lower case alphabetic characters converted to uppercase."
   (WITH-ONE-STRING-ONLY
 STRING START END (%%STRING-UPCASE
 STRING START END)))

(CL:DEFUN STRING
 (X)
   "Coerces X into a string. If X is a string, X is returned. If X is a symbol, X's pname is returned. If X is a character then a one element string containing that character is returned. If X cannot be coerced into a string, an error occurs."
   (CL:TYPECASE X
       (STRING X)
       (CL:SYMBOL (CL:SYMBOL-NAME X))
       (CL:CHARACTER (CL:MAKE-STRING
 1 :INITIAL-ELEMENT X))
       (CL:OTHERWISE (CL:ERROR "~S cannot be coerced into a string" X))))

(CL:DEFUN CL:STRING-CAPITALIZE
 (STRING
 &KEY START END)
   "Given a string, returns a new string that is a copy of it with the first letter of every word in uppercase and all other letters in lowercase. A word is defined to be a sequence of alphanumeric characters delimited by non-alphanumeric characters"
   (WITH-ONE-STRING
 STRING START END (LET ((NEW-STRING (CL:MAKE-STRING
 SLEN)))
                                              (CL:DOTIMES (INDEX START)
                                                  (CL:SETF (CL:SCHAR NEW-STRING INDEX)
                                                         (CL:CHAR STRING INDEX)))
                                              (CL:DO ((INDEX START (CL:1+ INDEX))
                                                      (ALPHA-P NIL)
                                                      (WAS-ALPHA-P NIL ALPHA-P)
                                                      CHAR)
                                                     ((EQ INDEX END))
                                                  (SETQ CHAR (CL:CHAR STRING INDEX))
                                                  (SETQ ALPHA-P (CL:ALPHANUMERICP CHAR))
                                                  (CL:SETF (CL:SCHAR NEW-STRING INDEX)
                                                         (CL:IF (AND ALPHA-P (NOT WAS-ALPHA-P))
                                                             (CL:CHAR-UPCASE CHAR)
                                                             (CL:CHAR-DOWNCASE CHAR))))
                                              (CL:DO ((INDEX END (CL:1+ INDEX)))
                                                     ((EQ INDEX SLEN))
                                                  (CL:SETF (CL:SCHAR NEW-STRING INDEX)
                                                         (CL:CHAR STRING INDEX)))
                                              NEW-STRING)))

(CL:DEFUN CL:STRING-DOWNCASE
 (STRING
 &KEY START END)
   "Given a string, returns a new string that is a copy of it with all uppercase case alphabetic characters converted to lowercase."
   (WITH-ONE-STRING
 STRING START END (%%STRING-DOWNCASE
 (COPY-VECTOR STRING (CL:MAKE-STRING

                                                                                     SLEN))
                                                START END)))

(CL:DEFUN STRING-EQUAL
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
   "Compare two strings for case insensitive equality"
   (CL:IF (OR START1 END1 START2 END2)
       [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
              (CL:IF (EQ SLEN1 SLEN2)
                  (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
                         (EQ END1 (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 
                                         TYPENUMBER2 START1 END1 START2 END2))))]
       (CL::SIMPLE-STRING-EQUAL
 STRING1 STRING2)))

(CL:DEFUN CL:STRING-GREATERP
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
   "Case insensitive version of STRING>"
   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
                 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
                                      START1 END1 START2 END2))
                        (REL-INDEX (- INDEX START1)))
                       (COND
                          ((EQ REL-INDEX SLEN2)
                           (CL:IF (> SLEN1 SLEN2)
                                  (- INDEX OFFSET1)))
                          ((EQ INDEX END1)
                           NIL)
                          ((CL:CHAR-GREATERP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
                           (- INDEX OFFSET1])

(CL:DEFUN CL:STRING-LEFT-TRIM
 (CHAR-BAG STRING)
   "Trim only on left"
   (WITH-STRING
 STRING (LET [(LEFT-END (CL:DO ((INDEX 0 (CL:1+ INDEX)))
                                                  ((OR (EQ INDEX SLEN)
                                                       (NOT (CL:FIND (CL:CHAR STRING INDEX)
                                                                   CHAR-BAG)))
                                                   INDEX))]
                                (CL:SUBSEQ STRING LEFT-END SLEN))))

(CL:DEFUN CL:STRING-LESSP
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
   "Case insensitive version of STRING<"
   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
                 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
                                      START1 END1 START2 END2))
                        (REL-INDEX (- INDEX START1)))
                       (COND
                          ((EQ INDEX END1)
                           (CL:IF (< SLEN1 SLEN2)
                                  (- INDEX OFFSET1)))
                          ((EQ (- INDEX START1)
                               SLEN2)
                           NIL)
                          ((CL:CHAR-LESSP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
                           (- INDEX OFFSET1])

(CL:DEFUN CL:STRING-NOT-EQUAL
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
   "Compare two string for case insensitive equality"
   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
                 (LET ((INDEX (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
                                     START1 END1 START2 END2)))
                      (CL:IF (AND (EQ INDEX END1)
                                  (EQ SLEN1 SLEN2))
                          NIL
                          (- INDEX OFFSET1))])

(CL:DEFUN CL:STRING-NOT-GREATERP
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
   "Case insensitive version of STRING<="
   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
                 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
                                      START1 END1 START2 END2))
                        (REL-INDEX (- INDEX START1)))
                       (COND
                          ((EQ INDEX END1)
                           (- INDEX OFFSET1))
                          ((EQ (- INDEX START1)
                               SLEN2)
                           NIL)
                          ((CL:CHAR-NOT-GREATERP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
                           (- INDEX OFFSET1])

(CL:DEFUN CL:STRING-NOT-LESSP
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
   "Case insensitive version of STRING>="
   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
                 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
                                      START1 END1 START2 END2))
                        (REL-INDEX (- INDEX START1)))
                       (COND
                          ((EQ REL-INDEX SLEN2)
                           (- INDEX OFFSET1))
                          ((EQ INDEX END1)
                           NIL)
                          ((CL:CHAR-NOT-LESSP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
                           (- INDEX OFFSET1])

(CL:DEFUN CL:STRING-RIGHT-TRIM
 (CHAR-BAG STRING)
   "Trim only on right"
   (WITH-STRING
 STRING (LET [(RIGHT-END (CL:DO ((INDEX (CL:1- SLEN)
                                                           (CL:1- INDEX)))
                                                   ((OR (< INDEX 0)
                                                        (NOT (CL:FIND (CL:CHAR STRING INDEX)
                                                                    CHAR-BAG)))
                                                    (CL:1+ INDEX)))]
                                (CL:SUBSEQ STRING 0 RIGHT-END))))

(CL:DEFUN CL:STRING-TRIM
 (CHAR-BAG STRING)

   (* ;; "Given a set of characters (a list or string) and a string, returns a copy of the string with the characters in the set removed from both ends.")


   (WITH-STRING
 STRING (LET* [(LEFT-END (CL:DO ((INDEX 0 (CL:1+ INDEX)))
                                                   ((OR (EQ INDEX SLEN)
                                                        (NOT (CL:FIND (CL:CHAR STRING INDEX)
                                                                    CHAR-BAG)))
                                                    INDEX)))
                                  (RIGHT-END (CL:DO ((INDEX (CL:1- SLEN)
                                                            (CL:1- INDEX)))
                                                    ((OR (< INDEX LEFT-END)
                                                         (NOT (CL:FIND (CL:CHAR STRING INDEX)
                                                                     CHAR-BAG)))
                                                     (CL:1+ INDEX)))]
                                 (CL:SUBSEQ STRING LEFT-END RIGHT-END))))

(CL:DEFUN CL:STRING-UPCASE
 (STRING
 &KEY START END)
   "Given a string, returns a new string that is a copy of it with all lower case alphabetic characters converted to uppercase."
   (WITH-ONE-STRING
 STRING START END (%%STRING-UPCASE
 (COPY-VECTOR STRING (CL:MAKE-STRING

                                                                                   SLEN))
                                                START END)))

(CL:DEFUN CL:STRING/=
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
   "Compare two strings for case sensitive inequality"
   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
                 (LET ((INDEX (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 
                                     END1 START2 END2)))
                      (CL:IF (AND (EQ INDEX END1)
                                  (EQ SLEN1 SLEN2))
                          NIL
                          (- INDEX OFFSET1))])

(CL:DEFUN CL:STRING<
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
   "A string A is less than a string B if in the first position in which they differ the character of A is less than the corresponding character of B according to char< or if string A is a proper prefix of string B (of shorter length and matching in all the characters of A). Returns either NIL or an index into STRING1"
   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
                 (LET* ((INDEX (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1
                                      END1 START2 END2))
                        (REL-INDEX (- INDEX START1)))
                       (COND
                          ((EQ INDEX END1)
                           (CL:IF (< SLEN1 SLEN2)
                                  (- INDEX OFFSET1)))
                          ((EQ (- INDEX START1)
                               SLEN2)
                           NIL)
                          ((CL:CHAR< (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
                           (- INDEX OFFSET1])

(CL:DEFUN CL:STRING<=
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
                 (LET* ((INDEX (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1
                                      END1 START2 END2))
                        (REL-INDEX (- INDEX START1)))
                       (COND
                          ((EQ INDEX END1)
                           (- INDEX OFFSET1))
                          ((EQ (- INDEX START1)
                               SLEN2)
                           NIL)
                          ((CL:CHAR<= (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
                           (- INDEX OFFSET1])

(CL:DEFUN CL:STRING=
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
   "Compare two strings for case sensitive equality"
   (CL:IF (OR START1 END1 START2 END2)
       [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
              (CL:IF (EQ SLEN1 SLEN2)
                  (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
                         (EQ END1 (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
                                         START1 END1 START2 END2))))]
       (CL::SIMPLE-STRING=
 STRING1 STRING2)))

(CL:DEFUN CL:STRING>
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
                 (LET* ((INDEX (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1
                                      END1 START2 END2))
                        (REL-INDEX (- INDEX START1)))
                       (COND
                          ((EQ REL-INDEX SLEN2)
                           (CL:IF (> SLEN1 SLEN2)
                                  (- INDEX OFFSET1)))
                          ((EQ INDEX END1)
                           NIL)
                          ((CL:CHAR> (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
                           (- INDEX OFFSET1])

(CL:DEFUN CL:STRING>=
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
                 (LET* ((INDEX (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1
                                      END1 START2 END2))
                        (REL-INDEX (- INDEX START1)))
                       (COND
                          ((EQ REL-INDEX SLEN2)
                           (- INDEX OFFSET1))
                          ((EQ INDEX END1)
                           NIL)
                          ((CL:CHAR>= (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
                           (- INDEX OFFSET1])

(DEFOPTIMIZER CL:STRING=
 (STRING1 STRING2 &REST OPTIONS)
                             (CL:IF OPTIONS
                                 'COMPILER:PASS
                                 `(CL::SIMPLE-STRING=
 ,STRING1 ,STRING2)))

(DEFOPTIMIZER STRING-EQUAL
 (STRING1 STRING2 &REST OPTIONS)
                               (CL:IF OPTIONS
                                   'COMPILER:PASS
                                   `(CL::SIMPLE-STRING-EQUAL
 ,STRING1 ,STRING2)))



(* ;; "Internal macros  ")


(DECLARE%: DONTCOPY DOEVAL@COMPILE 

(DEFMACRO WITH-ONE-STRING
 (STRING
 START END &REST FORMS)
   "WITH-ONE-STRING is used to set up string operations. The keywords are parsed, and STRING is coerced into a string. SLEN is bound to the string length"
   `(LET [(SLEN (VECTOR-LENGTH (SETQ ,STRING (STRING
 ,STRING]
         (%%CHECK-BOUNDS
 ,START ,END SLEN)
         ,@FORMS))

(DEFMACRO WITH-ONE-STRING-ONLY
 (STRING
 START END &REST FORMS)

   (* ;; "Like WITH-ONE-STRING but only strings allowed")


   `(PROGN (CL:IF (NOT (CL:STRINGP ,STRING))
               (CL:ERROR 'CONDITIONS:SIMPLE-TYPE-ERROR :EXPECTED-TYPE 'STRING :CULPRIT ,STRING))
           (LET [(SLEN (VECTOR-LENGTH ,STRING]
                (%%CHECK-BOUNDS
 ,START ,END SLEN)
                ,@FORMS)))

(DEFMACRO WITH-STRING
 (STRING
 &REST FORMS)

   (* ;; "WITH-STRING is like WITH-ONE-STRING, but doesn't process keywords")


   `(LET [(SLEN (VECTOR-LENGTH (SETQ ,STRING (STRING
 ,STRING]
         ,@FORMS))

(DEFMACRO WITH-TWO-UNPACKED-STRINGS
 (STRING1 STRING2 START1 END1 START2 END2 &REST FORMS)

   (* ;; "Used to set up string comparison operations. String1 and string2 are unpacked and start1, end1, start2, end2 are adjusted for non-zero offsets. Base1 and base2, typenumber1, typenumber2 , offset1 and offset2 are bound to the appropriate unpacked quantities")


   `(LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2)
         (%%UNPACK-STRING
 ,STRING1 BASE1 OFFSET1 TYPENUMBER1)
         (%%UNPACK-STRING
 ,STRING2 BASE2 OFFSET2 TYPENUMBER2)
         (%%ADJUST-FOR-OFFSET
 ,START1 ,END1 OFFSET1)
         (%%ADJUST-FOR-OFFSET
 ,START2 ,END2 OFFSET2)
         ,@FORMS))

(DEFMACRO %%UNPACK-STRING
 (OBJECT BASE OFFSET TYPENUMBER &OPTIONAL LENGTH)
   `[COND
       [(CL:SYMBOLP ,OBJECT)
        (SETQ ,BASE (fetch
 (LITATOM PNAMEBASE) of
 ,OBJECT))
        (SETQ ,OFFSET 1)
        (SETQ ,TYPENUMBER (CL:IF (fetch
 (LITATOM FATPNAMEP) of
 ,OBJECT)
                              %%FAT-CHAR-TYPENUMBER
                              %%THIN-CHAR-TYPENUMBER))
        ,@(CL:IF LENGTH
              `[(SETQ ,LENGTH (fetch
 (LITATOM PNAMELENGTH) of
 ,OBJECT])]
       (T [COND
             [(%%ONED-ARRAY-P ,OBJECT)
              (SETQ ,BASE (fetch
 (ARRAY-HEADER BASE) of
 ,OBJECT))
              (SETQ ,OFFSET (fetch
 (ARRAY-HEADER OFFSET) of
 ,OBJECT))
              (SETQ ,TYPENUMBER (fetch
 (ARRAY-HEADER TYPE-NUMBER) of
 ,OBJECT]
             (T (SETQ ,BASE (%%ARRAY-BASE ,OBJECT))
                (SETQ ,OFFSET (%%ARRAY-OFFSET ,OBJECT))
                (SETQ ,TYPENUMBER (%%ARRAY-TYPE-NUMBER ,OBJECT]
          ,@(CL:IF LENGTH
                `[(SETQ ,LENGTH (fetch
 (ARRAY-HEADER FILL-POINTER) of
 ,OBJECT])])

(DEFMACRO %%ADJUST-FOR-OFFSET
 (START END OFFSET)
   `(CL:WHEN (NOT (EQ 0 ,OFFSET))
        (SETQ ,START (+ ,START ,OFFSET))
        (SETQ ,END (+ ,END ,OFFSET))))

(DEFMACRO %%CHECK-BOUNDS
 (START END LENGTH)
   `[PROGN [COND
              ((NULL ,END)
               (SETQ ,END ,LENGTH))
              ((> ,END ,LENGTH)
               (CL:ERROR "End out of bounds: ~S" ,END]
           (COND
              ((NULL ,START)
               (SETQ ,START 0))
              ((NOT (<= 0 ,START ,END))
               (CL:ERROR "Improper substring bounds: ~s ~s" ,START ,END])

(DEFMACRO %%PARSE-STRING-ARGS
 (STRING1 STRING2 START1 END1 START2 END2 &REST FORMS)

   (* ;; "Used to set up string comparison operations. The keywords are defaulted, bounds are checked and  Slen1 and Slen1 are bound to substring lengths%"")


   `(LET [(SLEN1 (%%STRING-LENGTH
 ,STRING1))
          (SLEN2 (%%STRING-LENGTH
 ,STRING2]
         (%%CHECK-BOUNDS
 ,START1 ,END1 SLEN1)
         (%%CHECK-BOUNDS
 ,START2 ,END2 SLEN2)
         (SETQ SLEN1 (- ,END1 ,START1))
         (SETQ SLEN2 (- ,END2 ,START2))
         ,@FORMS))

(DEFMACRO %%STRING-LENGTH
 (STRING
)
   `(COND
       ((%%STRINGP ,STRING)
        (fetch
 (ARRAY-HEADER FILL-POINTER) of
 ,STRING))
       ((CL:SYMBOLP ,STRING)
        (fetch
 (LITATOM PNAMELENGTH) of
 ,STRING))
       [(CL:CHARACTERP ,STRING)
        (VECTOR-LENGTH (SETQ ,STRING (STRING
 ,STRING]
       (T (CL:ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE '(OR STRING CL:SYMBOL CL:CHARACTER)
                 :NAME
                 ,STRING :VALUE ,STRING :MESSAGE "a string, symbol or character"))))
)



(* ;; "Compiler options")



(PUTPROPS CMLSTRING
 FILETYPE
 CL:COMPILE-FILE)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
)
(PUTPROPS CMLSTRING COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1837 2573 (CL::SIMPLE-STRING= 1837 . 2573)) (2575 3323 (CL::SIMPLE-STRING-EQUAL 2575 . 
3323)) (3325 4321 (%%STRING-BASE-COMPARE 3325 . 4321)) (4323 5506 (%%STRING-BASE-COMPARE-EQUAL 4323 . 
5506)) (5508 6096 (%%STRING-UPCASE 5508 . 6096)) (6098 6692 (%%STRING-DOWNCASE 6098 . 6692)) (6730 
7047 (CL:MAKE-STRING 6730 . 7047)) (7049 8278 (CL:NSTRING-CAPITALIZE 7049 . 8278)) (8280 8536 (
CL:NSTRING-DOWNCASE 8280 . 8536)) (8538 8791 (CL:NSTRING-UPCASE 8538 . 8791)) (8793 9273 (STRING 8793
 . 9273)) (9275 11185 (CL:STRING-CAPITALIZE 9275 . 11185)) (11187 11637 (CL:STRING-DOWNCASE 11187 . 
11637)) (11639 12234 (STRING-EQUAL 11639 . 12234)) (12236 13199 (CL:STRING-GREATERP 12236 . 13199)) (
13201 13721 (CL:STRING-LEFT-TRIM 13201 . 13721)) (13723 14718 (CL:STRING-LESSP 13723 . 14718)) (14720 
15346 (CL:STRING-NOT-EQUAL 14720 . 15346)) (15348 16300 (CL:STRING-NOT-GREATERP 15348 . 16300)) (16302
 17210 (CL:STRING-NOT-LESSP 16302 . 17210)) (17212 17811 (CL:STRING-RIGHT-TRIM 17212 . 17811)) (17813 
18947 (CL:STRING-TRIM 17813 . 18947)) (18949 19389 (CL:STRING-UPCASE 18949 . 19389)) (19391 20004 (
CL:STRING/= 19391 . 20004)) (20006 21264 (CL:STRING< 20006 . 21264)) (21266 22147 (CL:STRING<= 21266
 . 22147)) (22149 22729 (CL:STRING= 22149 . 22729)) (22731 23630 (CL:STRING> 22731 . 23630)) (23632 
24475 (CL:STRING>= 23632 . 24475)))))
STOP