[Bug-openmcl] apropos (and related) patch

[bryan o'connor]

- a string-designator can also be a singleton character, update
   string-argp to reflect that.

- "" is a substring to all strings, update %apropos-substring-p
   to explicitly check for that and return t before doing any more
   work.  (patch looks bigger than it actually is due to new level
   of indenting)

		...bryan


-------------- next part --------------
Index: lib/apropos.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/lib/apropos.lisp,v
retrieving revision 1.1.1.1
diff -c -1 -r1.1.1.1 apropos.lisp
*** lib/apropos.lisp	19 Oct 2003 08:57:11 -0000	1.1.1.1
--- lib/apropos.lisp	14 Dec 2004 20:10:24 -0000
***************
*** 139,161 ****
      (declare (fixnum alen blen) (optimize (speed 3)(safety 0)))
!     (if *apropos-case-sensitive-p*
!       (dotimes (i (the fixnum (%imin blen (%i+ 1 (%i- blen alen)))))
!         (declare (fixnum i))
!         (when (eq (%schar b i) chara0)
!           (when
!             (do ((j 1 (1+ j)))
!                 ((>= j alen) t)
!               (declare (fixnum j))
!               (when (neq (%schar a j)(%schar b (%i+ j i)))
!                 (return nil)))
!             (return  (%i- blen i alen)))))
!      (dotimes (i (the fixnum (%imin blen (%i+ 1 (%i- blen alen)))))
!         (declare (fixnum i))
!         (when (eq (char-upcase (%schar b i)) (char-upcase chara0))
!           (when
!             (do ((j 1 (1+ j)))
!                 ((>= j alen) t)
!               (declare (fixnum j))
!               (unless (eq (char-upcase (%schar a j)) (char-upcase (%schar b (%i+ j i))))
!                 (return nil)))
!             (return  (%i- blen i alen))))))))
  
--- 139,163 ----
      (declare (fixnum alen blen) (optimize (speed 3)(safety 0)))
!     (if (= alen 0)  ; "" is substring of every string
!         t
!         (if *apropos-case-sensitive-p*
!             (dotimes (i (the fixnum (%imin blen (%i+ 1 (%i- blen alen)))))
!               (declare (fixnum i))
!               (when (eq (%schar b i) chara0)
!                 (when
!                     (do ((j 1 (1+ j)))
!                         ((>= j alen) t)
!                       (declare (fixnum j))
!                       (when (neq (%schar a j)(%schar b (%i+ j i)))
!                         (return nil)))
!                   (return  (%i- blen i alen)))))
!             (dotimes (i (the fixnum (%imin blen (%i+ 1 (%i- blen alen)))))
!               (declare (fixnum i))
!               (when (eq (char-upcase (%schar b i)) (char-upcase chara0))
!                 (when
!                     (do ((j 1 (1+ j)))
!                         ((>= j alen) t)
!                       (declare (fixnum j))
!                       (unless (eq (char-upcase (%schar a j)) (char-upcase (%schar b (%i+ j i))))
!                         (return nil)))
!                   (return  (%i- blen i alen)))))))))
  
Index: level-1/l1-utils.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/level-1/l1-utils.lisp,v
retrieving revision 1.14
diff -c -1 -r1.14 l1-utils.lisp
*** level-1/l1-utils.lisp	6 May 2004 06:29:00 -0000	1.14
--- level-1/l1-utils.lisp	14 Dec 2004 20:10:26 -0000
***************
*** 1189,1194 ****
  (defun string-argp (arg)
!  (if (symbolp arg) (symbol-name arg)
!    (if (stringp arg) (ensure-simple-string arg)
!      nil)))
! 
  (defun symbol-arg (arg)
--- 1189,1195 ----
  (defun string-argp (arg)
!   (cond ((symbolp arg) (symbol-name arg))
!         ((typep arg 'character) (string arg))
!         ((stringp arg) (ensure-simple-string arg))
!         (t nil)))
!   
  (defun symbol-arg (arg)
-------------- next part --------------