Changeset 9240


Ignore:
Timestamp:
Apr 23, 2008, 4:11:55 PM (11 years ago)
Author:
gz
Message:

Propagate r9237 to trunk: Stop ignoring defstruct slot type
specifiers. Types are checked unconditionally (i.e. regardless of
safety settings) by constructors and slot setters.

Location:
trunk/source
Files:
6 edited

Legend:

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

    r9134 r9240  
    177177         initargs))
    178178
     179;; Bootstrapping version, replaced in l1-typesys
     180(defun standardized-type-specifier (spec)
     181  (when (and (consp spec)
     182             (memq (%car spec) '(and or))
     183             (consp (%cdr spec))
     184             (null (%cddr spec)))
     185    (setq spec (%cadr spec)))
     186  (if (consp spec)
     187    (cons (%car spec) (mapcar #'standardized-type-specifier (%cdr spec)))
     188    (or (cdr (assoc spec '((string . base-string))))
     189        spec)))
     190
    179191;;; The type of an effective slot definition is the intersection of
    180192;;; the types of the direct slot definitions it's initialized from.
     
    183195        (unless (eq t (%slot-definition-type dslotd))
    184196          (return)))
    185       (type-specifier
    186        (specifier-type `(and ,@(mapcar #'(lambda (d)
    187                                            (or (%slot-definition-type d)
    188                                                t))
    189                                        direct-slots))))))
    190 
     197      (standardized-type-specifier
     198       `(and ,@(mapcar #'(lambda (d) (or (%slot-definition-type d) t))
     199                       direct-slots)))))
    191200
    192201(defmethod compute-effective-slot-definition ((class slots-class)
     
    267276
    268277;;; Should eventually do something here.
    269 (defmethod compute-slots ((s structure-class))
    270   (call-next-method))
     278;(defmethod compute-slots ((s structure-class))
     279;  (call-next-method))
    271280
    272281(defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
  • trunk/source/level-1/l1-streams.lisp

    r9184 r9240  
    373373
    374374(defstruct io-buffer
    375   (buffer nil :type (or (simple-array * (*)) null))
     375               ;; This type is too complex during bootstrapping.
     376  (buffer nil #|:type (or (simple-array * (*)) null)|#)
    376377  (bufptr nil :type (or macptr null))
    377378  (size 0 :type fixnum)                 ; size (in octets) of buffer
     
    399400  (element-type 'character)
    400401  (element-shift 0 :type fixnum)        ;element shift count
    401   (charpos 0 :type (or nil fixnum))     ;position of cursor
    402   (device -1 :type fixnum)              ;file descriptor
     402  (charpos 0 :type (or null fixnum))     ;position of cursor
     403  (device -1 :type (or null fixnum))     ;file descriptor
    403404  (advance-function 'ioblock-advance)
    404405  (listen-function 'ioblock-listen)
  • trunk/source/level-1/l1-typesys.lisp

    r8854 r9240  
    14791479        *universal-type*
    14801480        res)))
     1481
     1482(defun standardized-type-specifier (spec)
     1483  (type-specifier (specifier-type spec)))
    14811484
    14821485(defun modified-numeric-type (base
  • trunk/source/lib/defstruct-lds.lisp

    r8997 r9240  
    210210    (when (stringp (%car slots))
    211211      (setq documentation (%car slots) slots (%cdr slots)))
    212     (let (name args read-only initform)
     212    (let (name args read-only initform slot-type)
    213213      (while slots
    214214         (if (atom (%car slots))
     
    216216           (setq name (%caar slots) args (%cdar slots)))
    217217         (unless (symbolp name) (go bad-slot))
    218          (setq read-only nil initform (pop args))
     218         (setq read-only nil initform (pop args) slot-type t)
    219219         (while args
    220220            (when (atom (cdr args)) (go bad-slot))
    221             (cond ((eq (%car args) :type) )
     221            ;; To do: check for multiple/incompatible options.
     222            (cond ((eq (%car args) :type)
     223                   (setq slot-type (%cadr args)))
    222224                  ((eq (%car args) :read-only)
    223225                   (setq read-only (%cadr args)))
    224226                  (t (go bad-slot)))
    225227            (setq args (%cddr args)))
    226          (push (make-ssd name initform offset read-only) slot-list)
     228         (push (make-ssd name initform offset read-only slot-type) slot-list)
    227229         (setq slots (%cdr slots) offset (%i+ offset 1))))
    228230
     
    327329           (setq arg-kind arg))
    328330          ((setq slot (named-ssd arg (sd-slots sd)))
    329            (when (or (eq arg-kind '&optional) (eq arg-kind '&key))
     331           (when (or (eq arg-kind '&optional) (eq arg-kind '&key)
     332                     ;; for &aux variables, init value is implementation-defined, however it's not supposed
     333                     ;; to signal a type error until slot is assigned, so might as well just use the initform.
     334                     (eq arg-kind '&aux))
    330335             (setq arg (list arg (ssd-initform slot))))
    331336           (push slot used-slots))
  • trunk/source/lib/foreign-types.lisp

    r9212 r9240  
    186186
    187187  (defstruct foreign-type-class
    188     (name nil :type symbol)
     188    (name nil #|:type symbol|#)
    189189    (include nil :type (or null foreign-type-class))
    190190    (unparse nil :type (or null function))
     
    200200    (result-tn nil :type (or null function))
    201201    (subtypep nil :type (or null function)))
    202 
    203202
    204203  (defvar *foreign-type-classes* (make-hash-table :test #'eq))
  • trunk/source/lib/pprint.lisp

    r9121 r9240  
    162162(cl:defstruct (pprint-dispatch-table (:conc-name nil) (:copier nil))
    163163  (conses-with-cars (make-hash-table :test #'eq) :type hash-table)
    164   (structures (make-hash-table :test #'eq) :type hash-table)
     164  (structures (make-hash-table :test #'eq) :type (or null hash-table))
    165165  (others nil :type list))
    166166
Note: See TracChangeset for help on using the changeset viewer.