[Sbcl-commits] CVS: sbcl/src/compiler typetran.lisp,1.42,1.43

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23008/src/compiler

Modified Files:
	typetran.lisp 
Log Message:
0.8.16.10:
	CHARACTER-SET-TYPE implementation
	... easier to deal with than (MEMBER ...)
	... the usual complement of changes, a few extra tests, and so on.

	This patch was brought to you by character_branch


Index: typetran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/typetran.lisp,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -d -r1.42 -r1.43
--- typetran.lisp	26 Oct 2004 17:51:18 -0000	1.42
+++ typetran.lisp	27 Oct 2004 21:36:45 -0000	1.43
@@ -292,6 +292,21 @@
 			`((typep (cdr ,n-obj)
 				 ',(type-specifier cdr-type))))))))))
  
+(defun source-transform-character-set-typep (object type)
+  (let ((pairs (character-set-type-pairs type)))
+    (if (and (= (length pairs) 1)
+            (= (caar pairs) 0)
+            (= (cdar pairs) (1- sb!xc:char-code-limit)))
+       `(characterp ,object)
+       (once-only ((n-obj object))
+         (let ((n-code (gensym "CODE")))
+           `(and (characterp ,n-obj)
+                 (let ((,n-code (sb!xc:char-code ,n-obj)))
+                   (or
+                    ,@(loop for pair in pairs
+                            collect
+                            `(<= ,(car pair) ,n-code ,(cdr pair)))))))))))
+
 ;;; Return the predicate and type from the most specific entry in
 ;;; *TYPE-PREDICATES* that is a supertype of TYPE.
 (defun find-supertype-predicate (type)
@@ -493,6 +508,8 @@
 	       (source-transform-array-typep object type))
 	      (cons-type
 	       (source-transform-cons-typep object type))
+             (character-set-type
+              (source-transform-character-set-typep object type))
 	      (t nil))
 	    `(%typep ,object ,spec)))
       (values nil t)))