Mercurial > hg > xemacs-beta

changeset 5329:7b391d07b334

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Tweak a few compiler macros for functions in cl-seq.el. lisp/ChangeLog addition: 2011-01-02 Aidan Kehoe <kehoea@parhasard.net> * cl-macs.el (define-star-compiler-macros): Make sure the form has ITEM and LIST specified before attempting to change to calls with explicit tests; necessary for some tests in lisp-tests.el to compile correctly. (stable-union, stable-intersection): Add compiler macros for these functions, in the same way we do for most of the other functions in cl-seq.el. tests/ChangeLog addition: 2011-01-02 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el (test-fun): Test member*, assoc*, rassoc*, delete* here too.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 02 Jan 2011 16:18:26 +0000
parents dae3d95cf319
children fbafdc1bb4d2
files lisp/ChangeLog lisp/cl-macs.el tests/ChangeLog tests/automated/lisp-tests.el
diffstat 4 files changed, 76 insertions(+), 49 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Sun Jan 02 02:32:59 2011 +0000
+++ b/lisp/ChangeLog	Sun Jan 02 16:18:26 2011 +0000
@@ -1,3 +1,13 @@
+2011-01-02  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* cl-macs.el (define-star-compiler-macros):
+	Make sure the form has ITEM and LIST specified before attempting
+	to change to calls with explicit tests; necessary for some tests
+	in lisp-tests.el to compile correctly.
+	(stable-union, stable-intersection): Add compiler macros for these
+	functions, in the same way we do for most of the other functions
+	in cl-seq.el.
+
 2011-01-01  Aidan Kehoe  <kehoea@parhasard.net>
 
 	* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
--- a/lisp/cl-macs.el	Sun Jan 02 02:32:59 2011 +0000
+++ b/lisp/cl-macs.el	Sun Jan 02 16:18:26 2011 +0000
@@ -3283,51 +3283,53 @@
 	(mapcar
 	 (function*
 	  (lambda ((star-function eq-function equal-function))
-	    `(define-compiler-macro ,star-function (&whole form item list
-						    &rest keys)
-	      (condition-case nil
-		  (symbol-macrolet ((not-constant '#:not-constant))
-		    (let* ((test-expr (plist-get keys :test ''eql))
-			   (test (cl-const-expr-val test-expr not-constant))
-			   (item-val (cl-const-expr-val item not-constant))
-			   (list-val (cl-const-expr-val list not-constant)))
-		      (if (and keys
-			       (not (and (eq :test (car keys))
-					 (eql 2 (length keys)))))
-			  form
-			(cond ((eq test 'eq) `(,',eq-function ,item ,list))
-			      ((eq test 'equal)
-			       `(,',equal-function ,item ,list))
-			      ((and (eq test 'eql)
-				    (not (eq not-constant item-val)))
-			       (if (cl-non-fixnum-number-p item-val)
-				   `(,',equal-function ,item ,list)
-				 `(,',eq-function ,item ,list)))
-			      ((and (eq test 'eql) (not (eq not-constant
-							    list-val)))
-			       (if (some 'cl-non-fixnum-number-p list-val)
-				   `(,',equal-function ,item ,list)
-				 ;; This compiler macro used to limit calls
-				 ;; to ,,eq-function to lists where all
-				 ;; elements were either fixnums or
-				 ;; symbols. There's no
-				 ;; reason to do this.
-				 `(,',eq-function ,item ,list)))
-			      ;; This is a hilariously specific case; see
-			      ;; add-to-list in subr.el.
-			      ((and (eq test not-constant)
-				    (eq 'or (car-safe test-expr))
-				    (eql 3 (length test-expr))
-				    (every #'cl-safe-expr-p (cdr form))
-				    `(if ,(second test-expr)
-					 (,',star-function ,item ,list :test
-							   ,(second test-expr))
-				      (,',star-function
-				       ,item ,list :test ,(third test-expr)))))
-			      (t form)))))
-		;; No need to warn about a malformed property list,
-		;; #'byte-compile-normal-call will do that for us.
-		(malformed-property-list form)))))
+	    `(define-compiler-macro ,star-function (&whole form &rest keys)
+              (if (< (length form) 3)
+                  form
+                (condition-case nil
+                    (symbol-macrolet ((not-constant '#:not-constant))
+                      (let* ((item (pop keys))
+                             (list (pop keys))
+                             (test-expr (plist-get keys :test ''eql))
+                             (test (cl-const-expr-val test-expr not-constant))
+                             (item-val (cl-const-expr-val item not-constant))
+                             (list-val (cl-const-expr-val list not-constant)))
+                        (if (and keys (not (and (eq :test (car keys))
+                                                (eql 2 (length keys)))))
+                            form
+                          (cond ((eq test 'eq) `(,',eq-function ,item ,list))
+                                ((eq test 'equal)
+                                 `(,',equal-function ,item ,list))
+                                ((and (eq test 'eql)
+                                      (not (eq not-constant item-val)))
+                                 (if (cl-non-fixnum-number-p item-val)
+                                     `(,',equal-function ,item ,list)
+                                   `(,',eq-function ,item ,list)))
+                                ((and (eq test 'eql) (not (eq not-constant
+                                                              list-val)))
+                                 (if (some 'cl-non-fixnum-number-p list-val)
+                                     `(,',equal-function ,item ,list)
+                                   ;; This compiler macro used to limit
+                                   ;; calls to ,,eq-function to lists where
+                                   ;; all elements were either fixnums or
+                                   ;; symbols. There's no reason to do this.
+                                   `(,',eq-function ,item ,list)))
+                                ;; This is a hilariously specific case; see
+                                ;; add-to-list in subr.el.
+                                ((and (eq test not-constant)
+                                      (eq 'or (car-safe test-expr))
+                                      (eql 3 (length test-expr))
+                                      (every #'cl-safe-expr-p (cdr form))
+                                      `(if ,(second test-expr)
+                                        (,',star-function ,item ,list :test
+                                                          ,(second test-expr))
+                                        (,',star-function
+                                         ,item ,list :test
+                                         ,(third test-expr)))))
+                                (t form)))))
+                  ;; No need to warn about a malformed property list,
+                  ;; #'byte-compile-normal-call will do that for us.
+                  (malformed-property-list form))))))
 	 macros))))
   (define-star-compiler-macros
     (member* memq member)
@@ -3736,6 +3738,16 @@
 	(the string ,string) :test #'eq)
     form))
 
