Changeset 10080


Ignore:
Timestamp:
Jul 18, 2008, 3:20:04 PM (11 years ago)
Author:
gb
Message:

Propagate r10008 (several long-standing compiler-macro bugs) to
trunk.

File:
1 edited

Legend:

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

    r9892 r10080  
    122122    call))
    123123
    124 ;;; True if arg is an alternating list of keywords and args,
    125 ;;; only recognizes keywords in keyword package.
    126 ;;; Historical note: this used to try to ensure that the
    127 ;;; keyword appeared at most once.  Why ? (Even before
    128 ;;; destructuring, pl-search/getf would have dtrt.)
     124;;; True if arg is an alternating list of keywords and args, only
     125;;; recognizes keywords in keyword package.  Historical note: this
     126;;; used to try to ensure that the keyword appeared at most once.  Why
     127;;; ? (Even before destructuring, pl-search/getf would have dtrt.)
     128;;; Side effects: it's not the right thing to simply pick the value
     129;;; associated with the first occurrence of a keyword if the value
     130;;; associated with subsequent occurrence could have a side-effect.
     131;;; (We -can- ignore a duplicate key if the associated value is
     132;;; side-effect free.)
    129133(defun constant-keywords-p (keys)
    130134  (when (plistp keys)
    131     (while keys
    132       (unless (keywordp (%car keys))
    133         (return-from constant-keywords-p nil))
    134       (setq keys (%cddr keys)))
    135     t))
     135    (do* ((seen ())
     136          (keys keys (cddr keys)))
     137         ((null keys) t)
     138      (let* ((key (car keys)))
     139        (if (or (not (keywordp key))
     140                (and (memq key seen)
     141                     (not (constantp (cadr keys)))))
     142          (return))
     143        (push key seen)))))
    136144
    137145(defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly)
     
    683691          (setf (array-ctype-dimensions ctype)
    684692                '*))))
    685     (let* ((typespec (if element-type-p (nx-unquote element-type) t))
     693    (let* ((typespec (if element-type-p
     694                       (if (constantp element-type)
     695                         (nx-unquote element-type)
     696                         '*)
     697                       t))
    686698           (element-type (or (specifier-type-if-known typespec env)
    687699                             (make-unknown-ctype :specifier typespec))))
    688700      (setf (array-ctype-element-type ctype) element-type)
    689701      (if (typep element-type 'unknown-ctype)
    690         (setf (array-ctype-specialized-element-type ctype) *wild-type*)
    691         (specialize-array-type ctype)))
     702        (setf (array-ctype-element-type ctype) *wild-type*))
     703      (specialize-array-type ctype))
    692704    (type-specifier ctype)))
    693705
     
    795807(defun comp-nuke-keys (keys key-list call-list &optional required-bindings)
    796808  ; side effects call list, returns a let-list
    797   (let ((let-list (reverse required-bindings)))
     809  (let* ((let-list (reverse required-bindings))
     810         (seen nil))
    798811    (do ((lst keys (cddr lst)))
    799812        ((null lst) nil)
     
    804817             (ppos (caddr ass)))
    805818        (when ass
    806           (when (not (constantp val))
    807             (let ((gen (gensym)))
    808               (setq let-list (cons (list gen val) let-list)) ; reverse him
    809               (setq val gen)))
    810           (rplaca (nthcdr vpos call-list) val)
    811           (if ppos (rplaca (nthcdr ppos call-list) t)))))
     819          (unless (memq vpos seen)
     820            (push vpos seen)
     821            (when (not (constantp val))
     822              (let ((gen (gensym)))
     823                (setq let-list (cons (list gen val) let-list)) ; reverse him
     824                (setq val gen)))
     825            (rplaca (nthcdr vpos call-list) val)
     826            (if ppos (rplaca (nthcdr ppos call-list) t))))))
    812827    (nreverse let-list)))
    813828
     
    14971512                          ,@(unless (eq (car dims) '*)
    14981513                                    `((eq (%svref ,temp target::vectorH.logsize-cell) ,(car dims)))))))))))))
    1499         `(array-%%typep ,thing ,ctype))))))
     1514        `(values (array-%%typep ,thing ,ctype)))))))
    15001515
    15011516
     
    18761891         (gtype (gensym)))
    18771892    `(let* ((,gthing ,thing)
    1878             (,gtype (typecode ,thing)))
     1893            (,gtype (typecode ,gthing)))
    18791894      (declare (type (unsigned-byte 8) ,gtype))
    18801895      (if (= ,gtype ,(nx-lookup-target-uvector-subtag :vector-header))
     
    19301945    (if (null (cdr others))
    19311946      (let* ((third (car others))
    1932              (code (gensym)))
    1933         `(let* ((,code (%char-code (char-upcase ,ch))))
    1934           (and (eq ,code (setq ,code (%char-code (char-upcase ,other))))
    1935            (eq ,code (%char-code (char-upcase ,third))))))
     1947             (code (gensym))
     1948             (code2 (gensym))
     1949             (code3 (gensym)))
     1950        `(let* ((,code (%char-code (char-upcase ,ch)))
     1951                (,code2 (%char-code (char-upcase ,other)))
     1952                (,code3 (%char-code (char-upcase ,third))))
     1953          (and (eq ,code ,code2)
     1954           (eq ,code2 ,code3))))
    19361955      call)))
    19371956
     
    19511970    (if (null (cdr others))
    19521971      (let* ((third (car others))
    1953              (code (gensym)))
    1954         `(let* ((,code (char-code ,ch)))
    1955           (declare (fixnum ,code))
    1956           (and (< ,code (setq ,code (char-code ,other)))
    1957            (< ,code (the fixnum (char-code ,third))))))
     1972             (code (gensym))
     1973             (code2 (gensym))
     1974             (code3 (gensym)))
     1975        `(let* ((,code (char-code ,ch))
     1976                (,code2 (char-code ,other))
     1977                (,code3 (char-code ,third)))
     1978          (declare (fixnum ,code ,code2 ,code3))
     1979          (and (< ,code ,code2)
     1980           (< ,code2 ,code3))))
    19581981      call)))
    19591982
     
    19651988    (if (null (cdr others))
    19661989      (let* ((third (car others))
    1967              (code (gensym)))
    1968         `(let* ((,code (char-code ,ch)))
    1969           (declare (fixnum ,code))
    1970           (and (<= ,code (setq ,code (char-code ,other)))
    1971            (<= ,code (the fixnum (char-code ,third))))))
     1990             (code (gensym))
     1991             (code2 (gensym))
     1992             (code3 (gensym)))
     1993        `(let* ((,code (char-code ,ch))
     1994                (,code2 (char-code ,other))
     1995                (,code3 (char-code ,third)))
     1996          (declare (fixnum ,code ,code2 ,code3))
     1997          (and (<= ,code ,code2)
     1998           (<= ,code2 ,code3))))
    19721999      call)))
    19732000
     
    19792006    (if (null (cdr others))
    19802007      (let* ((third (car others))
    1981              (code (gensym)))
    1982         `(let* ((,code (char-code ,ch)))
    1983           (declare (fixnum ,code))
    1984           (and (> ,code (setq ,code (char-code ,other)))
    1985            (> ,code (the fixnum (char-code ,third))))))
     2008             (code (gensym))
     2009             (code2 (gensym))
     2010             (code3 (gensym)))
     2011        `(let* ((,code (char-code ,ch))
     2012                (,code2 (char-code ,other))
     2013                (,code3 (char-code ,third)))
     2014          (declare (fixnum ,code ,code2 ,code3))
     2015          (and (> ,code ,code2)
     2016           (> ,code2 ,code3))))
    19862017      call)))
    19872018
     
    19932024    (if (null (cdr others))
    19942025      (let* ((third (car others))
    1995              (code (gensym)))
    1996         `(let* ((,code (char-code ,ch)))
    1997           (declare (fixnum ,code))
    1998           (and (>= ,code (setq ,code (char-code ,other)))
    1999            (>= ,code (the fixnum (char-code ,third))))))
     2026             (code (gensym))
     2027             (code2 (gensym))
     2028             (code3 (gensym)))
     2029        `(let* ((,code (char-code ,ch))
     2030                (,code2 (char-code ,other))
     2031                (,code3 (char-code ,third)))
     2032          (declare (fixnum ,code ,code2 ,code3))
     2033          (and (>= ,code ,code2)
     2034           (>= ,code2 ,code3))))
    20002035      call)))
    20012036
Note: See TracChangeset for help on using the changeset viewer.