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)
         (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))
         (implement-p nil)
         (lock nil)
         (doc nil))

@@ -68,7 +68,7 @@
                :format-arguments (list option)))
       (case (car option)
         (:nicknames
                :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
         (: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
                  :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
            (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
            (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 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
                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 ((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
            (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))
            (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
            (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)
                     `(: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)))))
                     ',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)))))
 
                                         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
     (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
 
 (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))
     (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
       (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)
                   (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)))
         (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))
          (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
       (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))))))
                                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)
 
 ;;; 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
 
 ;;; 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))
   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)
             (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
 
 (with-test (:name (:throw :no-such-tag)
             :fails-on '(or

-                        (and :x86 (or :linux sunos))
+                        (and :x86 (or :sunos))

                         :alpha
                         :mips))
   (progn
                         :alpha
                         :mips))
   (progn

@@ -251,7 +251,7 @@
 
 ;;; FIXME: This test really should be broken into smaller pieces
 (with-test (:name (:backtrace :misc)
 
 ;;; 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)))
   (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))
 
 (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
       (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
 ;;; 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".)
 ;;; 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"