add merge in Ron's 11/21/2020 lispcore
This commit is contained in:
Larry Masinter
567
CLTL2/CMLSTRING
Normal file
567
CLTL2/CMLSTRING
Normal file
@@ -0,0 +1,567 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "18-Oct-93 15:18:00" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSTRING.;2" 30461
|
||||
|
||||
previous date%: "29-Aug-91 22:57:51" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSTRING.;1")
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985, 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT CMLSTRINGCOMS)
|
||||
|
||||
(RPAQQ CMLSTRINGCOMS
|
||||
(
|
||||
(* ;; "run-time support ")
|
||||
|
||||
(FUNCTIONS LISP::SIMPLE-STRING= LISP::SIMPLE-STRING-EQUAL)
|
||||
(FUNCTIONS %%STRING-BASE-COMPARE %%STRING-BASE-COMPARE-EQUAL %%STRING-UPCASE
|
||||
%%STRING-DOWNCASE)
|
||||
|
||||
(* ;; "User entry points ")
|
||||
|
||||
(FUNCTIONS LISP:MAKE-STRING LISP:NSTRING-CAPITALIZE LISP:NSTRING-DOWNCASE LISP:NSTRING-UPCASE
|
||||
STRING LISP:STRING-CAPITALIZE LISP:STRING-DOWNCASE STRING-EQUAL LISP:STRING-GREATERP
|
||||
LISP:STRING-LEFT-TRIM LISP:STRING-LESSP LISP:STRING-NOT-EQUAL LISP:STRING-NOT-GREATERP
|
||||
LISP:STRING-NOT-LESSP LISP:STRING-RIGHT-TRIM LISP:STRING-TRIM LISP:STRING-UPCASE
|
||||
LISP:STRING/= LISP:STRING< LISP:STRING<= LISP:STRING= LISP:STRING> LISP:STRING>=)
|
||||
(OPTIMIZERS LISP: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 ")
|
||||
|
||||
|
||||
(LISP:DEFUN LISP::SIMPLE-STRING= (STRING1 STRING2)
|
||||
[LET ((END1 (%%STRING-LENGTH STRING1))
|
||||
(END2 (%%STRING-LENGTH STRING2)))
|
||||
(LISP:IF (EQ END1 END2)
|
||||
(LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2)
|
||||
(%%UNPACK-STRING STRING1 BASE1 OFFSET1 TYPENUMBER1)
|
||||
(%%UNPACK-STRING STRING2 BASE2 OFFSET2 TYPENUMBER2)
|
||||
(LISP:IF (NOT (EQ 0 OFFSET1))
|
||||
(SETQ END1 (+ END1 OFFSET1)))
|
||||
(LISP:IF (NOT (EQ 0 OFFSET2))
|
||||
(SETQ END2 (+ END2 OFFSET2)))
|
||||
(EQ END1 (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 OFFSET1 END1
|
||||
OFFSET2 END2))))])
|
||||
|
||||
(LISP:DEFUN LISP::SIMPLE-STRING-EQUAL (STRING1 STRING2)
|
||||
[LET ((END1 (%%STRING-LENGTH STRING1))
|
||||
(END2 (%%STRING-LENGTH STRING2)))
|
||||
(LISP:IF (EQ END1 END2)
|
||||
(LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2)
|
||||
(%%UNPACK-STRING STRING1 BASE1 OFFSET1 TYPENUMBER1)
|
||||
(%%UNPACK-STRING STRING2 BASE2 OFFSET2 TYPENUMBER2)
|
||||
(LISP:IF (NOT (EQ 0 OFFSET1))
|
||||
(SETQ END1 (+ END1 OFFSET1)))
|
||||
(LISP:IF (NOT (EQ 0 OFFSET2))
|
||||
(SETQ END2 (+ END2 OFFSET2)))
|
||||
(EQ END1 (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2
|
||||
OFFSET1 END1 OFFSET2 END2))))])
|
||||
|
||||
(LISP: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")
|
||||
|
||||
(LISP:IF (EQ START1 START2)
|
||||
(LISP:DO ((INDEX START1 (LISP:1+ INDEX))
|
||||
(ENDINDEX (MIN END1 END2)))
|
||||
([OR (EQ INDEX ENDINDEX)
|
||||
(NOT (EQ (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
|
||||
(%%ARRAY-READ BASE2 TYPENUMBER2 INDEX]
|
||||
INDEX))
|
||||
(LISP:DO [(INDEX1 START1 (LISP:1+ INDEX1))
|
||||
(INDEX2 START2 (LISP: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))))
|
||||
|
||||
(LISP: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.")
|
||||
|
||||
(LISP:IF (EQ START1 START2)
|
||||
(LISP:DO ((INDEX START1 (LISP: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))
|
||||
(LISP:DO [(INDEX1 START1 (LISP:1+ INDEX1))
|
||||
(INDEX2 START2 (LISP: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))))
|
||||
|
||||
(LISP: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)
|
||||
(LISP:DO ((INDEX START (LISP:1+ INDEX)))
|
||||
((EQ INDEX END)
|
||||
STRING)
|
||||
(%%ARRAY-WRITE (LISP:CHAR-UPCASE (%%ARRAY-READ BASE TYPENUMBER INDEX))
|
||||
BASE TYPENUMBER INDEX))))
|
||||
|
||||
(LISP: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)
|
||||
(LISP:DO ((INDEX START (LISP:1+ INDEX)))
|
||||
((EQ INDEX END)
|
||||
STRING)
|
||||
(%%ARRAY-WRITE (LISP:CHAR-DOWNCASE (%%ARRAY-READ BASE TYPENUMBER INDEX))
|
||||
BASE TYPENUMBER INDEX))))
|
||||
|
||||
|
||||
|
||||
(* ;; "User entry points ")
|
||||
|
||||
|
||||
(LISP:DEFUN LISP:MAKE-STRING (SIZE &KEY (ELEMENT-TYPE 'LISP:CHARACTER)
|
||||
(INITIAL-ELEMENT NIL INITIAL-ELEMENT-P)
|
||||
FATP)
|
||||
"Makes a simple string"
|
||||
(LET ((STRING (MAKE-VECTOR SIZE :ELEMENT-TYPE ELEMENT-TYPE :FATP FATP)))
|
||||
(LISP:IF INITIAL-ELEMENT-P (FILL-ARRAY STRING INITIAL-ELEMENT))
|
||||
STRING))
|
||||
|
||||
(LISP:DEFUN LISP: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 (LISP:DO ((INDEX START (LISP:1+ INDEX))
|
||||
(ALPHA-P NIL)
|
||||
(WAS-ALPHA-P NIL ALPHA-P)
|
||||
CHAR)
|
||||
((EQ INDEX END)
|
||||
STRING)
|
||||
(SETQ CHAR (LISP:CHAR STRING INDEX))
|
||||
(SETQ ALPHA-P (LISP:ALPHANUMERICP CHAR))
|
||||
(LISP:SETF (LISP:CHAR STRING INDEX)
|
||||
(LISP:IF (AND ALPHA-P (NOT WAS-ALPHA-P))
|
||||
(LISP:CHAR-UPCASE CHAR)
|
||||
(LISP:CHAR-DOWNCASE CHAR))))])
|
||||
|
||||
(LISP:DEFUN LISP: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)))
|
||||
|
||||
(LISP:DEFUN LISP: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)))
|
||||
|
||||
(LISP: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."
|
||||
(LISP:TYPECASE X
|
||||
(STRING X)
|
||||
(LISP:SYMBOL (LISP:SYMBOL-NAME X))
|
||||
(LISP:CHARACTER (LISP:MAKE-STRING 1 :INITIAL-ELEMENT X))
|
||||
(LISP:OTHERWISE (LISP:ERROR "~S cannot be coerced into a string" X))))
|
||||
|
||||
(LISP:DEFUN LISP: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 (LISP:MAKE-STRING SLEN)))
|
||||
(LISP:DOTIMES (INDEX START)
|
||||
(LISP:SETF (LISP:SCHAR NEW-STRING INDEX)
|
||||
(LISP:CHAR STRING INDEX)))
|
||||
(LISP:DO ((INDEX START (LISP:1+ INDEX))
|
||||
(ALPHA-P NIL)
|
||||
(WAS-ALPHA-P NIL ALPHA-P)
|
||||
CHAR)
|
||||
((EQ INDEX END))
|
||||
(SETQ CHAR (LISP:CHAR STRING INDEX))
|
||||
(SETQ ALPHA-P (LISP:ALPHANUMERICP CHAR))
|
||||
(LISP:SETF (LISP:SCHAR NEW-STRING INDEX)
|
||||
(LISP:IF (AND ALPHA-P (NOT WAS-ALPHA-P))
|
||||
(LISP:CHAR-UPCASE CHAR)
|
||||
(LISP:CHAR-DOWNCASE CHAR))))
|
||||
(LISP:DO ((INDEX END (LISP:1+ INDEX)))
|
||||
((EQ INDEX SLEN))
|
||||
(LISP:SETF (LISP:SCHAR NEW-STRING INDEX)
|
||||
(LISP:CHAR STRING INDEX)))
|
||||
NEW-STRING)))
|
||||
|
||||
(LISP:DEFUN LISP: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 (
|
||||
LISP:MAKE-STRING
|
||||
SLEN))
|
||||
START END)))
|
||||
|
||||
(LISP:DEFUN STRING-EQUAL (STRING1 STRING2 &KEY START1 END1 START2 END2)
|
||||
"Compare two strings for case insensitive equality"
|
||||
(LISP:IF (OR START1 END1 START2 END2)
|
||||
[%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
|
||||
(LISP: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))))]
|
||||
(LISP::SIMPLE-STRING-EQUAL STRING1 STRING2)))
|
||||
|
||||
(LISP:DEFUN LISP: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)
|
||||
(LISP:IF (> SLEN1 SLEN2)
|
||||
(- INDEX OFFSET1)))
|
||||
((EQ INDEX END1)
|
||||
NIL)
|
||||
((LISP:CHAR-GREATERP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
|
||||
(%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
|
||||
(- INDEX OFFSET1])
|
||||
|
||||
(LISP:DEFUN LISP:STRING-LEFT-TRIM (CHAR-BAG STRING)
|
||||
"Trim only on left"
|
||||
(WITH-STRING STRING (LET [(LEFT-END (LISP:DO ((INDEX 0 (LISP:1+ INDEX)))
|
||||
((OR (EQ INDEX SLEN)
|
||||
(NOT (LISP:FIND (LISP:CHAR STRING INDEX)
|
||||
CHAR-BAG)))
|
||||
INDEX))]
|
||||
(LISP:SUBSEQ STRING LEFT-END SLEN))))
|
||||
|
||||
(LISP:DEFUN LISP: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)
|
||||
(LISP:IF (< SLEN1 SLEN2)
|
||||
(- INDEX OFFSET1)))
|
||||
((EQ (- INDEX START1)
|
||||
SLEN2)
|
||||
NIL)
|
||||
((LISP:CHAR-LESSP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
|
||||
(%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
|
||||
(- INDEX OFFSET1])
|
||||
|
||||
(LISP:DEFUN LISP: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)))
|
||||
(LISP:IF (AND (EQ INDEX END1)
|
||||
(EQ SLEN1 SLEN2))
|
||||
NIL
|
||||
(- INDEX OFFSET1))])
|
||||
|
||||
(LISP:DEFUN LISP: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)
|
||||
((LISP:CHAR-NOT-GREATERP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
|
||||
(%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
|
||||
(- INDEX OFFSET1])
|
||||
|
||||
(LISP:DEFUN LISP: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)
|
||||
((LISP:CHAR-NOT-LESSP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
|
||||
(%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
|
||||
(- INDEX OFFSET1])
|
||||
|
||||
(LISP:DEFUN LISP:STRING-RIGHT-TRIM (CHAR-BAG STRING)
|
||||
"Trim only on right"
|
||||
(WITH-STRING STRING (LET [(RIGHT-END (LISP:DO ((INDEX (LISP:1- SLEN)
|
||||
(LISP:1- INDEX)))
|
||||
((OR (< INDEX 0)
|
||||
(NOT (LISP:FIND (LISP:CHAR STRING INDEX)
|
||||
CHAR-BAG)))
|
||||
(LISP:1+ INDEX)))]
|
||||
(LISP:SUBSEQ STRING 0 RIGHT-END))))
|
||||
|
||||
(LISP:DEFUN LISP: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 (LISP:DO ((INDEX 0 (LISP:1+ INDEX)))
|
||||
((OR (EQ INDEX SLEN)
|
||||
(NOT (LISP:FIND (LISP:CHAR STRING INDEX)
|
||||
CHAR-BAG)))
|
||||
INDEX)))
|
||||
(RIGHT-END (LISP:DO ((INDEX (LISP:1- SLEN)
|
||||
(LISP:1- INDEX)))
|
||||
((OR (< INDEX LEFT-END)
|
||||
(NOT (LISP:FIND (LISP:CHAR STRING INDEX)
|
||||
CHAR-BAG)))
|
||||
(LISP:1+ INDEX)))]
|
||||
(LISP:SUBSEQ STRING LEFT-END RIGHT-END))))
|
||||
|
||||
(LISP:DEFUN LISP: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 (LISP:MAKE-STRING
|
||||
SLEN))
|
||||
START END)))
|
||||
|
||||
(LISP:DEFUN LISP: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)))
|
||||
(LISP:IF (AND (EQ INDEX END1)
|
||||
(EQ SLEN1 SLEN2))
|
||||
NIL
|
||||
(- INDEX OFFSET1))])
|
||||
|
||||
(LISP:DEFUN LISP: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)
|
||||
(LISP:IF (< SLEN1 SLEN2)
|
||||
(- INDEX OFFSET1)))
|
||||
((EQ (- INDEX START1)
|
||||
SLEN2)
|
||||
NIL)
|
||||
((LISP:CHAR< (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
|
||||
(%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
|
||||
(- INDEX OFFSET1])
|
||||
|
||||
(LISP:DEFUN LISP: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)
|
||||
((LISP:CHAR<= (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
|
||||
(%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
|
||||
(- INDEX OFFSET1])
|
||||
|
||||
(LISP:DEFUN LISP:STRING= (STRING1 STRING2 &KEY START1 END1 START2 END2)
|
||||
"Compare two strings for case sensitive equality"
|
||||
(LISP:IF (OR START1 END1 START2 END2)
|
||||
[%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2
|
||||
(LISP: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))))]
|
||||
(LISP::SIMPLE-STRING= STRING1 STRING2)))
|
||||
|
||||
(LISP:DEFUN LISP: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)
|
||||
(LISP:IF (> SLEN1 SLEN2)
|
||||
(- INDEX OFFSET1)))
|
||||
((EQ INDEX END1)
|
||||
NIL)
|
||||
((LISP:CHAR> (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
|
||||
(%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
|
||||
(- INDEX OFFSET1])
|
||||
|
||||
(LISP:DEFUN LISP: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)
|
||||
((LISP:CHAR>= (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
|
||||
(%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
|
||||
(- INDEX OFFSET1])
|
||||
|
||||
(DEFOPTIMIZER LISP:STRING= (STRING1 STRING2 &REST OPTIONS)
|
||||
(LISP:IF OPTIONS
|
||||
'COMPILER:PASS
|
||||
`(LISP::SIMPLE-STRING= ,STRING1 ,STRING2)))
|
||||
|
||||
(DEFOPTIMIZER STRING-EQUAL (STRING1 STRING2 &REST OPTIONS)
|
||||
(LISP:IF OPTIONS
|
||||
'COMPILER:PASS
|
||||
`(LISP::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 (LISP:IF (NOT (LISP:STRINGP ,STRING))
|
||||
(LISP: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
|
||||
[(LISP:SYMBOLP ,OBJECT)
|
||||
(SETQ ,BASE (fetch (LITATOM PNAMEBASE) of ,OBJECT))
|
||||
(SETQ ,OFFSET 1)
|
||||
(SETQ ,TYPENUMBER (LISP:IF (fetch (LITATOM FATPNAMEP) of ,OBJECT)
|
||||
%%FAT-CHAR-TYPENUMBER
|
||||
%%THIN-CHAR-TYPENUMBER))
|
||||
,@(LISP: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]
|
||||
,@(LISP:IF LENGTH
|
||||
`[(SETQ ,LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of ,OBJECT])])
|
||||
|
||||
(DEFMACRO %%ADJUST-FOR-OFFSET (START END OFFSET)
|
||||
`(LISP: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)
|
||||
(LISP:ERROR "End out of bounds: ~S" ,END]
|
||||
(COND
|
||||
((NULL ,START)
|
||||
(SETQ ,START 0))
|
||||
((NOT (<= 0 ,START ,END))
|
||||
(LISP: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))
|
||||
((LISP:SYMBOLP ,STRING)
|
||||
(fetch (LITATOM PNAMELENGTH) of ,STRING))
|
||||
[(LISP:CHARACTERP ,STRING)
|
||||
(VECTOR-LENGTH (SETQ ,STRING (STRING ,STRING]
|
||||
(T (LISP:ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE '(OR STRING LISP:SYMBOL LISP:CHARACTER)
|
||||
:NAME
|
||||
,STRING :VALUE ,STRING :MESSAGE "a string, symbol or character"))))
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "Compiler options")
|
||||
|
||||
|
||||
(PUTPROPS CMLSTRING FILETYPE LISP:COMPILE-FILE)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(LOCALVARS . T)
|
||||
)
|
||||
)
|
||||
(PUTPROPS CMLSTRING COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1993))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
Reference in New Issue
Block a user