Changeset 14004
- Timestamp:
- 07/13/12 14:07:31 (9 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
r13983 r14004 200 200 LispObject layout = getInstanceSlotValue(symLayout); 201 201 if (layout == UNBOUND_VALUE) 202 202 return null; 203 203 204 204 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 } 212 214 213 215 return (layout == UNBOUND_VALUE) ? null : (Layout)layout; … … 449 451 public static final StandardClass SPECIALIZER = 450 452 addStandardClass(Symbol.SPECIALIZER, list(METAOBJECT)); 451 public static final StandardClass EQL_SPECIALIZER =452 addStandardClass(Symbol.EQL_SPECIALIZER, list(SPECIALIZER));453 453 454 454 public static final StandardClass SLOT_DEFINITION = … … 732 732 METAOBJECT.setCPL(METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); 733 733 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)));739 734 METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); 740 735 STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT, … … 913 908 CLASS.finalizeClass(); 914 909 BUILT_IN_CLASS.finalizeClass(); 915 EQL_SPECIALIZER.finalizeClass();916 910 METHOD_COMBINATION.finalizeClass(); 917 911 SHORT_METHOD_COMBINATION.finalizeClass(); -
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r14003 r14004 215 215 (add-subclasses 'effective-slot-definition 216 216 'standard-effective-slot-definition) 217 (add-subclasses 'specializer '(eql-specializer class))218 217 (add-subclasses 'class 219 218 '(built-in-class forward-referenced-class standard-class … … 484 483 slot) 485 484 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 486 490 (defun make-direct-slot-definition (class &rest args) 487 491 (let ((slot-class (apply #'direct-slot-definition-class class args))) 488 492 (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+) 496 505 497 506 (defun make-effective-slot-definition (class &rest args) 498 507 (let ((slot-class (apply #'effective-slot-definition-class class args))) 499 508 (if (eq slot-class +the-standard-effective-slot-definition-class+) 500 501 502 503 504 505 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))))) 506 515 507 516 ;;; finalize-inheritance … … 530 539 class)) 531 540 (setf (class-slots class) 532 533 541 (funcall (if (eq (class-of class) +the-standard-class+) 542 #'std-compute-slots 534 543 #'compute-slots) class)) 535 544 (let ((old-layout (class-layout class)) … … 689 698 (types (delete-duplicates 690 699 (delete t (mapcar #'slot-definition-type direct-slots)) 691 :test #'equal)) 692 ) 700 :test #'equal))) 693 701 (make-effective-slot-definition 694 702 class … … 712 720 ((= 1 (length types)) types) 713 721 (t (list* 'and types))) 714 :documentation (documentation documentation-slot t)))) 722 :documentation (if documentation-slot 723 (documentation documentation-slot t) 724 nil)))) 715 725 716 726 ;;; Standard instance slot access … … 817 827 (std-allocate-instance class)) 818 828 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 819 835 (defun make-instance-standard-class (metaclass 820 836 &rest initargs … … 824 840 (declare (ignore metaclass)) 825 841 (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)) 830 847 (%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)) 832 851 (%set-class-direct-subclasses () class) 833 852 (%set-class-direct-methods () class) … … 870 889 (maybe-finalize-class-subtree class) 871 890 (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. 896 No non-standard metaclasses, accessor methods, duplicate slots, 897 non-existent superclasses, default initargs, or other complicated stuff. 898 Handle 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))) 872 911 873 912 (defvar *extensible-built-in-classes* … … 1344 1383 ;; setup, so have to rely on plain functions here. 1345 1384 (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) 1347 1386 (setf (std-slot-value instance 'direct-methods) nil) 1348 1387 instance)))) … … 1350 1389 (defun eql-specializer-object (eql-specializer) 1351 1390 (check-type eql-specializer eql-specializer) 1352 (std-slot-value eql-specializer ' sys::object))1391 (std-slot-value eql-specializer 'object)) 1353 1392 1354 1393 ;;; Initial versions of some method metaobject readers. Defined on … … 2999 3038 class) 3000 3039 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 3007 3040 (defmacro defclass (&whole form name direct-superclasses direct-slots &rest options) 3008 3041 (unless (>= (length form) 3)
Note: See TracChangeset
for help on using the changeset viewer.