Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5694:7f4c8574a590

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
No error from an incorrect number of arguments, recently-added compiler macros lisp/ChangeLog addition: 2012-11-06 Aidan Kehoe <kehoea@parhasard.net> * cl-macs.el (equal, member, assoc, rassoc): Never error at compile time in these compiler macros because of an incorrect number of arguments.
author Aidan Kehoe <kehoea@parhasard.net>
date Tue, 06 Nov 2012 23:12:06 +0000
parents 796f2a8fdced
children 165315eae1ab
comparison
equal deleted inserted replaced
5693:4d15e903800b 5694:7f4c8574a590
3236 (if (consp object) (car object) pi)) 3236 (if (consp object) (car object) pi))
3237 3237
3238 (defun cl-cdr-or-pi (object) 3238 (defun cl-cdr-or-pi (object)
3239 (if (consp object) (cdr object) pi)) 3239 (if (consp object) (cdr object) pi))
3240 3240
3241 (define-compiler-macro equal (&whole form a b) 3241 (define-compiler-macro equal (&whole form &rest args)
3242 (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val a pi)) 3242 (cond
3243 (cl-equal-equivalent-to-eq-p (cl-const-expr-val b pi))) 3243 ((not (eql (length form) 3))
3244 (cons 'eq (cdr form)) 3244 form)
3245 form)) 3245 ((or (cl-equal-equivalent-to-eq-p (cl-const-expr-val (pop args) pi))
3246 3246 (cl-equal-equivalent-to-eq-p (cl-const-expr-val (pop args) pi)))
3247 (define-compiler-macro member (&whole form elt list) 3247 (cons 'eq (cdr form)))
3248 (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val elt pi)) 3248 (t form)))
3249 (every #'cl-equal-equivalent-to-eq-p 3249
3250 (cl-const-expr-val list '(1.0)))) 3250 (define-compiler-macro member (&whole form &rest args)
3251 (cons 'memq (cdr form)) 3251 (cond
3252 form)) 3252 ((not (eql (length form) 3))
3253 3253 form)
3254 (define-compiler-macro assoc (&whole form elt list) 3254 ((or (cl-equal-equivalent-to-eq-p (cl-const-expr-val (pop args) pi))
3255 (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val elt pi)) 3255 (every #'cl-equal-equivalent-to-eq-p
3256 (not (find-if-not #'cl-equal-equivalent-to-eq-p 3256 (cl-const-expr-val (pop args) '(1.0))))
3257 (cl-const-expr-val list '((1.0 . nil))) 3257 (cons 'memq (cdr form)))
3258 :key #'cl-car-or-pi))) 3258 (t form)))
3259 (cons 'assq (cdr form)) 3259
3260 form)) 3260 (define-compiler-macro assoc (&whole form &rest args)
3261 3261 (cond
3262 (define-compiler-macro rassoc (&whole form elt list) 3262 ((not (eql (length form) 3))
3263 (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val elt pi)) 3263 form)
3264 (not (find-if-not #'cl-equal-equivalent-to-eq-p 3264 ((or (cl-equal-equivalent-to-eq-p (cl-const-expr-val (pop args) pi))
3265 (cl-const-expr-val list '((nil . 1.0))) 3265 (not (find-if-not #'cl-equal-equivalent-to-eq-p
3266 (cl-const-expr-val (pop args) '((1.0 . nil)))
3267 :key #'cl-car-or-pi)))
3268 (cons 'assq (cdr form)))
3269 (t form)))
3270
3271 (define-compiler-macro rassoc (&whole form &rest args)
3272 (cond
3273 ((not (eql (length form) 3))
3274 form)
3275 ((or (cl-equal-equivalent-to-eq-p (cl-const-expr-val (pop args) pi))
3276 (not (find-if-not #'cl-equal-equivalent-to-eq-p
3277 (cl-const-expr-val (pop args) '((nil . 1.0)))
3266 :key #'cl-cdr-or-pi))) 3278 :key #'cl-cdr-or-pi)))
3267 (cons 'rassq (cdr form)) 3279 (cons 'rassq (cdr form)))
3268 form)) 3280 (t form)))
3269 3281
3270 (macrolet 3282 (macrolet
3271 ((define-star-compiler-macros (&rest macros) 3283 ((define-star-compiler-macros (&rest macros)
3272 "For `member*', `assoc*' and `rassoc*' with constant ITEM or 3284 "For `member*', `assoc*' and `rassoc*' with constant ITEM or
3273 :test arguments, use the versions with explicit tests if that makes sense." 3285 :test arguments, use the versions with explicit tests if that makes sense."