X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-type.lisp;h=4ad4966a4fcf4fc017b0337822e75aa97345e640;hb=a18894dbea4495b885e1747babf4e2593dfb705e;hp=31f05ae0d159e06baf7ec0eccbe1c5bb2319cb46;hpb=9dfd024c6fe1337ae7b76f0fd68b8f3208a6c987;p=sbcl.git diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 31f05ae..4ad4966 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -63,7 +63,7 @@ ;; true if other &KEY arguments are allowed (allowp nil :type boolean)) -(defun canonicalize-args-type-args (required optional rest) +(defun canonicalize-args-type-args (required optional rest &optional keyp) (when (eq rest *empty-type*) ;; or vice-versa? (setq rest nil)) @@ -72,19 +72,20 @@ for opt in optional do (cond ((eq opt *empty-type*) (return (values required (subseq optional i) rest))) - ((neq opt rest) + ((and (not keyp) (neq opt rest)) (setq last-not-rest i))) finally (return (values required - (if last-not-rest - (subseq optional 0 (1+ last-not-rest)) - nil) + (cond (keyp + optional) + (last-not-rest + (subseq optional 0 (1+ last-not-rest)))) rest)))) (defun args-types (lambda-list-like-thing) (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count llk-p) - (parse-lambda-list-like-thing lambda-list-like-thing) + (parse-lambda-list-like-thing lambda-list-like-thing :silent t) (declare (ignore aux morep more-context more-count)) (when auxp (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list-like-thing)) @@ -106,7 +107,7 @@ :type (single-value-specifier-type (second key)))))) (key-info)))) (multiple-value-bind (required optional rest) - (canonicalize-args-type-args required optional rest) + (canonicalize-args-type-args required optional rest keyp) (values required optional rest keyp keywords allowp llk-p))))) (defstruct (values-type @@ -221,10 +222,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)) @@ -387,41 +393,78 @@ (class-info (type-class-or-lose 'member)) (enumerable t)) (:copier nil) - (:constructor %make-member-type (members)) + (:constructor %make-member-type (xset fp-zeroes)) #-sb-xc-host (:pure nil)) - ;; the things in the set, with no duplications - (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)))) + (xset (missing-arg) :type xset) + (fp-zeroes (missing-arg) :type list)) +(defun make-member-type (&key xset fp-zeroes members) + (unless xset + (aver (not fp-zeroes)) + (setf xset (alloc-xset)) + (dolist (elt members) + (if (fp-zero-p elt) + (pushnew elt fp-zeroes) + (add-to-xset elt xset)))) ;; 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)) - #!+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)))) + (let ((unpaired nil) + (union-types nil)) + (do ((tail (cdr fp-zeroes) (cdr tail)) + (zero (car fp-zeroes) (car tail))) + ((not zero)) + (macrolet ((frob (c) + `(let ((neg (neg-fp-zero zero))) + (if (member neg tail) + (push (ctype-of ,c) union-types) + (push zero unpaired))))) + (etypecase zero + (single-float (frob 0.0f0)) + (double-float (frob 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)))) + (long-float (frob 0.0l0))))) + ;; The actual member-type contains the XSET (with no FP zeroes), + ;; and a list of unpaired zeroes. + (let ((member-type (unless (and (xset-empty-p xset) (not unpaired)) + (%make-member-type xset unpaired)))) + (cond (union-types + (make-union-type t (if member-type + (cons member-type union-types) + union-types))) + (member-type + member-type) + (t + *empty-type*))))) + +(defun member-type-size (type) + (+ (length (member-type-fp-zeroes type)) + (xset-count (member-type-xset type)))) + +(defun member-type-member-p (x type) + (if (fp-zero-p x) + (and (member x (member-type-fp-zeroes type)) t) + (xset-member-p x (member-type-xset type)))) + +(defun mapcar-member-type-members (function type) + (declare (function function)) + (collect ((results)) + (map-xset (lambda (x) + (results (funcall function x))) + (member-type-xset type)) + (dolist (zero (member-type-fp-zeroes type)) + (results (funcall function zero))) + (results))) + +(defun mapc-member-type-members (function type) + (declare (function function)) + (map-xset function (member-type-xset type)) + (dolist (zero (member-type-fp-zeroes type)) + (funcall function zero))) + +(defun member-type-members (type) + (append (member-type-fp-zeroes type) + (xset-members (member-type-xset type)))) ;;; A COMPOUND-TYPE is a type defined out of a set of types, the ;;; common parent of UNION-TYPE and INTERSECTION-TYPE. @@ -530,11 +573,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))