/[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.24 by camm, Mon Aug 8 22:51:32 2005 UTC revision 1.25 by camm, Mon Aug 8 22:56:07 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* ((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)

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

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