[movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv22773

Modified Files:
	more-macros.lisp 
Log Message:
Added member compiler-macro.

Date: Sat Nov 20 18:36:07 2004
Author: ffjeld

Index: movitz/losp/muerte/more-macros.lisp
diff -u movitz/losp/muerte/more-macros.lisp:1.20 movitz/losp/muerte/more-macros.lisp:1.21
--- movitz/losp/muerte/more-macros.lisp:1.20	Wed Sep 22 19:48:00 2004
+++ movitz/losp/muerte/more-macros.lisp	Sat Nov 20 18:36:07 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Jun  7 15:05:57 2002
 ;;;;                
-;;;; $Id: more-macros.lisp,v 1.20 2004/09/22 17:48:00 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.21 2004/11/20 17:36:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -134,6 +134,32 @@
 	 ((null ,cons-var) ,result-form)
        (let ((,var (pop ,cons-var)))
 	 , at declarations-and-body))))
+
+(define-compiler-macro member (&whole form item list &key (key ''identity) (test ''eql)
+			       &environment env)
+  (let* ((test (or (and (movitz:movitz-constantp test env)
+			(translate-program (movitz:movitz-eval test env) :muerte.cl :cl))
+		   (and (consp test) (eq 'function (car test))
+			(cadr test))))
+	 (key (or (and (movitz:movitz-constantp key env)
+		       (translate-program (movitz:movitz-eval key env) :muerte.cl :cl))
+		  (and (consp key) (eq 'function (car key))
+		       (cadr key)))))
+    (cond
+     ((and test (symbolp test) (eq key 'identity))
+      `(do ((item ,item)
+	    (p ,list (cdr p)))
+	   ((endp p) nil)
+	 (when (,test (car p) item)
+	   (return p))))
+     ((and test (symbolp test)
+	   key (symbolp key))
+      `(do ((item ,item)
+	    (p ,list (cdr p)))
+	   ((endp p) nil)
+	 (when (,test (car p) (,key item))
+	   (return p))))
+     (t form))))
 
 (defmacro letf* (bindings &body body &environment env)
   "Does what one might expect, saving the old values and setting the generalized