Changeset 14004


Ignore:
Timestamp:
07/13/12 14:07:31 (8 years ago)
Author:
rschlatte
Message:

Move definition of eql-specializer metaclass into Lisp side

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

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

    r13983 r14004  
    200200    LispObject layout = getInstanceSlotValue(symLayout);
    201201    if (layout == UNBOUND_VALUE)
    202         return null;
     202      return null;
    203203
    204204    if (! (layout instanceof Layout)) {
    205         (new Error()).printStackTrace();
    206         LispThread.currentThread().printBacktrace();
    207         return (Layout)Lisp.error(Symbol.TYPE_ERROR,
    208                 new SimpleString("The value " + layout.princToString()
    209                     + " is not of expected type " + Symbol.LAYOUT.princToString()
    210                     + " in class " + this.princToString() + "."));
    211       }
     205      (new Error()).printStackTrace();
     206      LispThread.currentThread().printBacktrace();
     207      System.out.println("Class: " + this.princToString());
     208      return (Layout)Lisp.error(Symbol.TYPE_ERROR,
     209              new SimpleString("The value " + layout.princToString()
     210                               + " is not of expected type "
     211                               + Symbol.LAYOUT.princToString()
     212                               + " in class " + this.princToString() + "."));
     213    }
    212214   
    213215    return (layout == UNBOUND_VALUE) ? null : (Layout)layout;
     
    449451  public static final StandardClass SPECIALIZER =
    450452    addStandardClass(Symbol.SPECIALIZER, list(METAOBJECT));
    451   public static final StandardClass EQL_SPECIALIZER =
    452     addStandardClass(Symbol.EQL_SPECIALIZER, list(SPECIALIZER));
    453453
    454454    public static final StandardClass SLOT_DEFINITION =
     
    732732    METAOBJECT.setCPL(METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T);
    733733    SPECIALIZER.setCPL(SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T);
    734     EQL_SPECIALIZER.setCPL(EQL_SPECIALIZER, SPECIALIZER, METAOBJECT,
    735                            STANDARD_OBJECT, BuiltInClass.CLASS_T);
    736     EQL_SPECIALIZER.setDirectSlotDefinitions(
    737       list(new SlotDefinition(Symbol.OBJECT, NIL, constantlyNil),
    738            new SlotDefinition(symDirectMethods, NIL, constantlyNil)));
    739734    METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T);
    740735    STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT,
     
    913908    CLASS.finalizeClass();
    914909    BUILT_IN_CLASS.finalizeClass();
    915     EQL_SPECIALIZER.finalizeClass();
    916910    METHOD_COMBINATION.finalizeClass();
    917911    SHORT_METHOD_COMBINATION.finalizeClass();
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r14003 r14004  
    215215    (add-subclasses 'effective-slot-definition
    216216                    'standard-effective-slot-definition)
    217     (add-subclasses 'specializer '(eql-specializer class))
    218217    (add-subclasses 'class
    219218                    '(built-in-class forward-referenced-class standard-class
     
    484483  slot)
    485484
     485(declaim (notinline direct-slot-definition-class))
     486(defun direct-slot-definition-class (class &rest args)
     487  (declare (ignore class args))
     488  +the-standard-direct-slot-definition-class+)
     489
    486490(defun make-direct-slot-definition (class &rest args)
    487491  (let ((slot-class (apply #'direct-slot-definition-class class args)))
    488492    (if (eq slot-class +the-standard-direct-slot-definition-class+)
    489   (let ((slot (make-slot-definition +the-standard-direct-slot-definition-class+)))
    490     (apply #'init-slot-definition slot :allocation-class class args)
    491     slot)
    492   (progn
    493     (let ((slot (apply #'make-instance slot-class :allocation-class class
    494            args)))
    495       slot)))))
     493        (let ((slot (make-slot-definition +the-standard-direct-slot-definition-class+)))
     494          (apply #'init-slot-definition slot :allocation-class class args)
     495          slot)
     496        (progn
     497          (let ((slot (apply #'make-instance slot-class :allocation-class class
     498                             args)))
     499            slot)))))
     500
     501(declaim (notinline effective-slot-definition-class))
     502(defun effective-slot-definition-class (class &rest args)
     503  (declare (ignore class args))
     504  +the-standard-effective-slot-definition-class+)
    496505
    497506(defun make-effective-slot-definition (class &rest args)
    498507  (let ((slot-class (apply #'effective-slot-definition-class class args)))
    499508    (if (eq slot-class +the-standard-effective-slot-definition-class+)
    500   (let ((slot (make-slot-definition +the-standard-effective-slot-definition-class+)))
    501     (apply #'init-slot-definition slot args)
    502     slot)
    503   (progn
    504     (let ((slot (apply #'make-instance slot-class args)))
    505       slot)))))
     509        (let ((slot (make-slot-definition +the-standard-effective-slot-definition-class+)))
     510          (apply #'init-slot-definition slot args)
     511          slot)
     512        (progn
     513          (let ((slot (apply #'make-instance slot-class args)))
     514            slot)))))
    506515
    507516;;; finalize-inheritance
     
    530539            class))
    531540  (setf (class-slots class)
    532                    (funcall (if (eq (class-of class) +the-standard-class+)
    533                                 #'std-compute-slots
     541        (funcall (if (eq (class-of class) +the-standard-class+)
     542                     #'std-compute-slots
    534543                     #'compute-slots) class))
    535544  (let ((old-layout (class-layout class))
     
    689698        (types (delete-duplicates
    690699                (delete t (mapcar #'slot-definition-type direct-slots))
    691                 :test #'equal))
    692         )
     700                :test #'equal)))
    693701    (make-effective-slot-definition
    694702     class
     
    712720                 ((= 1 (length types)) types)
    713721                 (t (list* 'and types)))
    714      :documentation (documentation documentation-slot t))))
     722     :documentation (if documentation-slot
     723                        (documentation documentation-slot t)
     724                        nil))))
    715725
    716726;;; Standard instance slot access
     
    817827  (std-allocate-instance class))
    818828
     829(defun maybe-finalize-class-subtree (class)
     830  (when (every #'class-finalized-p (class-direct-superclasses class))
     831    (finalize-inheritance class)
     832    (dolist (subclass (class-direct-subclasses class))
     833      (maybe-finalize-class-subtree subclass))))
     834
    819835(defun make-instance-standard-class (metaclass
    820836                                     &rest initargs
     
    824840  (declare (ignore metaclass))
    825841  (let ((class (std-allocate-instance +the-standard-class+)))
    826     (check-initargs (list #'allocate-instance #'initialize-instance)
    827                     (list* class initargs)
    828                     class t initargs
    829                     *make-instance-initargs-cache* 'make-instance)
     842    (unless *clos-booting*
     843      (check-initargs (list #'allocate-instance #'initialize-instance)
     844                      (list* class initargs)
     845                      class t initargs
     846                      *make-instance-initargs-cache* 'make-instance))
    830847    (%set-class-name name class)
    831     (%set-class-layout nil class)
     848    ;; KLUDGE: necessary in define-primordial-class, otherwise
     849    ;; StandardClass.getClassLayout() throws an error
     850    (unless *clos-booting* (%set-class-layout nil class))
    832851    (%set-class-direct-subclasses ()  class)
    833852    (%set-class-direct-methods ()  class)
     
    870889  (maybe-finalize-class-subtree class)
    871890  (values))
     891
     892;;; Bootstrap the lower parts of the metaclass hierarchy.
     893
     894(defmacro define-primordial-class (name superclasses direct-slots)
     895  "Primitive class definition tool.
     896No non-standard metaclasses, accessor methods, duplicate slots,
     897non-existent superclasses, default initargs, or other complicated stuff.
     898Handle with care."
     899  (let ((class (gensym)))
     900    `(let ((,class (make-instance-standard-class
     901                    nil
     902                    :name ',name
     903                    :direct-superclasses ',(mapcar #'find-class superclasses)
     904                    :direct-slots ,(canonicalize-direct-slots direct-slots))))
     905       (%set-find-class ',name ,class)
     906       ,class)))
     907
     908(define-primordial-class eql-specializer (specializer)
     909  ((object :initform nil)
     910   (direct-methods :initform nil)))
    872911
    873912(defvar *extensible-built-in-classes*
     
    13441383            ;; setup, so have to rely on plain functions here.
    13451384            (let ((instance (std-allocate-instance (find-class 'eql-specializer))))
    1346               (setf (std-slot-value instance 'sys::object) object)
     1385              (setf (std-slot-value instance 'object) object)
    13471386              (setf (std-slot-value instance 'direct-methods) nil)
    13481387              instance))))
     
    13501389(defun eql-specializer-object (eql-specializer)
    13511390  (check-type eql-specializer eql-specializer)
    1352   (std-slot-value eql-specializer 'sys::object))
     1391  (std-slot-value eql-specializer 'object))
    13531392
    13541393;;; Initial versions of some method metaobject readers.  Defined on
     
    29993038  class)
    30003039
    3001 (defun maybe-finalize-class-subtree (class)
    3002   (when (every #'class-finalized-p (class-direct-superclasses class))
    3003     (finalize-inheritance class)
    3004     (dolist (subclass (class-direct-subclasses class))
    3005       (maybe-finalize-class-subtree subclass))))
    3006 
    30073040(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options)
    30083041  (unless (>= (length form) 3)
Note: See TracChangeset for help on using the changeset viewer.