[Bug-openmcl] ccl::hash-pname problem with fill-pointers?

[bryan o'connor]

> unless there are -lots- of other things that might pass non-simple
> strings to low-level package code - I think that it's probably better
> for the higher-level things to check/coerce their arguments.

looks like we can isolate it to three functions --

find-all-symbols did no checking and didn't massage.  added a
ccl::ensure-simple-string to both check and massage.

make-symbol checked that the arg was a 'simple-string using
#'require-type.  replacing that with ccl::ensure-simple-string both
checks and massages.

ccl::pkg-arg (called by a bunch of symbol iterator macros) did check
that if the arg was a string, that it was a simple string.  i rewrote
the initial if form as a cond that will call ccl::ensure-simple-string
if the arg is indeed a string.

i left ccl::hash-pname alone.  another option would have been to change
it and then widen the type checking in the above from 'simple-string to
'string.

these fixed the ~40 *-symbols ansi-tests.  patch below.

	...bryan


-------------- next part --------------
Index: level-0/nfasload.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/level-0/nfasload.lisp,v
retrieving revision 1.7
diff -c -r1.7 nfasload.lisp
*** level-0/nfasload.lisp	24 Mar 2004 06:34:38 -0000	1.7
--- level-0/nfasload.lisp	8 Dec 2004 23:05:53 -0000
***************
*** 204,213 ****
  
  
  (defun pkg-arg (thing &optional deleted-ok)
!   (let* ((xthing (if (or (symbolp thing)
!                          (typep thing 'character))
!                    (string thing)
!                    thing)))
      (let* ((typecode (typecode xthing)))
          (declare (fixnum typecode))
          (cond ((= typecode ppc32::subtag-package)
--- 204,215 ----
  
  
  (defun pkg-arg (thing &optional deleted-ok)
!   (let* ((xthing (cond ((or (symbolp thing) (typep thing 'character))
!                         (string thing))
!                        ((typep thing 'string)
!                         (ensure-simple-string thing))
!                        (t
!                         thing))))
      (let* ((typecode (typecode xthing)))
          (declare (fixnum typecode))
          (cond ((= typecode ppc32::subtag-package)
Index: level-0/l0-symbol.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/level-0/l0-symbol.lisp,v
retrieving revision 1.6
diff -c -r1.6 l0-symbol.lisp
*** level-0/l0-symbol.lisp	18 Nov 2003 06:59:56 -0000	1.6
--- level-0/l0-symbol.lisp	8 Dec 2004 23:05:54 -0000
***************
*** 164,170 ****
  
  (defun make-symbol (name)
    (%gvector ppc32::subtag-symbol
!                 (require-type name 'simple-string) ; pname
                  (%unbound-marker)       ; value cell
                  %unbound-function%      ; function cell
                  nil                     ; package&plist
--- 164,170 ----
  
  (defun make-symbol (name)
    (%gvector ppc32::subtag-symbol
!                 (ensure-simple-string name) ; pname
                  (%unbound-marker)       ; value cell
                  %unbound-function%      ; function cell
                  nil                     ; package&plist
Index: level-1/l1-symhash.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/level-1/l1-symhash.lisp,v
retrieving revision 1.1.1.1
diff -c -r1.1.1.1 l1-symhash.lisp
*** level-1/l1-symhash.lisp	19 Oct 2003 08:57:10 -0000	1.1.1.1
--- level-1/l1-symhash.lisp	8 Dec 2004 23:05:56 -0000
***************
*** 125,131 ****
  
  (defun find-all-symbols (name)
    (let* ((syms ())
!          (pname (string name))
           (len (length pname)))
      (with-package-list-read-lock
          (dolist (p %all-packages% syms)
--- 125,131 ----
  
  (defun find-all-symbols (name)
    (let* ((syms ())
!          (pname (ensure-simple-string (string name)))
           (len (length pname)))
      (with-package-list-read-lock
          (dolist (p %all-packages% syms)
-------------- next part --------------