Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5072:cc74f60c150e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge
author Ben Wing <ben@xemacs.org>
date Tue, 23 Feb 2010 05:11:15 -0600
parents b0f4adffca7d 6aba0daedb7c
children d555581e3cba
comparison
equal deleted inserted replaced
5071:f28a4e9f0133 5072:cc74f60c150e
3553 (cons 'not (cons 'some (cdr cl-rest)))) 3553 (cons 'not (cons 'some (cdr cl-rest))))
3554 3554
3555 (define-compiler-macro notevery (&whole form &rest cl-rest) 3555 (define-compiler-macro notevery (&whole form &rest cl-rest)
3556 (cons 'not (cons 'every (cdr cl-rest)))) 3556 (cons 'not (cons 'every (cdr cl-rest))))
3557 3557
3558 (define-compiler-macro constantly (&whole form value &rest more-values)
3559 (cond
3560 ((< (length form) 2)
3561 ;; Error at runtime:
3562 form)
3563 ((cl-const-exprs-p (cdr form))
3564 `#'(lambda (&rest ignore) (values ,@(cdr form))))
3565 (t
3566 (let* ((num-values (length (cdr form)))
3567 (placeholders-counts (make-vector num-values -1))
3568 (placeholders (loop
3569 for i from 0 below num-values
3570 collect (make-symbol (format "%d" i))))
3571 (compiled
3572 (byte-compile-sexp
3573 `#'(lambda (&rest ignore)
3574 ;; Compiles to a references into the compiled function
3575 ;; constants vector:
3576 (values ,@(mapcar #'quote-maybe placeholders)))))
3577 position)
3578 `(make-byte-code '(&rest ignore)
3579 ,(compiled-function-instructions compiled)
3580 (vector ,@(loop
3581 for constant across (compiled-function-constants compiled)
3582 collect (if (setq position
3583 (position constant placeholders))
3584 (prog2
3585 (incf (aref placeholders-counts position))
3586 (nth position (cdr form)))
3587 (quote-maybe constant))
3588 finally
3589 (assert (every #'zerop placeholders-counts)
3590 t "Placeholders should each have been used once")))
3591 ,(compiled-function-stack-depth compiled))))))
3592
3558 (mapc 3593 (mapc
3559 #'(lambda (y) 3594 #'(lambda (y)
3560 (put (car y) 'side-effect-free t) 3595 (put (car y) 'side-effect-free t)
3561 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) 3596 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)
3562 (put (car y) 'cl-compiler-macro 3597 (put (car y) 'cl-compiler-macro