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* ((syms (reduce (lambda (&rest r) |
(let* ((specials (if (member (car w) '(rassoc rassoc-if rassoc-if-not)) '(:k1 'cdr) '(:k1 'car))) |
453 |
(when r |
(specials (if (member (car w) '(member assoc rassoc)) `(:item ,(car args) ,@specials) specials)) |
|
(if (or (constantp (cadr r)) |
|
|
(and (consp (cadr r)) (eq (caadr r) 'lambda))) |
|
|
(car r) |
|
|
`(,@(car r) (,(gensym) ,(cadr r)))))) |
|
|
args :initial-value nil)) |
|
|
; (syms `((,(gensym) ,(car args)) (,(gensym) ,(cadr args)) ,@syms)) |
|
|
(r (mapcar (lambda (x) (cond ((constantp x) x) |
|
|
((and (consp x) (eq (car x) 'lambda)) x) |
|
|
((car (rassoc x syms :key 'car :test 'equal))) (x))) args)) |
|
|
(specials (if (member (car w) '(rassoc rassoc-if rassoc-if-not)) '(:k1 'cdr) '(:k1 'car))) |
|
|
(specials (if (member (car w) '(member assoc rassoc)) `(:item ,(car r) ,@specials) specials)) |
|
454 |
(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)) |
455 |
`(:ret 'car ,@specials) specials)) |
`(:ret 'car ,@specials) specials)) |
456 |
(overrides (if (member (car w) '(member-if assoc-if rassoc-if)) `(:test ,(car r)))) |
(overrides (if (member (car w) '(member-if assoc-if rassoc-if)) `(:test ,(car args)))) |
457 |
(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)) |
458 |
`(:test-not ,(car r) ,@overrides) overrides))) |
`(:test-not ,(car args) ,@overrides) overrides))) |
459 |
`(let (,@syms) |
(apply 'possible-eq-list-search (car args) (cadr args) specials `(,@overrides ,@(cddr args)))))) |
|
,(apply 'possible-eq-list-search (car r) (cadr r) specials `(,@overrides ,@(cddr r))))))) |
|
460 |
|
|
461 |
(si::putprop 'member (macro-function 'member-compiler-macro) 'compiler-macro) |
(si::putprop 'member (macro-function 'member-compiler-macro) 'compiler-macro) |
462 |
(si::putprop 'member-if (macro-function 'member-compiler-macro) 'compiler-macro) |
(si::putprop 'member-if (macro-function 'member-compiler-macro) 'compiler-macro) |