From 48713ab8344ee7e0b16a88ce562183584384ca0c Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 10 Oct 2005 14:54:48 +0000 Subject: [PATCH] 0.9.5.33: Fix SUBTYPEP.CONS.42 from PFD ansi-tests (solution provided by chandler on #lisp: "is it throwing away the second return value of subtypep somewhere?" --- NEWS | 4 +++ contrib/asdf-install/installer.lisp | 52 +++++++++++++++++------------------ src/code/late-type.lisp | 8 ++++-- tests/type.impure.lisp | 9 ++++++ version.lisp-expr | 2 +- 5 files changed, 46 insertions(+), 29 deletions(-) diff --git a/NEWS b/NEWS index b39d6f3..58b48dd 100644 --- a/NEWS +++ b/NEWS @@ -21,6 +21,10 @@ changes in sbcl-0.9.6 relative to sbcl-0.9.5: next exiting thread, no need to gc to collect thread stacks anymore ** minor incompatible change: INTERRUPT-THREAD-ERROR-ERRNO removed ** WITH-RECURSIVE-LOCK can be nested in a WITH-MUTEX for the same lock + * fixed some bugs revealed by Paul Dietz' test suite: + ** SUBTYPEP is slightly more accurate on heinously complicated + CONS types where some of the members have uncertain (in the + NIL, NIL sense) type relationships to each other. changes in sbcl-0.9.5 relative to sbcl-0.9.4: * new feature: timers based on Zach Beane's excellent timer package diff --git a/contrib/asdf-install/installer.lisp b/contrib/asdf-install/installer.lisp index 0f5b1f1..c63f6ba 100644 --- a/contrib/asdf-install/installer.lisp +++ b/contrib/asdf-install/installer.lisp @@ -105,35 +105,35 @@ (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) (host (url-host url)) (port (url-port url)) - result) + result) (declare (ignore port)) (unwind-protect - (progn - (socket-connect - s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url))))) - (url-port (or *proxy* url))) - (let ((stream (socket-make-stream s :input t :output t :buffering :full :external-format :iso-8859-1))) - ;; we are exceedingly unportable about proper line-endings here. - ;; Anyone wishing to run this under non-SBCL should take especial care - (format stream "GET ~A HTTP/1.0~c~%Host: ~A~c~%Cookie: CCLAN-SITE=~A~c~%~c~%" - url #\Return host #\Return *cclan-mirror* #\Return #\Return) - (force-output stream) - (setf result - (list - (let* ((l (read-line stream)) - (space (position #\Space l))) - (parse-integer l :start (1+ space) :junk-allowed t)) - (loop for line = (read-line stream nil nil) - until (or (null line) (eql (elt line 0) (code-char 13))) - collect - (let ((colon (position #\: line))) - (cons (intern (string-upcase (subseq line 0 colon)) :keyword) - (string-trim (list #\Space (code-char 13)) - (subseq line (1+ colon)))))) - stream)))) + (progn + (socket-connect + s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url))))) + (url-port (or *proxy* url))) + (let ((stream (socket-make-stream s :input t :output t :buffering :full :external-format :iso-8859-1))) + ;; we are exceedingly unportable about proper line-endings here. + ;; Anyone wishing to run this under non-SBCL should take especial care + (format stream "GET ~A HTTP/1.0~c~%Host: ~A~c~%Cookie: CCLAN-SITE=~A~c~%~c~%" + url #\Return host #\Return *cclan-mirror* #\Return #\Return) + (force-output stream) + (setf result + (list + (let* ((l (read-line stream)) + (space (position #\Space l))) + (parse-integer l :start (1+ space) :junk-allowed t)) + (loop for line = (read-line stream nil nil) + until (or (null line) (eql (elt line 0) (code-char 13))) + collect + (let ((colon (position #\: line))) + (cons (intern (string-upcase (subseq line 0 colon)) :keyword) + (string-trim (list #\Space (code-char 13)) + (subseq line (1+ colon)))))) + stream)))) (when (and (null result) - (socket-open-p s)) - (socket-close s))))) + (socket-open-p s)) + (socket-close s))))) (defun download-files-for-package (package-name-or-url file-name) (let ((url diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index bc99643..bf179ac 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -2999,11 +2999,15 @@ used for a COMPLEX component.~:@>" ;; more general case of the above, but harder to compute ((progn (setf car-not1 (type-negation car-type1)) - (not (csubtypep car-type2 car-not1))) + (multiple-value-bind (yes win) + (csubtypep car-type2 car-not1) + (and (not yes) win))) (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1)) ((progn (setf car-not2 (type-negation car-type2)) - (not (csubtypep car-type1 car-not2))) + (multiple-value-bind (yes win) + (csubtypep car-type1 car-not2) + (and (not yes) win))) (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2)) ;; Don't put these in -- consider the effect of taking the ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 1e5acd9..be9e55b 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -436,4 +436,13 @@ (assert (functionp (sb-pcl::ensure-ctor (list 'sb-pcl::ctor (gensym)) nil nil)))) +;;; from PFD ansi-tests +(let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons) + (integer -234496 215373)) + integer)) + (t2 '(cons (cons (cons integer integer) + (integer -234496 215373)) + t))) + (assert (null (values (subtypep `(not ,t2) `(not ,t1)))))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index e349be1..c1489cd 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.5.32" +"0.9.5.33" -- 1.7.10.4