Ignore:
Timestamp:
Jan 30, 2009, 12:00:31 PM (11 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:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-typesys.lisp

    r11121 r11665  
    13561356    (funcall (type-class-unparse (ctype-class-info type)) type)))
    13571357
     1358
     1359(defconstant compound-only-type-specifiers
     1360  ;; See CLHS Figure 4-4.
     1361  '(and mod satisfies eql not values member or))
     1362
     1363
    13581364;;; VALUES-SPECIFIER-TYPE  --  Interface
    13591365;;;
     
    13861392           (and cell (cdr cell))))
    13871393         (t
     1394          (when (member spec compound-only-type-specifiers)
     1395            (error 'invalid-type-specifier :typespec spec))
    13881396          (let* ((lspec (if (atom spec) (list spec) spec))
    13891397                 (fun (info-type-translator (car lspec))))
    13901398            (cond (fun (funcall fun lspec env))
    1391                   ((or (and (consp spec) (symbolp (car spec)))
     1399                  ((or (and (consp spec)
     1400                            (symbolp (car spec))
     1401                            (not (or (find-class (car spec) nil env)
     1402                                     (info-type-builtin (car spec)))))
    13921403                       (symbolp spec))
    13931404                   (when *type-system-initialized*
     
    13971408                   nil)
    13981409                  (t
    1399                    (error "Bad thing to be a type specifier: ~S." spec)))))))))
     1410                   (error 'invalid-type-specifier :typespec spec)))))))))
    14001411
    14011412(eval-when (:compile-toplevel :execute)
     
    15281539  (handler-case
    15291540      (type-specifier (specifier-type spec env))
     1541    (invalid-type-specifier () spec)
    15301542    (parse-unknown-type () spec)))
    15311543
     
    15581570          (when pred (setf (numeric-ctype-predicate res) pred))))
    15591571      (unless (unknown-ctype-p res)
    1560           (setf (info-type-builtin spec) res)
    1561           (setf (info-type-kind spec) :primitive)))))
     1572        (setf (info-type-builtin spec) res)
     1573        (setf (info-type-kind spec) :primitive)))))
    15621574
    15631575;;;; Builtin types.
     
    39563968  `(simple-array (signed-byte 32) (,size)))
    39573969
     3970
     3971
     3972(deftype simple-short-float-vector (&optional size)
     3973  `(simple-array short-float (,size)))
     3974
     3975(deftype unsigned-word-vector (&optional size)
     3976  `(vector (unsigned-byte 16) ,size))
     3977
     3978(deftype single-float-vector (&optional size)
     3979  `(vector short-float ,size))
     3980
     3981(deftype unsigned-byte-vector (&optional size)
     3982  `(vector (unsigned-byte 8) ,size))
     3983
     3984(deftype unsigned-long-vector (&optional size)
     3985  `(vector (unsigned-byte 32) ,size))
     3986
     3987(deftype long-float-vector (&optional size)
     3988  `(vector double-float ,size))
     3989
     3990(deftype long-vector (&optional size)
     3991  `(vector (signed-byte 32) ,size))
     3992
     3993(deftype double-float-vector (&optional size)
     3994  `(vector double-float ,size))
     3995
     3996(deftype byte-vector (&optional size)
     3997  `(vector (signed-byte 8) ,size))
     3998
     3999(deftype general-vector (&optional size)
     4000  `(vector t ,size))
     4001
     4002(deftype word-vector (&optional size)
     4003  `(vector (signed-byte 16) ,size))
     4004
     4005(deftype short-float-vector (&optional size)
     4006  `(vector single-float ,size))
     4007
     4008(deftype simple-1d-array (&optional size)
     4009  `(simple-array * (,size)))
     4010
     4011(deftype simple-long-vector (&optional size)
     4012  `(simple-array (signed-byte 32) (,size)))
     4013
     4014(deftype simple-word-vector (&optional size)
     4015  `(simple-array (signed-byte 16) (,size)))
     4016
     4017(deftype simple-short-float-vector (&optional size)
     4018  `(simple-array single-float (,size)))
     4019
     4020(deftype simple-byte-vector (&optional size)
     4021  `(simple-array (signed-byte 8) (,size)))
     4022
    39584023(deftype simple-double-float-vector (&optional size)
    39594024  `(simple-array double-float (,size)))
    39604025
    3961 (deftype simple-short-float-vector (&optional size)
    3962   `(simple-array short-float (,size)))
    3963 
    3964 (deftype unsigned-word-vector (&optional size)
    3965   `(vector (unsigned-byte 16) ,size))
    3966 
    3967 (deftype single-float-vector (&optional size)
    3968   `(vector short-float ,size))
    3969 
    3970 (deftype unsigned-byte-vector (&optional size)
    3971   `(vector (unsigned-byte 8) ,size))
    3972 
    3973 (deftype unsigned-long-vector (&optional size)
    3974   `(vector (unsigned-byte 32) ,size))
    3975 
    3976 (deftype long-float-vector (&optional size)
    3977   `(vector double-float ,size))
    3978 
    3979 (deftype long-vector (&optional size)
    3980   `(vector (signed-byte 32) ,size))
    3981 
    3982 (deftype double-float-vector (&optional size)
    3983   `(vector double-float ,size))
    3984 
    3985 (deftype byte-vector (&optional size)
    3986   `(vector (signed-byte 8) ,size))
    3987 
    3988 (deftype general-vector (&optional size)
    3989   `(vector t ,size))
    3990 
    3991 (deftype word-vector (&optional size)
    3992   `(vector (signed-byte 16) ,size))
    3993 
    3994 (deftype short-float-vector (&optional size)
    3995   `(vector single-float ,size))
    3996 
    3997 (deftype simple-1d-array (&optional size)
    3998   `(simple-array * (,size)))
    3999 
    4000 (deftype simple-long-vector (&optional size)
    4001   `(simple-array (signed-byte 32) (,size)))
    4002 
    4003 (deftype simple-word-vector (&optional size)
    4004   `(simple-array (signed-byte 16) (,size)))
    4005 
    4006 (deftype simple-short-float-vector (&optional size)
    4007   `(simple-array single-float (,size)))
    4008 
    4009 (deftype simple-byte-vector (&optional size)
    4010   `(simple-array (signed-byte 8) (,size)))
    4011 
    4012 (deftype simple-double-float-vector (&optional size)
    4013   `(simple-array double-float (,size)))
    4014 
    40154026(deftype simple-single-float-vector (&optional size)
    40164027  `(simple-array single-float (,size)))
    40174028
     4029(deftype simple-long-float-vector (&optional size)
     4030  `(simple-array double-float (,size)))
     4031
    40184032(deftype simple-fixnum-vector (&optional size)
    40194033  `(simple-array fixnum (,size)))
     4034
     4035(deftype fixnum-vector (&optional size)
     4036  `(array fixnum (,size)))
    40204037
    40214038#+64-bit-target
     
    40344051  `(double-float ,low ,high))
    40354052
     4053#||
    40364054;;; As empty a type as you're likely to find ...
    40374055(deftype extended-char ()
    40384056  "Type of CHARACTERs that aren't BASE-CHARs."
    40394057  nil)
     4058||#
    40404059
    40414060(deftype natural ()
     
    43214340                    (unless (eq ctype *universal-type*)
    43224341                      (generate-predicate-for-ctype ctype)))
     4342                (invalid-type-specifier ()
     4343                  (warn "Invalid type soecifier ~s in slot definition for ~s in class ~s." type (slot-definition-name spec) (slot-definition-class spec))
     4344                  (lambda (v)
     4345                    (cerror "Allow the assignment or initialization."
     4346                            "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."
     4347                            v (slot-definition-name spec) (slot-definition-class spec) (slot-definition-type spec))
     4348                    ;; Suppress further checking, at least for things that use this effective slotd.
     4349                    ;; (It's hard to avoid this, and more trouble than it's worth to do better.)
     4350                    (setf (slot-value spec 'type-predicate) nil)
     4351                    t))
    43234352                (parse-unknown-type (c)
    43244353                   (declare (ignore c))
Note: See TracChangeset for help on using the changeset viewer.