Changeset 14498


Ignore:
Timestamp:
05/15/13 06:42:43 (9 years ago)
Author:
rschlatte
Message:

Unify checks for standard classes

  • fix some cases where we took the slow path for funcallable-standard-class
File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r14493 r14498  
    209209                    '(built-in-class standard-class funcallable-standard-class))))
    210210(fixup-standard-class-hierarchy)
     211
     212(defun std-class-p (class)
     213  (let ((metaclass (class-of class)))
     214    (or (eq metaclass +the-standard-class+)
     215        (eq metaclass +the-funcallable-standard-class+))))
    211216
    212217(defun no-applicable-method (generic-function &rest args)
     
    526531    (return-from std-finalize-inheritance))
    527532  (setf (class-precedence-list class)
    528    (funcall (if (eq (class-of class) +the-standard-class+)
    529                 #'std-compute-class-precedence-list
    530                 #'compute-class-precedence-list)
    531             class))
     533        (funcall (if (std-class-p class)
     534                     #'std-compute-class-precedence-list
     535                     #'compute-class-precedence-list)
     536                 class))
    532537  (setf (class-slots class)
    533         (funcall (if (eq (class-of class) +the-standard-class+)
     538        (funcall (if (std-class-p class)
    534539                     #'std-compute-slots
    535540                     #'compute-slots) class))
     
    682687    (mapcar #'(lambda (name)
    683688               (funcall
    684                 (if (eq (class-of class) +the-standard-class+)
     689                (if (std-class-p class)
    685690                    #'std-compute-effective-slot-definition
    686691                    #'compute-effective-slot-definition)
     
    773778
    774779(defun slot-boundp (object slot-name)
    775   (let* ((class (class-of object))
    776          (metaclass (class-of class)))
    777     (if (or (eq metaclass +the-standard-class+)
    778             (eq metaclass +the-funcallable-standard-class+))
     780  (let ((class (class-of object)))
     781    (if (std-class-p class)
    779782        (std-slot-boundp object slot-name)
    780783        (slot-boundp-using-class class object
     
    792795
    793796(defun slot-makunbound (object slot-name)
    794   (let* ((class (class-of object))
    795          (metaclass (class-of class)))
    796     (if (or (eq metaclass +the-standard-class+)
    797             (eq metaclass +the-funcallable-standard-class+))
     797  (let ((class (class-of object)))
     798    (if (std-class-p class)
    798799        (std-slot-makunbound object slot-name)
    799800        (slot-makunbound-using-class class object
     
    805806
    806807(defun slot-exists-p (object slot-name)
    807   (if (eq (class-of (class-of object)) +the-standard-class+)
    808       (std-slot-exists-p object slot-name)
    809       (slot-exists-p-using-class (class-of object) object slot-name)))
     808  (let ((class (class-of object)))
     809    (if (std-class-p class)
     810        (std-slot-exists-p object slot-name)
     811        (slot-exists-p-using-class class object slot-name))))
    810812
    811813(defun instance-slot-p (slot)
     
    967969(defconstant +the-forward-referenced-class+
    968970  (find-class 'forward-referenced-class))
     971
     972(defun std-generic-function-p (gf)
     973  (eq (class-of gf) +the-standard-generic-function-class+))
    969974
    970975(defvar *extensible-built-in-classes*
     
    17981803          (when mc-p
    17991804            (error "Preliminary ensure-method does not support :method-combination argument."))
    1800           (setf gf (apply (if (eq generic-function-class
    1801                                   +the-standard-generic-function-class+)
    1802                               #'make-instance-standard-generic-function
    1803                               #'make-instance)
    1804                           generic-function-class
    1805                           :name function-name
    1806                           :method-class method-class
    1807                           :method-combination method-combination
    1808                           all-keys))
    1809           gf))))
     1805          (apply #'make-instance-standard-generic-function
     1806                 generic-function-class
     1807                 :name function-name
     1808                 :method-class method-class
     1809                 :method-combination method-combination
     1810                 all-keys)))))
    18101811
    18111812(defun collect-eql-specializer-objects (generic-function)
     
    18231824  (set-funcallable-instance-function
    18241825   gf
    1825    (if (eq (class-of gf) +the-standard-generic-function-class+)
     1826   (if (std-generic-function-p gf)
    18261827       (std-compute-discriminating-function gf)
    18271828       (compute-discriminating-function gf)))
     
    21452146      (if (and
    21462147           (eq (generic-function-method-class gf) +the-standard-method-class+)
    2147            (eq (class-of gf) +the-standard-generic-function-class+))
     2148           (std-generic-function-p gf))
    21482149          (progn
    21492150            (std-add-method gf method)
     
    21992200                                 (method-specializers method) nil)))
    22002201    (when old-method
    2201       (if (and (eq (class-of gf) +the-standard-generic-function-class+)
     2202      (if (and (std-generic-function-p gf)
    22022203               (eq (class-of old-method) +the-standard-method-class+))
    22032204          (std-remove-method gf old-method)
     
    23732374      methods
    23742375      (sort methods
    2375             (if (eq (class-of gf) +the-standard-generic-function-class+)
     2376            (if (std-generic-function-p gf)
    23762377                (let ((method-indices
    23772378                       (argument-precedence-order-indices
     
    24742475(defun slow-method-lookup (gf args)
    24752476  (let ((applicable-methods
    2476           (if (eq (class-of gf) +the-standard-generic-function-class+)
     2477          (if (std-generic-function-p gf)
    24772478              (std-compute-applicable-methods gf args)
    24782479              (or (compute-applicable-methods-using-classes gf (mapcar #'class-of args))
    24792480                  (compute-applicable-methods gf args)))))
    24802481    (if applicable-methods
    2481         (let* ((emfun (funcall (if (eq (class-of gf)
    2482                                        +the-standard-generic-function-class+)
     2482        (let* ((emfun (funcall (if (std-generic-function-p gf)
    24832483                                   #'std-compute-effective-method
    24842484                                   #'compute-effective-method)
     
    26032603       (let ((next-emfun
    26042604              (funcall
    2605                (if (eq (class-of gf) +the-standard-generic-function-class+)
     2605               (if (std-generic-function-p gf)
    26062606                   #'std-compute-effective-method
    26072607                   #'compute-effective-method)
     
    28762876  (let* ((slot-name (slot-definition-name slot-definition))
    28772877         (lambda-expression
    2878           (if (eq (class-of class) +the-standard-class+)
     2878          (if (std-class-p class)
    28792879              `(lambda (object) (std-slot-value object ',slot-name))
    28802880              `(lambda (object) (slot-value object ',slot-name))))
     
    28932893                                         (autocompile fast-function))
    28942894                     :slot-definition ,slot-definition))
    2895          (method-class (if (eq class +the-standard-class+)
     2895         (method-class (if (std-class-p class)
    28962896                           +the-standard-reader-method-class+
    28972897                           (apply #'reader-method-class class slot-definition
     
    29122912                      :generic-function nil ; handled by add-method
    29132913                      initargs))))
    2914       (if (eq (class-of gf) +the-standard-generic-function-class+)
     2914      (if (std-generic-function-p gf)
    29152915          (progn
    29162916            (std-add-method gf method)
     
    29242924  (let* ((slot-name (slot-definition-name slot-definition))
    29252925         (lambda-expression
    2926           (if (eq (class-of class) +the-standard-class+)
     2926          (if (std-class-p class)
    29272927              `(lambda (new-value object)
    29282928                 (setf (std-slot-value object ',slot-name) new-value))
     
    29432943                                         (autocompile fast-function))
    29442944                     :slot-definition ,slot-definition))
    2945          (method-class (if (eq class +the-standard-class+)
     2945         (method-class (if (std-class-p class)
    29462946                           +the-standard-writer-method-class+
    29472947                           (apply #'writer-method-class class slot-definition
     
    29622962                      :generic-function nil ; handled by add-method
    29632963                      initargs))))
    2964       (if (eq (class-of gf) +the-standard-generic-function-class+)
     2964      (if (std-generic-function-p gf)
    29652965          (progn
    29662966            (std-add-method gf method)
     
    34823482                                                    initargs))
    34833483             (mapcan #'(lambda (gf)
    3484                          (if (eq (class-of gf)
    3485                                  +the-standard-generic-function-class+)
     3484                         (if (std-generic-function-p gf)
    34863485                             (std-compute-applicable-methods gf args)
    34873486                             (compute-applicable-methods gf args)))
Note: See TracChangeset for help on using the changeset viewer.