Mercurial > hg > xemacs-beta
comparison lisp/cl-macs.el @ 5317:8aa511adfad6
#'delete-duplicates: don't attempt to compiler macroexpand with bad arguments
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete-duplicates):
If the form has an incorrect number of arguments, don't attempt a
compiler macroexpansion.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 29 Dec 2010 23:56:57 +0000 |
| parents | 9ac28212c75a |
| children | 60ba780f9078 6506fcb40fcf |
comparison
equal
deleted
inserted
replaced
| 5316:9ac28212c75a | 5317:8aa511adfad6 |
|---|---|
| 3485 `(delete-duplicates (the list ,list) :test #'equal :from-end t)) | 3485 `(delete-duplicates (the list ,list) :test #'equal :from-end t)) |
| 3486 | 3486 |
| 3487 ;; XEmacs; inline delete-duplicates if it's called with one of the | 3487 ;; XEmacs; inline delete-duplicates if it's called with one of the |
| 3488 ;; common compile-time constant tests and an optional :from-end | 3488 ;; common compile-time constant tests and an optional :from-end |
| 3489 ;; argument, we want the speed in font-lock.el. | 3489 ;; argument, we want the speed in font-lock.el. |
| 3490 (define-compiler-macro delete-duplicates (&whole form cl-seq &rest cl-keys) | 3490 (define-compiler-macro delete-duplicates (&whole form &rest cl-keys) |
| 3491 (if (not (or (memq (car-safe cl-seq) | 3491 (let ((cl-seq (if cl-keys (pop cl-keys)))) |
| 3492 ;; No need to check for a list at runtime with | 3492 (if (or |
| 3493 ;; these. We could expand the list, but these are all | 3493 (not (or (memq (car-safe cl-seq) |
| 3494 ;; the functions in the relevant context at the moment. | 3494 ;; No need to check for a list at runtime with |
| 3495 '(nreverse append nconc mapcan mapcar string-to-list)) | 3495 ;; these. We could expand the list, but these are all |
| 3496 (and (listp cl-seq) (equal (butlast cl-seq) '(the list))))) | 3496 ;; the functions in the relevant context at the moment. |
| 3497 form | 3497 '(nreverse append nconc mapcan mapcar string-to-list)) |
| 3498 (cond | 3498 (and (listp cl-seq) (equal (butlast cl-seq) '(the list))))) |
| 3499 ((or (plists-equal cl-keys '(:test 'eq) t) | 3499 ;; Wrong number of arguments. |
| 3500 (plists-equal cl-keys '(:test #'eq) t)) | 3500 (not (cdr form))) |
| 3501 `(let* ((begin ,cl-seq) | 3501 form |
| 3502 cl-seq) | 3502 (cond |
| 3503 (while (memq (car begin) (cdr begin)) | 3503 ((or (plists-equal cl-keys '(:test 'eq) t) |
| 3504 (setq begin (cdr begin))) | 3504 (plists-equal cl-keys '(:test #'eq) t)) |
| 3505 (setq cl-seq begin) | 3505 `(let* ((begin ,cl-seq) |
| 3506 (while (cddr cl-seq) | 3506 cl-seq) |
| 3507 (if (memq (cadr cl-seq) (cddr cl-seq)) | 3507 (while (memq (car begin) (cdr begin)) |
| 3508 (setcdr (cdr cl-seq) (cddr cl-seq))) | 3508 (setq begin (cdr begin))) |
| 3509 (setq cl-seq (cdr cl-seq))) | 3509 (setq cl-seq begin) |
| 3510 begin)) | 3510 (while (cddr cl-seq) |
| 3511 ((or (plists-equal cl-keys '(:test 'eq :from-end t) t) | 3511 (if (memq (cadr cl-seq) (cddr cl-seq)) |
| 3512 (plists-equal cl-keys '(:test #'eq :from-end t) t)) | 3512 (setcdr (cdr cl-seq) (cddr cl-seq))) |
| 3513 `(let* ((begin ,cl-seq) | 3513 (setq cl-seq (cdr cl-seq))) |
| 3514 (cl-seq begin)) | 3514 begin)) |
| 3515 (while cl-seq | 3515 ((or (plists-equal cl-keys '(:test 'eq :from-end t) t) |
| 3516 (setq cl-seq (setcdr cl-seq | 3516 (plists-equal cl-keys '(:test #'eq :from-end t) t)) |
| 3517 (delq (car cl-seq) (cdr cl-seq))))) | 3517 `(let* ((begin ,cl-seq) |
| 3518 begin)) | 3518 (cl-seq begin)) |
| 3519 ((or (plists-equal cl-keys '(:test 'equal) t) | 3519 (while cl-seq |
| 3520 (plists-equal cl-keys '(:test #'equal) t)) | 3520 (setq cl-seq (setcdr cl-seq |
| 3521 `(let* ((begin ,cl-seq) | 3521 (delq (car cl-seq) (cdr cl-seq))))) |
| 3522 cl-seq) | 3522 begin)) |
| 3523 (while (member (car begin) (cdr begin)) | 3523 ((or (plists-equal cl-keys '(:test 'equal) t) |
| 3524 (setq begin (cdr begin))) | 3524 (plists-equal cl-keys '(:test #'equal) t)) |
| 3525 (setq cl-seq begin) | 3525 `(let* ((begin ,cl-seq) |
| 3526 (while (cddr cl-seq) | 3526 cl-seq) |
| 3527 (if (member (cadr cl-seq) (cddr cl-seq)) | 3527 (while (member (car begin) (cdr begin)) |
| 3528 (setcdr (cdr cl-seq) (cddr cl-seq))) | 3528 (setq begin (cdr begin))) |
| 3529 (setq cl-seq (cdr cl-seq))) | 3529 (setq cl-seq begin) |
| 3530 begin)) | 3530 (while (cddr cl-seq) |
| 3531 ((or (plists-equal cl-keys '(:test 'equal :from-end t) t) | 3531 (if (member (cadr cl-seq) (cddr cl-seq)) |
| 3532 (plists-equal cl-keys '(:test #'equal :from-end t) t)) | 3532 (setcdr (cdr cl-seq) (cddr cl-seq))) |
| 3533 `(let* ((begin ,cl-seq) | 3533 (setq cl-seq (cdr cl-seq))) |
| 3534 (cl-seq begin)) | 3534 begin)) |
| 3535 (while cl-seq | 3535 ((or (plists-equal cl-keys '(:test 'equal :from-end t) t) |
| 3536 (setq cl-seq (setcdr cl-seq (delete (car cl-seq) | 3536 (plists-equal cl-keys '(:test #'equal :from-end t) t)) |
| 3537 (cdr cl-seq))))) | 3537 `(let* ((begin ,cl-seq) |
| 3538 begin)) | 3538 (cl-seq begin)) |
| 3539 (t form)))) | 3539 (while cl-seq |
| 3540 (setq cl-seq (setcdr cl-seq (delete (car cl-seq) | |
| 3541 (cdr cl-seq))))) | |
| 3542 begin)) | |
| 3543 (t form))))) | |
| 3540 | 3544 |
| 3541 ;; XEmacs; it's perfectly reasonable, and often much clearer to those | 3545 ;; XEmacs; it's perfectly reasonable, and often much clearer to those |
| 3542 ;; reading the code, to call regexp-quote on a constant string, which is | 3546 ;; reading the code, to call regexp-quote on a constant string, which is |
| 3543 ;; something we can optimise here easily. | 3547 ;; something we can optimise here easily. |
| 3544 (define-compiler-macro regexp-quote (&whole form string) | 3548 (define-compiler-macro regexp-quote (&whole form string) |