1.0.8.7: printer-control variables affecting MEMBER & ASSOC transforms

 Reported by Dan Corkill on sbcl-devel.

 * Use WRITE-STRING on SYMBOL-NAME instead of FORMAT %A to ironclad
   the specialized function name generation.

 * Tests.

diff --git a/NEWS b/NEWS
index ebd61fc..ad4ecb2 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,8 @@
 ;;;; -*- coding: utf-8; -*-
+changes in sbcl-1.0.9 relative to sbcl-1.0.8:
+  * bug fix: new compiler transforms for MEMBER and ASSOC were affected
+    by printer control variables. (reported by Dan Corkill)
+
 changes in sbcl-1.0.8 relative to sbcl-1.0.7:
   * enhancement: experimental macro SB-EXT:COMPARE-AND-SWAP provides
     atomic compare-and-swap operations on threaded platforms.

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index b687c92..55c4dba 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -291,6 +291,21 @@
             (or end length)
             (sb!impl::signal-bounding-indices-bad-error vector start end)))))
 
+(defun specialized-list-seek-function-name (function-name key-functions)
+  (or (find-symbol (with-output-to-string (s)
+                     ;; Write "%NAME-FUN1-FUN2-FUN3", etc. Not only is
+                     ;; this ever so slightly faster then FORMAT, this
+                     ;; way we are also proof against *PRINT-CASE*
+                     ;; frobbing and such.
+                     (write-char #\% s)
+                     (write-string (symbol-name function-name) s)
+                     (dolist (f key-functions)
+                       (write-char #\- s)
+                       (write-string (symbol-name f) s)))
+                   (load-time-value (find-package "SB!KERNEL")))
+      (bug "Unknown list item seek transform: name=~S, key-functions=~S"
+           function-name key-functions)))
+
 (defun transform-list-item-seek (name list key test test-not node)
   ;; Key can legally be NIL, but if it's NIL for sure we pretend it's
   ;; not there at all. If it might be NIL, make up a form to that
@@ -309,10 +324,6 @@
                    (values key '(%coerce-callable-to-fun key))))))
     (let* ((funs (remove nil (list (and key 'key) (cond (test 'test)
                                                         (test-not 'test-not)))))
-           (out-of-line (or (find-symbol (format nil "%~A~{-~A~}" name funs)
-                                         (load-time-value (find-package "SB!KERNEL")))
-                            (bug "Unknown list item seek transform: name=~S, funs=~S"
-                                 name funs)))
            (target-expr (if key '(%funcall key target) 'target))
            (test-expr (cond (test `(%funcall test item ,target-expr))
                             (test-not `(not (%funcall test-not item ,target-expr)))
@@ -344,7 +355,9 @@
                  ;; constant nil list -- nothing to find!
                  nil)
                 (t
-                 `(,out-of-line item list ,@(mapcar #'ensure-fun funs)))))))))
+                 ;; specialized out-of-line version
+                 `(,(specialized-list-seek-function-name name funs)
+                    item list ,@(mapcar #'ensure-fun funs)))))))))
 
 (deftransform member ((item list &key key test test-not) * * :node node)
   (transform-list-item-seek 'member list key test test-not node))

diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp
index 8f251d4..afc5c6b 100644 (file)
--- a/tests/list.pure.lisp
+++ b/tests/list.pure.lisp
@@ -186,15 +186,15 @@
                   (assert (equal ',expected (let ((numbers ',numbers)
                                                   (tricky ',tricky))
                                               (funcall fun ,@(cdr form)))))
-                 (assert (equal ',expected (funcall (lambda ()
-                                                      (declare (optimize speed))
-                                                      (let ((numbers ',numbers)
-                                                            (tricky ',tricky))
-                                                        ,form)))))
-                 (assert (equal ',expected (funcall (lambda ()
-                                                      (declare (optimize space))
-                                                      (let ((numbers ',numbers)
-                                                            (tricky ',tricky))
+                  (assert (equal ',expected (funcall (lambda ()
+                                                       (declare (optimize speed))
+                                                       (let ((numbers ',numbers)
+                                                             (tricky ',tricky))
+                                                         ,form)))))
+                  (assert (equal ',expected (funcall (lambda ()
+                                                       (declare (optimize space))
+                                                       (let ((numbers ',numbers)
+                                                             (tricky ',tricky))
                                                         ,form)))))))))
   (let ((fun (car (list 'assoc))))
     (test (1 a) (assoc 1 numbers))
@@ -221,3 +221,11 @@
     ;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements in a
     ;; alist
     (test (nil . c) (assoc nil tricky :test #'eq))))
+
+;;; bug reported by Dan Corkill: *PRINT-CASE* affected the compiler transforms
+;;; for ASSOC & MEMBER
+(let ((*print-case* :downcase))
+  (assert (eql 2 (cdr (funcall (compile nil '(lambda (i l) (assoc i l)))
+                               :b '((:a . 1) (:b . 2))))))
+  (assert (equal '(3 4 5) (funcall (compile nil '(lambda (i l) (member i l)))
+                                   3 '(1 2 3 4 5)))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 3253fce..4f269e8 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.8.6"
+"1.0.8.7"