carbon2-commit: Add Common Lisp's #'complement to cl-extra.el.

[Aidan Kehoe]

changeset:   5280:7789ae555c45
user:        Aidan Kehoe <kehoea at parhasard.net>
date:        Wed Jun 02 16:18:50 2010 +0100
files:       lisp/ChangeLog lisp/cl-extra.el lisp/cl-macs.el
description:
Add Common Lisp's #'complement to cl-extra.el.

2010-06-02  Aidan Kehoe  <kehoea at 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.


diff -r 1086297242fe -r 7789ae555c45 lisp/ChangeLog
--- a/lisp/ChangeLog	Wed Jun 02 15:31:15 2010 +0100
+++ b/lisp/ChangeLog	Wed Jun 02 16:18:50 2010 +0100
@@ -1,3 +1,12 @@
+2010-06-02  Aidan Kehoe  <kehoea at 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.
+
 2010-05-31  Aidan Kehoe  <kehoea at parhasard.net>
 
 	* specifier.el (current-display-table):
diff -r 1086297242fe -r 7789ae555c45 lisp/cl-extra.el
--- a/lisp/cl-extra.el	Wed Jun 02 15:31:15 2010 +0100
+++ b/lisp/cl-extra.el	Wed Jun 02 16:18:50 2010 +0100
@@ -99,6 +99,14 @@
 
 ;; XEmacs; #'map, #'mapc, #'mapl, #'maplist, #'mapcon, #'some and #'every
 ;; are now in C, together with #'map-into, which was never in this file.
+
+;; The compiler macro for this in cl-macs.el means if #'complement is handed
+;; a constant expression, byte-compiled code will see a byte-compiled
+;; function.
+(defun complement (function &optional documentation)
+  "Return a function which gives the logical inverse of what FUNCTION would."
+  `(lambda (&rest arguments) ,@(if documentation (list documentation))
+     (not (apply ',function arguments))))
 
 (defun notany (cl-pred cl-seq &rest cl-rest)
   "Return true if PREDICATE is false of every element of SEQ or SEQs."
diff -r 1086297242fe -r 7789ae555c45 lisp/cl-macs.el
--- 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)