Changeset 13534 for release/1.4/source


Ignore:
Timestamp:
Mar 16, 2010, 6:22:17 PM (10 years ago)
Author:
rme
Message:

Merge r13488 to 1.4 branch from trunk; fixes ticket:664.

Location:
release/1.4/source
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • release/1.4/source

  • release/1.4/source/compiler

  • release/1.4/source/compiler/nx1.lisp

    r13152 r13534  
    1818(in-package "CCL")
    1919
    20 (defnx1 nx1-the the (&whole call typespec form &environment env)
     20(defun nx1-typespec-for-typep (typespec env)
    2121  ;; Allow VALUES types here (or user-defined types that
    2222  ;; expand to VALUES types).  We could do a better job
     
    2525  ;; in type declarations, but aren't legal args to TYPEP;
    2626  ;; treat them as the simple FUNCTION type.
    27   (flet ((typespec-for-the (typespec)
    28            (let* ((ctype (handler-case (values-specifier-type (nx-target-type typespec) env)
    29                            (parse-unknown-type (c)
    30                              (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
    31                              *wild-type*)
    32                            (program-error (c)
    33                               (nx1-whine :invalid-type typespec c)
    34                              *wild-type*))))
    35              (if (typep ctype 'function-ctype)
    36                'function
    37                (if (typep ctype 'values-ctype)
    38                  '*
    39                  (nx-target-type (type-specifier ctype)))))))
    40     (let* ((typespec (typespec-for-the typespec))
    41            (*nx-form-type* typespec)
    42            (transformed (nx-transform form env)))
    43       (flet ((fold-the ()
    44                (do* ()
    45                     ((or (atom transformed)
    46                          (not (eq (car transformed) 'the))))
    47                  (destructuring-bind (ftype form) (cdr transformed)
    48                    (setq typespec (nx-target-type (nx1-type-intersect call typespec (typespec-for-the ftype)))
    49                          *nx-form-type* typespec
    50                          transformed form)))))
     27  (labels ((ctype-spec (ctype)
     28             (typecase ctype
     29               (function-ctype 'function)
     30               (values-ctype '*)
     31               (array-ctype
     32                  (let ((new (ctype-spec (array-ctype-element-type ctype))))
     33                    (when new
     34                      (list (if (array-ctype-complexp ctype) 'array 'simple-array)
     35                            new
     36                            (array-ctype-dimensions ctype)))))
     37               (negation-ctype
     38                  (let ((new (ctype-spec (negation-ctype-type ctype))))
     39                    (when new
     40                      `(not ,new))))
     41               (union-ctype
     42                  (let* ((types (union-ctype-types ctype))
     43                         (new (mapcar #'ctype-spec types)))
     44                    (unless (every #'null new)
     45                      `(or ,@(mapcar (lambda (new old) (or new (type-specifier old))) new types)))))
     46               (intersection-ctype
     47                  (let* ((types (intersection-ctype-types ctype))
     48                         (new (mapcar #'ctype-spec types)))
     49                    (unless (every #'null new)
     50                      `(and ,@(mapcar (lambda (new old) (or new (type-specifier old))) new types)))))
     51               (t nil))))
     52    (let* ((ctype (handler-case (values-specifier-type (nx-target-type typespec) env)
     53                    (parse-unknown-type (c)
     54                      (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
     55                      *wild-type*)
     56                    (program-error (c)
     57                      (nx1-whine :invalid-type typespec c)
     58                      *wild-type*)))
     59           (new (ctype-spec ctype)))
     60      (nx-target-type (type-specifier (if new (specifier-type new) ctype))))))
     61
     62(defnx1 nx1-the the (&whole call typespec form &environment env)
     63  (let* ((typespec (nx1-typespec-for-typep typespec env))
     64         (*nx-form-type* typespec)
     65         (transformed (nx-transform form env)))
     66    (flet ((fold-the ()
     67             (do* ()
     68                 ((or (atom transformed)
     69                      (not (eq (car transformed) 'the))))
     70               (destructuring-bind (ftype form) (cdr transformed)
     71                 (setq typespec (nx-target-type (nx1-type-intersect call typespec (nx1-typespec-for-typep ftype env)))
     72                       *nx-form-type* typespec
     73                       transformed form)))))
     74      (fold-the)
     75      (do* ((last transformed transformed))
     76          ()
     77        (setq transformed (nx-transform transformed env))
     78        (when (or (atom transformed)
     79                  (not (eq (car transformed) 'the)))
     80          (return))
    5181        (fold-the)
    52         (do* ((last transformed transformed))
    53              ()
    54           (setq transformed (nx-transform transformed env))
    55           (when (or (atom transformed)
    56                     (not (eq (car transformed) 'the)))
    57             (return))
    58           (fold-the)
    59           (when (eq transformed last)
    60             (return)))
    61         (if (and (nx-form-constant-p transformed env)
    62                  (or (equal typespec '(values))
    63                      (not (typep (nx-form-constant-value transformed env)
    64                                  (single-value-type (values-specifier-type typespec))))))
    65           (progn
    66             (nx1-whine :type call)
    67             (setq typespec '*))
    68           (setq typespec (nx-target-type
    69                           (or (nx1-type-intersect call
    70                                                   typespec
    71                                                   (typespec-for-the (nx-form-type transformed env)))
    72                               '*))))
    73         ;; Wimp out, but don't choke on (the (values ...) form)
    74         (when (and (consp typespec) (eq (car typespec) 'values))
     82        (when (eq transformed last)
     83          (return)))
     84      (if (and (nx-form-constant-p transformed env)
     85               (or (equal typespec '(values))
     86                   (not (typep (nx-form-constant-value transformed env)
     87                               (single-value-type (values-specifier-type typespec))))))
     88        (progn
     89          (nx1-whine :type call)
    7590          (setq typespec '*))
    76         (make-acode
    77          (%nx1-operator typed-form)
    78          typespec
    79          (let* ((*nx-form-type* typespec))
    80            (nx1-transformed-form transformed env))
    81          (nx-declarations-typecheck env))))))
     91        (setq typespec (nx-target-type
     92                        (or (nx1-type-intersect call
     93                                                typespec
     94                                                (nx1-typespec-for-typep (nx-form-type transformed env)env))
     95                            '*))))
     96      ;; Wimp out, but don't choke on (the (values ...) form)
     97      (when (and (consp typespec) (eq (car typespec) 'values))
     98        (setq typespec '*))
     99      (make-acode
     100       (%nx1-operator typed-form)
     101       typespec
     102       (let* ((*nx-form-type* typespec))
     103         (nx1-transformed-form transformed env))
     104       (nx-declarations-typecheck env)))))
    82105
    83106(defnx1 nx1-struct-ref struct-ref (&whole whole structure offset)
  • release/1.4/source/level-0/X86

    • Property svn:mergeinfo changed (with no actual effect on merging)
  • release/1.4/source/lisp-kernel

    • Property svn:mergeinfo changed (with no actual effect on merging)
  • release/1.4/source/scripts

    • Property svn:mergeinfo changed (with no actual effect on merging)
Note: See TracChangeset for help on using the changeset viewer.