From 961c7076f5fba67ddba0e12dd131104834348b1a Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 27 Jul 2007 11:13:22 +0000 Subject: [PATCH] 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. --- NEWS | 4 ++++ src/compiler/seqtran.lisp | 23 ++++++++++++++++++----- tests/list.pure.lisp | 26 +++++++++++++++++--------- version.lisp-expr | 2 +- 4 files changed, 40 insertions(+), 15 deletions(-) diff --git a/NEWS b/NEWS index ebd61fc..ad4ecb2 100644 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4