X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-type.lisp;h=4ad4966a4fcf4fc017b0337822e75aa97345e640;hb=61e6ba93d83266662a1e17431fab02a981ec6bc8;hp=6bc004ef62d06d79b4b6c2af12c8c4c6781344ab;hpb=b2f0204834bd0c314d44942dd92475c15ffa8c89;p=sbcl.git diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 6bc004e..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 @@ -392,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.