Changeset 7917

Timestamp:

Dec 17, 2007, 2:03:43 PM (17 years ago)

Author:

Gary Byers

Message:

Provide type-predicate for NAMED-CTYPE; the type system otherwise
wanders around the CLOS class hierarchy trying to determine whether
or not CTYPE objects are NAMED-CTYPEs.

Unparse ARRAY-CTYPEs into STRINGs when possible.

File:

• branches/working-0711/ccl/level-1/l1-typesys.lisp (modified) (2 diffs)

branches/working-0711/ccl/level-1/l1-typesys.lisp

@@ -1529 +1529 @@
 (defvar *empty-type* (define-named-ctype nil))
 (defvar *universal-type* (define-named-ctype t))
+
+(defun named-ctype-p (x)
+  (istruct-typep x 'named-ctype))
+
+(setf (type-predicate 'named-ctype) 'named-ctype-p)
 
 (define-type-method (named :simple-=) (type1 type2)
@@ -2671 +2676 @@
                    (case eltype
                      (bit 'bit-vector)
-                     (base-char 'base-string)
+                     ((character base-char) 'base-string)
                      (* 'vector)
                      (t `(vector ,eltype)))
                    (case eltype
                      (bit `(bit-vector ,(car dims)))
-                     (base-char `(base-string ,(car dims)))
+                     ((character base-char) `(base-string ,(car dims)))
                      (t `(vector ,eltype ,(car dims)))))
                (if (eq (car dims) '*)
                    (case eltype
                      (bit 'simple-bit-vector)
-                     (base-char 'simple-base-string)
+                     ((base-char character) 'simple-base-string)
                      ((t) 'simple-vector)
                      (t `(simple-array ,eltype (*))))
                    (case eltype
                      (bit `(simple-bit-vector ,(car dims)))
-                     (base-char `(simple-base-string ,(car dims)))
+                     ((base-char character) `(simple-base-string ,(car dims)))
                      ((t) `(simple-vector ,(car dims)))
                      (t `(simple-array ,eltype ,dims))))))