Commit a4efad0f authored by rtoy's avatar rtoy
Browse files

code/char.lisp: 

o Use simple case folding for case-insensitive character comparisons.

code/string.lisp:
o Add new :CASING parameter for STRING-EQUAL and friends to allow for
  simple or full case folding.  Default is :SIMPLE.
o Update code to allow for simple or full case folding.

compiler/fndb.lisp:
o Tell compiler about new :CASING parameter.
parent f65856f5

code/char.lisp

+2 −2
Original line number Diff line number Diff line
@@ -5,7 +5,7 @@ 
;;; Carnegie Mellon University, and has been placed in the public domain.

;;;

(ext:file-comment

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/char.lisp,v 1.15.18.3.2.15 2009/06/06 19:57:09 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/char.lisp,v 1.15.18.3.2.16 2009/06/09 14:53:12 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -373,7 +373,7 @@ 
	 #-(and unicode (not unicode-bootstrap))

	 ch

	 #+(and unicode (not unicode-bootstrap))

	 (if (> ch 127) (unicode-lower ch) ch))))

	 (if (> ch 127) (unicode-case-fold-simple ch) ch))))





(defun char-equal (character &rest more-characters)

code/string.lisp

+84 −38
Original line number Diff line number Diff line
@@ -5,7 +5,7 @@ 
;;; Carnegie Mellon University, and has been placed in the public domain.

;;;

(ext:file-comment

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/string.lisp,v 1.12.30.30 2009/06/06 20:53:46 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/string.lisp,v 1.12.30.31 2009/06/09 14:53:13 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -361,13 +361,39 @@ 
				    (schar string2 index2)))

		   (return ,abort-value)))))))



#+unicode

(defmacro handle-case-fold-equal (f &body body)

  `(if (eq casing :simple)

       ,@body

       (let* ((s1 (case-fold string1 start1 end1))

	      (s2 (case-fold string1 start2 end2)))

	 (,f s1 s2))))



#-unicode

(defmacro handle-case-fold-equal (f &body body)

  (declare (ignore f))

  `(progn ,@body))

  

) ; eval-when



(defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)

#+unicode

(defun case-fold (string start end)

  ;; Create a new string performing full case folding of String

  (with-output-to-string (s)

    (with-one-string string start end offset

      (do ((index offset (1+ index)))

	  ((>= index end))

	(multiple-value-bind (code widep)

	    (codepoint string index)

	  (when widep (incf index))

	  (write-string (unicode-case-fold-full code) s))))))



(defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2 #+unicode (casing :simple))

  "Given two strings (string1 and string2), and optional integers start1,

  start2, end1 and end2, compares characters in string1 to characters in

  string2 (using char-equal)."

  (declare (fixnum start1 start2))

  (handle-case-fold-equal string-equal

    (with-two-strings string1 string2 start1 end1 offset1 start2 end2

       (let ((slen1 (- (the fixnum end1) start1))

	     (slen2 (- (the fixnum end2) start2)))
@@ -377,12 +403,13 @@ 
	     (error "Improper bounds for string comparison."))

	 (if (= slen1 slen2)

	     ;;return () immediately if lengths aren't equal.

	  (string-not-equal-loop 1 t nil))))) 

	     (string-not-equal-loop 1 t nil))))))



(defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)

(defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2 #+unicode (casing :simple))

  "Given two strings, if the first string is not lexicographically equal

  to the second string, returns the longest common prefix (using char-equal)

  of the two strings. Otherwise, returns ()."

  (handle-case-fold-equal string-not-equal

    (with-two-strings string1 string2 start1 end1 offset1 start2 end2

      (let ((slen1 (- end1 start1))

	    (slen2 (- end2 start2)))
@@ -397,7 +424,7 @@ 
	      ((< slen1 slen2)

	       (string-not-equal-loop 1 (- index1 offset1)))

	      (t

	     (string-not-equal-loop 2 (- index1 offset1)))))))

	       (string-not-equal-loop 2 (- index1 offset1))))))))
