449 |
(defmacro member-compiler-macro (&whole w &rest args) |
(defmacro member-compiler-macro (&whole w &rest args) |
450 |
(if (or (< (length args) 2) (do ((r (cddr args) (cddr r))) ((not (and r (keywordp (car r)))) r))) |
(if (or (< (length args) 2) (do ((r (cddr args) (cddr r))) ((not (and r (keywordp (car r)))) r))) |
451 |
w |
w |
452 |
(let* ((specials (if (member (car w) '(rassoc rassoc-if rassoc-if-not)) '(:k1 'cdr) '(:k1 'car))) |
(let* ((syms (reduce (lambda (&rest r) |
453 |
(specials (if (member (car w) '(member assoc rassoc)) `(:item ,(car args) ,@specials) specials)) |
(when r |
454 |
|
(if (or (constantp (cadr r)) |
455 |
|
(and (consp (cadr r)) (eq (caadr r) 'lambda))) |
456 |
|
(car r) |
457 |
|
`(,@(car r) (,(gensym) ,(cadr r)))))) |
458 |
|
args :initial-value nil)) |
459 |
|
; (syms `((,(gensym) ,(car args)) (,(gensym) ,(cadr args)) ,@syms)) |
460 |
|
(r (mapcar (lambda (x) (cond ((constantp x) x) |
461 |
|
((and (consp x) (eq (car x) 'lambda)) x) |
462 |
|
((car (rassoc x syms :key 'car :test 'equal))) (x))) args)) |
463 |
|
(specials (if (member (car w) '(rassoc rassoc-if rassoc-if-not)) '(:k1 'cdr) '(:k1 'car))) |
464 |
|
(specials (if (member (car w) '(member assoc rassoc)) `(:item ,(car r) ,@specials) specials)) |
465 |
(specials (if (member (car w) '(assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not)) |
(specials (if (member (car w) '(assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not)) |
466 |
`(:ret 'car ,@specials) specials)) |
`(:ret 'car ,@specials) specials)) |
467 |
(overrides (if (member (car w) '(member-if assoc-if rassoc-if)) `(:test ,(car args)))) |
(overrides (if (member (car w) '(member-if assoc-if rassoc-if)) `(:test ,(car r)))) |
468 |
(overrides (if (member (car w) '(member-if-not assoc-if-not rassoc-if-not)) |
(overrides (if (member (car w) '(member-if-not assoc-if-not rassoc-if-not)) |
469 |
`(:test-not ,(car args) ,@overrides) overrides))) |
`(:test-not ,(car r) ,@overrides) overrides))) |
470 |
(apply 'possible-eq-list-search (car args) (cadr args) specials `(,@overrides ,@(cddr args)))))) |
`(let (,@syms) |
471 |
|
,(apply 'possible-eq-list-search (car r) (cadr r) specials `(,@overrides ,@(cddr r))))))) |
472 |
|
|
473 |
(si::putprop 'member (macro-function 'member-compiler-macro) 'compiler-macro) |
(si::putprop 'member (macro-function 'member-compiler-macro) 'compiler-macro) |
474 |
(si::putprop 'member-if (macro-function 'member-compiler-macro) 'compiler-macro) |
(si::putprop 'member-if (macro-function 'member-compiler-macro) 'compiler-macro) |