Mercurial > hg > xemacs-beta
comparison lisp/cl-macs.el @ 5445:6506fcb40fcf
Merged with trunk.
| author | Mats Lidell <matsl@xemacs.org> |
|---|---|
| date | Fri, 31 Dec 2010 00:27:29 +0100 |
| parents | 8d29f1c4bb98 8aa511adfad6 |
| children | 89331fa1c819 |
comparison
equal
deleted
inserted
replaced
| 5444:388762703a21 | 5445:6506fcb40fcf |
|---|---|
| 107 (setq xs (cdr xs))) | 107 (setq xs (cdr xs))) |
| 108 (not xs)) | 108 (not xs)) |
| 109 | 109 |
| 110 ;;; Check if no side effects. | 110 ;;; Check if no side effects. |
| 111 (defun cl-safe-expr-p (x) | 111 (defun cl-safe-expr-p (x) |
| 112 (or (not (and (consp x) (not (memq (car x) '(quote function function*))))) | 112 (or (not (and (consp x) (not (memq (car x) |
| 113 '(quote function function* lambda))))) | |
| 113 (and (symbolp (car x)) | 114 (and (symbolp (car x)) |
| 114 (or (memq (car x) cl-simple-funcs) | 115 (or (memq (car x) cl-simple-funcs) |
| 115 (memq (car x) cl-safe-funcs) | 116 (memq (car x) cl-safe-funcs) |
| 116 (get (car x) 'side-effect-free)) | 117 (get (car x) 'side-effect-free)) |
| 117 (progn | 118 (progn |
| 3482 `(delete-duplicates (the list ,list) :test #'equal :from-end t)) | 3483 `(delete-duplicates (the list ,list) :test #'equal :from-end t)) |
| 3483 | 3484 |
| 3484 ;; XEmacs; inline delete-duplicates if it's called with one of the | 3485 ;; XEmacs; inline delete-duplicates if it's called with one of the |
| 3485 ;; common compile-time constant tests and an optional :from-end | 3486 ;; common compile-time constant tests and an optional :from-end |
| 3486 ;; argument, we want the speed in font-lock.el. | 3487 ;; argument, we want the speed in font-lock.el. |
| 3487 (define-compiler-macro delete-duplicates (&whole form cl-seq &rest cl-keys) | 3488 (define-compiler-macro delete-duplicates (&whole form &rest cl-keys) |
| 3488 (if (not (or (memq (car-safe cl-seq) | 3489 (let ((cl-seq (if cl-keys (pop cl-keys)))) |
| 3489 ;; No need to check for a list at runtime with | 3490 (if (or |
| 3490 ;; these. We could expand the list, but these are all | 3491 (not (or (memq (car-safe cl-seq) |
| 3491 ;; the functions in the relevant context at the moment. | 3492 ;; No need to check for a list at runtime with |
| 3492 '(nreverse append nconc mapcan mapcar string-to-list)) | 3493 ;; these. We could expand the list, but these are all |
| 3493 (and (listp cl-seq) (equal (butlast cl-seq) '(the list))))) | 3494 ;; the functions in the relevant context at the moment. |
| 3494 form | 3495 '(nreverse append nconc mapcan mapcar string-to-list)) |
| 3495 (cond | 3496 (and (listp cl-seq) (equal (butlast cl-seq) '(the list))))) |
| 3496 ((or (plists-equal cl-keys '(:test 'eq) t) | 3497 ;; Wrong number of arguments. |
| 3497 (plists-equal cl-keys '(:test #'eq) t)) | 3498 (not (cdr form))) |
| 3498 `(let* ((begin ,cl-seq) | 3499 form |
| 3499 cl-seq) | 3500 (cond |
| 3500 (while (memq (car begin) (cdr begin)) | 3501 ((or (plists-equal cl-keys '(:test 'eq) t) |
| 3501 (setq begin (cdr begin))) | 3502 (plists-equal cl-keys '(:test #'eq) t)) |
| 3502 (setq cl-seq begin) | 3503 `(let* ((begin ,cl-seq) |
| 3503 (while (cddr cl-seq) | 3504 cl-seq) |
| 3504 (if (memq (cadr cl-seq) (cddr cl-seq)) | 3505 (while (memq (car begin) (cdr begin)) |
| 3505 (setcdr (cdr cl-seq) (cddr cl-seq))) | 3506 (setq begin (cdr begin))) |
| 3506 (setq cl-seq (cdr cl-seq))) | 3507 (setq cl-seq begin) |
| 3507 begin)) | 3508 (while (cddr cl-seq) |
| 3508 ((or (plists-equal cl-keys '(:test 'eq :from-end t) t) | 3509 (if (memq (cadr cl-seq) (cddr cl-seq)) |
| 3509 (plists-equal cl-keys '(:test #'eq :from-end t) t)) | 3510 (setcdr (cdr cl-seq) (cddr cl-seq))) |
| 3510 `(let* ((begin ,cl-seq) | 3511 (setq cl-seq (cdr cl-seq))) |
| 3511 (cl-seq begin)) | 3512 begin)) |
| 3512 (while cl-seq | 3513 ((or (plists-equal cl-keys '(:test 'eq :from-end t) t) |
| 3513 (setq cl-seq (setcdr cl-seq | 3514 (plists-equal cl-keys '(:test #'eq :from-end t) t)) |
| 3514 (delq (car cl-seq) (cdr cl-seq))))) | 3515 `(let* ((begin ,cl-seq) |
| 3515 begin)) | 3516 (cl-seq begin)) |
| 3516 ((or (plists-equal cl-keys '(:test 'equal) t) | 3517 (while cl-seq |
| 3517 (plists-equal cl-keys '(:test #'equal) t)) | 3518 (setq cl-seq (setcdr cl-seq |
| 3518 `(let* ((begin ,cl-seq) | 3519 (delq (car cl-seq) (cdr cl-seq))))) |
| 3519 cl-seq) | 3520 begin)) |
| 3520 (while (member (car begin) (cdr begin)) | 3521 ((or (plists-equal cl-keys '(:test 'equal) t) |
| 3521 (setq begin (cdr begin))) | 3522 (plists-equal cl-keys '(:test #'equal) t)) |
| 3522 (setq cl-seq begin) | 3523 `(let* ((begin ,cl-seq) |
| 3523 (while (cddr cl-seq) | 3524 cl-seq) |
| 3524 (if (member (cadr cl-seq) (cddr cl-seq)) | 3525 (while (member (car begin) (cdr begin)) |
| 3525 (setcdr (cdr cl-seq) (cddr cl-seq))) | 3526 (setq begin (cdr begin))) |
| 3526 (setq cl-seq (cdr cl-seq))) | 3527 (setq cl-seq begin) |
| 3527 begin)) | 3528 (while (cddr cl-seq) |
| 3528 ((or (plists-equal cl-keys '(:test 'equal :from-end t) t) | 3529 (if (member (cadr cl-seq) (cddr cl-seq)) |
| 3529 (plists-equal cl-keys '(:test #'equal :from-end t) t)) | 3530 (setcdr (cdr cl-seq) (cddr cl-seq))) |
| 3530 `(let* ((begin ,cl-seq) | 3531 (setq cl-seq (cdr cl-seq))) |
| 3531 (cl-seq begin)) | 3532 begin)) |
| 3532 (while cl-seq | 3533 ((or (plists-equal cl-keys '(:test 'equal :from-end t) t) |
| 3533 (setq cl-seq (setcdr cl-seq (delete (car cl-seq) | 3534 (plists-equal cl-keys '(:test #'equal :from-end t) t)) |
| 3534 (cdr cl-seq))))) | 3535 `(let* ((begin ,cl-seq) |
| 3535 begin)) | 3536 (cl-seq begin)) |
| 3536 (t form)))) | 3537 (while cl-seq |
| 3538 (setq cl-seq (setcdr cl-seq (delete (car cl-seq) | |
| 3539 (cdr cl-seq))))) | |
| 3540 begin)) | |
| 3541 (t form))))) | |
| 3537 | 3542 |
| 3538 ;; XEmacs; it's perfectly reasonable, and often much clearer to those | 3543 ;; XEmacs; it's perfectly reasonable, and often much clearer to those |
| 3539 ;; reading the code, to call regexp-quote on a constant string, which is | 3544 ;; reading the code, to call regexp-quote on a constant string, which is |
| 3540 ;; something we can optimise here easily. | 3545 ;; something we can optimise here easily. |
| 3541 (define-compiler-macro regexp-quote (&whole form string) | 3546 (define-compiler-macro regexp-quote (&whole form string) |
| 3748 ;; have no side effects, transform to a series of two-argument | 3753 ;; have no side effects, transform to a series of two-argument |
| 3749 ;; calls. | 3754 ;; calls. |
| 3750 (put function 'cl-compiler-macro | 3755 (put function 'cl-compiler-macro |
| 3751 #'(lambda (form &rest arguments) | 3756 #'(lambda (form &rest arguments) |
| 3752 (if (or (null (nthcdr 3 form)) | 3757 (if (or (null (nthcdr 3 form)) |
| 3753 (notevery #'cl-safe-expr-p (cdr form))) | 3758 (notevery #'cl-safe-expr-p (butlast (cdr arguments)))) |
| 3754 form | 3759 form |
| 3755 (cons 'and (mapcon | 3760 (cons 'and (mapcon |
| 3756 #'(lambda (rest) | 3761 #'(lambda (rest) |
| 3757 (and (cdr rest) | 3762 (and (cdr rest) |
| 3758 `((,(car form) ,(pop rest) | 3763 `((,(car form) ,(pop rest) |
| 3759 ,(car rest))))) | 3764 ,(car rest))))) |
| 3760 (cdr form))))))) | 3765 (cdr form))))))) |
| 3761 '(= < > <= >=)) | 3766 '(= < > <= >=)) |
| 3762 | 3767 |
| 3763 (mapc | 3768 ;; XEmacs; unroll this loop at macro-expansion time, so the compiler macros |
| 3764 #'(lambda (y) | 3769 ;; are byte-compiled. |
| 3765 (put (car y) 'side-effect-free t) | 3770 (macrolet |
| 3766 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) | 3771 ((inline-side-effect-free-compiler-macros (&rest details) |
| 3767 (put (car y) 'cl-compiler-macro | 3772 (cons |
| 3768 (list 'lambda '(w x) | 3773 'progn |
| 3769 (if (symbolp (cadr y)) | 3774 (loop |
| 3770 (list 'list (list 'quote (cadr y)) | 3775 for (function . details) in details |
| 3771 (list 'list (list 'quote (caddr y)) 'x)) | 3776 nconc `((put ',function 'side-effect-free t) |
| 3772 (cons 'list (cdr y)))))) | 3777 (define-compiler-macro ,function (&whole form x) |
| 3773 '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) | 3778 ,(if (symbolp (car details)) |
| 3779 (reduce #'(lambda (object1 object2) | |
| 3780 `(list ',object1 ,object2)) | |
| 3781 details :from-end t :initial-value 'x) | |
| 3782 (cons 'list details)))))))) | |
| 3783 (inline-side-effect-free-compiler-macros | |
| 3784 (first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) | |
| 3774 (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) | 3785 (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) |
| 3775 (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) | 3786 (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) |
| 3776 (rest 'cdr x) (plusp '> x 0) (minusp '< x 0) | 3787 (rest 'cdr x) (plusp '> x 0) (minusp '< x 0) |
| 3777 (oddp 'eq (list 'logand x 1) 1) | 3788 (oddp 'eql (list 'logand x 1) 1) |
| 3778 (evenp 'eq (list 'logand x 1) 0) | 3789 (evenp 'eql (list 'logand x 1) 0) |
| 3779 (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr) | 3790 (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr) |
| 3780 (caaar car caar) (caadr car cadr) (cadar car cdar) | 3791 (caaar car caar) (caadr car cadr) (cadar car cdar) |
| 3781 (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) | 3792 (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) |
| 3782 (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) | 3793 (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) |
| 3783 (caaadr car caadr) (caadar car cadar) (caaddr car caddr) | 3794 (caaadr car caadr) (caadar car cadar) (caaddr car caddr) |