From: William Harold Newman Date: Tue, 13 Feb 2001 18:12:30 +0000 (+0000) Subject: 0.6.10.16: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=854b904d18932d85fa3255a22e4872a7de97092a;p=sbcl.git 0.6.10.16: simplified ANY-TYPE-OP and EVERY-TYPE-OP, and renamed them to ANY/TYPE and EVERY/TYPE since the interface changed PUNT-TYPE-METHOD now local and used only once, renamed to PUNT --- diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 1e73b31..e61294d 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1513,11 +1513,10 @@ t)) (!define-type-method (member :complex-subtypep-arg1) (type1 type2) - (values (every-type-op ctypep - type2 - (member-type-members type1) - :list-first t) - t)) + (every/type #'ctypep + type2 + (member-type-members type1) + :list-first t)) ;;; We punt if the odd type is enumerable and intersects with the ;;; MEMBER type. If not enumerable, then it is definitely not a @@ -1541,19 +1540,20 @@ t))) (!define-type-method (member :complex-intersection) (type1 type2) - (collect ((members)) - (let ((mem2 (member-type-members type2))) - (dolist (member mem2) - (multiple-value-bind (val win) (ctypep member type1) - (unless win - (return-from punt-type-method (values type2 nil))) - (when val (members member)))) - - (values (cond ((subsetp mem2 (members)) type2) - ((null (members)) *empty-type*) - (t - (make-member-type :members (members)))) - t)))) + (block punt + (collect ((members)) + (let ((mem2 (member-type-members type2))) + (dolist (member mem2) + (multiple-value-bind (val win) (ctypep member type1) + (unless win + (return-from punt (values type2 nil))) + (when val (members member)))) + + (values (cond ((subsetp mem2 (members)) type2) + ((null (members)) *empty-type*) + (t + (make-member-type :members (members)))) + t))))) ;;; We don't need a :COMPLEX-UNION, since the only interesting case is ;;; a union type, and the member/union interaction is handled by the @@ -1669,28 +1669,31 @@ (!define-type-method (intersection :simple-subtypep) (type1 type2) (declare (type list type1 type2)) (/show0 "entering INTERSECTION :SIMPLE-SUBTYPEP") - (some (lambda (t1) - (every (lambda (t2) - (csubtypep t1 t2)) - type2)) - type1)) + (let ((certain? t)) + (dolist (t1 (intersection-type-types type1) (values nil certain?)) + (multiple-value-bind (subtypep validp) + (intersection-complex-subtypep-arg2 t1 type2) + (cond ((not validp) + (setf certain? nil)) + (subtypep + (return (values t t)))))))) (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG1") - (values (any-type-op csubtypep - type2 - (intersection-type-types type1) - :list-first t) - t)) + (any/type #'csubtypep + type2 + (intersection-type-types type1) + :list-first t)) +(defun intersection-complex-subtypep-arg2 (type1 type2) + (every/type #'csubtypep type1 (intersection-type-types type2))) (!define-type-method (intersection :complex-subtypep-arg2) (type1 type2) (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG2") - (values (every-type-op csubtypep type1 (intersection-type-types type2)) - t)) + (intersection-complex-subtypep-arg2 type1 type2)) ;;; Return a new type list where pairs of types whose intersections -;;; can be represented simply have been replaced by the simple -;;; representation. +;;; can be represented simply have been replaced by their simple +;;; representations. (defun simplify-intersection-type-types (%types) (/show0 "entering SIMPLE-INTERSECTION-TYPE-TYPES") (do* ((types (copy-list %types)) ; (to undestructivize the algorithm below) @@ -1779,25 +1782,27 @@ ;;; don't grok the system well enough to tell whether it's simple to ;;; arrange this. -- WHN 2000-02-03 (!define-type-method (union :simple-subtypep) (type1 type2) - (let ((types2 (union-type-types type2))) - (values (dolist (type1 (union-type-types type1) t) - (unless (any-type-op csubtypep type1 types2) - (return nil))) - t))) + (dolist (t1 (union-type-types type1) (values t t)) + (multiple-value-bind (subtypep validp) + (union-complex-subtypep-arg2 t1 type2) + (cond ((not validp) + (return (values nil nil))) + ((not subtypep) + (return (values nil t))))))) (!define-type-method (union :complex-subtypep-arg1) (type1 type2) - (values (every-type-op csubtypep - type2 - (union-type-types type1) - :list-first t) - t)) + (every/type #'csubtypep + type2 + (union-type-types type1) + :list-first t)) +(defun union-complex-subtypep-arg2 (type1 type2) + (any/type #'csubtypep type1 (union-type-types type2))) (!define-type-method (union :complex-subtypep-arg2) (type1 type2) - (values (any-type-op csubtypep type1 (union-type-types type2)) - t)) + (union-complex-subtypep-arg2 type1 type2)) (!define-type-method (union :complex-union) (type1 type2) - (let* ((class1 (type-class-info type1))) + (let ((class1 (type-class-info type1))) (collect ((res)) (let ((this-type type1)) (dolist (type (union-type-types type2) diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index e4a1b6b..d1dbb0b 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -144,21 +144,18 @@ ) ; EVAL-WHEN (defmacro !define-type-method ((class method &rest more-methods) - lambda-list &body forms-and-decls) + lambda-list &body body) (let ((name (symbolicate CLASS "-" method "-TYPE-METHOD"))) - (multiple-value-bind (forms decls) (parse-body forms-and-decls) - `(progn - (defun ,name ,lambda-list - ,@decls - (block punt-type-method - ,@forms)) - (!cold-init-forms - ,@(mapcar #'(lambda (method) - `(setf (,(class-function-slot-or-lose method) - (type-class-or-lose ',class)) - #',name)) - (cons method more-methods))) - ',name)))) + `(progn + (defun ,name ,lambda-list + ,@body) + (!cold-init-forms + ,@(mapcar (lambda (method) + `(setf (,(class-function-slot-or-lose method) + (type-class-or-lose ',class)) + #',name)) + (cons method more-methods))) + ',name))) (defmacro !define-type-class (name &key inherits) `(!cold-init-forms diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index 241732c..2f4dc44 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -91,50 +91,38 @@ ;;;; utilities -;;; Like ANY and EVERY, except that we handle two-arg uncertain -;;; predicates. If the result is uncertain, then we return DEFAULT -;;; from the block PUNT-TYPE-METHOD. If LIST-FIRST is true, then the -;;; list element is the first arg, otherwise the second. +;;; Like ANY and EVERY, except that we handle two-VALUES predicate +;;; functions like SUBTYPEP. If the result is uncertain, then we +;;; return (VALUES NIL NIL). ;;; -;;; FIXME: The way that we return from PUNT-TYPE-METHOD rather ruins -;;; the analogy with SOME and EVERY, and completely surprised me (WHN) -;;; when I was trying to maintain code which uses these macros. I -;;; think it would be a good idea to redo these so that they really -;;; are analogous to EVERY and SOME. And then, while we're at it, we -;;; could also make them functions (perhaps inline) instead of macros. -(defmacro any-type-op (op thing list &key (default '(values nil nil)) - list-first) - (let ((n-this (gensym)) - (n-thing (gensym)) - (n-val (gensym)) - (n-win (gensym)) - (n-uncertain (gensym))) - `(let ((,n-thing ,thing) - (,n-uncertain nil)) - (dolist (,n-this ,list - (if ,n-uncertain - (return-from punt-type-method ,default) - nil)) - (multiple-value-bind (,n-val ,n-win) - ,(if list-first - `(,op ,n-this ,n-thing) - `(,op ,n-thing ,n-this)) - (unless ,n-win (setq ,n-uncertain t)) - (when ,n-val (return t))))))) -(defmacro every-type-op (op thing list &key (default '(values nil nil)) - list-first) - (let ((n-this (gensym)) - (n-thing (gensym)) - (n-val (gensym)) - (n-win (gensym))) - `(let ((,n-thing ,thing)) - (dolist (,n-this ,list t) - (multiple-value-bind (,n-val ,n-win) - ,(if list-first - `(,op ,n-this ,n-thing) - `(,op ,n-thing ,n-this)) - (unless ,n-win (return-from punt-type-method ,default)) - (unless ,n-val (return nil))))))) +;;; If LIST-FIRST is true, then the list element is the first arg, +;;; otherwise the second. +(defun any/type (op thing list &key list-first) + (declare (type function op)) + (let ((certain? t)) + (dolist (i list (values nil certain?)) + (multiple-value-bind (sub-value sub-certain?) + (if list-first + (funcall op i thing) + (funcall op thing i)) + (unless sub-certain? (setf certain? nil)) + (when sub-value (return (values t t))))))) +(defun every/type (op thing list &key list-first) + (declare (type function op)) + (dolist (i list (values t t)) + (multiple-value-bind (sub-value sub-certain?) + (if list-first + (funcall op i thing) + (funcall op thing i)) + (unless sub-certain? (return (values nil nil))) + (unless sub-value (return (values nil t)))))) + +;;; Reverse the order of arguments of a SUBTYPEP-like function. +(declaim (inline swapped/type)) +(defun swapped/type (op) + (declare (type function op)) + (lambda (x y) + (funcall op y x))) ;;; Compute the intersection for types that intersect only when one is a ;;; hierarchical subtype of the other. diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 9784892..2e52965 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -2,6 +2,13 @@ (load "assertoid.lisp") +(defmacro assert-nil-nil (expr) + `(assert (equal '(nil nil) (multiple-value-list ,expr)))) +(defmacro assert-nil-t (expr) + `(assert (equal '(nil t) (multiple-value-list ,expr)))) +(defmacro assert-t-t (expr) + `(assert (equal '(t t) (multiple-value-list ,expr)))) + (let ((types '(character integer fixnum (integer 0 10) single-float (single-float -1.0 1.0) (single-float 0.1) @@ -14,7 +21,29 @@ (assert (subtypep i `(or ,i ,j))) (assert (subtypep i `(or ,j ,i))) (assert (subtypep i `(or ,i ,i ,j))) - (assert (subtypep i `(or ,j ,i)))))) + (assert (subtypep i `(or ,j ,i))) + (dolist (k types) + (format t " type K=~S~%" k) + (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k))) + ;; FIXME: The old code (including original CMU CL code) + ;; fails this test. When this is fixed, we can re-enable it. + #+nil (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i))))))) + +;;; gotchas that can come up in handling subtypeness as "X is a +;;; subtype of Y if each of the elements of X is a subtype of Y" +#+nil ; FIXME: suppressed until we can fix old CMU CL big +(let ((subtypep-values (multiple-value-list + (subtypep '(single-float -1.0 1.0) + '(or (real -100.0 0.0) + (single-float 0.0 100.0)))))) + (assert (member subtypep-values + '(;; The system isn't expected to + ;; understand the subtype relationship. + (nil nil) + ;; But if it does, that'd be neat. + (t t) + ;; (And any other return would be wrong.) + )))) (defun type-evidently-= (x y) (and (subtypep x y) @@ -42,12 +71,10 @@ ;;; part II: SUBTYPEP (assert (subtypep '(vector some-undef-type) 'vector)) (assert (not (subtypep '(vector some-undef-type) 'integer))) -(macrolet ((nilnil (expr) - `(assert (equal '(nil nil) (multiple-value-list ,expr))))) - (nilnil (subtypep 'utype-1 'utype-2)) - (nilnil (subtypep '(vector utype-1) '(vector utype-2))) - (nilnil (subtypep '(vector utype-1) '(vector t))) - (nilnil (subtypep '(vector t) '(vector utype-2)))) +(assert-nil-nil (subtypep 'utype-1 'utype-2)) +(assert-nil-nil (subtypep '(vector utype-1) '(vector utype-2))) +(assert-nil-nil (subtypep '(vector utype-1) '(vector t))) +(assert-nil-nil (subtypep '(vector t) '(vector utype-2))) ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 2c75b03..6ce9af0 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.10.15" +"0.6.10.16"