X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-type.lisp;h=0aa097449c4a6cbfadaeae7d1acab968e224de91;hb=260a9146f02374a9cfbd9deb53283ee493f3729f;hp=b338ad70907ba514600592ad04ad928053dad36f;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index b338ad7..0aa0974 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -221,10 +221,15 @@ ;; specifier to win. (type (missing-arg) :type ctype)) -;;; The NAMED-TYPE is used to represent *, T and NIL. These types must -;;; be super- or sub-types of all types, not just classes and * and -;;; NIL aren't classes anyway, so it wouldn't make much sense to make -;;; them built-in classes. +;;; The NAMED-TYPE is used to represent *, T and NIL, the standard +;;; special cases, as well as other special cases needed to +;;; interpolate between regions of the type hierarchy, such as +;;; INSTANCE (which corresponds to all those classes with slots which +;;; are not funcallable), FUNCALLABLE-INSTANCE (those classes with +;;; slots which are funcallable) and EXTENDED-SEQUUENCE (non-LIST +;;; non-VECTOR classes which are also sequences). These special cases +;;; are the ones that aren't really discussed by Baker in his +;;; "Decision Procedure for SUBTYPEP" paper. (defstruct (named-type (:include ctype (class-info (type-class-or-lose 'named))) (:copier nil)) @@ -337,8 +342,13 @@ (:copier nil)) (pairs (missing-arg) :type list :read-only t)) (defun make-character-set-type (&key pairs) - (aver (equal (mapcar #'car pairs) - (sort (mapcar #'car pairs) #'<))) + ; (aver (equal (mapcar #'car pairs) + ; (sort (mapcar #'car pairs) #'<))) + ;; aver that the cars of the list elements are sorted into increasing order + (aver (or (null pairs) + (do ((p pairs (cdr p))) + ((null (cdr p)) t) + (when (> (caar p) (caadr p)) (return nil))))) (let ((pairs (let (result) (do ((pairs pairs (cdr pairs))) ((null pairs) (nreverse result)) @@ -388,35 +398,62 @@ (members nil :type list)) (defun make-member-type (&key members) (declare (type list members)) - ;; make sure that we've removed duplicates - (aver (= (length members) (length (remove-duplicates members)))) ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric ;; ranges are compared by arithmetic operators (while MEMBERship is ;; compared by EQL). -- CSR, 2003-04-23 - (let ((singlep (subsetp `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members)) - (doublep (subsetp `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) + (let ((n-single (load-time-value + (make-unportable-float :single-float-negative-zero))) + (n-double (load-time-value + (make-unportable-float :double-float-negative-zero))) #!+long-float - (longp (subsetp `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members))) - (if (or singlep doublep #!+long-float longp) - (let (union-types) - (when singlep - (push (ctype-of 0.0f0) union-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) - (when doublep - (push (ctype-of 0.0d0) union-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) - #!+long-float - (when longp - (push (ctype-of 0.0l0) union-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) - (aver (not (null union-types))) - (make-union-type t - (if (null members) - union-types - (cons (%make-member-type members) - union-types)))) - (%make-member-type members)))) + (n-long (load-time-value + (make-unportable-float :long-float-negative-zero))) + (singles nil) + (doubles nil) + #!+long-float + (longs nil)) + ;; Just a single traversal, please! MEMBERS2 starts as with MEMBERS, + ;; sans any zeroes -- if there are any paired zeroes then the + ;; unpaired ones are added back to it. + (let (members2) + (dolist (elt members) + (if (and (numberp elt) (zerop elt)) + (typecase elt + (single-float (push elt singles)) + (double-float (push elt doubles)) + #!+long-float + (long-float (push elt longs))) + (push elt members2))) + (let ((singlep (and (member 0.0f0 singles) + (member n-single singles) + (or (aver (= 2 (length singles))) t))) + (doublep (and (member 0.0d0 doubles) + (member n-double doubles) + (or (aver (= 2 (length doubles))) t))) + #!+long-float + (longp (and (member 0.0l0 longs) + (member n-long longs) + (or (aver (= 2 (lenght longs))) t)))) + (if (or singlep doublep #!+long-float longp) + (let (union-types) + (if singlep + (push (ctype-of 0.0f0) union-types) + (setf members2 (nconc singles members2))) + (if doublep + (push (ctype-of 0.0d0) union-types) + (setf members2 (nconc doubles members2))) + #!+long-float + (if longp + (push (ctype-of 0.0l0) union-types) + (setf members2 (nconc longs members2))) + (aver (not (null union-types))) + (make-union-type t + (if (null members2) + union-types + (cons (%make-member-type members2) + union-types)))) + (%make-member-type members)))))) ;;; A COMPOUND-TYPE is a type defined out of a set of types, the ;;; common parent of UNION-TYPE and INTERSECTION-TYPE. @@ -525,11 +562,6 @@ ((eq (info :type :kind spec) :instance) (find-classoid spec)) ((typep spec 'classoid) - ;; There doesn't seem to be any way to translate - ;; (TYPEP SPEC 'BUILT-IN-CLASS) into something which can be - ;; executed on the host Common Lisp at cross-compilation time. - #+sb-xc-host (error - "stub: (TYPEP SPEC 'BUILT-IN-CLASS) on xc host") (if (typep spec 'built-in-classoid) (or (built-in-classoid-translation spec) spec) spec))