Changeset 11665 for trunk/source/level-1/l1-typesys.lisp

Timestamp:

Jan 30, 2009, 12:00:31 PM (12 years ago)

Author:

gb

Message:

In VALUES-SPECIFIER-TYPE, signal an INVALID-TYPE-SPECIFIER if the
alleged type specifier is clearly invalid (not a symbol, class, or
list whose CAR is a symbol; a symbol that can only be used as a
compound type specifier, or a compound type specifier whose CAR
names a builtin type that's not otherwise handled or a class.)
This still allows some things to slip through - (BIT) is treated
like BIT - somewhat arbitrarily.

When generating type predicates for slot definitions, catch
INVALID-TYPE-SPECIFIERS and warn about them; install a predicate
that'll CERROR and offer to remove the predicate from the effective
slot definition.

File:

• trunk/source/level-1/l1-typesys.lisp (modified) (8 diffs)

trunk/source/level-1/l1-typesys.lisp

@@ -1356 +1356 @@
     (funcall (type-class-unparse (ctype-class-info type)) type)))
 
+
+(defconstant compound-only-type-specifiers
+  ;; See CLHS Figure 4-4.
+  '(and mod satisfies eql not values member or))
+
+
 ;;; VALUES-SPECIFIER-TYPE  --  Interface
 ;;;
@@ -1386 +1392 @@
            (and cell (cdr cell))))
          (t
+          (when (member spec compound-only-type-specifiers)
+            (error 'invalid-type-specifier :typespec spec))
           (let* ((lspec (if (atom spec) (list spec) spec))
                  (fun (info-type-translator (car lspec))))
             (cond (fun (funcall fun lspec env))
-                  ((or (and (consp spec) (symbolp (car spec)))
+                  ((or (and (consp spec)
+                            (symbolp (car spec))
+                            (not (or (find-class (car spec) nil env)
+                                     (info-type-builtin (car spec)))))
                        (symbolp spec))
                    (when *type-system-initialized*
@@ -1397 +1408 @@
                    nil)
                   (t
-                   (error "Bad thing to be a type specifier: ~S." spec)))))))))
+                   (error 'invalid-type-specifier :typespec spec)))))))))
 
 (eval-when (:compile-toplevel :execute)
@@ -1528 +1539 @@
   (handler-case
       (type-specifier (specifier-type spec env))
+    (invalid-type-specifier () spec)
     (parse-unknown-type () spec)))
 
@@ -1558 +1570 @@
           (when pred (setf (numeric-ctype-predicate res) pred))))
       (unless (unknown-ctype-p res)
-          (setf (info-type-builtin spec) res)
-          (setf (info-type-kind spec) :primitive)))))
+        (setf (info-type-builtin spec) res)
+        (setf (info-type-kind spec) :primitive)))))
 
 ;;;; Builtin types.
