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

[Frode Vatvedt Fjeld]

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

Modified Files:
	typep.lisp 
Log Message:
Made typep considerably smarter about the integer type.

Date: Fri Apr 16 19:34:43 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.6 movitz/losp/muerte/typep.lisp:1.7
--- movitz/losp/muerte/typep.lisp:1.6	Tue Apr  6 20:17:19 2004
+++ movitz/losp/muerte/typep.lisp	Fri Apr 16 19:34:43 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.6 2004/04/07 00:17:19 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.7 2004/04/16 23:34:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -239,17 +239,70 @@
 		     (when deriver-function
 		       `(typep ,object ',(funcall deriver-function)))))))
 	     ((consp type)
-	      (case (car type)
-		((not)
-		 (assert (and (cadr type) (not (cddr type))))
-		 `(not (typep ,object ',(cadr type))))
-		((or and)
-		 `(let ((typep-object ,object))
-		    (,(car type)
-		     ,@(loop for subtype in (cdr type)
-			   collect `(typep ,object ',subtype)))))
-		((not and or)
-		 (warn "typep compilermacro: ~S" type)))))
+	      (let ((deriver-function (gethash (car type) *compiler-derived-typespecs*)))
+		(if deriver-function
+		    `(typep ,object ',(apply deriver-function (cdr type)))
+		  (case (car type)
+		    ((integer)
+		     (destructuring-bind (&optional (lower-limit '*) (upper-limit '*))
+			 (cdr type)
+		       (let* ((min movitz:+movitz-most-negative-fixnum+)
+			      (max movitz:+movitz-most-positive-fixnum+)
+			      (lower-limit (if (eq lower-limit '*) min lower-limit))
+			      (upper-limit (if (eq upper-limit '*) max upper-limit)))
+			 (assert (<= lower-limit upper-limit) ()
+			   "The lower limit of an integer type must be smaller than the upper limit.")
+			 (cond
+			  ((and (= lower-limit min) (= upper-limit max))
+			   `(typep ,object 'integer))
+			  ((= lower-limit upper-limit)
+			   `(eql ,object ,lower-limit))
+			  ((and (= lower-limit 0)
+				(= 1 (logcount (1+ upper-limit))))
+			   `(with-inline-assembly (:returns :boolean-zf=1)
+			      (:compile-form (:result-mode :eax) ,object)
+			      (:testl ,(logxor #xffffffff
+					       (* movitz:+movitz-fixnum-factor+ upper-limit))
+				      :eax)))
+			  ((= 1 (logcount (1+ (- upper-limit lower-limit))))
+			   `(with-inline-assembly (:returns :boolean-zf=1)
+			      (:compile-form (:result-mode :eax) ,object)
+			      (:leal (:eax ,(* movitz:+movitz-fixnum-factor+
+					       (- lower-limit)))
+				     :ecx)
+			      (:testl ,(logxor #xffffffff
+					       (* movitz:+movitz-fixnum-factor+
+						  (- upper-limit lower-limit)))
+				      :ecx)))
+			  ((= lower-limit 0)
+			   `(with-inline-assembly-case ()
+			      (do-case (t :boolean-cf=1 :labels (not-fixnum))
+				(:compile-form (:result-mode :eax) ,object)
+				(:testb ,movitz:+movitz-fixnum-zmask+ :al) ; CF<=0
+				(:jnz 'not-fixnum)
+				(:cmpl ,(* (1+ upper-limit) movitz:+movitz-fixnum-factor+)
+				       :eax)
+			       not-fixnum)))
+			  (t `(with-inline-assembly-case ()
+				(do-case (t :boolean-cf=1 :labels (not-fixnum))
+				  (:compile-form (:result-mode :eax) ,object)
+				  (:testb ,movitz:+movitz-fixnum-zmask+ :al) ; CF<=0
+				  (:jnz 'not-fixnum)
+				  (:subl ,(* lower-limit movitz:+movitz-fixnum-factor+) :eax)
+				  (:cmpl ,(* (- upper-limit lower-limit -1)
+					     movitz:+movitz-fixnum-factor+)
+					 :eax)
+				 not-fixnum)))))))
+		    ((not)
+		     (assert (and (cadr type) (not (cddr type))))
+		     `(not (typep ,object ',(cadr type))))
+		    ((or and)
+		     `(let ((typep-object ,object))
+			(,(car type)
+			 ,@(loop for subtype in (cdr type)
+			       collect `(typep ,object ',subtype)))))
+		    ((not and or)
+		     (warn "typep compilermacro: ~S" type)))))))
 	    form)))))
 
 (defmacro define-typep (tname lambda &body body)