X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=04a93f2a4e44f94232e83c7914c4e3f6b6311b0a;hb=0c3bbfaa2286626a2d915c8810f690aefc702661;hp=34b5f0d9f435372216dc1b22ceee9369d5f2c724;hpb=dbe82b489260b2ef76e916d0aeaee8b3850f5f52;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 34b5f0d..04a93f2 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -432,8 +432,9 @@ 1 (values-type-max-value-count type))) +;;; VALUES type with a single value. (defun type-single-value-p (type) - (and (values-type-p type) + (and (%values-type-p type) (not (values-type-rest type)) (null (values-type-optional type)) (singleton-p (values-type-required type)))) @@ -450,10 +451,11 @@ *empty-type*) ((not (values-type-p type)) type) - (t (or (car (args-type-required type)) - (car (args-type-optional type)) - (args-type-rest type) - (specifier-type 'null))))) + ((car (args-type-required type))) + (t (type-union (specifier-type 'null) + (or (car (args-type-optional type)) + (args-type-rest type) + (specifier-type 'null)))))) ;;; Return the minimum number of arguments that a function can be ;;; called with, and the maximum number or NIL. If not a function @@ -653,6 +655,19 @@ :rest rest) exactp))) +(defun compare-key-args (type1 type2) + (let ((keys1 (args-type-keywords type1)) + (keys2 (args-type-keywords type2))) + (and (= (length keys1) (length keys2)) + (eq (args-type-allowp type1) + (args-type-allowp type2)) + (loop for key1 in keys1 + for match = (find (key-info-name key1) + keys2 :key #'key-info-name) + always (and match + (type= (key-info-type key1) + (key-info-type match))))))) + (defun type=-args (type1 type2) (macrolet ((compare (comparator field) (let ((reader (symbolicate '#:args-type- field))) @@ -667,7 +682,7 @@ (and/type (and/type (compare type=-list required) (compare type=-list optional)) (if (or (args-type-keyp type1) (args-type-keyp type2)) - (values nil nil) + (values (compare-key-args type1 type2) t) (values t t)))))) ;;; Do a union or intersection operation on types that might be values @@ -1731,7 +1746,7 @@ (eql low high) (eql (numeric-type-complexp type) :real) (member (numeric-type-class type) '(integer rational - #!-sb-xc-host float))) + #-sb-xc-host float))) (values t (numeric-type-low type)) (values nil nil)))) @@ -2403,14 +2418,8 @@ used for a COMPLEX component.~:@>" (values nil t)) ((or (unknown-type-p (array-type-element-type type1)) (unknown-type-p (array-type-element-type type2))) - (multiple-value-bind (equalp certainp) - (type= (array-type-element-type type1) - (array-type-element-type type2)) - ;; By its nature, the call to TYPE= should never return - ;; NIL, T, as we don't know what the UNKNOWN-TYPE will grow - ;; up to be. -- CSR, 2002-08-19 - (aver (not (and (not equalp) certainp))) - (values equalp certainp))) + (type= (array-type-element-type type1) + (array-type-element-type type2))) (t (values (type= (array-type-specialized-element-type type1) (array-type-specialized-element-type type2)) @@ -2909,11 +2918,12 @@ used for a COMPLEX component.~:@>" :high (if (null (numeric-type-high type1)) nil (list (1+ (numeric-type-high type1))))))) - (type-union type1 - (apply #'type-intersection - (remove (specifier-type '(not integer)) - (intersection-type-types type2) - :test #'type=)))) + (let* ((intersected (intersection-type-types type2)) + (remaining (remove (specifier-type '(not integer)) + intersected + :test #'type=))) + (and (not (equal intersected remaining)) + (type-union type1 (apply #'type-intersection remaining))))) (t (let ((accumulator *universal-type*)) (do ((t2s (intersection-type-types type2) (cdr t2s))) @@ -3301,10 +3311,20 @@ used for a COMPLEX component.~:@>" ((type= type (specifier-type 'base-char)) 'base-char) ((type= type (specifier-type 'extended-char)) 'extended-char) ((type= type (specifier-type 'standard-char)) 'standard-char) - (t (let ((pairs (character-set-type-pairs type))) - `(member ,@(loop for (low . high) in pairs + (t + ;; Unparse into either MEMBER or CHARACTER-SET. We use MEMBER if there + ;; are at most as many characters than there are character code ranges. + (let* ((pairs (character-set-type-pairs type)) + (count (length pairs)) + (chars (loop named outer + for (low . high) in pairs nconc (loop for code from low upto high - collect (sb!xc:code-char code)))))))) + collect (sb!xc:code-char code) + when (minusp (decf count)) + do (return-from outer t))))) + (if (eq chars t) + `(character-set ,pairs) + `(member ,@chars)))))) (!define-type-method (character-set :singleton-p) (type) (let* ((pairs (character-set-type-pairs type)) @@ -3475,6 +3495,60 @@ used for a COMPLEX component.~:@>" *wild-type* (specifier-type element-type))))) +;;;; SIMD-PACK types +#!+sb-simd-pack +(progn + (!define-type-class simd-pack) + + (!def-type-translator simd-pack (&optional (element-type-spec '*)) + (if (eql element-type-spec '*) + (%make-simd-pack-type *simd-pack-element-types*) + (make-simd-pack-type (single-value-specifier-type element-type-spec)))) + + (!define-type-method (simd-pack :negate) (type) + (let ((remaining (set-difference *simd-pack-element-types* + (simd-pack-type-element-type type))) + (not-simd-pack (make-negation-type :type (specifier-type 'simd-pack)))) + (if remaining + (type-union not-simd-pack (%make-simd-pack-type remaining)) + not-simd-pack))) + + (!define-type-method (simd-pack :unparse) (type) + (let ((eltypes (simd-pack-type-element-type type))) + (cond ((equal eltypes *simd-pack-element-types*) + 'simd-pack) + ((= 1 (length eltypes)) + `(simd-pack ,(first eltypes))) + (t + `(or ,@(mapcar (lambda (eltype) + `(simd-pack ,eltype)) + eltypes)))))) + + (!define-type-method (simd-pack :simple-=) (type1 type2) + (declare (type simd-pack-type type1 type2)) + (null (set-exclusive-or (simd-pack-type-element-type type1) + (simd-pack-type-element-type type2)))) + + (!define-type-method (simd-pack :simple-subtypep) (type1 type2) + (declare (type simd-pack-type type1 type2)) + (subsetp (simd-pack-type-element-type type1) + (simd-pack-type-element-type type2))) + + (!define-type-method (simd-pack :simple-union2) (type1 type2) + (declare (type simd-pack-type type1 type2)) + (%make-simd-pack-type (union (simd-pack-type-element-type type1) + (simd-pack-type-element-type type2)))) + + (!define-type-method (simd-pack :simple-intersection2) (type1 type2) + (declare (type simd-pack-type type1 type2)) + (let ((intersection (intersection (simd-pack-type-element-type type1) + (simd-pack-type-element-type type2)))) + (if intersection + (%make-simd-pack-type intersection) + *empty-type*))) + + (!define-superclasses simd-pack ((simd-pack)) !cold-init-forms)) + ;;;; utilities shared between cross-compiler and target system ;;; Does the type derived from compilation of an actual function