From 20fb9e4ed1aae3f7fb43cd1310fc893fb4ae8c5e Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Wed, 13 May 1998 04:03:40 +0000 Subject: [PATCH] Handle a few 'not hairy type specifier subtypep cases, which overcomes some problems with the 'atom type which is defined as (not cons). --- code/type.lisp | 30 +++++++++++++++++++++++++----- 1 file changed, 25 insertions(+), 5 deletions(-) diff --git a/code/type.lisp b/code/type.lisp index 6c20afa4a..2aef5b487 100644 --- a/code/type.lisp +++ b/code/type.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.28 1998/04/17 00:44:53 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.29 1998/05/13 04:03:40 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -975,9 +975,29 @@ (define-type-method (hairy :unparse) (x) (hairy-type-specifier x)) -(define-type-method (hairy :complex-subtypep-arg1 :complex-subtypep-arg2 - :complex-=) - (type1 type2) +(define-type-method (hairy :simple-subtypep) (type1 type2) + (let ((hairy-spec1 (hairy-type-specifier type1)) + (hairy-spec2 (hairy-type-specifier type2))) + (cond ((and (eq (car hairy-spec1) 'not) (eq (car hairy-spec2) 'not)) + (csubtypep (specifier-type (cadr hairy-spec2)) + (specifier-type (cadr hairy-spec1)))) + ((equal hairy-spec1 hairy-spec2) + (values t t)) + (t + (values nil nil))))) + +(define-type-method (hairy :complex-subtypep-arg2) (type1 type2) + (let ((hairy-spec (hairy-type-specifier type2))) + (cond ((eq (car hairy-spec) 'not) + (multiple-value-bind (val win) + (type-intersection type1 (specifier-type (cadr hairy-spec))) + (if win + (values (eq val *empty-type*) t) + (values nil nil)))) + (t + (values nil nil))))) + +(define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2) (declare (ignore type1 type2)) (values nil nil)) @@ -989,7 +1009,7 @@ (define-type-method (hairy :complex-union) (type1 type2) (make-union-type (list type1 type2))) -(define-type-method (hairy :simple-= :simple-subtypep) (type1 type2) +(define-type-method (hairy :simple-=) (type1 type2) (if (equal (hairy-type-specifier type1) (hairy-type-specifier type2)) (values t t) -- GitLab