Changeset 12583


Ignore:
Timestamp:
Aug 15, 2009, 2:17:40 PM (10 years ago)
Author:
gz
Message:

I broke THE in r12500, forcing single-value returns in the typechecking case. Fix it.

Location:
trunk/source/compiler
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/nx0.lisp

    r12533 r12583  
    18691869
    18701870(defun nx1-type-intersect (form type1 type2 &optional (env *nx-lexical-environment*))
    1871   (let* ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1 env)))
    1872          (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2 env)))
    1873          (intersection (type-intersection ctype1 ctype2)))
     1871  (let* ((ctype1 (if (typep type1 'ctype) type1 (values-specifier-type type1 env)))
     1872         (ctype2 (if (typep type2 'ctype) type2 (values-specifier-type type2 env)))
     1873         (intersection (if (or (values-ctype-p ctype1) (values-ctype-p ctype2))
     1874                         (values-type-intersection ctype1 ctype2)
     1875                         (type-intersection ctype1 ctype2))))
    18741876    (when (eq intersection *empty-type*)
    18751877      (let ((type1 (if (typep type1 'ctype)
  • trunk/source/compiler/nx1.lisp

    r12535 r12583  
    1717(in-package "CCL")
    1818
    19 ;;; Wimp out, but don't choke on (the (values ...) form)
    2019(defnx1 nx1-the the (&whole call typespec form &environment env)
    2120  ;; Allow VALUES types here (or user-defined types that
     
    2928                           (parse-unknown-type (c)
    3029                             (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
    31                              nil)
     30                             *wild-type*)
    3231                           (program-error (c)
    3332                              (nx1-whine :invalid-type typespec c)
    34                               nil))))
    35              (if (null ctype)
    36                '*
    37                (if (typep ctype 'function-ctype)
    38                  'function
    39                  (nx-target-type (type-specifier (single-value-type ctype))))))))
     33                             *wild-type*))))
     34             (if (typep ctype 'function-ctype)
     35               'function
     36               (nx-target-type (type-specifier ctype))))))
    4037    (let* ((typespec (typespec-for-the typespec))
    4138           (*nx-form-type* typespec)
     
    5956          (when (eq transformed last)
    6057            (return)))
    61         (when (and (nx-form-constant-p transformed env)
    62                    (not (typep (nx-form-constant-value transformed env) typespec)))
    63           (nx1-whine :type call)
    64           (setq typespec t))
    65         (setq typespec (nx-target-type
    66                         (or (nx1-type-intersect call
    67                                                 typespec
    68                                                 (typespec-for-the (nx-form-type transformed env)))
    69                             t)))
     58        (if (and (nx-form-constant-p transformed env)
     59                 (or (equal typespec '(values))
     60                     (not (typep (nx-form-constant-value transformed env)
     61                                 (single-value-type (values-specifier-type typespec))))))
     62          (progn
     63            (nx1-whine :type call)
     64            (setq typespec '*))
     65          (setq typespec (nx-target-type
     66                          (or (nx1-type-intersect call
     67                                                  typespec
     68                                                  (typespec-for-the (nx-form-type transformed env)))
     69                              '*))))
     70        ;; Wimp out, but don't choke on (the (values ...) form)
     71        (when (and (consp typespec) (eq (car typespec) 'values))
     72          (setq typespec '*))
    7073        (make-acode
    7174         (%nx1-operator typed-form)
Note: See TracChangeset for help on using the changeset viewer.