Mercurial > hg > xemacs-beta
diff 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 |
line wrap: on
line diff
--- a/lisp/cl-macs.el Wed Jun 02 15:31:15 2010 +0100 +++ b/lisp/cl-macs.el Wed Jun 02 16:18:50 2010 +0100 @@ -3712,6 +3712,45 @@ (define-compiler-macro pairlis (a b &optional c) `(nconc (mapcar* #'cons ,a ,b) ,c)) +(define-compiler-macro complement (&whole form fn) + (if (or (eq (car-safe fn) 'function) (eq (car-safe fn) 'quote)) + (cond + ((and (symbolp (second fn)) (get (second fn) 'byte-compile-negated-op)) + (list 'function (get (second fn) 'byte-compile-negated-op))) + ((and (symbolp (second fn)) (fboundp (second fn)) + (compiled-function-p (indirect-function (second fn)))) + (let* ((cf (indirect-function (second fn))) + (cfa (compiled-function-arglist cf)) + (do-apply (memq '&rest cfa))) + `#'(lambda ,cfa + (not (,@(if do-apply `(apply ',(second fn)) (list (second fn))) + ,@(remq '&optional + (remq '&rest cfa))))))) + (t + `#'(lambda (&rest arguments) + (not (apply ,fn arguments))))) + ;; Determine the function to call at runtime. + (destructuring-bind + (arglist instructions constants stack-depth) + (let ((compiled-lambda + (byte-compile-sexp + #'(lambda (&rest arguments) + (not (apply 'placeholder arguments)))))) + (list + (compiled-function-arglist compiled-lambda) + (compiled-function-instructions compiled-lambda) + (append (compiled-function-constants compiled-lambda) nil) + (compiled-function-stack-depth compiled-lambda))) + `(make-byte-code + ',arglist ,instructions (vector + ,@(nsublis + (list (cons (quote-maybe + 'placeholder) + fn)) + (mapcar #'quote-maybe constants) + :test #'equal)) + ,stack-depth)))) + (mapc #'(lambda (y) (put (car y) 'side-effect-free t)