Changeset 15430 for release


Ignore:
Timestamp:
Aug 3, 2012, 8:27:23 PM (7 years ago)
Author:
gb
Message:

Propagate r15427, r15428 to 1.8 branch.
Fixes ticket:976 in 1.8.

Location:
release/1.8/source/level-1
Files:
2 edited

Legend:

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

    r15093 r15430  
    2424(in-package "CCL")
    2525
     26
     27
     28(defstatic *clos-optimizations-active* nil)
     29
     30(defun disable-clos-optimizations (operation operand)
     31  (when *clos-optimizations-active*
     32    (cerror "Peform the requested operation after disabling CLOS optimizations.~&To reenable CLOS optimizations, call ~s."
     33            (make-condition 'simple-error
     34                           :format-control "CLOS optimizations are in effect, so it isn't safe to ~a ~s."
     35                           :format-arguments (list operation operand))
     36            (cons 'snap-reader-methods *clos-optimizations-active*))
     37    (setq *clos-optimizations-active* nil)
     38    (pessimize-clos)
     39    t))
    2640
    2741;;; Early accessors.  These functions eventually all get replaced with
     
    646660                   &allow-other-keys)
    647661  (declare (dynamic-extent keys))
     662  (disable-clos-optimizations 'ensure-generic-function function-name)
    648663  (when gfc-p
    649664    (if (symbolp generic-function-class)
     
    667682        (lambda-list nil ll-p)
    668683        name)
     684  (disable-clos-optimizations 'ensure-generic-function function-name)
    669685  (when gfc-p
    670686    (if (symbolp generic-function-class)
     
    882898         (qualifiers (%method-qualifiers method)))
    883899    (remove-obsoleted-combined-methods method dt specializers)
    884     (maybe-remove-make-instance-optimization gfn method)
    885900    (apply #'invalidate-initargs-vector-for-gf gfn specializers)
    886901    (dolist (m methods)
     
    12811296  (if (class-cell-typep arg class-cell)
    12821297    arg
    1283     (%kernel-restart $xwrongtype arg (car class-cell))))
     1298    (%kernel-restart $xwrongtype arg (class-cell-class class-cell))))
    12841299
    12851300
  • release/1.8/source/level-1/l1-clos.lisp

    r15279 r15430  
    835835;;; This defines a new class.
    836836(defmethod ensure-class-using-class ((class null) name &rest keys &key &allow-other-keys)
     837  (disable-clos-optimizations "define new class" name)
    837838  (multiple-value-bind (metaclass initargs)
    838839      (ensure-class-metaclass-and-initargs class keys)
     
    841842
    842843(defmethod ensure-class-using-class ((class forward-referenced-class) name &rest keys &key &allow-other-keys)
     844  (disable-clos-optimizations "define new class" name)
    843845  (multiple-value-bind (metaclass initargs)
    844846      (ensure-class-metaclass-and-initargs class keys)
     
    861863;;; Redefine an existing (not forward-referenced) class.
    862864(defmethod ensure-class-using-class ((class class) name &rest keys &key)
     865  (disable-clos-optimizations "redefine existing class" name) 
    863866  (multiple-value-bind (metaclass initargs)
    864867      (ensure-class-metaclass-and-initargs class keys)
     
    25312534;;; involving reader methods.
    25322535
    2533 (defun snap-reader-methods (&key known-sealed-world
     2536(defun snap-reader-methods (&rest args
     2537                                  &key known-sealed-world
    25342538                                 (check-conflicts t)
    25352539                                 (optimize-make-instance t))
    25362540  (declare (ignore check-conflicts)
    2537            (ignore known-sealed-world))
    2538   (when optimize-make-instance
    2539     (optimize-named-class-make-instance-methods))
    2540   (let* ((ngf 0)
    2541          (nwin 0))
    2542     (dolist (f (population.data %all-gfs%))
    2543       (incf ngf)
    2544       (when (%snap-reader-method f)
    2545         (incf nwin)))
    2546     (values ngf nwin 0)))
     2541           (ignore known-sealed-world)
     2542           (special *clos-optimizations-active*));bootstrapping
     2543  (if *clos-optimizations-active*
     2544    (values nil nil 0)
     2545    (progn
     2546      (setq *clos-optimizations-active* args)
     2547      (when optimize-make-instance
     2548        (optimize-named-class-make-instance-methods))
     2549      (let* ((ngf 0)
     2550             (nwin 0))
     2551        (dolist (f (population.data %all-gfs%))
     2552          (incf ngf)
     2553          (when (%snap-reader-method f)
     2554            (incf nwin)))
     2555        (values ngf nwin 0)))))
     2556
     2557
     2558   
    25472559
    25482560(defun register-non-dt-dcode-function (f)
Note: See TracChangeset for help on using the changeset viewer.