Mercurial > hg > xemacs-beta
comparison lisp/cl-macs.el @ 5313:5ed261fd2bd9
Unrool a load-time loop at macro expansion time, cl-macs.el
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (inline-side-effect-free-compiler-macros):
Unroll a loop here at macro-expansion time, so these compiler
macros are compiled. Use #'eql instead of #'eq in a couple of
places for better style.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 29 Dec 2010 23:43:10 +0000 |
| parents | 09fed7053634 |
| children | 596011a8bf8f |
comparison
equal
deleted
inserted
replaced
| 5312:f6471e4ae703 | 5313:5ed261fd2bd9 |
|---|---|
| 3760 `((,(car form) ,(pop rest) | 3760 `((,(car form) ,(pop rest) |
| 3761 ,(car rest))))) | 3761 ,(car rest))))) |
| 3762 (cdr form))))))) | 3762 (cdr form))))))) |
| 3763 '(= < > <= >=)) | 3763 '(= < > <= >=)) |
| 3764 | 3764 |
| 3765 (mapc | 3765 ;; XEmacs; unroll this loop at macro-expansion time, so the compiler macros |
| 3766 #'(lambda (y) | 3766 ;; are byte-compiled. |
| 3767 (put (car y) 'side-effect-free t) | 3767 (macrolet |
| 3768 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) | 3768 ((inline-side-effect-free-compiler-macros (&rest details) |
| 3769 (put (car y) 'cl-compiler-macro | 3769 (cons |
| 3770 (list 'lambda '(w x) | 3770 'progn |
| 3771 (if (symbolp (cadr y)) | 3771 (loop |
| 3772 (list 'list (list 'quote (cadr y)) | 3772 for (function . details) in details |
| 3773 (list 'list (list 'quote (caddr y)) 'x)) | 3773 nconc `((put ',function 'side-effect-free t) |
| 3774 (cons 'list (cdr y)))))) | 3774 (define-compiler-macro ,function (&whole form x) |
| 3775 '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) | 3775 ,(if (symbolp (car details)) |
| 3776 (reduce #'(lambda (object1 object2) | |
| 3777 `(list ',object1 ,object2)) | |
| 3778 details :from-end t :initial-value 'x) | |
| 3779 (cons 'list details)))))))) | |
| 3780 (inline-side-effect-free-compiler-macros | |
| 3781 (first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) | |
| 3776 (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) | 3782 (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) |
| 3777 (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) | 3783 (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) |
| 3778 (rest 'cdr x) (plusp '> x 0) (minusp '< x 0) | 3784 (rest 'cdr x) (plusp '> x 0) (minusp '< x 0) |
| 3779 (oddp 'eq (list 'logand x 1) 1) | 3785 (oddp 'eql (list 'logand x 1) 1) |
| 3780 (evenp 'eq (list 'logand x 1) 0) | 3786 (evenp 'eql (list 'logand x 1) 0) |
| 3781 (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr) | 3787 (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr) |
| 3782 (caaar car caar) (caadr car cadr) (cadar car cdar) | 3788 (caaar car caar) (caadr car cadr) (cadar car cdar) |
| 3783 (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) | 3789 (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) |
| 3784 (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) | 3790 (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) |
| 3785 (caaadr car caadr) (caadar car cadar) (caaddr car caddr) | 3791 (caaadr car caadr) (caadar car cadar) (caaddr car caddr) |