X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftypedefs.lisp;h=57f432e3af966b9b6d18478fd8139db1d13b554b;hb=cbaa1997bb097a55d108df592ac3b7eb4a703fff;hp=b1602716bb721c6cca361eb8ec1405e2e82ca2b3;hpb=77360ee4a1f94c41b807be7ad0e8687199fceef1;p=sbcl.git diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index b160271..57f432e 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -41,8 +41,8 @@ ;; package!) (multiple-value-bind (whole wholeless-arglist) (if (eq '&whole (car arglist)) - (values (cadr arglist) (cddr arglist)) - (values (gensym) arglist)) + (values (cadr arglist) (cddr arglist)) + (values (gensym) arglist)) (multiple-value-bind (forms decls) (parse-body body nil) `(progn (!cold-init-forms @@ -58,25 +58,24 @@ ;;; DEFVARs for these come later, after we have enough stuff defined. (declaim (special *wild-type* *universal-type* *empty-type*)) -;;; The XXX-Type structures include the CTYPE structure for some slots that -;;; apply to all types. +;;; the base class for the internal representation of types (def!struct (ctype (:conc-name type-) (:constructor nil) (:make-load-form-fun make-type-load-form) #-sb-xc-host (:pure t)) - ;; The class of this type. + ;; the class of this type ;; ;; FIXME: It's unnecessarily confusing to have a structure accessor ;; named TYPE-CLASS-INFO which is an accessor for the CTYPE structure ;; even though the TYPE-CLASS structure also exists in the system. ;; Rename this slot: TYPE-CLASS or ASSOCIATED-TYPE-CLASS or something. (class-info (required-argument) :type type-class) - ;; True if this type has a fixed number of members, and as such could - ;; possibly be completely specified in a MEMBER type. This is used by the - ;; MEMBER type methods. - (enumerable nil :type (member t nil) :read-only t) - ;; an arbitrary hash code used in EQ-style hashing of identity (since EQ - ;; hashing can't be done portably) + ;; True if this type has a fixed number of members, and as such + ;; could possibly be completely specified in a MEMBER type. This is + ;; used by the MEMBER type methods. + (enumerable nil :read-only t) + ;; an arbitrary hash code used in EQ-style hashing of identity + ;; (since EQ hashing can't be done portably) (hash-value (random (1+ most-positive-fixnum)) :type (and fixnum unsigned-byte) :read-only t)) @@ -91,63 +90,47 @@ ;;;; 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. -;;; If LIST-FIRST is true, then the list element is the first arg, otherwise -;;; the second. -(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 ,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 ,default)) - (unless ,n-val (return nil))))))) +;;; sort of like ANY and EVERY, except: +;;; * We handle two-VALUES predicate functions like SUBTYPEP. (And +;;; if the result is uncertain, then we return (VALUES NIL NIL), +;;; just like SUBTYPEP.) +;;; * THING is just an atom, and we apply OP (an arity-2 function) +;;; successively to THING and each element of LIST. +(defun any/type (op thing list) + (declare (type function op)) + (let ((certain? t)) + (dolist (i list (values nil certain?)) + (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) + (if sub-certain? + (when sub-value (return (values t t))) + (setf certain? nil)))))) +(defun every/type (op thing list) + (declare (type function op)) + (let ((certain? t)) + (dolist (i list (if certain? (values t t) (values nil nil))) + (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) + (if sub-certain? + (unless sub-value (return (values nil t))) + (setf certain? nil)))))) -;;; Compute the intersection for types that intersect only when one is a -;;; hierarchical subtype of the other. -(defun vanilla-intersection (type1 type2) - (multiple-value-bind (stp1 win1) (csubtypep type1 type2) - (multiple-value-bind (stp2 win2) (csubtypep type2 type1) - (cond (stp1 (values type1 t)) - (stp2 (values type2 t)) - ((and win1 win2) (values *empty-type* t)) - (t - (values type1 nil)))))) - -(defun vanilla-union (type1 type2) +;;; Look for nice relationships for types that have nice relationships +;;; only when one is a hierarchical subtype of the other. +(defun hierarchical-intersection2 (type1 type2) + (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2) + (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1) + (cond (subtypep1 type1) + (subtypep2 type2) + ((and win1 win2) *empty-type*) + (t nil))))) +(defun hierarchical-union2 (type1 type2) (cond ((csubtypep type1 type2) type2) ((csubtypep type2 type1) type1) (t nil))) -;;; Hash two things (types) down to 8 bits. In CMU CL this was an EQ hash, but -;;; since it now needs to run in vanilla ANSI Common Lisp at cross-compile -;;; time, it's now based on the CTYPE-HASH-VALUE field instead. +;;; Hash two things (types) down to 8 bits. In CMU CL this was an EQ +;;; hash, but since it now needs to run in vanilla ANSI Common Lisp at +;;; cross-compile time, it's now based on the CTYPE-HASH-VALUE field +;;; instead. ;;; ;;; FIXME: This was a macro in CMU CL, and is now an INLINE function. Is ;;; it important for it to be INLINE, or could be become an ordinary