From 2034cb134af58c5998f4e305673af6e2c75bc179 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 27 Oct 2004 21:36:30 +0000 Subject: [PATCH] 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 --- package-data-list.lisp-expr | 5 +- src/code/class.lisp | 1 + src/code/early-type.lisp | 28 +++++++++++ src/code/late-type.lisp | 94 +++++++++++++++++++++++++++++++++++- src/code/target-type.lisp | 3 ++ src/code/typecheckfuns.lisp | 6 ++- src/code/typep.lisp | 8 +++ src/compiler/generic/primtype.lisp | 9 +++- src/compiler/typetran.lisp | 17 +++++++ tests/type.before-xc.lisp | 7 +++ tests/type.impure.lisp | 2 +- version.lisp-expr | 2 +- 12 files changed, 174 insertions(+), 8 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 8088f68..1d5e0f0 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1122,7 +1122,10 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" diff --git a/src/code/class.lisp b/src/code/class.lisp index e6b0b8b..d9db35f 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -937,6 +937,7 @@ NIL is returned when no such class exists." '((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) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 6f34191..16404c7 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -330,6 +330,34 @@ :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 diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 365c00b..5a1e0e8 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -2378,18 +2378,24 @@ (!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*)) @@ -2562,6 +2568,7 @@ ((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 @@ -2834,7 +2841,90 @@ (type-intersection (cons-type-car-type type1) (cons-type-car-type type2)) cdr-int2))))) - + +;;;; 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))))))) + ;;; 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. ;;; diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index ddf35ed..f8dccd3 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -33,6 +33,7 @@ named-type member-type array-type + character-set-type built-in-classoid cons-type) (values (%typep obj type) t)) @@ -191,6 +192,8 @@ :specialized-element-type etype))) (cons (make-cons-type *universal-type* *universal-type*)) + (character + (specifier-type 'character)) (t (classoid-of x)))) diff --git a/src/code/typecheckfuns.lisp b/src/code/typecheckfuns.lisp index f8253cc..eeaeb0a 100644 --- a/src/code/typecheckfuns.lisp +++ b/src/code/typecheckfuns.lisp @@ -199,7 +199,11 @@ (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. diff --git a/src/code/typep.lisp b/src/code/typep.lisp index 121e205..0df87b1 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -117,6 +117,14 @@ (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") diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index f0ab8a9..962b22f 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -304,6 +304,13 @@ (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 @@ -311,8 +318,6 @@ (values (primitive-type-or-lose (classoid-name type)) t)) (funcallable-instance (part-of function)) - (character - (exactly character)) (cons-type (part-of list)) (t diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 5503f87..c1b1908 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -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))) diff --git a/tests/type.before-xc.lisp b/tests/type.before-xc.lisp index 5b03e45..90d8f1d 100644 --- a/tests/type.before-xc.lisp +++ b/tests/type.before-xc.lisp @@ -209,4 +209,11 @@ (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") diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 7170619..248955e 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -30,7 +30,7 @@ (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 diff --git a/version.lisp-expr b/version.lisp-expr index 9240fe1..d691460 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4