From: Christophe R. <cr...@us...> - 2004-10-27 21:36:57
|
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))) |