Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/code class.lisp,1.50.2.2,1.50.2.3 early-type.lisp,1.44.12.1,1.44.12.2 late-type.lisp,1.106.4.2,1.106.4.3 target-type.lisp,1.25.26.1,1.25.26.2 typep.lisp,1.16.30.1,1.16.30.2
|
From: Christophe R. <cr...@us...> - 2004-08-24 14:48:02
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28335/src/code Modified Files: Tag: character_branch class.lisp early-type.lisp late-type.lisp target-type.lisp typep.lisp Log Message: 0.8.13.77.character.3 "A good flogging never hurt anyone" Implement CHARACTER-SET to replace CHARACTER-RANGE ... builds, passes all tests (including some extra bonus ones), builds all contribs. Index: class.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/class.lisp,v retrieving revision 1.50.2.2 retrieving revision 1.50.2.3 diff -u -d -r1.50.2.2 -r1.50.2.3 --- class.lisp 23 Aug 2004 22:54:24 -0000 1.50.2.2 +++ class.lisp 24 Aug 2004 14:47:19 -0000 1.50.2.3 @@ -932,9 +932,7 @@ *built-in-classes* '((t :state :read-only :translation t) (character :enumerable t - :translation (character-range 0 #.(1- sb!xc:char-code-limit)) - :codes (#.sb!vm:character-widetag) - :prototype-form (code-char 42)) + :translation (character-set)) #+nil (base-char :enumerable t :inherits (character) Index: early-type.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/early-type.lisp,v retrieving revision 1.44.12.1 retrieving revision 1.44.12.2 diff -u -d -r1.44.12.1 -r1.44.12.2 --- early-type.lisp 23 Aug 2004 22:54:24 -0000 1.44.12.1 +++ early-type.lisp 24 Aug 2004 14:47:19 -0000 1.44.12.2 @@ -330,28 +330,33 @@ :high high :enumerable enumerable)) -(defstruct (character-range-type +(defstruct (character-set-type (:include ctype - (class-info (type-class-or-lose 'character-range))) - (:constructor %make-character-range-type) + (class-info (type-class-or-lose 'character-set))) + (:constructor %make-character-set-type) (:copier nil)) - (low (missing-arg) :type (integer 0 (#.sb!xc:char-code-limit)) :read-only t) - (high (missing-arg) - :type (integer 0 (#.sb!xc:char-code-limit)) :read-only t)) -(defun make-character-range-type (&key low high) - (if (or - ;; interval is empty - (and low - high - (> low high)) - ;; high is less than zero - (and high (< high 0)) - ;; low is greater than or equal to CHAR-CODE-LIMIT - (and low (>= low sb!xc:char-code-limit))) - *empty-type* - (let ((low (if (null low) 0 low)) - (high (if (null high) (1- sb!xc:char-code-limit) high))) - (%make-character-range-type :low low :high high)))) + (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. Index: late-type.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v retrieving revision 1.106.4.2 retrieving revision 1.106.4.3 diff -u -d -r1.106.4.2 -r1.106.4.3 --- late-type.lisp 23 Aug 2004 22:54:24 -0000 1.106.4.2 +++ late-type.lisp 24 Aug 2004 14:47:19 -0000 1.106.4.3 @@ -2392,11 +2392,9 @@ (make-member-type :members ms) *empty-type*) (if char-codes - ;; FIXME: this almost certainly sucks too hard. - (apply #'type-union - (mapcar (lambda (x) (make-character-range-type - :low x :high x)) - char-codes)) + (make-character-set-type + :pairs (mapcar (lambda (x) (cons x x)) + (sort char-codes #'<))) *empty-type*) (nreverse numbers))) *empty-type*)) @@ -2844,82 +2842,88 @@ (cons-type-car-type type2)) cdr-int2))))) -;;;; CHARACTER-RANGE types +;;;; CHARACTER-SET types -(!define-type-class character-range) +(!define-type-class character-set) -(!def-type-translator character-range (&optional - (low 0) (high sb!xc:char-code-limit)) - (make-character-range-type :low low :high high)) +(!def-type-translator character-set + (&optional (pairs '((0 . #.(1- sb!xc:char-code-limit))))) + (make-character-set-type :pairs pairs)) -(!define-type-method (character-range :negate) (type) - ;; FIXME: rearrange the NUMBER :NEGATE method similarly to this one - (let ((low (character-range-type-low type)) - (high (character-range-type-high type))) - (if (and (= low 0) - (= high (1- sb!xc:char-code-limit))) +(!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-range-type - :low 0 :high (1- sb!xc:char-code-limit))))) + :type (make-character-set-type + :pairs '((0 . #.(1- sb!xc:char-code-limit))))))) (type-union not-character - (type-union - (make-character-range-type - :low (1+ high) :high sb!xc:char-code-limit) - (make-character-range-type :low 0 :high (1- low)))))))) + (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-range :unparse) (type) +(!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 ((low (character-range-type-low type)) - (high (character-range-type-high type))) - `(member ,@(loop for code from low upto high - collect (sb!xc:code-char code))))))) + (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-range :simple-=) (type1 type2) - (let ((low1 (character-range-type-low type1)) - (low2 (character-range-type-low type2)) - (high1 (character-range-type-high type1)) - (high2 (character-range-type-high type2))) - (values (and (= low1 low2) (= high1 high2)) t))) +(!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-range :simple-subtypep) (type1 type2) - (let ((low1 (character-range-type-low type1)) - (low2 (character-range-type-low type2)) - (high1 (character-range-type-high type1)) - (high2 (character-range-type-high type2))) - (cond - ((and (>= low1 low2) (<= high1 high2)) - (values t t)) - (t - (values nil 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-range :simple-union2) (type1 type2) - (let ((low1 (character-range-type-low type1)) - (low2 (character-range-type-low type2)) - (high1 (character-range-type-high type1)) - (high2 (character-range-type-high type2))) - (cond - ((and (<= low1 low2) (<= (1- low2) high1)) - (make-character-range-type :low low1 :high (max high1 high2))) - ((and (<= low2 low1) (<= (1- low1) high2)) - (make-character-range-type :low low2 :high (max high1 high2)))))) +(!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-range :simple-intersection2) (type1 type2) - (let ((low1 (character-range-type-low type1)) - (low2 (character-range-type-low type2)) - (high1 (character-range-type-high type1)) - (high2 (character-range-type-high type2))) - (cond - ((and (<= low1 low2) (<= low2 high1)) - (make-character-range-type :low low2 :high (min high1 high2))) - ((and (<= low2 low1) (<= (1- low1) high2)) - (make-character-range-type :low low1 :high (min high1 high2)))))) +(!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. Index: target-type.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/target-type.lisp,v retrieving revision 1.25.26.1 retrieving revision 1.25.26.2 diff -u -d -r1.25.26.1 -r1.25.26.2 --- target-type.lisp 23 Aug 2004 22:54:24 -0000 1.25.26.1 +++ target-type.lisp 24 Aug 2004 14:47:19 -0000 1.25.26.2 @@ -33,7 +33,7 @@ named-type member-type array-type - character-range-type + character-set-type built-in-classoid cons-type) (values (%typep obj type) t)) Index: typep.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/typep.lisp,v retrieving revision 1.16.30.1 retrieving revision 1.16.30.2 diff -u -d -r1.16.30.1 -r1.16.30.2 --- typep.lisp 23 Aug 2004 22:54:25 -0000 1.16.30.1 +++ typep.lisp 24 Aug 2004 14:47:20 -0000 1.16.30.2 @@ -117,12 +117,14 @@ (and (consp object) (%%typep (car object) (cons-type-car-type type)) (%%typep (cdr object) (cons-type-cdr-type type)))) - (character-range-type + (character-set-type (and (characterp object) (let ((code (char-code object)) - (low (character-range-type-low type)) - (high (character-range-type-high type))) - (<= low code high)))) + (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") |