+(define-compiler-macro stable-union (&whole form &rest cl-keys)
+  (if (> (length form) 2)
+      (list* 'union (pop cl-keys) (pop cl-keys) :stable t cl-keys)
+    form))
+
+(define-compiler-macro stable-intersection (&whole form &rest cl-keys)
+  (if (> (length form) 2)
+      (list* 'intersection (pop cl-keys) (pop cl-keys) :stable t cl-keys)
+    form))
+
 (map nil
      #'(lambda (function)
          ;; There are byte codes for the two-argument versions of these
--- a/tests/ChangeLog	Sun Jan 02 02:32:59 2011 +0000
+++ b/tests/ChangeLog	Sun Jan 02 16:18:26 2011 +0000
@@ -1,3 +1,8 @@
+2011-01-02  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* automated/lisp-tests.el (test-fun): Test member*, assoc*,
+	rassoc*, delete* here too.
+
 2010-12-30  Aidan Kehoe  <kehoea@parhasard.net>
 
 	* automated/lisp-tests.el (wrong-type-argument): Add a missing
--- a/tests/automated/lisp-tests.el	Sun Jan 02 02:32:59 2011 +0000
+++ b/tests/automated/lisp-tests.el	Sun Jan 02 16:18:26 2011 +0000
@@ -798,12 +798,12 @@
 	     collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
      (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun)))))
 
-  (test-funs member old-member
+  (test-funs member* member old-member 
 	     memq   old-memq
-	     assoc  old-assoc
-	     rassoc old-rassoc
+	     assoc* assoc  old-assoc
+	     rassoc* rassoc old-rassoc
 	     rassq  old-rassq
-	     delete old-delete
+	     delete* delete old-delete
 	     delq   old-delq
 	     remassoc remassq remrassoc remrassq))