From: Juho Snellman <jsnell@iki.fi>
Date: Mon, 2 Oct 2006 05:15:44 +0000 (+0000)
Subject: 0.9.17.3:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1f1ffa37f8eed97c92c55b25f200e27940ef9d9e;p=sbcl.git

0.9.17.3:
	Fix negation of character-set types (reported by Anton Kazennikov
        on comp.lang.lisp).
---

diff --git a/NEWS b/NEWS
index 499e5be..e3e283d 100644
--- a/NEWS
+++ b/NEWS
@@ -1,6 +1,8 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-0.9.18 (1.0.beta?) relative to sbcl-0.9.16:
   * bug fix: two potential GC deadlocks affecting threaded builds.
+  * bug fix: (TYPEP #\A '(NOT (MEMBER #\" #\{ #\:))) now correctly
+    returns T (reported by Anton Kazennikov)
 
 changes in sbcl-0.9.17 (0.9.99?) relative to sbcl-0.9.16:
   * feature: weak hash tables, see MAKE-HASH-TABLE documentation
diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index b253984..a4d31ab 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -3104,29 +3104,29 @@ used for a COMPLEX component.~:@>"
 (!define-type-method (character-set :negate) (type)
   (let ((pairs (character-set-type-pairs type)))
     (if (and (= (length pairs) 1)
-            (= (caar pairs) 0)
-            (= (cdar pairs) (1- sb!xc:char-code-limit)))
-       (make-negation-type :type type)
-       (let ((not-character
-              (make-negation-type
-               :type (make-character-set-type
-                      :pairs '((0 . #.(1- sb!xc:char-code-limit)))))))
-         (type-union
-          not-character
-          (make-character-set-type
-           :pairs (let (not-pairs)
-                    (when (> (caar pairs) 0)
-                      (push (cons 0 (1- (caar pairs))) not-pairs))
-                    (do* ((tail pairs (cdr tail))
-                          (high1 (cdar tail))
-                          (low2 (caadr tail)))
-                         ((null (cdr tail))
-                          (when (< (cdar tail) (1- sb!xc:char-code-limit))
-                            (push (cons (1+ (cdar tail))
-                                        (1- sb!xc:char-code-limit))
-                                  not-pairs))
-                          (nreverse not-pairs))
-                      (push (cons (1+ high1) (1- low2)) not-pairs)))))))))
+             (= (caar pairs) 0)
+             (= (cdar pairs) (1- sb!xc:char-code-limit)))
+        (make-negation-type :type type)
+        (let ((not-character
+               (make-negation-type
+                :type (make-character-set-type
+                       :pairs '((0 . #.(1- sb!xc:char-code-limit)))))))
+          (type-union
+           not-character
+           (make-character-set-type
+            :pairs (let (not-pairs)
+                     (when (> (caar pairs) 0)
+                       (push (cons 0 (1- (caar pairs))) not-pairs))
+                     (do* ((tail pairs (cdr tail))
+                           (high1 (cdar tail) (cdar tail))
+                           (low2 (caadr tail) (caadr tail)))
+                          ((null (cdr tail))
+                           (when (< (cdar tail) (1- sb!xc:char-code-limit))
+                             (push (cons (1+ (cdar tail))
+                                         (1- sb!xc:char-code-limit))
+                                   not-pairs))
+                           (nreverse not-pairs))
+                       (push (cons (1+ high1) (1- low2)) not-pairs)))))))))
 
 (!define-type-method (character-set :unparse) (type)
   (cond
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index bac6d51..31f8688 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -257,6 +257,7 @@
         (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-~:[HIGH~;LOW~]-BOUND"
                                        op minimize)
                                (find-package :sb-c))))
+          (format t "testing type derivation: ~A~%" deriver)
           (loop for a from 0 below size do
                 (loop for b from a below size do
                       (loop for c from 0 below size do
@@ -346,3 +347,20 @@ ACTUAL ~D DERIVED ~D~%"
 
 (assert (typep #p"" 'sb-kernel:instance))
 (assert (subtypep '(member #p"") 'sb-kernel:instance))
+
+(with-test (:name (:typep :character-set :negation))
+  (flet ((generate-chars ()
+           (loop repeat 100
+                 collect (code-char (random char-code-limit)))))
+    (dotimes (i 1000)
+      (let* ((chars (generate-chars))
+             (type `(member ,@chars))
+             (not-type `(not ,type)))
+        (dolist (char chars)
+          (assert (typep char type))
+          (assert (not (typep char not-type))))
+        (let ((other-chars (generate-chars)))
+          (dolist (char other-chars)
+            (unless (member char chars)
+              (assert (not (typep char type)))
+              (assert (typep char not-type)))))))))
diff --git a/version.lisp-expr b/version.lisp-expr
index 94ed619..ee3ea9c 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".)
-"0.9.17.2"
+"0.9.17.3"