Changeset 9049


Ignore:
Timestamp:
Apr 8, 2008, 3:17:29 AM (11 years ago)
Author:
gz
Message:

make defclass check for illegal class options (ticket #271)

Location:
trunk/source
Files:
2 edited

Legend:

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

    r8863 r9049  
    30253025
    30263026
    3027 (defun compute-initargs-vector (instance class functions)
     3027;; This is used for compile-time defclass option checking.
     3028(defun class-keyvect (class-arg initargs)
     3029  (let* ((class (if (typep class-arg 'class) class-arg (find-class class-arg nil)))
     3030         (meta-arg (getf initargs :metaclass (if (and class (not (typep class 'forward-referenced-class)))
     3031                                               (class-of class)
     3032                                               *standard-class-class*)))
     3033         (meta-spec (if (quoted-form-p meta-arg) (%cadr meta-arg) meta-arg))
     3034         (meta (if (typep meta-spec 'class) meta-spec (find-class meta-spec))))
     3035    (compute-initargs-vector class meta (list #'initialize-instance #'allocate-instance #'shared-initialize) t)))
     3036
     3037(defun compute-initargs-vector (instance class functions &optional require-rest)
    30283038  (let ((initargs (class-slot-initargs class))
    30293039        (cpl (%inited-class-cpl class)))
     
    30383048                  (memq spec cpl))
    30393049            (let* ((func (%inner-method-function method))
    3040                    (keyvect (if (logbitp $lfbits-aok-bit (lfun-bits func))
    3041                               (return-from compute-initargs-vector t)
     3050                   (keyvect (if (and (logbitp $lfbits-aok-bit (lfun-bits func))
     3051                                     (or (not require-rest)
     3052                                         (logbitp $lfbits-rest-bit (lfun-bits func))))
     3053                              (return-from compute-initargs-vector t)
    30423054                              (lfun-keyvect func))))
    30433055              (dovector (key keyvect)
  • trunk/source/lib/macros.lisp

    r8996 r9049  
    19621962        (let* ((direct-superclasses superclasses)
    19631963               (direct-slot-specs (mapcar #'canonicalize-slot-spec slots))
    1964                (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options ))))
     1964               (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options )))
     1965               (keyvect (class-keyvect class-name other-options)))
     1966          (when (vectorp keyvect)
     1967            (let ((illegal (loop for arg in other-options by #'cddr
     1968                              as key = (if (quoted-form-p arg) (%cadr arg) arg)
     1969                              unless (or (eq key :metaclass) (find key keyvect)) collect key)))
     1970              (when illegal
     1971                (signal-program-error "Class option~p~{ ~s~} is not one of ~s"
     1972                                      (length illegal) illegal keyvect))))
    19651973          `(progn
    19661974            (eval-when (:compile-toplevel)
Note: See TracChangeset for help on using the changeset viewer.