Changeset 13273
- Timestamp:
- 05/01/11 22:34:47 (11 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 6 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/LispClass.java
r13221 r13273 42 42 = new ConcurrentHashMap<Symbol, LispObject>(); 43 43 44 public static LispClass addClass(Symbol symbol, LispClassc)44 public static <T extends LispClass> T addClass(Symbol symbol, T c) 45 45 { 46 46 map.put(symbol, c); -
trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java
r12752 r13273 40 40 public SlotDefinition() 41 41 { 42 super(StandardClass.S LOT_DEFINITION,43 StandardClass.S LOT_DEFINITION.getClassLayout().getLength());42 super(StandardClass.STANDARD_SLOT_DEFINITION, 43 StandardClass.STANDARD_SLOT_DEFINITION.getClassLayout().getLength()); 44 44 slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; 45 45 } 46 46 47 public SlotDefinition(StandardClass clazz) 48 { 49 super(clazz, clazz.getClassLayout().getLength()); 50 slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; 51 } 47 public SlotDefinition(StandardClass clazz) { 48 super(clazz, clazz.getClassLayout().getLength()); 49 slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; 50 } 51 52 public SlotDefinition(StandardClass clazz, LispObject name) { 53 super(clazz, clazz.getClassLayout().getLength()); 54 slots[SlotDefinitionClass.SLOT_INDEX_NAME] = name; 55 slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = NIL; 56 slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = 57 new Cons(PACKAGE_KEYWORD.intern(((Symbol)name).getName())); 58 slots[SlotDefinitionClass.SLOT_INDEX_READERS] = NIL; 59 slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE; 60 slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; 61 } 52 62 53 63 public SlotDefinition(LispObject name, LispObject readers) … … 93 103 public static StandardObject checkSlotDefinition(LispObject obj) { 94 104 if (obj instanceof StandardObject) return (StandardObject)obj; 95 return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION); 105 return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION); 96 106 } 97 107 … … 132 142 public LispObject execute(LispObject slotDefinitionClass) 133 143 { 134 144 return new SlotDefinition((StandardClass) slotDefinitionClass); 135 145 } 136 146 }; -
trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java
r12288 r13273 48 48 public static final int SLOT_INDEX_LOCATION = 8; 49 49 50 public SlotDefinitionClass() 51 { 52 super(Symbol.SLOT_DEFINITION, list(StandardClass.STANDARD_OBJECT)); 50 /** 51 * For internal use only. This constructor hardcodes the layout of the class, and can't be used 52 * to create arbitrary subclasses of slot-definition. 53 */ 54 public SlotDefinitionClass(Symbol symbol, LispObject cpl) { 55 super(symbol, cpl); 53 56 Package pkg = PACKAGE_SYS; 54 57 LispObject[] instanceSlotNames = { … … 64 67 }; 65 68 setClassLayout(new Layout(this, instanceSlotNames, NIL)); 69 //Set up slot definitions so that this class can be extended by users 70 LispObject slotDefinitions = NIL; 71 for(int i = instanceSlotNames.length - 1; i >= 0; i--) { 72 slotDefinitions = slotDefinitions.push(new SlotDefinition(this, instanceSlotNames[i])); 73 } 74 setDirectSlotDefinitions(slotDefinitions); 75 setSlotDefinitions(slotDefinitions); 76 66 77 setFinalized(true); 67 78 } -
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
r13195 r13273 387 387 addStandardClass(Symbol.STANDARD_OBJECT, list(BuiltInClass.CLASS_T)); 388 388 389 public static final StandardClass SLOT_DEFINITION = 390 new SlotDefinitionClass(); 389 public static final StandardClass SLOT_DEFINITION = 390 addStandardClass(Symbol.SLOT_DEFINITION, list(STANDARD_OBJECT)); 391 public static final StandardClass STANDARD_SLOT_DEFINITION = 392 addClass(Symbol.STANDARD_SLOT_DEFINITION, new SlotDefinitionClass(Symbol.STANDARD_SLOT_DEFINITION, list(SLOT_DEFINITION))); 393 391 394 static 392 395 { 393 addClass(Symbol.SLOT_DEFINITION, SLOT_DEFINITION);396 SLOT_DEFINITION.finalizeClass(); 394 397 395 398 STANDARD_CLASS.setClassLayout(layoutStandardClass); … … 400 403 addStandardClass(Symbol.DIRECT_SLOT_DEFINITION, list(SLOT_DEFINITION)); 401 404 public static final StandardClass EFFECTIVE_SLOT_DEFINITION = 402 addStandardClass(Symbol.EFFECTIVE_SLOT_DEFINITION, list(SLOT_DEFINITION)); 405 addStandardClass(Symbol.EFFECTIVE_SLOT_DEFINITION, list(SLOT_DEFINITION)); 406 // addStandardClass(Symbol.STANDARD_SLOT_DEFINITION, list(SLOT_DEFINITION)); 407 public static final StandardClass STANDARD_DIRECT_SLOT_DEFINITION = 408 addClass(Symbol.STANDARD_DIRECT_SLOT_DEFINITION, 409 new SlotDefinitionClass(Symbol.STANDARD_DIRECT_SLOT_DEFINITION, 410 list(STANDARD_SLOT_DEFINITION, DIRECT_SLOT_DEFINITION))); 411 public static final StandardClass STANDARD_EFFECTIVE_SLOT_DEFINITION = 412 addClass(Symbol.STANDARD_EFFECTIVE_SLOT_DEFINITION, 413 new SlotDefinitionClass(Symbol.STANDARD_EFFECTIVE_SLOT_DEFINITION, 414 list(STANDARD_SLOT_DEFINITION, EFFECTIVE_SLOT_DEFINITION))); 415 403 416 404 417 // BuiltInClass.FUNCTION is also null here (see previous comment). … … 742 755 743 756 DIRECT_SLOT_DEFINITION.setCPL(DIRECT_SLOT_DEFINITION, SLOT_DEFINITION, 744 757 STANDARD_OBJECT, BuiltInClass.CLASS_T); 745 758 DIRECT_SLOT_DEFINITION.finalizeClass(); 746 759 EFFECTIVE_SLOT_DEFINITION.setCPL(EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION, 747 760 STANDARD_OBJECT, BuiltInClass.CLASS_T); 748 761 EFFECTIVE_SLOT_DEFINITION.finalizeClass(); 762 STANDARD_SLOT_DEFINITION.setCPL(STANDARD_SLOT_DEFINITION, SLOT_DEFINITION, 763 STANDARD_OBJECT, BuiltInClass.CLASS_T); 764 STANDARD_SLOT_DEFINITION.finalizeClass(); 765 STANDARD_DIRECT_SLOT_DEFINITION.setCPL(STANDARD_DIRECT_SLOT_DEFINITION, STANDARD_SLOT_DEFINITION, 766 DIRECT_SLOT_DEFINITION, SLOT_DEFINITION, STANDARD_OBJECT, 767 BuiltInClass.CLASS_T); 768 STANDARD_DIRECT_SLOT_DEFINITION.finalizeClass(); 769 STANDARD_EFFECTIVE_SLOT_DEFINITION.setCPL(STANDARD_EFFECTIVE_SLOT_DEFINITION, STANDARD_SLOT_DEFINITION, 770 EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION, STANDARD_OBJECT, 771 BuiltInClass.CLASS_T); 772 STANDARD_EFFECTIVE_SLOT_DEFINITION.finalizeClass(); 749 773 750 774 // STANDARD-METHOD -
trunk/abcl/src/org/armedbear/lisp/Symbol.java
r13259 r13273 2962 2962 public static final Symbol EFFECTIVE_SLOT_DEFINITION = 2963 2963 PACKAGE_MOP.addExternalSymbol("EFFECTIVE-SLOT-DEFINITION"); 2964 public static final Symbol STANDARD_SLOT_DEFINITION = 2965 PACKAGE_MOP.addExternalSymbol("STANDARD-SLOT-DEFINITION"); 2966 public static final Symbol STANDARD_DIRECT_SLOT_DEFINITION = 2967 PACKAGE_MOP.addExternalSymbol("STANDARD-DIRECT-SLOT-DEFINITION"); 2968 public static final Symbol STANDARD_EFFECTIVE_SLOT_DEFINITION = 2969 PACKAGE_MOP.addExternalSymbol("STANDARD-EFFECTIVE-SLOT-DEFINITION"); 2964 2970 2965 2971 // Java interface. -
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r13220 r13273 32 32 33 33 ;;; Originally based on Closette. 34 34 35 35 ;;; Closette Version 1.0 (February 10, 1991) 36 36 ;;; … … 97 97 ;; 98 98 99 (export '(class-precedence-list class-slots)) 99 (export '(class-precedence-list class-slots 100 slot-definition-name)) 100 101 (defconstant +the-standard-class+ (find-class 'standard-class)) 101 102 (defconstant +the-structure-class+ (find-class 'structure-class)) … … 107 108 (find-class 'standard-generic-function)) 108 109 (defconstant +the-T-class+ (find-class 'T)) 109 (defconstant +the-s lot-definition-class+ (find-class 'slot-definition))110 (defconstant +the- direct-slot-definition-class+ (find-class 'direct-slot-definition))111 (defconstant +the- effective-slot-definition-class+ (find-class 'effective-slot-definition))110 (defconstant +the-standard-slot-definition-class+ (find-class 'standard-slot-definition)) 111 (defconstant +the-standard-direct-slot-definition-class+ (find-class 'standard-direct-slot-definition)) 112 (defconstant +the-standard-effective-slot-definition-class+ (find-class 'standard-effective-slot-definition)) 112 113 113 114 ;; Don't use DEFVAR, because that disallows loading clos.lisp … … 255 256 (t 256 257 (push-on-end `(quote ,(car olist)) non-std-options) 257 (push-on-end (cadr olist) non-std-options))))258 (push-on-end `(quote ,(cadr olist)) non-std-options)))) 258 259 `(list 259 260 :name ',name … … 378 379 379 380 (defun init-slot-definition (slot &key name 380 381 382 383 384 385 386 381 (initargs ()) 382 (initform nil) 383 (initfunction nil) 384 (readers ()) 385 (writers ()) 386 (allocation :instance) 387 (allocation-class nil)) 387 388 (setf (slot-definition-name slot) name) 388 389 (setf (slot-definition-initargs slot) initargs) … … 397 398 (defun make-direct-slot-definition (class &rest args) 398 399 (let ((slot-class (direct-slot-definition-class class))) 399 (if (eq slot-class +the- direct-slot-definition-class+)400 (let ((slot (make-slot-definition +the- direct-slot-definition-class+)))400 (if (eq slot-class +the-standard-direct-slot-definition-class+) 401 (let ((slot (make-slot-definition +the-standard-direct-slot-definition-class+))) 401 402 (apply #'init-slot-definition slot :allocation-class class args) 402 403 slot) … … 408 409 (defun make-effective-slot-definition (class &rest args) 409 410 (let ((slot-class (effective-slot-definition-class class))) 410 (if (eq slot-class +the- effective-slot-definition-class+)411 (let ((slot (make-slot-definition +the- effective-slot-definition-class+)))411 (if (eq slot-class +the-standard-effective-slot-definition-class+) 412 (let ((slot (make-slot-definition +the-standard-effective-slot-definition-class+))) 412 413 (apply #'init-slot-definition slot args) 413 414 slot) … … 581 582 #'compute-effective-slot-definition) 582 583 class 584 name 583 585 (remove name all-slots 584 586 :key 'slot-definition-name … … 586 588 all-names))) 587 589 588 (defun std-compute-effective-slot-definition (class direct-slots)590 (defun std-compute-effective-slot-definition (class name direct-slots) 589 591 (let ((initer (find-if-not #'null direct-slots 590 592 :key 'slot-definition-initfunction))) 591 593 (make-effective-slot-definition 592 594 class 593 :name (slot-definition-name (car direct-slots))595 :name name 594 596 :initform (if initer 595 597 (slot-definition-initform initer) … … 774 776 (dolist (class direct-superclasses) 775 777 (when (and (typep class 'built-in-class) 776 778 (not (member class *extensible-built-in-classes*))) 777 779 (error "Attempt to define a subclass of a built-in-class: ~S" class)))) 778 780 (let ((old-class (find-class name nil))) … … 795 797 (t 796 798 ;; We're redefining the class. 797 (remhash old-class *make-instance-initargs-cache*) 798 (remhash old-class *reinitialize-instance-initargs-cache*) 799 (%make-instances-obsolete old-class) 800 (setf (class-finalized-p old-class) nil) 801 (check-initargs (list #'allocate-instance 802 #'initialize-instance) 803 (list* old-class all-keys) 804 old-class t all-keys 805 nil) 806 (apply #'std-after-initialization-for-classes old-class all-keys) 799 (apply #'reinitialize-instance old-class all-keys) 807 800 old-class))) 808 801 (t … … 2385 2378 (defmethod direct-slot-definition-class ((class class) &rest initargs) 2386 2379 (declare (ignore initargs)) 2387 +the- direct-slot-definition-class+)2380 +the-standard-direct-slot-definition-class+) 2388 2381 2389 2382 (defgeneric effective-slot-definition-class (class &rest initargs)) … … 2391 2384 (defmethod effective-slot-definition-class ((class class) &rest initargs) 2392 2385 (declare (ignore initargs)) 2393 +the- effective-slot-definition-class+)2386 +the-standard-effective-slot-definition-class+) 2394 2387 2395 2388 (atomic-defgeneric documentation (x doc-type) … … 2732 2725 ;; checking initarg validity 2733 2726 (do* ((tail all-keys (cddr tail)) 2734 2727 (initarg (car tail) (car tail))) 2735 2728 ((null tail)) 2736 2729 (unless (symbolp initarg) 2737 2730 (error 'program-error 2738 2739 2731 :format-control "Invalid initarg ~S." 2732 :format-arguments (list initarg)))) 2740 2733 (dolist (slot (class-slots (class-of instance))) 2741 2734 (let ((slot-name (slot-definition-name slot))) … … 2758 2751 2759 2752 (defmethod shared-initialize ((slot slot-definition) slot-names 2760 2761 2762 2763 2753 &rest args 2754 &key name initargs initform initfunction 2755 readers writers allocation 2756 &allow-other-keys) 2764 2757 ;;Keyword args are duplicated from init-slot-definition only to have 2765 2758 ;;them checked. … … 2855 2848 (apply #'std-after-initialization-for-classes class args)) 2856 2849 2850 (defmethod reinitialize-instance :after ((class standard-class) &rest all-keys) 2851 (remhash class *make-instance-initargs-cache*) 2852 (remhash class *reinitialize-instance-initargs-cache*) 2853 (%make-instances-obsolete class) 2854 (setf (class-finalized-p class) nil) 2855 (check-initargs (list #'allocate-instance 2856 #'initialize-instance) 2857 (list* class all-keys) 2858 class t all-keys 2859 nil) 2860 (apply #'std-after-initialization-for-classes class all-keys)) 2861 2857 2862 ;;; Finalize inheritance 2858 2863 … … 2873 2878 (std-compute-slots class)) 2874 2879 2875 (defgeneric compute-effective-slot-definition (class direct-slots))2880 (defgeneric compute-effective-slot-definition (class name direct-slots)) 2876 2881 (defmethod compute-effective-slot-definition 2877 ((class standard-class) direct-slots)2878 (std-compute-effective-slot-definition class direct-slots))2882 ((class standard-class) name direct-slots) 2883 (std-compute-effective-slot-definition class name direct-slots)) 2879 2884 2880 2885 ;;; Methods having to do with generic function metaobjects. … … 2910 2915 `(let (($cl (class-of ,slot-definition))) 2911 2916 (case $cl 2912 ((+the-s lot-definition-class+2913 +the-direct-slot-definition-class+2914 +the-effective-slot-definition-class+)2915 2917 ((+the-standard-slot-definition-class+ 2918 +the-standard-direct-slot-definition-class+ 2919 +the-standard-effective-slot-definition-class+) 2920 ,std-form) 2916 2921 (t ,generic-form)))) 2917 2922 … … 2933 2938 (%slot-definition-initargs slot-definition) 2934 2939 (slot-value slot-definition 'sys::initargs)))) 2935 2936 (atomic-defgeneric (setf slot-definition-initargs) (value slot-definition)2937 (:method (value (slot-definition slot-definition))2938 (slot-definition-dispatch slot-definition2939 (set-slot-definition-initargs slot-definition value)2940 (setf (slot-value slot-definition 'sys::initargs) value))))2941 2940 2942 2941 (atomic-defgeneric slot-definition-initform (slot-definition)
Note: See TracChangeset
for help on using the changeset viewer.