From 5ec5d0e068ab2b6435e0c841d686a95dbd58cbc4 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 16 Aug 2006 18:04:34 +0000 Subject: [PATCH] 0.9.15.35: fix CONS :SIMPLE-= method * The failure is uncertain if both types may be the empty type in disguise. * Tests. --- src/code/late-type.lisp | 18 +++++++++++++++--- src/code/run-program.lisp | 40 ++++++++++++++++++++-------------------- tests/mop-23.impure.lisp | 4 ++-- tests/type.impure.lisp | 23 +++++++++++++++++++++++ tests/type.pure.lisp | 4 ++-- version.lisp-expr | 2 +- 6 files changed, 63 insertions(+), 28 deletions(-) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 8a6e01f..aaf4213 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -2970,11 +2970,23 @@ used for a COMPLEX component.~:@>" (!define-type-method (cons :simple-=) (type1 type2) (declare (type cons-type type1 type2)) - (multiple-value-bind (match win) + (multiple-value-bind (car-match car-win) (type= (cons-type-car-type type1) (cons-type-car-type type2)) - (if (and match win) + (multiple-value-bind (cdr-match cdr-win) (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2)) - (values nil win)))) + (cond ((and car-match cdr-match) + (aver (and car-win cdr-win)) + (values t t)) + (t + (values nil + ;; FIXME: Ideally we would like to detect and handle + ;; (CONS UNKNOWN INTEGER) (CONS UNKNOWN SYMBOL) => NIL, T + ;; but just returning a secondary true on (and car-win cdr-win) + ;; unfortunately breaks other things. --NS 2006-08-16 + (and (or (and (not car-match) car-win) + (and (not cdr-match) cdr-win)) + (not (and (cons-type-might-be-empty-type type1) + (cons-type-might-be-empty-type type2)))))))))) (!define-type-method (cons :simple-subtypep) (type1 type2) (declare (type cons-type type1 type2)) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 198fc61..bdd3ef7 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -845,28 +845,28 @@ Common Lisp Users Manual for details about the PROCESS structure. (when (< handle 0) (error "Couldn't spawn program: ~A" (strerror))) (setf proc - (if wait - (make-process :pid handle - :%status :exited - :input input-stream - :output output-stream - :error error-stream - :status-hook status-hook - :cookie cookie - :exit-code handle) - (make-process :pid handle - :%status :running - :input input-stream - :output output-stream - :error error-stream - :status-hook status-hook - :cookie cookie))) - (push proc *active-processes*))))))) + (if wait + (make-process :pid handle + :%status :exited + :input input-stream + :output output-stream + :error error-stream + :status-hook status-hook + :cookie cookie + :exit-code handle) + (make-process :pid handle + :%status :running + :input input-stream + :output output-stream + :error error-stream + :status-hook status-hook + :cookie cookie))) + (push proc *active-processes*))))))) (dolist (fd *close-in-parent*) - (sb-unix:unix-close fd))) + (sb-unix:unix-close fd))) (unless proc (dolist (fd *close-on-error*) - (sb-unix:unix-close fd))) + (sb-unix:unix-close fd))) proc)) @@ -966,7 +966,7 @@ Common Lisp Users Manual for details about the PROCESS structure. #o666) (unless fd (error #-win32 "~@" - #+win32 "~@" + #+win32 "~@" (strerror errno))) (push fd *close-in-parent*) (values fd nil))) diff --git a/tests/mop-23.impure.lisp b/tests/mop-23.impure.lisp index 04d9cf5..8080afe 100644 --- a/tests/mop-23.impure.lisp +++ b/tests/mop-23.impure.lisp @@ -54,8 +54,8 @@ '(4 nil)))) "Called a method!Called a method!")) -(defclass super () - ((b :initform 3) +(defclass super () + ((b :initform 3) (a :initarg :a))) (assert (string= (with-output-to-string (*trace-output*) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 1ab5a2c..bf0bd45 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -500,4 +500,27 @@ (setf (find-class 'to-be-type-ofed) nil) (assert (eq (type-of (make-instance class)) class))) +;;; accuracy of CONS :SIMPLE-TYPE-= +(deftype goldbach-1 () '(satisfies even-and-greater-then-two-p)) +(deftype goldbach-2 () ' (satisfies sum-of-two-primes-p)) + +(multiple-value-bind (ok win) + (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer)) + (sb-kernel:specifier-type '(cons goldbach1 integer))) + (assert ok) + (assert win)) + +;; See FIXME in type method for CONS :SIMPLE-TYPE-= +#+nil +(multiple-value-bind (ok win) + (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer)) + (sb-kernel:specifier-type '(cons goldbach1 single-float))) + (assert (not ok)) + (assert win)) + +(multiple-value-bind (ok win) + (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer)) + (sb-kernel:specifier-type '(cons goldbach2 single-float))) + (assert (not ok)) + (assert (not win))) ;;; success diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index f92c3b7..af467d7 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -332,11 +332,11 @@ ACTUAL ~D DERIVED ~D~%" (sb-kernel:specifier-type '(simple-array an-unkown-type (8)))))) (assert - (sb-kernel:type/= (sb-kernel:specifier-type 'cons) + (sb-kernel:type/= (sb-kernel:specifier-type 'cons) (sb-kernel:specifier-type '(cons single-float single-float)))) (multiple-value-bind (match win) - (sb-kernel:type= (sb-kernel:specifier-type '(cons integer)) + (sb-kernel:type= (sb-kernel:specifier-type '(cons integer)) (sb-kernel:specifier-type '(cons))) (assert (and (not match) win))) diff --git a/version.lisp-expr b/version.lisp-expr index ff5a94d..2090cab 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.15.34" +"0.9.15.35" -- 1.7.10.4