Mercurial > hg > xemacs-beta
comparison lisp/cl-macs.el @ 5226:7789ae555c45
Add Common Lisp's #'complement to cl-extra.el.
2010-06-02 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (complement):
* cl-extra.el (complement):
Add an implementation and a compiler macro for #'complement, as
specified by CL. For discussion; the compiler macro may be a
little too aggressive about taking the compile time argument lists
of the functions it is inverting.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 02 Jun 2010 16:18:50 +0100 |
| parents | 2d0937dc83cf |
| children | f3eca926258e |
comparison
equal
deleted
inserted
replaced
| 5225:1086297242fe | 5226:7789ae555c45 |
|---|---|
| 3710 `(cons (cons ,a ,b) ,c)) | 3710 `(cons (cons ,a ,b) ,c)) |
| 3711 | 3711 |
| 3712 (define-compiler-macro pairlis (a b &optional c) | 3712 (define-compiler-macro pairlis (a b &optional c) |
| 3713 `(nconc (mapcar* #'cons ,a ,b) ,c)) | 3713 `(nconc (mapcar* #'cons ,a ,b) ,c)) |
| 3714 | 3714 |
| 3715 (define-compiler-macro complement (&whole form fn) | |
| 3716 (if (or (eq (car-safe fn) 'function) (eq (car-safe fn) 'quote)) | |
| 3717 (cond | |
| 3718 ((and (symbolp (second fn)) (get (second fn) 'byte-compile-negated-op)) | |
| 3719 (list 'function (get (second fn) 'byte-compile-negated-op))) | |
| 3720 ((and (symbolp (second fn)) (fboundp (second fn)) | |
| 3721 (compiled-function-p (indirect-function (second fn)))) | |
| 3722 (let* ((cf (indirect-function (second fn))) | |
| 3723 (cfa (compiled-function-arglist cf)) | |
| 3724 (do-apply (memq '&rest cfa))) | |
| 3725 `#'(lambda ,cfa | |
| 3726 (not (,@(if do-apply `(apply ',(second fn)) (list (second fn))) | |
| 3727 ,@(remq '&optional | |
| 3728 (remq '&rest cfa))))))) | |
| 3729 (t | |
| 3730 `#'(lambda (&rest arguments) | |
| 3731 (not (apply ,fn arguments))))) | |
| 3732 ;; Determine the function to call at runtime. | |
| 3733 (destructuring-bind | |
| 3734 (arglist instructions constants stack-depth) | |
| 3735 (let ((compiled-lambda | |
| 3736 (byte-compile-sexp | |
| 3737 #'(lambda (&rest arguments) | |
| 3738 (not (apply 'placeholder arguments)))))) | |
| 3739 (list | |
| 3740 (compiled-function-arglist compiled-lambda) | |
| 3741 (compiled-function-instructions compiled-lambda) | |
| 3742 (append (compiled-function-constants compiled-lambda) nil) | |
| 3743 (compiled-function-stack-depth compiled-lambda))) | |
| 3744 `(make-byte-code | |
| 3745 ',arglist ,instructions (vector | |
| 3746 ,@(nsublis | |
| 3747 (list (cons (quote-maybe | |
| 3748 'placeholder) | |
| 3749 fn)) | |
| 3750 (mapcar #'quote-maybe constants) | |
| 3751 :test #'equal)) | |
| 3752 ,stack-depth)))) | |
| 3753 | |
| 3715 (mapc | 3754 (mapc |
| 3716 #'(lambda (y) | 3755 #'(lambda (y) |
| 3717 (put (car y) 'side-effect-free t) | 3756 (put (car y) 'side-effect-free t) |
| 3718 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) | 3757 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) |
| 3719 (put (car y) 'cl-compiler-macro | 3758 (put (car y) 'cl-compiler-macro |