Mercurial > hg > xemacs-beta
comparison lisp/cl-macs.el @ 5057:742b7a124d6c
Automated merge with file:///home/aidan/xemacs-21.5-checked-out
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 22 Feb 2010 20:09:23 +0000 |
| parents | 6aba0daedb7c |
| children | cc74f60c150e |
comparison
equal
deleted
inserted
replaced
| 5055:79564cbad5f3 | 5057:742b7a124d6c |
|---|---|
| 3549 (cons 'not (cons 'some (cdr cl-rest)))) | 3549 (cons 'not (cons 'some (cdr cl-rest)))) |
| 3550 | 3550 |
| 3551 (define-compiler-macro notevery (&whole form &rest cl-rest) | 3551 (define-compiler-macro notevery (&whole form &rest cl-rest) |
| 3552 (cons 'not (cons 'every (cdr cl-rest)))) | 3552 (cons 'not (cons 'every (cdr cl-rest)))) |
| 3553 | 3553 |
| 3554 (define-compiler-macro constantly (&whole form value &rest more-values) | |
| 3555 (cond | |
| 3556 ((< (length form) 2) | |
| 3557 ;; Error at runtime: | |
| 3558 form) | |
| 3559 ((cl-const-exprs-p (cdr form)) | |
| 3560 `#'(lambda (&rest ignore) (values ,@(cdr form)))) | |
| 3561 (t | |
| 3562 (let* ((num-values (length (cdr form))) | |
| 3563 (placeholders-counts (make-vector num-values -1)) | |
| 3564 (placeholders (loop | |
| 3565 for i from 0 below num-values | |
| 3566 collect (make-symbol (format "%d" i)))) | |
| 3567 (compiled | |
| 3568 (byte-compile-sexp | |
| 3569 `#'(lambda (&rest ignore) | |
| 3570 ;; Compiles to a references into the compiled function | |
| 3571 ;; constants vector: | |
| 3572 (values ,@(mapcar #'quote-maybe placeholders))))) | |
| 3573 position) | |
| 3574 `(make-byte-code '(&rest ignore) | |
| 3575 ,(compiled-function-instructions compiled) | |
| 3576 (vector ,@(loop | |
| 3577 for constant across (compiled-function-constants compiled) | |
| 3578 collect (if (setq position | |
| 3579 (position constant placeholders)) | |
| 3580 (prog2 | |
| 3581 (incf (aref placeholders-counts position)) | |
| 3582 (nth position (cdr form))) | |
| 3583 (quote-maybe constant)) | |
| 3584 finally | |
| 3585 (assert (every #'zerop placeholders-counts) | |
| 3586 t "Placeholders should each have been used once"))) | |
| 3587 ,(compiled-function-stack-depth compiled)))))) | |
| 3588 | |
| 3554 (mapc | 3589 (mapc |
| 3555 #'(lambda (y) | 3590 #'(lambda (y) |
| 3556 (put (car y) 'side-effect-free t) | 3591 (put (car y) 'side-effect-free t) |
| 3557 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) | 3592 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) |
| 3558 (put (car y) 'cl-compiler-macro | 3593 (put (car y) 'cl-compiler-macro |