X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=04a93f2a4e44f94232e83c7914c4e3f6b6311b0a;hb=4f0bd9304dfa5010e2c7f17d7cecde0bba6c578e;hp=13e3368efd11a934662439c48d64fafdc9b8fb1c;hpb=a27847030e4ba8f7298ad3d302b0c5b05a8b8542;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 13e3368..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
@@ -3296,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))
@@ -3470,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