@@ -3956 +3968 @@
   `(simple-array (signed-byte 32) (,size)))
 
+
+
+(deftype simple-short-float-vector (&optional size)
+  `(simple-array short-float (,size)))
+
+(deftype unsigned-word-vector (&optional size)
+  `(vector (unsigned-byte 16) ,size))
+
+(deftype single-float-vector (&optional size)
+  `(vector short-float ,size))
+
+(deftype unsigned-byte-vector (&optional size)
+  `(vector (unsigned-byte 8) ,size))
+
+(deftype unsigned-long-vector (&optional size)
+  `(vector (unsigned-byte 32) ,size))
+
+(deftype long-float-vector (&optional size)
+  `(vector double-float ,size))
+
+(deftype long-vector (&optional size)
+  `(vector (signed-byte 32) ,size))
+
+(deftype double-float-vector (&optional size)
+  `(vector double-float ,size))
+
+(deftype byte-vector (&optional size)
+  `(vector (signed-byte 8) ,size))
+
+(deftype general-vector (&optional size)
+  `(vector t ,size))
+
+(deftype word-vector (&optional size)
+  `(vector (signed-byte 16) ,size))
+
+(deftype short-float-vector (&optional size)
+  `(vector single-float ,size))
+
+(deftype simple-1d-array (&optional size)
+  `(simple-array * (,size)))
+
+(deftype simple-long-vector (&optional size)
+  `(simple-array (signed-byte 32) (,size)))
+
+(deftype simple-word-vector (&optional size)
+  `(simple-array (signed-byte 16) (,size)))
+
+(deftype simple-short-float-vector (&optional size)
+  `(simple-array single-float (,size)))
+
+(deftype simple-byte-vector (&optional size)
+  `(simple-array (signed-byte 8) (,size)))
+
 (deftype simple-double-float-vector (&optional size)
   `(simple-array double-float (,size)))
 
-(deftype simple-short-float-vector (&optional size)
-  `(simple-array short-float (,size)))
-
-(deftype unsigned-word-vector (&optional size)
-  `(vector (unsigned-byte 16) ,size))
-
-(deftype single-float-vector (&optional size)
-  `(vector short-float ,size))
-
-(deftype unsigned-byte-vector (&optional size)
-  `(vector (unsigned-byte 8) ,size))
-
-(deftype unsigned-long-vector (&optional size)
-  `(vector (unsigned-byte 32) ,size))
-
-(deftype long-float-vector (&optional size)
-  `(vector double-float ,size))
-
-(deftype long-vector (&optional size)
-  `(vector (signed-byte 32) ,size))
-
-(deftype double-float-vector (&optional size)
-  `(vector double-float ,size))
-
-(deftype byte-vector (&optional size)
-  `(vector (signed-byte 8) ,size))
-
-(deftype general-vector (&optional size)
-  `(vector t ,size))
-
-(deftype word-vector (&optional size)
-  `(vector (signed-byte 16) ,size))
-
-(deftype short-float-vector (&optional size)
-  `(vector single-float ,size))
-
-(deftype simple-1d-array (&optional size)
-  `(simple-array * (,size)))
-
-(deftype simple-long-vector (&optional size)
-  `(simple-array (signed-byte 32) (,size)))
-
-(deftype simple-word-vector (&optional size)
-  `(simple-array (signed-byte 16) (,size)))
-
-(deftype simple-short-float-vector (&optional size)
-  `(simple-array single-float (,size)))
-
-(deftype simple-byte-vector (&optional size)
-  `(simple-array (signed-byte 8) (,size)))
-
-(deftype simple-double-float-vector (&optional size)
-  `(simple-array double-float (,size)))
-
 (deftype simple-single-float-vector (&optional size)
   `(simple-array single-float (,size)))
 
+(deftype simple-long-float-vector (&optional size)
+  `(simple-array double-float (,size)))
+
 (deftype simple-fixnum-vector (&optional size)
   `(simple-array fixnum (,size)))
+
+(deftype fixnum-vector (&optional size)
+  `(array fixnum (,size)))
 
 #+64-bit-target
@@ -4034 +4051 @@
   `(double-float ,low ,high))
 
+#||
 ;;; As empty a type as you're likely to find ...
 (deftype extended-char ()
   "Type of CHARACTERs that aren't BASE-CHARs."
   nil)
+||#
 
 (deftype natural ()
@@ -4321 +4340 @@
                     (unless (eq ctype *universal-type*)
                       (generate-predicate-for-ctype ctype)))
+                (invalid-type-specifier ()
+                  (warn "Invalid type soecifier ~s in slot definition for ~s in class ~s." type (slot-definition-name spec) (slot-definition-class spec))
+                  (lambda (v)
+                    (cerror "Allow the assignment or initialization."
+                            "Can't determine whether or not the value ~s should be used to initialize or assign to the slot ~&named ~s in an instance of ~s, because the slot is declared ~&to be of the invalid type ~s."
+                            v (slot-definition-name spec) (slot-definition-class spec) (slot-definition-type spec))
+                    ;; Suppress further checking, at least for things that use this effective slotd.
+                    ;; (It's hard to avoid this, and more trouble than it's worth to do better.)
+                    (setf (slot-value spec 'type-predicate) nil)
+                    t))
                 (parse-unknown-type (c)
                    (declare (ignore c))