/[gcl]/gcl/cmpnew/gcl_cmpeval.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpeval.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.25 by camm, Mon Aug 8 22:56:07 2005 UTC revision 1.26 by camm, Mon Aug 8 22:56:43 2005 UTC
# Line 449  Line 449 
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)

Legend:
Removed from v.1.25  
changed lines
  Added in v.1.26

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26