From: Christophe Rhodes Date: Sun, 3 Jun 2007 20:02:35 +0000 (+0000) Subject: 1.0.6.18: Two fixes from Eric Marsden X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1596e9fdeb2265c4a00e441bc8a1dbdc5364afa7;p=sbcl.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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)) +;;; 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)))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index ed6ea52..ebae058 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.6.17" +"1.0.6.18"