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

Modified Files: typep.lisp Log Message: Teach typep about the eql and cons types.

Date: Fri Apr 16 20:02:53 2004 Author: ffjeld

Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.7 movitz/losp/muerte/typep.lisp:1.8 --- movitz/losp/muerte/typep.lisp:1.7 Fri Apr 16 19:34:43 2004 +++ movitz/losp/muerte/typep.lisp Fri Apr 16 20:02:53 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.7 2004/04/16 23:34:43 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.8 2004/04/17 00:02:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -293,6 +293,17 @@ movitz:+movitz-fixnum-factor+) :eax) not-fixnum))))))) + ((eql) + `(eql ,object ',(cadr type))) + ((cons) + (destructuring-bind (&optional (car t) (cdr t)) + (cdr type) + (let ((car (if (eq car '*) t car)) + (cdr (if (eq cdr '*) t cdr))) + `(let ((typep-object ,object)) + (and (typep typep-object 'cons) + (typep (car typep-object) ',car) + (typep (cdr typep-object) ',cdr)))))) ((not) (assert (and (cadr type) (not (cddr type)))) `(not (typep ,object ',(cadr type)))) @@ -301,9 +312,12 @@ (,(car type) ,@(loop for subtype in (cdr type) collect `(typep ,object ',subtype))))) - ((not and or) - (warn "typep compilermacro: ~S" type))))))) + (t (warn "typep ~A" type))))))) form))))) + +#+ignore +(defun foo (x) + (typep x '(cons * symbol)))

(defmacro define-typep (tname lambda &body body) (let ((fname (format nil "~A-~A" 'typep tname)))