From: Alexey Dejneka Date: Fri, 11 Jul 2003 16:48:47 +0000 (+0000) Subject: 0.8.1.32: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=cc420058fedd26d85158b92285bf5a0ea9a826c1;p=sbcl.git 0.8.1.32: * Condition slot accessor installer: call ENSURE-GENERIC-FUNCTION; * fixed type method (VALUES :SIMPLE-=); * SB-C::DOMAIN-SUBTYPEP: merged patch by DTC 1999/01/23. --- diff --git a/src/code/late-condition.lisp b/src/code/late-condition.lisp index 2aa8921..7070f60 100644 --- a/src/code/late-condition.lisp +++ b/src/code/late-condition.lisp @@ -14,8 +14,12 @@ (fmakunbound 'install-condition-slot-reader) (fmakunbound 'install-condition-slot-writer) (defun install-condition-slot-reader (name condition slot-name) + (unless (fboundp name) + (ensure-generic-function name :lambda-list '(condition))) (eval `(defmethod ,name ((.condition. ,condition)) (condition-reader-function .condition. ',slot-name)))) (defun install-condition-slot-writer (name condition slot-name) + (unless (fboundp name) + (ensure-generic-function name :lambda-list '(new-value condition))) (eval `(defmethod ,name (new-value (.condition. ,condition)) (condition-writer-function .condition. new-value ',slot-name)))) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index d0a2938..cd1a796 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -182,20 +182,7 @@ (return (values nil t)))))) (!define-type-method (values :simple-=) (type1 type2) - (let ((rest1 (args-type-rest type1)) - (rest2 (args-type-rest type2))) - (cond ((and rest1 rest2 (type/= rest1 rest2)) - (type= rest1 rest2)) - ((or rest1 rest2) - (values nil t)) - (t - (multiple-value-bind (req-val req-win) - (type=-list (values-type-required type1) - (values-type-required type2)) - (multiple-value-bind (opt-val opt-win) - (type=-list (values-type-optional type1) - (values-type-optional type2)) - (values (and req-val opt-val) (and req-win opt-win)))))))) + (type=-args type1 type2)) (!define-type-class function) @@ -327,32 +314,7 @@ (values nil t)) ((eq (fun-type-wild-args type1) t) (values t t)) - (t (and/type - (cond ((null (fun-type-rest type1)) - (values (null (fun-type-rest type2)) t)) - ((null (fun-type-rest type2)) - (values nil t)) - (t - (compare type= rest))) - (labels ((type-list-= (l1 l2) - (cond ((null l1) - (values (null l2) t)) - ((null l2) - (values nil t)) - (t (multiple-value-bind (res winp) - (type= (first l1) (first l2)) - (cond ((not winp) - (values nil nil)) - ((not res) - (values nil t)) - (t - (type-list-= (rest l1) - (rest l2))))))))) - (and/type (and/type (compare type-list-= required) - (compare type-list-= optional)) - (if (or (fun-type-keyp type1) (fun-type-keyp type2)) - (values nil nil) - (values t t)))))))))) + (t (type=-args type1 type2)))))) (!define-type-class constant :inherits values) @@ -627,6 +589,23 @@ :rest rest) exactp))) +(defun type=-args (type1 type2) + (macrolet ((compare (comparator field) + (let ((reader (symbolicate '#:args-type- field))) + `(,comparator (,reader type1) (,reader type2))))) + (and/type + (cond ((null (args-type-rest type1)) + (values (null (args-type-rest type2)) t)) + ((null (args-type-rest type2)) + (values nil t)) + (t + (compare type= rest))) + (and/type (and/type (compare type=-list required) + (compare type=-list optional)) + (if (or (args-type-keyp type1) (args-type-keyp type2)) + (values nil nil) + (values t t)))))) + ;;; Do a union or intersection operation on types that might be values ;;; types. The result is optimized for utility rather than exactness, ;;; but it is guaranteed that it will be no smaller (more restrictive) diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 4a1f65f..ddf35ed 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -159,7 +159,8 @@ values-subtypep-cache-clear csubtypep-cache-clear type-intersection2-cache-clear - values-type-intersection-cache-clear)) + values-type-intersection-cache-clear + type=-cache-clear)) (funcall (the function (symbol-function sym))))) (values)) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 9ddb5aa..972a954 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -561,34 +561,27 @@ (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo) (minusp (float-sign arg-lo-val))) (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-lo) - (setq arg-lo '(0e0) arg-lo-val 0e0)) + (setq arg-lo 0e0 arg-lo-val arg-lo)) (when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi) (plusp (float-sign arg-hi-val))) (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-hi) - (setq arg-hi `(,(ecase *read-default-float-format* - (double-float (load-time-value (make-unportable-float :double-float-negative-zero))) - #!+long-float - (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))) - arg-hi-val (ecase *read-default-float-format* - (double-float (load-time-value (make-unportable-float :double-float-negative-zero))) - #!+long-float - (long-float (load-time-value (make-unportable-float :long-float-negative-zero)))))) - (and (or (null domain-low) - (and arg-lo (>= arg-lo-val domain-low) - (not (and (zerop domain-low) (floatp domain-low) - (plusp (float-sign domain-low)) - (zerop arg-lo-val) (floatp arg-lo-val) - (if (consp arg-lo) - (plusp (float-sign arg-lo-val)) - (minusp (float-sign arg-lo-val))))))) - (or (null domain-high) - (and arg-hi (<= arg-hi-val domain-high) - (not (and (zerop domain-high) (floatp domain-high) - (minusp (float-sign domain-high)) - (zerop arg-hi-val) (floatp arg-hi-val) - (if (consp arg-hi) - (minusp (float-sign arg-hi-val)) - (plusp (float-sign arg-hi-val)))))))))) + (setq arg-hi (ecase *read-default-float-format* + (double-float (load-time-value (make-unportable-float :double-float-negative-zero))) + #!+long-float + (long-float (load-time-value (make-unportable-float :long-float-negative-zero)))) + arg-hi-val arg-hi)) + (flet ((fp-neg-zero-p (f) ; Is F -0.0? + (and (floatp f) (zerop f) (minusp (float-sign f)))) + (fp-pos-zero-p (f) ; Is F +0.0? + (and (floatp f) (zerop f) (plusp (float-sign f))))) + (and (or (null domain-low) + (and arg-lo (>= arg-lo-val domain-low) + (not (and (fp-pos-zero-p domain-low) + (fp-neg-zero-p arg-lo))))) + (or (null domain-high) + (and arg-hi (<= arg-hi-val domain-high) + (not (and (fp-neg-zero-p domain-high) + (fp-pos-zero-p arg-hi))))))))) (eval-when (:compile-toplevel :execute) (setf *read-default-float-format* 'single-float)) diff --git a/version.lisp-expr b/version.lisp-expr index ac4f6d1..38c70fc 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.8.1.31" +"0.8.1.32"