Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 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 60ba780f9078
children 8608eadee6ba 89331fa1c819
comparison
equal deleted inserted replaced
5328:dae3d95cf319 5329:7b391d07b334
3281 (list* 3281 (list*
3282 'progn 3282 'progn
3283 (mapcar 3283 (mapcar
3284 (function* 3284 (function*
3285 (lambda ((star-function eq-function equal-function)) 3285 (lambda ((star-function eq-function equal-function))
3286 `(define-compiler-macro ,star-function (&whole form item list 3286 `(define-compiler-macro ,star-function (&whole form &rest keys)
3287 &rest keys) 3287 (if (< (length form) 3)
3288 (condition-case nil 3288 form
3289 (symbol-macrolet ((not-constant '#:not-constant)) 3289 (condition-case nil
3290 (let* ((test-expr (plist-get keys :test ''eql)) 3290 (symbol-macrolet ((not-constant '#:not-constant))
3291 (test (cl-const-expr-val test-expr not-constant)) 3291 (let* ((item (pop keys))
3292 (item-val (cl-const-expr-val item not-constant)) 3292 (list (pop keys))
3293 (list-val (cl-const-expr-val list not-constant))) 3293 (test-expr (plist-get keys :test ''eql))
3294 (if (and keys 3294 (test (cl-const-expr-val test-expr not-constant))
3295 (not (and (eq :test (car keys)) 3295 (item-val (cl-const-expr-val item not-constant))
3296 (eql 2 (length keys))))) 3296 (list-val (cl-const-expr-val list not-constant)))
3297 form 3297 (if (and keys (not (and (eq :test (car keys))
3298 (cond ((eq test 'eq) `(,',eq-function ,item ,list)) 3298 (eql 2 (length keys)))))
3299 ((eq test 'equal) 3299 form
3300 `(,',equal-function ,item ,list)) 3300 (cond ((eq test 'eq) `(,',eq-function ,item ,list))
3301 ((and (eq test 'eql) 3301 ((eq test 'equal)
3302 (not (eq not-constant item-val))) 3302 `(,',equal-function ,item ,list))
3303 (if (cl-non-fixnum-number-p item-val) 3303 ((and (eq test 'eql)
3304 `(,',equal-function ,item ,list) 3304 (not (eq not-constant item-val)))
3305 `(,',eq-function ,item ,list))) 3305 (if (cl-non-fixnum-number-p item-val)
3306 ((and (eq test 'eql) (not (eq not-constant 3306 `(,',equal-function ,item ,list)
3307 list-val))) 3307 `(,',eq-function ,item ,list)))
3308 (if (some 'cl-non-fixnum-number-p list-val) 3308 ((and (eq test 'eql) (not (eq not-constant
3309 `(,',equal-function ,item ,list) 3309 list-val)))
3310 ;; This compiler macro used to limit calls 3310 (if (some 'cl-non-fixnum-number-p list-val)
3311 ;; to ,,eq-function to lists where all 3311 `(,',equal-function ,item ,list)
3312 ;; elements were either fixnums or 3312 ;; This compiler macro used to limit
3313 ;; symbols. There's no 3313 ;; calls to ,,eq-function to lists where
3314 ;; reason to do this. 3314 ;; all elements were either fixnums or
3315 `(,',eq-function ,item ,list))) 3315 ;; symbols. There's no reason to do this.
3316 ;; This is a hilariously specific case; see 3316 `(,',eq-function ,item ,list)))
3317 ;; add-to-list in subr.el. 3317 ;; This is a hilariously specific case; see
3318 ((and (eq test not-constant) 3318 ;; add-to-list in subr.el.
3319 (eq 'or (car-safe test-expr)) 3319 ((and (eq test not-constant)
3320 (eql 3 (length test-expr)) 3320 (eq 'or (car-safe test-expr))
3321 (every #'cl-safe-expr-p (cdr form)) 3321 (eql 3 (length test-expr))
3322 `(if ,(second test-expr) 3322 (every #'cl-safe-expr-p (cdr form))
3323 (,',star-function ,item ,list :test 3323 `(if ,(second test-expr)
3324 ,(second test-expr)) 3324 (,',star-function ,item ,list :test
3325 (,',star-function 3325 ,(second test-expr))
3326 ,item ,list :test ,(third test-expr))))) 3326 (,',star-function
3327 (t form))))) 3327 ,item ,list :test
3328 ;; No need to warn about a malformed property list, 3328 ,(third test-expr)))))
3329 ;; #'byte-compile-normal-call will do that for us. 3329 (t form)))))
3330 (malformed-property-list form))))) 3330 ;; No need to warn about a malformed property list,
3331 ;; #'byte-compile-normal-call will do that for us.
3332 (malformed-property-list form))))))
3331 macros)))) 3333 macros))))
3332 (define-star-compiler-macros 3334 (define-star-compiler-macros
3333 (member* memq member) 3335 (member* memq member)
3334 (assoc* assq assoc) 3336 (assoc* assq assoc)
3335 (rassoc* rassq rassoc))) 3337 (rassoc* rassq rassoc)))
3734 (if (every #'cl-safe-expr-p (cdr form)) 3736 (if (every #'cl-safe-expr-p (cdr form))
3735 `(funcall (if ,inplace #'nsubstitute #'substitute) ,tochar ,fromchar 3737 `(funcall (if ,inplace #'nsubstitute #'substitute) ,tochar ,fromchar
3736 (the string ,string) :test #'eq) 3738 (the string ,string) :test #'eq)
3737 form)) 3739 form))
3738 3740
3741 (define-compiler-macro stable-union (&whole form &rest cl-keys)
3742 (if (> (length form) 2)
3743 (list* 'union (pop cl-keys) (pop cl-keys) :stable t cl-keys)
3744 form))
3745
3746 (define-compiler-macro stable-intersection (&whole form &rest cl-keys)
3747 (if (> (length form) 2)
3748 (list* 'intersection (pop cl-keys) (pop cl-keys) :stable t cl-keys)
3749 form))
3750
3739 (map nil 3751 (map nil
3740 #'(lambda (function) 3752 #'(lambda (function)
3741 ;; There are byte codes for the two-argument versions of these 3753 ;; There are byte codes for the two-argument versions of these
3742 ;; functions; if the form has more arguments and those arguments 3754 ;; functions; if the form has more arguments and those arguments
3743 ;; have no side effects, transform to a series of two-argument 3755 ;; have no side effects, transform to a series of two-argument