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)