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
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
(!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)
;;; 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)
) ; 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
\f
;;;; 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.
(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)
(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)
;;; 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)
;;; 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"
projects / sbcl.git / commitdiff