Ignore:
Timestamp:
05/08/10 21:55:47 (11 years ago)
Author:
astalla
Message:

Fixed and rationalized class precedence list computation for java-class metaclasses.

File:
1 edited

Legend:

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

    r12583 r12660  
    326326
    327327;;; JAVA-CLASS support
     328(defconstant +java-lang-object+ (jclass "java.lang.Object"))
    328329
    329330(defclass java-class (standard-class)
     
    331332     :initform (error "class is required")
    332333     :reader java-class-jclass)))
     334
     335;;init java.lang.Object class
     336(defconstant +java-lang-object-class+
     337  (%register-java-class +java-lang-object+
     338      (mop::ensure-class (make-symbol "java.lang.Object")
     339             :metaclass (find-class 'java-class)
     340             :direct-superclasses (list (find-class 'java-object))
     341             :java-class +java-lang-object+)))
    333342
    334343(defun ensure-java-class (jclass)
     
    337346  class
    338347  (%register-java-class
    339    jclass (mop::ensure-class (make-symbol (jclass-name jclass))
    340            :metaclass (find-class 'java-class)
    341            :direct-superclasses (if (jclass-superclass-p jclass (jclass "java.lang.Object"))
    342                   (list (find-class 'java-object))
    343                   (mapcar #'ensure-java-class
    344                     (delete nil
    345                       (concatenate 'list (list (jclass-superclass jclass))
    346                        (jclass-interfaces jclass)))))
    347            :java-class jclass)))))
     348   jclass (mop::ensure-class
     349     (make-symbol (jclass-name jclass))
     350     :metaclass (find-class 'java-class)
     351     :direct-superclasses (mapcar #'ensure-java-class
     352                (remove-duplicates
     353                 (delete nil
     354                   (concatenate 'list
     355                    (list (jclass-superclass jclass))
     356                    (jclass-interfaces jclass)))
     357                 :key #'jclass-name :test #'string=))
     358     :java-class jclass)))))
     359
     360(defmethod mop::compute-class-precedence-list ((class java-class))
     361  "Sort classes this way:
     362   1. Java classes (but not java.lang.Object)
     363   2. Java interfaces
     364   3. java.lang.Object
     365   4. other classes
     366   Rationale:
     367   1. Concrete classes are the most specific.
     368   2. Then come interfaces.
     369     So if a generic function is specialized both on an interface and a concrete class,
     370     the concrete class comes first.
     371   3. because everything is an Object.
     372   4. to handle base CLOS classes.
     373   Note: Java interfaces are not sorted among themselves in any way, so if a
     374   gf is specialized on two different interfaces and you apply it to an object that
     375   implements both, it is unspecified which method will be called."
     376  (let ((cpl (call-next-method)))
     377    (flet ((score (class)
     378       (if (not (typep class 'java-class))
     379     4
     380     (cond
     381       ((jcall (jmethod "java.lang.Object" "equals" "java.lang.Object")
     382         (java-class-jclass class) +java-lang-object+) 3)
     383       ((jclass-interface-p (java-class-jclass class)) 2)
     384       (t 1)))))
     385      (stable-sort cpl #'(lambda (x y)
     386         (< (score x) (score y)))))))
    348387   
    349388(defmethod make-instance ((class java-class) &rest initargs &key &allow-other-keys)
Note: See TracChangeset for help on using the changeset viewer.