@@ -464,7 +491,7 @@ 
	 #-(and unicode (not unicode-bootstrap))

	 ch

	 #+(and unicode (not unicode-bootstrap))

	 (if (> ch 127) (unicode-lower ch) ch))))

	 (if (> ch 127) (unicode-case-fold-simple ch) ch))))



#+unicode

(defmacro string-less-greater-equal (lessp equalp)
@@ -516,30 +543,49 @@ 
  (declare (fixnum start1 start2))

  (string-less-greater-equal t t))



(defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)



(eval-when (compile)

  

#+unicode

(defmacro handle-case-folding (f)

  `(if (eq casing :simple)

      (,f string1 string2 start1 end1 start2 end2)

      (let* ((s1 (case-fold string1 start1 end1))

	     (s2 (case-fold string2 start2 end2))

	     (result (,f s1 s2 0 (length s1) 0 (length s2))))

	(when result

	  (+ result start1)))))



#-unicode

(defmacro handle-case-folding (f)

  `(,f string1 string2 start1 end1 start2 end2))



) ; compile



(defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2 #+unicode (casing :simple))

  "Given two strings, if the first string is lexicographically less than

  the second string, returns the longest common prefix (using char-equal)

  of the two strings. Otherwise, returns ()."

  (string-lessp* string1 string2 start1 end1 start2 end2))

  (handle-case-folding string-lessp*))



(defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2)

(defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2 #+unicode (casing :simple))

  "Given two strings, if the first string is lexicographically greater than

  the second string, returns the longest common prefix (using char-equal)

  of the two strings. Otherwise, returns ()."

  (string-greaterp* string1 string2 start1 end1 start2 end2))

  (handle-case-folding string-greaterp*))



(defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)

(defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2 #+unicode (casing :simple))

  "Given two strings, if the first string is lexicographically greater

  than or equal to the second string, returns the longest common prefix

  (using char-equal) of the two strings. Otherwise, returns ()."

  (string-not-lessp* string1 string2 start1 end1 start2 end2))

  (handle-case-folding string-not-lessp*))



(defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0)

				    end2)

				    end2 #+unicode (casing :simple))

  "Given two strings, if the first string is lexicographically less than

  or equal to the second string, returns the longest common prefix

  (using char-equal) of the two strings. Otherwise, returns ()."

  (string-not-greaterp* string1 string2 start1 end1 start2 end2))

  (handle-case-folding string-not-greaterp*))





(defun make-string (count &key element-type ((:initial-element fill-char)))

compiler/fndb.lisp

+16 −4
Original line number Diff line number Diff line
@@ -5,7 +5,7 @@ 
;;; Carnegie Mellon University, and has been placed in the public domain.

;;;

(ext:file-comment

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.136.4.1.2.2 2009/06/05 19:17:01 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.136.4.1.2.3 2009/06/09 14:53:14 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -815,20 +815,32 @@ 


(deftype stringable () '(or character string symbol))



(defknown (string= string-equal)

(defknown (string=)

  (stringable stringable &key (:start1 index) (:end1 sequence-end)

	      (:start2 index) (:end2 sequence-end))

  boolean

  (foldable flushable))



(defknown (string< string> string<= string>= string/= string-lessp

		   string-greaterp string-not-lessp string-not-greaterp

(defknown (string-equal)

  (stringable stringable &key (:start1 index) (:end1 sequence-end)

	      (:start2 index) (:end2 sequence-end) #+unicode (:casing t))

  boolean

  (foldable flushable))



(defknown (string< string> string<= string>= string/=

		   string-not-greaterp

		   string-not-equal)

  (stringable stringable &key (:start1 index) (:end1 sequence-end)

	      (:start2 index) (:end2 sequence-end))

  (or index null)

  (foldable flushable))



(defknown (string-lessp string-greaterp string-not-lessp)

  (stringable stringable &key (:start1 index) (:end1 sequence-end)

	      (:start2 index) (:end2 sequence-end) #+unicode (:casing t))

  (or index null)

  (foldable flushable))



(defknown make-string (index &key (:element-type type-specifier)

		       (:initial-element character))

  simple-string (flushable))