[Sbcl-commits] CVS: sbcl/src/compiler typetran.lisp,1.41,1.41.4.1

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

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

Modified Files:
      Tag: character_branch
	typetran.lisp 
Log Message:
0.8.13.77.character.2:
	"Pull your socks up"

	Zeroth draft of teaching the type system about character sets: 
	implement CHARACTER subtypes as CHARACTER-RANGE.
	... builds, passes all tests, builds all contribs;
	... zeroth draft because it makes types such as
		(member #\a #\c #\e) unparse uglily.  Probably I
		actually want a CHARACTER-SET representation


Index: typetran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/typetran.lisp,v
retrieving revision 1.41
retrieving revision 1.41.4.1
diff -u -d -r1.41 -r1.41.4.1
--- typetran.lisp	13 Apr 2004 10:30:39 -0000	1.41
+++ typetran.lisp	23 Aug 2004 22:54:25 -0000	1.41.4.1
@@ -292,6 +292,15 @@
 			`((typep (cdr ,n-obj)
 				 ',(type-specifier cdr-type))))))))))
  
+(defun source-transform-character-range-typep (object type)
+  (let ((low (character-range-type-low type))
+	(high (character-range-type-high type)))
+    (if (and (= low 0) (= high (1- sb!xc:char-code-limit)))
+	`(characterp ,object)
+	(once-only ((n-obj object))
+	  `(and (characterp ,n-obj)
+	        (<= ,low (sb!xc:char-code ,n-obj) ,high))))))
+
 ;;; 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 +502,8 @@
 	       (source-transform-array-typep object type))
 	      (cons-type
 	       (source-transform-cons-typep object type))
+	      (character-range-type
+	       (source-transform-character-range-typep object type))
 	      (t nil))
 	    `(%typep ,object ,spec)))
       (values nil t)))