"BINDING-STACK-POINTER-SAP" "BIT-BASH-COPY" "BIT-INDEX"
"BOGUS-ARG-TO-VALUES-LIST-ERROR" "BOOLE-CODE"
"BOUNDING-INDICES-BAD-ERROR" "BYTE-SPECIFIER" "%BYTE-BLT"
- "CALLABLE" "CASE-BODY-ERROR" "CHARPOS"
+ "CALLABLE" "CASE-BODY-ERROR"
+ "CHARACTER-SET" "CHARACTER-SET-TYPE"
+ "CHARACTER-SET-TYPE-PAIRS"
+ "CHARPOS"
"CHECK-FOR-CIRCULARITY" "CHECK-TYPE-ERROR" "CLOSED-FLAME"
"CODE-COMPONENT" "CODE-COMPONENT-P" "CODE-DEBUG-INFO"
"CODE-HEADER-REF" "CODE-HEADER-SET" "CODE-INSTRUCTIONS"
'((t :state :read-only :translation t)
(character :enumerable t
:codes (#.sb!vm:character-widetag)
+ :translation (character-set)
:prototype-form (code-char 42))
(symbol :codes (#.sb!vm:symbol-header-widetag)
:prototype-form '#:mu)
:high high
:enumerable enumerable))
+(defstruct (character-set-type
+ (:include ctype
+ (class-info (type-class-or-lose 'character-set)))
+ (:constructor %make-character-set-type)
+ (:copier nil))
+ (pairs (missing-arg) :type list :read-only t))
+(defun make-character-set-type (&key pairs)
+ (aver (equal (mapcar #'car pairs)
+ (sort (mapcar #'car pairs) #'<)))
+ (let ((pairs (let (result)
+ (do ((pairs pairs (cdr pairs)))
+ ((null pairs) (nreverse result))
+ (destructuring-bind (low . high) (car pairs)
+ (loop for (low1 . high1) in (cdr pairs)
+ if (<= low1 (1+ high))
+ do (progn (setf high (max high high1))
+ (setf pairs (cdr pairs)))
+ else do (return nil))
+ (cond
+ ((>= low sb!xc:char-code-limit))
+ ((< high 0))
+ (t (push (cons (max 0 low)
+ (min high (1- sb!xc:char-code-limit)))
+ result))))))))
+ (if (null pairs)
+ *empty-type*
+ (%make-character-set-type :pairs pairs))))
+
;;; An ARRAY-TYPE is used to represent any array type, including
;;; things such as SIMPLE-BASE-STRING.
(defstruct (array-type (:include ctype
(!def-type-translator member (&rest members)
(if members
- (let (ms numbers)
+ (let (ms numbers char-codes)
(dolist (m (remove-duplicates members))
(typecase m
(float (if (zerop m)
(push m ms)
(push (ctype-of m) numbers)))
(real (push (ctype-of m) numbers))
+ (character (push (sb!xc:char-code m) char-codes))
(t (push m ms))))
(apply #'type-union
(if ms
(make-member-type :members ms)
*empty-type*)
+ (if char-codes
+ (make-character-set-type
+ :pairs (mapcar (lambda (x) (cons x x))
+ (sort char-codes #'<)))
+ *empty-type*)
(nreverse numbers)))
*empty-type*))
\f
((type= type (specifier-type 'simple-string)) 'simple-string)
((type= type (specifier-type 'string)) 'string)
((type= type (specifier-type 'complex)) 'complex)
+ ((type= type (specifier-type 'standard-char)) 'standard-char)
(t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
;;; Two union types are equal if they are each subtypes of each
(type-intersection (cons-type-car-type type1)
(cons-type-car-type type2))
cdr-int2)))))
-\f
+\f
+;;;; CHARACTER-SET types
+
+(!define-type-class character-set)
+
+(!def-type-translator character-set
+ (&optional (pairs '((0 . #.(1- sb!xc:char-code-limit)))))
+ (make-character-set-type :pairs pairs))
+
+(!define-type-method (character-set :negate) (type)
+ (let ((pairs (character-set-type-pairs type)))
+ (if (and (= (length pairs) 1)
+ (= (caar pairs) 0)
+ (= (cdar pairs) (1- sb!xc:char-code-limit)))
+ (make-negation-type :type type)
+ (let ((not-character
+ (make-negation-type
+ :type (make-character-set-type
+ :pairs '((0 . #.(1- sb!xc:char-code-limit)))))))
+ (type-union
+ not-character
+ (make-character-set-type
+ :pairs (let (not-pairs)
+ (when (> (caar pairs) 0)
+ (push (cons 0 (1- (caar pairs))) not-pairs))
+ (do* ((tail pairs (cdr tail))
+ (high1 (cdar tail))
+ (low2 (caadr tail)))
+ ((null (cdr tail))
+ (when (< (cdar tail) (1- sb!xc:char-code-limit))
+ (push (cons (1+ (cdar tail))
+ (1- sb!xc:char-code-limit))
+ not-pairs))
+ (nreverse not-pairs))
+ (push (cons (1+ high1) (1- low2)) not-pairs)))))))))
+
+(!define-type-method (character-set :unparse) (type)
+ (cond
+ ((type= type (specifier-type 'character)) 'character)
+ ((type= type (specifier-type 'base-char)) 'base-char)
+ ((type= type (specifier-type 'extended-char)) 'extended-char)
+ ((type= type (specifier-type 'standard-char)) 'standard-char)
+ (t (let ((pairs (character-set-type-pairs type)))
+ `(member ,@(loop for (low . high) in pairs
+ append (loop for code from low upto high
+ collect (sb!xc:code-char code))))))))
+
+(!define-type-method (character-set :simple-=) (type1 type2)
+ (let ((pairs1 (character-set-type-pairs type1))
+ (pairs2 (character-set-type-pairs type2)))
+ (values (equal pairs1 pairs2) t)))
+
+(!define-type-method (character-set :simple-subtypep) (type1 type2)
+ (values
+ (dolist (pair (character-set-type-pairs type1) t)
+ (unless (position pair (character-set-type-pairs type2)
+ :test (lambda (x y) (and (>= (car x) (car y))
+ (<= (cdr x) (cdr y)))))
+ (return nil)))
+ t))
+
+(!define-type-method (character-set :simple-union2) (type1 type2)
+ ;; KLUDGE: the canonizing in the MAKE-CHARACTER-SET-TYPE function
+ ;; actually does the union for us. It might be a little fragile to
+ ;; rely on it.
+ (make-character-set-type
+ :pairs (merge 'list
+ (copy-alist (character-set-type-pairs type1))
+ (copy-alist (character-set-type-pairs type2))
+ #'< :key #'car)))
+
+(!define-type-method (character-set :simple-intersection2) (type1 type2)
+ ;; KLUDGE: brute force.
+ (let (pairs)
+ (dolist (pair1 (character-set-type-pairs type1)
+ (make-character-set-type
+ :pairs (sort pairs #'< :key #'car)))
+ (dolist (pair2 (character-set-type-pairs type2))
+ (cond
+ ((<= (car pair1) (car pair2) (cdr pair1))
+ (push (cons (car pair2) (min (cdr pair1) (cdr pair2))) pairs))
+ ((<= (car pair2) (car pair1) (cdr pair2))
+ (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs)))))))
+\f
;;; Return the type that describes all objects that are in X but not
;;; in Y. If we can't determine this type, then return NIL.
;;;
named-type
member-type
array-type
+ character-set-type
built-in-classoid
cons-type)
(values (%typep obj type) t))
:specialized-element-type etype)))
(cons
(make-cons-type *universal-type* *universal-type*))
+ (character
+ (specifier-type 'character))
(t
(classoid-of x))))
(member-type-p ctype)
(numeric-type-p ctype)
(array-type-p ctype)
- (cons-type-p ctype))))
+ (cons-type-p ctype)
+ (intersection-type-p ctype)
+ (union-type-p ctype)
+ (negation-type-p ctype)
+ (character-set-type-p ctype))))
;;; Evaluate (at load/execute time) to a function which checks that
;;; its argument is of the specified type.
(and (consp object)
(%%typep (car object) (cons-type-car-type type))
(%%typep (cdr object) (cons-type-cdr-type type))))
+ (character-set-type
+ (and (characterp object)
+ (let ((code (char-code object))
+ (pairs (character-set-type-pairs type)))
+ (dolist (pair pairs nil)
+ (destructuring-bind (low . high) pair
+ (when (<= low code high)
+ (return t)))))))
(unknown-type
;; dunno how to do this ANSIly -- WHN 19990413
#+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
(ecase (named-type-name type)
((t *) (values *backend-t-primitive-type* t))
((nil) (any))))
+ (character-set-type
+ (let ((pairs (character-set-type-pairs type)))
+ (if (and (= (length pairs) 1)
+ (= (caar pairs) 0)
+ (= (cdar pairs) (1- sb!xc:char-code-limit)))
+ (exactly character)
+ (part-of character))))
(built-in-classoid
(case (classoid-name type)
((complex function instance
(values (primitive-type-or-lose (classoid-name type)) t))
(funcallable-instance
(part-of function))
- (character
- (exactly character))
(cons-type
(part-of list))
(t
`((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)
(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)))
(specifier-type '(or (single-float -1.0 1.0)
(single-float 0.1))))))
+(assert (sb-xc:typep #\, 'character))
+(assert (sb-xc:typep #\@ 'character))
+
+(assert (type= (type-intersection (specifier-type '(member #\a #\c #\e))
+ (specifier-type '(member #\b #\c #\f)))
+ (specifier-type '(member #\c))))
+
(/show "done with tests/type.before-xc.lisp")
(real 4 8) (real -1 7) (real 2 11)
null symbol keyword
(member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3)
- (integer -1 1)
+ (member #\a #\c #\d #\f) (integer -1 1)
unsigned-byte
(rational -1 7) (rational -2 4)
ratio
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.16.9"
+"0.8.16.10"
projects / sbcl.git / commitdiff