(define-source-transform atom (x)
`(not (consp ,x)))
+#!+sb-unicode
+(define-source-transform base-char-p (x)
+ `(typep ,x 'base-char))
\f
;;;; TYPEP source transform
;;; Do source transformation for TYPEP of a known union type. If a
;;; union type contains LIST, then we pull that out and make it into a
-;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
-;;; will be a subtype even without there being any (member NIL). We
-;;; just drop through to the general code in this case, rather than
-;;; trying to optimize it.
+;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
+;;; will be a subtype even without there being any (member NIL). We
+;;; currently just drop through to the general code in this case,
+;;; rather than trying to optimize it (but FIXME CSR 2004-04-05: it
+;;; wouldn't be hard to optimize it after all).
(defun source-transform-union-typep (object type)
(let* ((types (union-type-types type))
- (type-list (specifier-type 'list))
(type-cons (specifier-type 'cons))
(mtype (find-if #'member-type-p types))
(members (when mtype (member-type-members mtype))))
`((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)
;; If not properly named, error.
((not (and name (eq (find-classoid name) class)))
(compiler-error "can't compile TYPEP of anonymous or undefined ~
- class:~% ~S"
+ class:~% ~S"
class))
(t
;; Delay the type transform to give type propagation a chance.
(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)))