(FILECREATED "19-Aug-86 20:59:07" {QV}<PEDERSEN>LISP>CMLSTRING.;6 24896
changes to: (FUNCTIONS STRING \STRING-LENGTH STRING-NOT-EQUAL STRING/= MAKE-STRING)
(VARS CMLSTRINGCOMS)
previous date: "18-Aug-86 23:24:35" {QV}<PEDERSEN>LISP>CMLSTRING.;5)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSTRINGCOMS)
(RPAQQ CMLSTRINGCOMS
[(* * User entry points)
(FUNCTIONS MAKE-STRING NSTRING-CAPITALIZE NSTRING-DOWNCASE NSTRING-UPCASE STRING
STRING-CAPITALIZE STRING-DOWNCASE STRING-EQUAL STRING-GREATERP STRING-LEFT-TRIM
STRING-LESSP STRING-NOT-EQUAL STRING-NOT-GREATERP STRING-NOT-LESSP STRING-RIGHT-TRIM
STRING-TRIM STRING-UPCASE STRING/= STRING< STRING<= STRING= STRING> STRING>=)
(* * Internal stuff)
(FUNCTIONS WITH-ONE-STRING WITH-ONE-STRING-ONLY WITH-STRING WITH-TWO-STRINGS \STRING-COMPARE
\STRING-COMPARE-EQUAL \STRING-LENGTH)
(* * Compiler options)
(PROP FILETYPE CMLSTRING)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* * User entry points)
(DEFUN MAKE-STRING (SIZE &KEY INITIAL-ELEMENT FATP) "Make a simple string"
(CL:IF (NOT (AND (>= SIZE 0)
(< SIZE ARRAY-TOTAL-SIZE-LIMIT)))
(CL:ERROR "Size out of bounds: ~A" SIZE))
(LET ((STRING (\MAKE-ONED-ARRAY SIZE (QUOTE STRING-CHAR)
NIL FATP)))
(CL:IF INITIAL-ELEMENT (DOTIMES (I SIZE)
(ASET INITIAL-ELEMENT STRING I)))
STRING))
(DEFUN NSTRING-CAPITALIZE (STRING &KEY (START 0)
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 (1+ INDEX))
(ALPHA-P NIL)
(WAS-ALPHA-P NIL ALPHA-P)
CHAR)
((EQL INDEX END)
STRING)
(SETQ CHAR (CHAR STRING INDEX))
(SETQ ALPHA-P (ALPHANUMERICP CHAR))
(SETF (CHAR STRING INDEX)
(CL:IF (AND ALPHA-P (NOT WAS-ALPHA-P))
(CHAR-UPCASE CHAR)
(CHAR-DOWNCASE CHAR))))))
(DEFUN NSTRING-DOWNCASE (STRING &KEY (START 0)
END) "Given a string, returns that string with all uppercase alphabetic characters converted to lowercase."
(WITH-ONE-STRING-ONLY STRING START END (CL:DO ((INDEX START (1+ INDEX)))
((EQL INDEX END)
STRING)
(SETF (CHAR STRING INDEX)
(CHAR-DOWNCASE (CHAR STRING INDEX))))))
(DEFUN NSTRING-UPCASE (STRING &KEY (START 0)
END) "Given a string, returns that string with all lower case alphabetic characters converted to uppercase."
(WITH-ONE-STRING-ONLY STRING START END (CL:DO ((INDEX START (1+ INDEX)))
((EQL INDEX END)
STRING)
(SETF (CHAR STRING INDEX)
(CHAR-UPCASE (CHAR STRING INDEX))))))
(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."
(COND
((\STRINGP X) (* Common Lisp string)
X)
((STRINGP X) (* Interlisp String)
(LET* ((SSIZE (NCHARS X))
(STR (MAKE-STRING SSIZE)))
(DOTIMES (I SSIZE STR)
(ASET (CODE-CHAR (NTHCHARCODE X (1+ I)))
STR I))))
((SYMBOLP X)
(SYMBOL-NAME X))
((CHARACTERP X)
(MAKE-STRING 1 :INITIAL-ELEMENT X))
(T (CL:ERROR "~S cannot be coerced into a string"))))
(DEFUN STRING-CAPITALIZE (STRING &KEY (START 0)
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 (MAKE-STRING SLEN)))
(DOTIMES (INDEX START)
(SETF (SCHAR NEW-STRING INDEX)
(CHAR STRING INDEX)))
(CL:DO ((INDEX START (1+ INDEX))
(ALPHA-P NIL)
(WAS-ALPHA-P NIL ALPHA-P)
CHAR)
((EQL INDEX END))
(SETQ CHAR (CHAR STRING INDEX))
(SETQ ALPHA-P (ALPHANUMERICP CHAR))
(SETF (SCHAR NEW-STRING INDEX)
(CL:IF (AND ALPHA-P (NOT WAS-ALPHA-P))
(CHAR-UPCASE CHAR)
(CHAR-DOWNCASE CHAR))))
(CL:DO ((INDEX END (1+ INDEX)))
((EQL INDEX SLEN))
(SETF (SCHAR NEW-STRING INDEX)
(CHAR STRING INDEX)))
NEW-STRING)))
(DEFUN STRING-DOWNCASE (STRING &KEY (START 0)
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 (LET ((NEW-STRING (MAKE-STRING SLEN)))
(DOTIMES (INDEX SLEN)
(CL:IF (AND (>= INDEX START)
(< INDEX END))
(SETF (SCHAR NEW-STRING INDEX)
(CHAR-DOWNCASE (CHAR STRING INDEX)))
(SETF (SCHAR NEW-STRING INDEX)
(CHAR STRING INDEX))))
NEW-STRING)))
(DEFUN STRING-EQUAL (STRING1 STRING2 &KEY (START1 0)
END1
(START2 0)
END2) "Compare two string for case insensitive equality"
(WITH-TWO-STRINGS STRING1 STRING2 START1 END1 START2 END2
(AND (EQL SLEN1 SLEN2)
(EQL END1 (\STRING-COMPARE-EQUAL STRING1 STRING2 START1 END1 START2 END2)))))
(DEFUN STRING-GREATERP (STRING1 STRING2 &KEY (START1 0)
END1
(START2 0)
END2) "Case insensitive version of STRING>"
(WITH-TWO-STRINGS STRING1 STRING2 START1 END1 START2 END2
(LET ((INDEX (\STRING-COMPARE-EQUAL STRING1 STRING2 START1 END1 START2 END2)))
(COND
((EQL (- INDEX START1)
SLEN2)
(CL:IF (> SLEN1 SLEN2)
INDEX))
((EQL INDEX END1)
NIL)
((CHAR-GREATERP (CHAR STRING1 INDEX)
(CHAR STRING2 (+ START2 (- INDEX START1))))
INDEX)))))
(DEFUN STRING-LEFT-TRIM (CHAR-BAG STRING) "Trim only on left"
(WITH-STRING STRING (LET ((LEFT-END (CL:DO ((INDEX 0 (1+ INDEX)))
((OR (EQL INDEX SLEN)
(NOT (CL:FIND (CHAR STRING INDEX)
CHAR-BAG)))
INDEX))))
(SUBSEQ STRING LEFT-END SLEN))))
(DEFUN STRING-LESSP (STRING1 STRING2 &KEY (START1 0)
END1
(START2 0)
END2) "Case insensitive version of STRING<"
(WITH-TWO-STRINGS STRING1 STRING2 START1 END1 START2 END2
(LET ((INDEX (\STRING-COMPARE-EQUAL STRING1 STRING2 START1 END1 START2 END2)))
(COND
((EQL INDEX END1)
(CL:IF (< SLEN1 SLEN2)
INDEX))
((EQL (- INDEX START1)
SLEN2)
NIL)
((CHAR-LESSP (CHAR STRING1 INDEX)
(CHAR STRING2 (+ START2 (- INDEX START1))))
INDEX)))))
(DEFUN STRING-NOT-EQUAL (STRING1 STRING2 &KEY (START1 0)
END1
(START2 0)
END2) "Compare two string for case insensitive equality"
(WITH-TWO-STRINGS STRING1 STRING2 START1 END1 START2 END2
(OR (NOT (EQL SLEN1 SLEN2))
(NOT (EQL END1 (\STRING-COMPARE-EQUAL STRING1 STRING2 START1 END1 START2 END2))))))
(DEFUN STRING-NOT-GREATERP (STRING1 STRING2 &KEY (START1 0)
END1
(START2 0)
END2) "Case insensitive version of STRING<="
(WITH-TWO-STRINGS STRING1 STRING2 START1 END1 START2 END2
(LET ((INDEX (\STRING-COMPARE-EQUAL STRING1 STRING2 START1 END1 START2 END2)))
(COND
((EQL INDEX END1)
T)
((EQL (- INDEX START1)
SLEN2)
NIL)
((CHAR-NOT-GREATERP (CHAR STRING1 INDEX)
(CHAR STRING2 (+ START2 (- INDEX START1))))
INDEX)))))
(DEFUN STRING-NOT-LESSP (STRING1 STRING2 &KEY (START1 0)
END1
(START2 0)
END2) "Case insensitive version of STRING>="
(WITH-TWO-STRINGS STRING1 STRING2 START1 END1 START2 END2
(LET ((INDEX (\STRING-COMPARE-EQUAL STRING1 STRING2 START1 END1 START2 END2)))
(COND
((EQL (- INDEX START1)
SLEN2)
T)
((EQL INDEX END1)
NIL)
((CHAR-NOT-LESSP (CHAR STRING1 INDEX)
(CHAR STRING2 (+ START2 (- INDEX START1))))
INDEX)))))
(DEFUN STRING-RIGHT-TRIM (CHAR-BAG STRING) "Trim only on right"
(WITH-STRING STRING (LET ((RIGHT-END (CL:DO ((INDEX (1- SLEN)
(1- INDEX)))
((OR (< INDEX 0)
(NOT (CL:FIND (CHAR STRING INDEX)
CHAR-BAG)))
(1+ INDEX)))))
(SUBSEQ STRING 0 RIGHT-END))))
(DEFUN 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 (1+ INDEX)))
((OR (EQL INDEX SLEN)
(NOT (CL:FIND (CHAR STRING INDEX)
CHAR-BAG)))
INDEX)))
(RIGHT-END (CL:DO ((INDEX (1- SLEN)
(1- INDEX)))
((OR (< INDEX LEFT-END)
(NOT (CL:FIND (CHAR STRING INDEX)
CHAR-BAG)))
(1+ INDEX)))))
(SUBSEQ STRING LEFT-END RIGHT-END))))
(DEFUN STRING-UPCASE (STRING &KEY (START 0)
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 (LET ((NEW-STRING (MAKE-STRING SLEN)))
(DOTIMES (INDEX SLEN)
(CL:IF (AND (>= INDEX START)
(< INDEX END))
(SETF (SCHAR NEW-STRING INDEX)
(CHAR-UPCASE (CHAR STRING INDEX)))
(SETF (SCHAR NEW-STRING INDEX)
(CHAR STRING INDEX))))
NEW-STRING)))
(DEFUN STRING/= (STRING1 STRING2 &KEY (START1 0)
END1
(START2 0)
END2) "Compare two strings for case sensitive inequality"
(WITH-TWO-STRINGS STRING1 STRING2 START1 END1 START2 END2
(OR (NOT (EQL SLEN1 SLEN2))
(NOT (EQL END1 (\STRING-COMPARE STRING1 STRING2 START1 END1 START2 END2))))))
(DEFUN STRING< (STRING1 STRING2 &KEY (START1 0)
END1
(START2 0)
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"
(WITH-TWO-STRINGS STRING1 STRING2 START1 END1 START2 END2
(LET ((INDEX (\STRING-COMPARE STRING1 STRING2 START1 END1 START2 END2)))
(COND
((EQL INDEX END1)
(CL:IF (< SLEN1 SLEN2)
INDEX))
((EQL (- INDEX START1)
SLEN2)
NIL)
((CHAR< (CHAR STRING1 INDEX)
(CHAR STRING2 (+ START2 (- INDEX START1))))
INDEX)))))
(DEFUN STRING<= (STRING1 STRING2 &KEY (START1 0)
END1
(START2 0)
END2) (WITH-TWO-STRINGS STRING1 STRING2 START1 END1 START2 END2
(LET ((INDEX (\STRING-COMPARE STRING1 STRING2 START1 END1 START2
END2)))
(COND
((EQL INDEX END1)
T)
((EQL (- INDEX START1)
SLEN2)
NIL)
((CHAR<= (CHAR STRING1 INDEX)
(CHAR STRING2 (+ START2 (- INDEX START1))))
INDEX)))))
(DEFUN STRING= (STRING1 STRING2 &KEY (START1 0)
END1
(START2 0)
END2) "Compare two strings for case sensitive equality"
(WITH-TWO-STRINGS STRING1 STRING2 START1 END1 START2 END2
(AND (EQL SLEN1 SLEN2)
(EQL END1 (\STRING-COMPARE STRING1 STRING2 START1 END1 START2 END2)))))
(DEFUN STRING> (STRING1 STRING2 &KEY (START1 0)
END1
(START2 0)
END2) (WITH-TWO-STRINGS STRING1 STRING2 START1 END1 START2 END2
(LET ((INDEX (\STRING-COMPARE STRING1 STRING2 START1 END1 START2
END2)))
(COND
((EQL (- INDEX START1)
SLEN2)
(CL:IF (> SLEN1 SLEN2)
INDEX))
((EQL INDEX END1)
NIL)
((CHAR> (CHAR STRING1 INDEX)
(CHAR STRING2 (+ START2 (- INDEX START1))))
INDEX)))))
(DEFUN STRING>= (STRING1 STRING2 &KEY (START1 0)
END1
(START2 0)
END2) (WITH-TWO-STRINGS STRING1 STRING2 START1 END1 START2 END2
(LET ((INDEX (\STRING-COMPARE STRING1 STRING2 START1 END1 START2
END2)))
(COND
((EQL (- INDEX START1)
SLEN2)
T)
((EQL INDEX END1)
NIL)
((CHAR>= (CHAR STRING1 INDEX)
(CHAR STRING2 (+ START2 (- INDEX START1))))
INDEX)))))
(* * Internal stuff)
(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"
(BQUOTE (PROGN (SETQ (\, STRING)
(ETYPECASE (\, STRING)
(STRING (\, STRING))
(SYMBOL (SYMBOL-NAME (\, STRING)))))
(LET ((SLEN (\STRING-LENGTH (\, STRING))))
(CL:IF (NULL (\, END))
(SETQ (\, END)
SLEN))
(CL:IF (> (\, START)
(\, END))
(CL:ERROR "Improper substring bounds"))
(\,@ FORMS)))))
(DEFMACRO WITH-ONE-STRING-ONLY (STRING START END &REST FORMS)
"Like WITH-ONE-STRING but only strings allowed"
(BQUOTE (PROGN (CL:IF (NOT (CL:STRINGP (\, STRING)))
(CL:ERROR "Not a string ~S" STRING))
(LET ((SLEN (\STRING-LENGTH (\, STRING))))
(CL:IF (NULL (\, END))
(SETQ (\, END)
SLEN))
(CL:IF (> (\, START)
(\, END))
(CL:ERROR "Improper substring bounds"))
(\,@ FORMS)))))
(DEFMACRO WITH-STRING (STRING &REST FORMS)
"WITH-STRING is like WITH-ONE-STRING, but doesn't parse keywords"
(BQUOTE (PROGN (SETQ (\, STRING)
(ETYPECASE (\, STRING)
(STRING (\, STRING))
(SYMBOL (SYMBOL-NAME (\, STRING)))))
(LET ((SLEN (\STRING-LENGTH STRING)))
(\,@ FORMS)))))
(DEFMACRO WITH-TWO-STRINGS (STRING1 STRING2 START1 END1 START2 END2 &REST FORMS) "WITH-TWO-STRINGS is used to set up string comparison operations. The keywords are parsed, and symbols are hacked into strings. SLEN1 and SLEN2 are bound to substring lengths"
(BQUOTE (PROGN (SETQ (\, STRING1)
(ETYPECASE (\, STRING1)
(STRING (\, STRING1))
(SYMBOL (SYMBOL-NAME (\, STRING1)))))
(CL:IF (NULL (\, END1))
(SETQ (\, END1)
(\STRING-LENGTH (\, STRING1))))
(SETQ (\, STRING2)
(ETYPECASE (\, STRING2)
(STRING (\, STRING2))
(SYMBOL (SYMBOL-NAME (\, STRING2)))))
(CL:IF (NULL (\, END2))
(SETQ (\, END2)
(\STRING-LENGTH (\, STRING2))))
(LET ((SLEN1 (- (\, END1)
(\, START1)))
(SLEN2 (- (\, END2)
(\, START2))))
(CL:IF (OR (MINUSP SLEN1)
(MINUSP SLEN2))
(CL:ERROR "improper substring bounds"))
(\,@ FORMS)))))
(DEFUN \STRING-COMPARE (STRING1 STRING2 START1 END1 START2 END2)
"Return index into STRING1 of first inequality"
(CL:IF (EQL START1 START2)
(CL:DO ((INDEX START1 (1+ INDEX))
(ENDINDEX (CL:IF (< END1 END2)
END1 END2)))
((OR (EQL INDEX ENDINDEX)
(NOT (EQL (CHAR STRING1 INDEX)
(CHAR STRING2 INDEX))))
INDEX))
(CL:DO ((INDEX1 START1 (1+ INDEX1))
(INDEX2 START2 (1+ INDEX2)))
((OR (EQL INDEX1 END1)
(EQL INDEX2 END2)
(NOT (EQL (CHAR STRING1 INDEX1)
(CHAR STRING2 INDEX2))))
INDEX1))))
(DEFUN \STRING-COMPARE-EQUAL (STRING1 STRING2 START1 END1 START2 END2)
"Return index into STRING1 of first case insensitive inequality"
(CL:IF (EQL START1 START2)
(CL:DO ((INDEX START1 (1+ INDEX))
(ENDINDEX (CL:IF (< END1 END2)
END1 END2)))
((OR (EQL INDEX ENDINDEX)
(NOT (EQL (CHAR-UPCASE (CHAR STRING1 INDEX))
(CHAR-UPCASE (CHAR STRING2 INDEX)))))
INDEX))
(CL:DO ((INDEX1 START1 (1+ INDEX1))
(INDEX2 START2 (1+ INDEX2)))
((OR (EQL INDEX1 END1)
(EQL INDEX2 END2)
(NOT (EQL (CHAR-UPCASE (CHAR STRING1 INDEX1))
(CHAR-UPCASE (CHAR STRING2 INDEX2)))))
INDEX1))))
(DEFUN \STRING-LENGTH (STRING) "Assumes STRING is CL:STRINGP and returns (CL:LENGTH STRING)"
(COND
((\STRINGP STRING)
(CL:IF (fetch (ARRAY-HEADER FILL-POINTER-P) of STRING)
(fetch (ARRAY-HEADER FILL-POINTER) of STRING)
(fetch (ARRAY-HEADER TOTAL-SIZE) of STRING)))
((STRINGP STRING)
(NCHARS STRING))
(T (CL:ERROR "~S not a string" STRING))))
(* * Compiler options)
(PUTPROPS CMLSTRING FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS CMLSTRING COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL)))
STOP