Changeset 8624


Ignore:
Timestamp:
Feb 29, 2008, 6:18:55 AM (14 years ago)
Author:
gb
Message:

ENSURE-CLASS, ENSURE-CLASS-FOR-DEFCLASS: observe *SEALED-CLOS-WORLD*.

SNAP-READER-METHODS sets *SEALED-CLOS-WORLD*.

New function PESSIMIZE-CLOS tries to undo GF and MAKE-INSTANCE
optimizations, then clears *SEALED-CLOS-WORLD*.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-clos.lisp

    r8421 r8624  
    756756
    757757(defun ensure-class (name &rest keys &key &allow-other-keys)
    758   (apply #'ensure-class-using-class (find-class name nil) name keys))
     758  (declare (special *sealed-clos-world*))
     759  (if *sealed-clos-world*
     760    (error "Class (re)definition is not allowed in this environment")
     761    (apply #'ensure-class-using-class (find-class name nil) name keys)))
    759762
    760763(defparameter *defclass-redefines-improperly-named-classes-pedantically*
     
    766769
    767770(defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys)
    768   (record-source-file name 'class)
    769   ;; Maybe record source-file information for accessors as well
    770   ;; We should probably record them as "accessors of the class", since
    771   ;; there won't be any other explicit defining form associated with
    772   ;; them.
    773   (let* ((existing-class (find-class name nil)))
    774     (when (and *defclass-redefines-improperly-named-classes-pedantically*
    775                existing-class
    776               (not (eq (class-name existing-class) name)))
    777       ;; Class isn't properly named; act like it didn't exist
    778       (setq existing-class nil))
    779     (apply #'ensure-class-using-class existing-class name keys)))
     771  (declare (special *sealed-clos-world*))
     772  (if *sealed-clos-world*
     773    (error "Class (re)definition is not allowed in this environment")
     774    (progn
     775      (record-source-file name 'class)
     776      ;; Maybe record source-file information for accessors as well
     777      ;; We should probably record them as "accessors of the class", since
     778      ;; there won't be any other explicit defining form associated with
     779      ;; them.
     780      (let* ((existing-class (find-class name nil)))
     781        (when (and *defclass-redefines-improperly-named-classes-pedantically*
     782                   existing-class
     783                   (not (eq (class-name existing-class) name)))
     784          ;; Class isn't properly named; act like it didn't exist
     785          (setq existing-class nil))
     786        (apply #'ensure-class-using-class existing-class name keys)))))
    780787
    781788
     
    22642271                                 (check-conflicts t)
    22652272                                 (optimize-make-instance t))
    2266   (declare (ignore check-conflicts))
     2273  (declare (ignore check-conflicts)
     2274           (special *sealed-clos-world*))
    22672275  (unless known-sealed-world
    22682276    (cerror "Proceed, if it's known that no new classes or methods will be defined."
     
    22762284      (when (%snap-reader-method f)
    22772285        (incf nwin)))
     2286    (setq *sealed-clos-world* t)
    22782287    (values ngf nwin 0)))
    22792288
     2289(defun pessimize-clos ()
     2290  (declare (special *sealed-clos-world*))
     2291  (when *sealed-clos-world*
     2292    ;; Undo MAKE-INSTANCE optimization
     2293    (maphash (lambda (class-name class-cell)
     2294               (declare (ignore class-name))
     2295               (setf (class-cell-instantiate class-cell) '%make-instance))
     2296             %find-classes%)
     2297    ;; Un-snap reader methods, undo other GF optimizations.
     2298    (dolist (f (population-data %all-gfs%))
     2299      (let* ((dt (%gf-dispatch-table f)))
     2300        (clear-gf-dispatch-table dt)
     2301        (compute-dcode f)))
     2302    (setq *sealed-clos-world* nil)
     2303    t))
Note: See TracChangeset for help on using the changeset viewer.