From 5d43b3b14eadc7774b5dcb1f3b40441eec58c90e Mon Sep 17 00:00:00 2001 From: pmai <pmai> Date: Sat, 23 Feb 2002 01:48:57 +0000 Subject: [PATCH] Added limited handling of subtypep for hairy and types, so that we can report meaningful subtype information for types like ratio, which are internally expanded to hairy and types, but where the standard requires us to return valid subtype relationships with other built-in types, like e.g. rational. --- code/type.lisp | 41 ++++++++++++++++++++++++++++++----------- 1 file changed, 30 insertions(+), 11 deletions(-) diff --git a/code/type.lisp b/code/type.lisp index adbea1e3d..21a388174 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.39 2001/11/22 13:39:15 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.40 2002/02/23 01:48:57 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1013,16 +1013,35 @@ (define-type-method (hairy :complex-subtypep-arg2) (type1 type2) (let ((hairy-spec (hairy-type-specifier type2))) - (cond ((and (consp hairy-spec) (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) + (cond + ((and (consp hairy-spec) (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)))) + ((and (consp hairy-spec) (eq (car hairy-spec) 'and)) + (block PUNT + (values (every-type-op csubtypep type1 + (mapcar #'specifier-type (cdr hairy-spec))) + t))) + (t + (values nil nil))))) + +(define-type-method (hairy :complex-subtypep-arg1) (type1 type2) + (let ((hairy-spec (hairy-type-specifier type1))) + (cond + ((and (consp hairy-spec) (eq (car hairy-spec) 'and)) + (block PUNT + (if (any-type-op csubtypep type2 + (mapcar #'specifier-type (cdr hairy-spec)) + :list-first t) + (values t t) + (values nil nil)))) + (t + (values nil nil))))) + +(define-type-method (hairy :complex-=) (type1 type2) (declare (ignore type1 type2)) (values nil nil)) -- GitLab