1.0.6.18: Two fixes from Eric Marsden

	... DEFPACKAGE :USE/:IMPORT-FROM takes package designators
	... REMOVE-DUPLICATES / :TEST-NOT / vectors
	Include test cases, and do a little bit of other tidying
	of test case expected failures.

diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp
index 1d6a191..e1988d8 100644 (file)
--- a/src/code/defpackage.lisp
+++ b/src/code/defpackage.lisp
@@ -55,7 +55,7 @@
         (imports nil)
         (interns nil)
         (exports nil)
-        (implement (stringify-names (list package) "package"))
+        (implement (stringify-package-designators (list package)))
         (implement-p nil)
         (lock nil)
         (doc nil))
@@ -68,7 +68,7 @@
                :format-arguments (list option)))
       (case (car option)
         (:nicknames
-         (setf nicknames (stringify-names (cdr option) "package")))
+         (setf nicknames (stringify-package-designators (cdr option))))
         (:size
          (cond (size
                 (error 'simple-program-error
@@ -82,11 +82,11 @@
                  :format-control ":SIZE is not a positive integer: ~S"
                  :format-arguments (list (second option))))))
         (:shadow
-         (let ((new (stringify-names (cdr option) "symbol")))
+         (let ((new (stringify-string-designators (cdr option))))
            (setf shadows (append shadows new))))
         (:shadowing-import-from
-         (let ((package-name (stringify-name (second option) "package"))
-               (names (stringify-names (cddr option) "symbol")))
+         (let ((package-name (stringify-package-designator (second option)))
+               (names (stringify-string-designators (cddr option))))
            (let ((assoc (assoc package-name shadowing-imports
                                :test #'string=)))
              (if assoc
@@ -94,27 +94,27 @@
                  (setf shadowing-imports
                        (acons package-name names shadowing-imports))))))
         (:use
-         (setf use (append use (stringify-names (cdr option) "package") )
+         (setf use (append use (stringify-package-designators (cdr option)) )
                use-p t))
         (:import-from
-         (let ((package-name (stringify-name (second option) "package"))
-               (names (stringify-names (cddr option) "symbol")))
+         (let ((package-name (stringify-package-designator (second option)))
+               (names (stringify-string-designators (cddr option))))
            (let ((assoc (assoc package-name imports
                                :test #'string=)))
              (if assoc
                  (setf (cdr assoc) (append (cdr assoc) names))
                  (setf imports (acons package-name names imports))))))
         (:intern
-         (let ((new (stringify-names (cdr option) "symbol")))
+         (let ((new (stringify-string-designators (cdr option))))
            (setf interns (append interns new))))
         (:export
-         (let ((new (stringify-names (cdr option) "symbol")))
+         (let ((new (stringify-string-designators (cdr option))))
            (setf exports (append exports new))))
         #!+sb-package-locks
         (:implement
          (unless implement-p
            (setf implement nil))
-         (let ((new (stringify-names (cdr option) "package")))
+         (let ((new (stringify-package-designators (cdr option))))
            (setf implement (append implement new)
                  implement-p t)))
         #!+sb-package-locks
@@ -140,7 +140,7 @@
                     `(:shadowing-import-from
                       ,@(apply #'append (mapcar #'rest shadowing-imports))))
     `(eval-when (:compile-toplevel :load-toplevel :execute)
-       (%defpackage ,(stringify-name package "package") ',nicknames ',size
+       (%defpackage ,(stringify-string-designator package) ',nicknames ',size
                     ',shadows ',shadowing-imports ',(if use-p use :default)
                     ',imports ',interns ',exports ',implement ',lock ',doc
                     (sb!c:source-location)))))
@@ -158,19 +158,31 @@
                                         but have common elements ~%   ~S"
                        :format-arguments (list (car x)(car y) z)))))
 
-(defun stringify-name (name kind)
-  (typecase name
-    (simple-string name)
-    (string (coerce name 'simple-string))
-    (symbol (symbol-name name))
-    (character (string name))
+(defun stringify-string-designator (string-designator)
+  (typecase string-designator
+    (simple-string string-designator)
+    (string (coerce string-designator 'simple-string))
+    (symbol (symbol-name string-designator))
+    (character (string string-designator))
     (t
-     (error "bogus ~A name: ~S" kind name))))
+     (error "~S does not designate a string" string-designator))))
+
+(defun stringify-string-designators (string-designators)
+  (mapcar #'stringify-string-designator string-designators))
+
+(defun stringify-package-designator (package-designator)
+  (typecase package-designator
+    (simple-string package-designator)
+    (string (coerce package-designator 'simple-string))
+    (symbol (symbol-name package-designator))
+    (character (string package-designator))
+    (package (package-name package-designator))
+    (t
+     (error "~S does not designate a package" package-designator))))
+
+(defun stringify-package-designators (package-designators)
+  (mapcar #'stringify-package-designator package-designators))
 
-(defun stringify-names (names kind)
-  (mapcar (lambda (name)
-            (stringify-name name kind))
-          names))
 
 (defun %defpackage (name nicknames size shadows shadowing-imports
                     use imports interns exports implement lock doc-string

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 6ff9ebc..ed87d4c 100644 (file)
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -1682,20 +1682,22 @@
     (do ((elt))
         ((= index end))
       (setq elt (aref vector index))
-      ;; FIXME: Relying on POSITION allowing both :TEST and :TEST-NOT
-      ;; arguments simultaneously is a little fragile, since ANSI says
-      ;; we can't depend on it, so we need to remember to keep that
-      ;; extension in our implementation. It'd probably be better to
-      ;; rewrite this to avoid passing both (as
-      ;; LIST-REMOVE-DUPLICATES* was rewritten ca. sbcl-0.7.12.18).
       (unless (or (and from-end
-                       (position (apply-key key elt) result
-                                 :start start :end jndex
-                                 :test test :test-not test-not :key key))
+                       (if test-not
+                           (position (apply-key key elt) result
+                                     :start start :end jndex
+                                     :test-not test-not :key key)
+                           (position (apply-key key elt) result
+                                     :start start :end jndex
+                                     :test test :key key)))
                   (and (not from-end)
-                       (position (apply-key key elt) vector
-                                 :start (1+ index) :end end
-                                 :test test :test-not test-not :key key)))
+                       (if test-not
+                           (position (apply-key key elt) vector
+                                     :start (1+ index) :end end
+                                     :test-not test-not :key key)
+                           (position (apply-key key elt) vector
+                                     :start (1+ index) :end end
+                                     :test test :key key))))
         (setf (aref result jndex) elt)
         (setq jndex (1+ jndex)))
       (setq index (1+ index)))
@@ -1770,9 +1772,15 @@
          (setf (aref vector jndex) (aref vector index))))
     (declare (fixnum index jndex))
     (setf (aref vector jndex) (aref vector index))
-    (unless (position (apply-key key (aref vector index)) vector :key key
-                      :start (if from-end start (1+ index)) :test test
-                      :end (if from-end jndex end) :test-not test-not)
+    (unless (if test-not
+                (position (apply-key key (aref vector index)) vector :key key
+                          :start (if from-end start (1+ index))
+                          :end (if from-end jndex end)
+                          :test-not test-not)
+                (position (apply-key key (aref vector index)) vector :key key
+                          :start (if from-end start (1+ index))
+                          :end (if from-end jndex end)
+                          :test test))
       (setq jndex (1+ jndex)))))
 
 (define-sequence-traverser delete-duplicates
@@ -2542,4 +2550,4 @@
                                axis (car dims) contents (length contents)))
                       (sb!sequence:dosequence (content contents)
                         (frob (1+ axis) (cdr dims) content))))))
-      (frob 0 dimensions initial-contents))))
\ No newline at end of file
+      (frob 0 dimensions initial-contents))))

diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp
index 7a914d3..9689b16 100644 (file)
--- a/src/code/target-package.lisp
+++ b/src/code/target-package.lisp
@@ -375,7 +375,7 @@ error if any of PACKAGES is not a valid package designator."
 
 ;;; Make a package name into a simple-string.
 (defun package-namify (n)
-  (stringify-name n "package"))
+  (stringify-package-designator n))
 
 ;;; ANSI specifies (in the definition of DELETE-PACKAGE) that PACKAGE-NAME
 ;;; returns NIL (not an error) for a deleted package, so this is a special
@@ -1299,7 +1299,7 @@ error if any of PACKAGES is not a valid package designator."
   of describing them."
   (if package-designator
       (let ((package (find-undeleted-package-or-lose package-designator))
-            (string (stringify-name string-designator "APROPOS search"))
+            (string (stringify-string-designator string-designator))
             (result nil))
         (do-symbols (symbol package)
           (when (and (eq (symbol-package symbol) package)

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 9109fa7..2fdda62 100644 (file)
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -206,7 +206,7 @@
 
 (with-test (:name (:throw :no-such-tag)
             :fails-on '(or
-                        (and :x86 (or :linux sunos))
+                        (and :x86 (or :sunos))
                         :alpha
                         :mips))
   (progn
@@ -251,7 +251,7 @@
 
 ;;; FIXME: This test really should be broken into smaller pieces
 (with-test (:name (:backtrace :misc)
-            :fails-on '(and :x86 (or :linux :sunos)))
+            :fails-on '(and :x86 (or :sunos)))
   (macrolet ((with-details (bool &body body)
                `(let ((sb-debug:*show-entry-point-details* ,bool))
                  ,@body)))

diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp
index a392aec..82b6e3c 100644 (file)
--- a/tests/packages.impure.lisp
+++ b/tests/packages.impure.lisp
@@ -24,3 +24,8 @@
 
 (make-package "FOO")
 (assert (shadow #\a :foo))
+
+(defpackage :PACKAGE-DESIGNATOR-1 (:use #.(find-package :cl)))
+
+(defpackage :PACKAGE-DESIGNATOR-2
+  (:import-from #.(find-package :cl) "+"))

diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index b8ee470..2145c2d 100644 (file)
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -1075,4 +1075,10 @@
       (assert (test-inlined-bashing i))
       until (= i sb-vm:n-word-bits))
 \f
+;;; tests from the Sacla test suite via Eric Marsden, 2007-05-07
+(remove-duplicates (vector 1 2 2 1) :test-not (lambda (a b) (not (= a b))))
+
+(delete-duplicates (vector #\a #\b #\c #\a)
+                   :test-not (lambda (a b) (not (char-equal a b))))
+\f
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index ed6ea52..ebae058 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.6.17"
+"1.0.6.18"