Changeset 12527
- Timestamp:
- 03/13/10 19:05:15 (12 years ago)
- Location:
- branches/metaclass/abcl/src/org/armedbear/lisp
- Files:
-
- 14 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/metaclass/abcl/src/org/armedbear/lisp/Autoload.java
r12451 r12527 685 685 autoload(Symbol.SET_SCHAR, "StringFunctions"); 686 686 687 autoload(Symbol. SET_CLASS_SLOTS, "SlotClass");687 autoload(Symbol._SET_CLASS_SLOTS, "SlotClass"); 688 688 autoload(Symbol._CLASS_SLOTS, "SlotClass"); 689 689 -
branches/metaclass/abcl/src/org/armedbear/lisp/Condition.java
r12481 r12527 138 138 public LispObject typeOf() 139 139 { 140 LispClass c = getLispClass(); 141 if (c != null) 142 return c.getName(); 140 LispObject c = getLispClass(); 141 if (c instanceof LispClass) 142 return ((LispClass)c).getName(); 143 else if (c != null) 144 return Symbol.CLASS_NAME.execute(c); 143 145 return Symbol.CONDITION; 144 146 } … … 147 149 public LispObject classOf() 148 150 { 149 Lisp Classc = getLispClass();151 LispObject c = getLispClass(); 150 152 if (c != null) 151 153 return c; -
branches/metaclass/abcl/src/org/armedbear/lisp/Layout.java
r12481 r12527 38 38 public class Layout extends LispObject 39 39 { 40 private final Lisp ClasslispClass;40 private final LispObject lispClass; 41 41 public final EqHashTable slotTable; 42 42 … … 46 46 private boolean invalid; 47 47 48 public Layout(Lisp ClasslispClass, LispObject instanceSlots, LispObject sharedSlots)48 public Layout(LispObject lispClass, LispObject instanceSlots, LispObject sharedSlots) 49 49 { 50 50 this.lispClass = lispClass; … … 65 65 } 66 66 67 public Layout(Lisp ClasslispClass, LispObject[] instanceSlotNames,67 public Layout(LispObject lispClass, LispObject[] instanceSlotNames, 68 68 LispObject sharedSlots) 69 69 { … … 104 104 } 105 105 106 public Lisp ClassgetLispClass()106 public LispObject getLispClass() 107 107 { 108 108 return lispClass; … … 160 160 161 161 { 162 return new Layout(checkClass(first), checkList(second), 163 checkList(third)); 162 return new Layout(first, checkList(second), checkList(third)); 164 163 } 165 164 … … 236 235 237 236 { 238 237 final Layout layOutFirst = checkLayout(first); 239 238 final LispObject slotNames[] = layOutFirst.slotNames; 240 239 final int limit = slotNames.length; … … 264 263 public LispObject execute(LispObject arg) 265 264 { 266 final LispClass lispClass = checkClass(arg); 267 Layout oldLayout = lispClass.getClassLayout(); 268 Layout newLayout = new Layout(oldLayout); 269 lispClass.setClassLayout(newLayout); 270 oldLayout.invalidate(); 265 final LispObject lispClass = arg; 266 LispObject oldLayout; 267 if (lispClass instanceof LispClass) 268 oldLayout = ((LispClass)lispClass).getClassLayout(); 269 else 270 oldLayout = Symbol.CLASS_LAYOUT.execute(lispClass); 271 272 Layout newLayout = new Layout((Layout)oldLayout); 273 if (lispClass instanceof LispClass) 274 ((LispClass)lispClass).setClassLayout(newLayout); 275 else 276 Symbol.CLASS_LAYOUT.getSymbolSetfFunction() 277 .execute(newLayout, lispClass); 278 ((Layout)oldLayout).invalidate(); 271 279 return arg; 272 280 } -
branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java
r12481 r12527 180 180 } 181 181 182 public void setClassLayout(L ayout layout)183 { 184 classLayout = layout ;182 public void setClassLayout(LispObject layout) 183 { 184 classLayout = layout == NIL ? null : (Layout)layout; 185 185 } 186 186 … … 202 202 } 203 203 204 public finalboolean isFinalized()204 public boolean isFinalized() 205 205 { 206 206 return finalized; 207 207 } 208 208 209 public finalvoid setFinalized(boolean b)209 public void setFinalized(boolean b) 210 210 { 211 211 finalized = b; -
branches/metaclass/abcl/src/org/armedbear/lisp/LispObject.java
r12431 r12527 669 669 } 670 670 671 public LispObject getSymbolSetfFunction() 672 { 673 return type_error(this, Symbol.SYMBOL); 674 } 675 676 public LispObject getSymbolSetfFunctionOrDie() 677 { 678 return type_error(this, Symbol.SYMBOL); 679 } 680 671 681 public String writeToString() 672 682 { -
branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java
r12481 r12527 5332 5332 5333 5333 { 5334 checkClass( first).setName(checkSymbol(second));5335 return second;5334 checkClass(second).setName(checkSymbol(first)); 5335 return first; 5336 5336 } 5337 5337 }; 5338 5338 5339 5339 // ### class-layout 5340 private static final Primitive CLASS_LAYOUT = new pf_ class_layout();5341 private static final class pf_ class_layout extends Primitive {5342 pf_ class_layout() {5343 super(" class-layout", PACKAGE_SYS, true, "class");5340 private static final Primitive CLASS_LAYOUT = new pf__class_layout(); 5341 private static final class pf__class_layout extends Primitive { 5342 pf__class_layout() { 5343 super("%class-layout", PACKAGE_SYS, true, "class"); 5344 5344 } 5345 5345 … … 5362 5362 5363 5363 { 5364 if ( secondinstanceof Layout) {5365 checkClass( first).setClassLayout((Layout)second);5366 return second;5367 } 5368 return type_error( second, Symbol.LAYOUT);5369 } 5370 }; 5371 5372 // ### class-direct-superclasses5373 private static final Primitive CLASS_DIRECT_SUPERCLASSES = new pf_class_direct_superclasses();5374 private static final class pf_ class_direct_superclasses extends Primitive {5375 pf_ class_direct_superclasses() {5376 super(" class-direct-superclasses", PACKAGE_SYS, true);5364 if (first == NIL || first instanceof Layout) { 5365 checkClass(second).setClassLayout(first); 5366 return first; 5367 } 5368 return type_error(first, Symbol.LAYOUT); 5369 } 5370 }; 5371 5372 // ### %class-direct-superclasses 5373 private static final Primitive _CLASS_DIRECT_SUPERCLASSES = new pf__class_direct_superclasses(); 5374 private static final class pf__class_direct_superclasses extends Primitive { 5375 pf__class_direct_superclasses() { 5376 super("%class-direct-superclasses", PACKAGE_SYS, true); 5377 5377 } 5378 5378 … … 5394 5394 5395 5395 { 5396 checkClass( first).setDirectSuperclasses(second);5397 return second;5398 } 5399 }; 5400 5401 // ### class-direct-subclasses5402 private static final Primitive CLASS_DIRECT_SUBCLASSES = new pf_class_direct_subclasses();5403 private static final class pf_ class_direct_subclasses extends Primitive {5404 pf_ class_direct_subclasses() {5405 super(" class-direct-subclasses", PACKAGE_SYS, true);5396 checkClass(second).setDirectSuperclasses(first); 5397 return first; 5398 } 5399 }; 5400 5401 // ### %class-direct-subclasses 5402 private static final Primitive _CLASS_DIRECT_SUBCLASSES = new pf__class_direct_subclasses(); 5403 private static final class pf__class_direct_subclasses extends Primitive { 5404 pf__class_direct_subclasses() { 5405 super("%class-direct-subclasses", PACKAGE_SYS, true); 5406 5406 } 5407 5407 … … 5424 5424 5425 5425 { 5426 checkClass( first).setDirectSubclasses(second);5427 return second;5426 checkClass(second).setDirectSubclasses(first); 5427 return first; 5428 5428 } 5429 5429 }; … … 5442 5442 }; 5443 5443 5444 // ### set-class-precedence-list5445 private static final Primitive SET_CLASS_PRECEDENCE_LIST = new pf_set_class_precedence_list();5446 private static final class pf_ set_class_precedence_list extends Primitive {5447 pf_ set_class_precedence_list() {5448 super(" set-class-precedence-list", PACKAGE_SYS, true);5449 } 5450 5451 @Override 5452 public LispObject execute(LispObject first, LispObject second) 5453 5454 { 5455 checkClass( first).setCPL(second);5456 return second;5457 } 5458 }; 5459 5460 // ### class-direct-methods5461 private static final Primitive CLASS_DIRECT_METHODS = new pf_class_direct_methods();5462 private static final class pf_ class_direct_methods extends Primitive {5463 pf_ class_direct_methods() {5464 super(" class-direct-methods", PACKAGE_SYS, true);5444 // ### %set-class-precedence-list 5445 private static final Primitive _SET_CLASS_PRECEDENCE_LIST = new pf__set_class_precedence_list(); 5446 private static final class pf__set_class_precedence_list extends Primitive { 5447 pf__set_class_precedence_list() { 5448 super("%set-class-precedence-list", PACKAGE_SYS, true); 5449 } 5450 5451 @Override 5452 public LispObject execute(LispObject first, LispObject second) 5453 5454 { 5455 checkClass(second).setCPL(first); 5456 return first; 5457 } 5458 }; 5459 5460 // ### %class-direct-methods 5461 private static final Primitive _CLASS_DIRECT_METHODS = new pf__class_direct_methods(); 5462 private static final class pf__class_direct_methods extends Primitive { 5463 pf__class_direct_methods() { 5464 super("%class-direct-methods", PACKAGE_SYS, true); 5465 5465 } 5466 5466 … … 5484 5484 5485 5485 { 5486 checkClass( first).setDirectMethods(second);5487 return second;5486 checkClass(second).setDirectMethods(first); 5487 return first; 5488 5488 } 5489 5489 }; … … 5522 5522 }; 5523 5523 5524 // ### class-finalized-p5525 private static final Primitive CLASS_FINALIZED_P = new pf_class_finalized_p();5526 private static final class pf_ class_finalized_p extends Primitive {5527 pf_ class_finalized_p() {5528 super(" class-finalized-p", PACKAGE_SYS, true);5524 // ### %class-finalized-p 5525 private static final Primitive _CLASS_FINALIZED_P = new pf__class_finalized_p(); 5526 private static final class pf__class_finalized_p extends Primitive { 5527 pf__class_finalized_p() { 5528 super("%class-finalized-p", PACKAGE_SYS, true); 5529 5529 } 5530 5530 … … 5546 5546 5547 5547 { 5548 checkClass( first).setFinalized(second!= NIL);5549 return second;5548 checkClass(second).setFinalized(first != NIL); 5549 return first; 5550 5550 } 5551 5551 }; -
branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java
r12481 r12527 179 179 // ### class-direct-slots 180 180 private static final Primitive CLASS_DIRECT_SLOTS = 181 new Primitive(" class-direct-slots", PACKAGE_SYS, true)181 new Primitive("%class-direct-slots", PACKAGE_SYS, true) 182 182 { 183 183 @Override … … 201 201 202 202 { 203 if ( firstinstanceof SlotClass) {204 ((SlotClass) first).setDirectSlotDefinitions(second);205 return second;203 if (second instanceof SlotClass) { 204 ((SlotClass)second).setDirectSlotDefinitions(first); 205 return first; 206 206 } 207 207 else { 208 return type_error( first, Symbol.STANDARD_CLASS);208 return type_error(second, Symbol.STANDARD_CLASS); 209 209 } 210 210 } … … 228 228 229 229 // ### set-class-slots 230 private static final Primitive SET_CLASS_SLOTS =231 new Primitive(Symbol. SET_CLASS_SLOTS, "class slot-definitions")230 private static final Primitive _SET_CLASS_SLOTS = 231 new Primitive(Symbol._SET_CLASS_SLOTS, "class slot-definitions") 232 232 { 233 233 @Override … … 235 235 236 236 { 237 if ( firstinstanceof SlotClass) {238 ((SlotClass) first).setSlotDefinitions(second);239 return second;237 if (second instanceof SlotClass) { 238 ((SlotClass)second).setSlotDefinitions(first); 239 return first; 240 240 } 241 241 else { 242 return type_error( first, Symbol.STANDARD_CLASS);242 return type_error(second, Symbol.STANDARD_CLASS); 243 243 } 244 244 } … … 247 247 // ### class-direct-default-initargs 248 248 private static final Primitive CLASS_DIRECT_DEFAULT_INITARGS = 249 new Primitive(" class-direct-default-initargs", PACKAGE_SYS, true)249 new Primitive("%class-direct-default-initargs", PACKAGE_SYS, true) 250 250 { 251 251 @Override … … 269 269 270 270 { 271 if ( firstinstanceof SlotClass) {272 ((SlotClass) first).setDirectDefaultInitargs(second);273 return second;274 } 275 return type_error( first, Symbol.STANDARD_CLASS);271 if (second instanceof SlotClass) { 272 ((SlotClass)second).setDirectDefaultInitargs(first); 273 return first; 274 } 275 return type_error(second, Symbol.STANDARD_CLASS); 276 276 } 277 277 }; … … 279 279 // ### class-default-initargs 280 280 private static final Primitive CLASS_DEFAULT_INITARGS = 281 new Primitive(" class-default-initargs", PACKAGE_SYS, true)281 new Primitive("%class-default-initargs", PACKAGE_SYS, true) 282 282 { 283 283 @Override … … 301 301 302 302 { 303 if ( firstinstanceof SlotClass) {304 ((SlotClass) first).setDefaultInitargs(second);305 return second;306 } 307 return type_error( first, Symbol.STANDARD_CLASS);303 if (second instanceof SlotClass) { 304 ((SlotClass)second).setDefaultInitargs(first); 305 return first; 306 } 307 return type_error(second, Symbol.STANDARD_CLASS); 308 308 } 309 309 }; -
branches/metaclass/abcl/src/org/armedbear/lisp/SlotDefinition.java
r12431 r12527 71 71 } 72 72 73 public static SlotDefinition checkSlotDefin ation(LispObject obj) {73 public static SlotDefinition checkSlotDefinition(LispObject obj) { 74 74 if (obj instanceof SlotDefinition) return (SlotDefinition)obj; 75 75 return (SlotDefinition)type_error(obj, Symbol.SLOT_DEFINITION); … … 118 118 public LispObject execute(LispObject arg) 119 119 { 120 return checkSlotDefin ation(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME];120 return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME]; 121 121 } 122 122 }; … … 131 131 132 132 { 133 checkSlotDefin ation(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second;133 checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second; 134 134 return second; 135 135 } … … 143 143 public LispObject execute(LispObject arg) 144 144 { 145 return checkSlotDefin ation(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION];145 return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION]; 146 146 } 147 147 }; 148 148 149 149 // ### set-slot-definition-initfunction 150 privatestatic final Primitive SET_SLOT_DEFINITION_INITFUNCTION =150 static final Primitive SET_SLOT_DEFINITION_INITFUNCTION = 151 151 new Primitive("set-slot-definition-initfunction", PACKAGE_SYS, true, 152 152 "slot-definition initfunction") … … 156 156 157 157 { 158 checkSlotDefin ation(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second;158 checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second; 159 159 return second; 160 160 } … … 169 169 public LispObject execute(LispObject arg) 170 170 { 171 return checkSlotDefin ation(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM];171 return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM]; 172 172 } 173 173 }; 174 174 175 175 // ### set-slot-definition-initform 176 privatestatic final Primitive SET_SLOT_DEFINITION_INITFORM =176 static final Primitive SET_SLOT_DEFINITION_INITFORM = 177 177 new Primitive("set-slot-definition-initform", PACKAGE_SYS, true, 178 178 "slot-definition initform") … … 182 182 183 183 { 184 checkSlotDefin ation(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second;184 checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second; 185 185 return second; 186 186 } … … 194 194 public LispObject execute(LispObject arg) 195 195 { 196 return checkSlotDefin ation(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS];196 return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS]; 197 197 } 198 198 }; … … 207 207 208 208 { 209 checkSlotDefin ation(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second;209 checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second; 210 210 return second; 211 211 } … … 220 220 public LispObject execute(LispObject arg) 221 221 { 222 return checkSlotDefin ation(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS];222 return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS]; 223 223 } 224 224 }; … … 233 233 234 234 { 235 checkSlotDefin ation(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second;235 checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second; 236 236 return second; 237 237 } … … 246 246 public LispObject execute(LispObject arg) 247 247 { 248 return checkSlotDefin ation(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS];248 return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS]; 249 249 } 250 250 }; … … 259 259 260 260 { 261 checkSlotDefin ation(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second;261 checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second; 262 262 return second; 263 263 } … … 272 272 public LispObject execute(LispObject arg) 273 273 { 274 return checkSlotDefin ation(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION];274 return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION]; 275 275 } 276 276 }; … … 285 285 286 286 { 287 checkSlotDefin ation(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second;287 checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second; 288 288 return second; 289 289 } … … 298 298 public LispObject execute(LispObject arg) 299 299 { 300 return checkSlotDefin ation(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS];300 return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS]; 301 301 } 302 302 }; … … 311 311 312 312 { 313 checkSlotDefin ation(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second;313 checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second; 314 314 return second; 315 315 } … … 323 323 public LispObject execute(LispObject arg) 324 324 { 325 return checkSlotDefin ation(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION];325 return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION]; 326 326 } 327 327 }; … … 335 335 336 336 { 337 checkSlotDefin ation(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second;337 checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second; 338 338 return second; 339 339 } -
branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java
r12481 r12527 59 59 private static Symbol symDefaultInitargs 60 60 = PACKAGE_MOP.intern("DEFAULT-INITARGS"); 61 private static Symbol symFinalizedP 62 = PACKAGE_MOP.intern("FINALIZED-P"); 61 63 62 64 static Layout layoutStandardClass = … … 72 74 symSlots, 73 75 symDirectDefaultInitargs, 74 symDefaultInitargs), 76 symDefaultInitargs, 77 symFinalizedP), 75 78 NIL) 76 79 { … … 87 90 setDirectSuperclasses(NIL); 88 91 setDirectSubclasses(NIL); 92 setClassLayout(layoutStandardClass); 89 93 setCPL(NIL); 90 94 setDirectMethods(NIL); … … 94 98 setDirectDefaultInitargs(NIL); 95 99 setDefaultInitargs(NIL); 100 setFinalized(false); 96 101 } 97 102 … … 101 106 symbol, directSuperclasses); 102 107 setDirectSubclasses(NIL); 108 setClassLayout(layoutStandardClass); 103 109 setCPL(NIL); 104 110 setDirectMethods(NIL); … … 108 114 setDirectDefaultInitargs(NIL); 109 115 setDefaultInitargs(NIL); 116 setFinalized(false); 110 117 } 111 118 … … 130 137 131 138 @Override 132 public void setClassLayout(L ayout newLayout)139 public void setClassLayout(LispObject newLayout) 133 140 { 134 141 setInstanceSlotValue(symLayout, newLayout); … … 145 152 { 146 153 setInstanceSlotValue(symDirectSuperclasses, directSuperclasses); 154 } 155 156 @Override 157 public final boolean isFinalized() 158 { 159 return getInstanceSlotValue(symFinalizedP) != NIL; 160 } 161 162 @Override 163 public final void setFinalized(boolean b) 164 { 165 setInstanceSlotValue(symFinalizedP, b ? T : NIL); 147 166 } 148 167 … … 323 342 STANDARD_CLASS.setClassLayout(layoutStandardClass); 324 343 STANDARD_CLASS.setDirectSlotDefinitions(STANDARD_CLASS.getClassLayout().generateSlotDefinitions()); 344 LispObject slots = STANDARD_CLASS.getDirectSlotDefinitions(); 345 while (slots != NIL) { 346 SlotDefinition slot = (SlotDefinition)slots.car(); 347 if (slot.getName() == symLayout) 348 SlotDefinition.SET_SLOT_DEFINITION_INITFUNCTION.execute(slot, 349 new Function() { 350 @Override 351 public LispObject execute() { 352 return NIL; 353 } 354 }); 355 slots = slots.cdr(); 356 } 357 325 358 } 326 359 … … 617 650 618 651 // Condition classes. 652 STANDARD_CLASS.finalizeClass(); 619 653 ARITHMETIC_ERROR.finalizeClass(); 620 654 CELL_ERROR.finalizeClass(); -
branches/metaclass/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
r12481 r12527 210 210 { 211 211 StringBuilder sb = new StringBuilder(); 212 sb.append(getLispClass().getName().writeToString()); 212 LispObject className; 213 LispObject lispClass = getLispClass(); 214 if (lispClass instanceof LispClass) 215 className = ((LispClass)lispClass).getName(); 216 else 217 className = Symbol.CLASS_NAME.execute(lispClass); 218 219 sb.append(className.writeToString()); 213 220 sb.append(' '); 214 221 sb.append(name.writeToString()); -
branches/metaclass/abcl/src/org/armedbear/lisp/StandardMethod.java
r12481 r12527 157 157 { 158 158 StringBuilder sb = new StringBuilder(); 159 sb.append(getLispClass().getName().writeToString()); 159 LispObject className; 160 LispObject lispClass = getLispClass(); 161 if (lispClass instanceof LispClass) 162 className = ((LispClass)lispClass).getName(); 163 else 164 className = Symbol.CLASS_NAME.execute(lispClass); 165 166 sb.append(className.writeToString()); 160 167 sb.append(' '); 161 168 sb.append(name.writeToString()); -
branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java
r12481 r12527 47 47 48 48 49 protected StandardObject(Layout layout) 50 { 51 this(layout, layout.getLength()); 52 } 53 49 54 protected StandardObject(Layout layout, int length) 50 55 { … … 99 104 } 100 105 101 public final Lisp ClassgetLispClass()106 public final LispObject getLispClass() 102 107 { 103 108 return layout.getLispClass(); 109 } 110 111 private LispObject helperGetClassName() 112 { 113 final LispObject c1 = layout.getLispClass(); 114 if (c1 instanceof LispClass) 115 return ((LispClass)c1).getName(); 116 else 117 return LispThread.currentThread().execute(Symbol.CLASS_NAME, c1); 118 } 119 120 private LispObject helperGetCPL() 121 { 122 final LispObject c1 = layout.getLispClass(); 123 if (c1 instanceof LispClass) 124 return ((LispClass)c1).getCPL(); 125 else 126 return LispThread.currentThread().execute(Symbol.CLASS_PRECEDENCE_LIST, c1); 104 127 } 105 128 … … 111 134 // CLASS-OF if it has a proper name, and otherwise returns the class 112 135 // itself." 113 final LispClass c1 = layout.getLispClass(); 136 final LispObject c1 = layout.getLispClass(); 137 LispObject name; 138 if (c1 instanceof LispClass) 139 name = ((LispClass)c1).getName(); 140 else 141 name = LispThread.currentThread().execute(Symbol.CLASS_NAME, c1); 142 114 143 // The proper name of a class is "a symbol that names the class whose 115 144 // name is that symbol". 116 final LispObject name = c1.getName();117 145 if (name != NIL && name != UNBOUND_VALUE) 118 146 { … … 138 166 if (type == StandardClass.STANDARD_OBJECT) 139 167 return T; 140 Lisp Classcls = layout != null ? layout.getLispClass() : null;168 LispObject cls = layout != null ? layout.getLispClass() : null; 141 169 if (cls != null) 142 170 { 143 171 if (type == cls) 144 172 return T; 145 if (type == cls.getName())173 if (type == helperGetClassName()) 146 174 return T; 147 LispObject cpl = cls.getCPL();175 LispObject cpl = helperGetCPL(); 148 176 while (cpl != NIL) 149 177 { 150 178 if (type == cpl.car()) 151 179 return T; 152 if (type == ((LispClass)cpl.car()).getName()) 153 return T; 180 181 LispObject otherName; 182 LispObject otherClass = cpl.car(); 183 if (otherClass instanceof LispClass) { 184 if (type == ((LispClass)otherClass).getName()) 185 return T; 186 } 187 else 188 if (type == LispThread 189 .currentThread().execute(Symbol.CLASS_NAME, otherClass)) 190 return T; 191 154 192 cpl = cpl.cdr(); 155 193 } … … 184 222 Debug.assertTrue(layout.isInvalid()); 185 223 Layout oldLayout = layout; 186 LispClass cls = oldLayout.getLispClass(); 187 Layout newLayout = cls.getClassLayout(); 224 LispObject cls = oldLayout.getLispClass(); 225 Layout newLayout; 226 227 if (cls instanceof LispClass) 228 newLayout = ((LispClass)cls).getClassLayout(); 229 else 230 newLayout = (Layout)Symbol.CLASS_LAYOUT.execute(cls); 231 188 232 Debug.assertTrue(!newLayout.isInvalid()); 189 StandardObject newInstance = new StandardObject( cls);233 StandardObject newInstance = new StandardObject(newLayout); 190 234 Debug.assertTrue(newInstance.layout == newLayout); 191 235 LispObject added = NIL; -
branches/metaclass/abcl/src/org/armedbear/lisp/Symbol.java
r12431 r12527 391 391 } 392 392 393 @Override 394 public final LispObject getSymbolSetfFunction() 395 { 396 return get(this, Symbol.SETF_FUNCTION, NIL); 397 } 398 399 400 @Override 393 401 public final LispObject getSymbolSetfFunctionOrDie() 394 395 402 { 396 403 LispObject obj = get(this, Symbol.SETF_FUNCTION, null); … … 2914 2921 2915 2922 // MOP. 2923 public static final Symbol CLASS_LAYOUT = 2924 PACKAGE_MOP.addInternalSymbol("CLASS-LAYOUT"); 2925 public static final Symbol CLASS_PRECEDENCE_LIST = 2926 PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST"); 2916 2927 public static final Symbol STANDARD_READER_METHOD = 2917 2928 PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD"); … … 2966 2977 public static final Symbol OUTPUT_OBJECT = 2967 2978 PACKAGE_SYS.addExternalSymbol("OUTPUT-OBJECT"); 2968 public static final Symbol SET_CLASS_SLOTS =2969 PACKAGE_SYS.addExternalSymbol(" SET-CLASS-SLOTS");2979 public static final Symbol _SET_CLASS_SLOTS = 2980 PACKAGE_SYS.addExternalSymbol("%SET-CLASS-SLOTS"); 2970 2981 public static final Symbol SETF_FUNCTION = 2971 2982 PACKAGE_SYS.addExternalSymbol("SETF-FUNCTION"); -
branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp
r12481 r12527 54 54 (export '(class-precedence-list class-slots)) 55 55 56 (defun class-slots (class) 57 (%class-slots class)) 56 ;; Don't use DEFVAR, because that disallows loading clos.lisp 57 ;; after compiling it: the binding won't get assigned to T anymore 58 (defparameter *clos-booting* t) 59 60 (defmacro define-class->%class-forwarder (name) 61 (let* (($name (if (consp name) (cadr name) name)) 62 (%name (intern (concatenate 'string 63 "%" 64 (if (consp name) 65 (symbol-name 'set-) "") 66 (symbol-name $name)) 67 (symbol-package $name)))) 68 `(progn 69 (declaim (notinline ,name)) 70 (defun ,name (&rest args) 71 (apply #',%name args))))) 72 73 (define-class->%class-forwarder class-name) 74 (define-class->%class-forwarder (setf class-name)) 75 (define-class->%class-forwarder class-slots) 76 (define-class->%class-forwarder (setf class-slots)) 77 (define-class->%class-forwarder class-direct-slots) 78 (define-class->%class-forwarder (setf class-direct-slots)) 79 (define-class->%class-forwarder class-layout) 80 (define-class->%class-forwarder (setf class-layout)) 81 (define-class->%class-forwarder class-direct-superclasses) 82 (define-class->%class-forwarder (setf class-direct-superclasses)) 83 (define-class->%class-forwarder class-direct-subclasses) 84 (define-class->%class-forwarder (setf class-direct-subclasses)) 85 (define-class->%class-forwarder class-direct-methods) 86 (define-class->%class-forwarder (setf class-direct-methods)) 87 (define-class->%class-forwarder class-precedence-list) 88 (define-class->%class-forwarder (setf class-precedence-list)) 89 (define-class->%class-forwarder class-finalized-p) 90 (define-class->%class-forwarder (setf class-finalized-p)) 91 (define-class->%class-forwarder class-default-initargs) 92 (define-class->%class-forwarder (setf class-default-initargs)) 93 (define-class->%class-forwarder class-direct-default-initargs) 94 (define-class->%class-forwarder (setf class-direct-default-initargs)) 95 96 (defun no-applicable-method (generic-function &rest args) 97 (error "There is no applicable method for the generic function ~S when called with arguments ~S." 98 generic-function 99 args)) 100 101 58 102 59 103 (defmacro push-on-end (value location) … … 86 130 (mapplist fun (cddr x))))) 87 131 88 (defsetf class-layout %set-class-layout)89 (defsetf class-direct-superclasses %set-class-direct-superclasses)90 (defsetf class-direct-subclasses %set-class-direct-subclasses)91 (defsetf class-direct-methods %set-class-direct-methods)92 (defsetf class-direct-slots %set-class-direct-slots)93 ;; (defsetf class-slots %set-class-slots)94 (defsetf class-direct-default-initargs %set-class-direct-default-initargs)95 (defsetf class-default-initargs %set-class-default-initargs)96 (defsetf class-finalized-p %set-class-finalized-p)97 132 (defsetf std-instance-layout %set-std-instance-layout) 98 133 (defsetf standard-instance-access %set-standard-instance-access) … … 255 290 256 291 (defun std-finalize-inheritance (class) 257 (set-class-precedence-list 258 class 292 (setf (class-precedence-list class) 259 293 (funcall (if (eq (class-of class) (find-class 'standard-class)) 260 294 #'std-compute-class-precedence-list 261 295 #'compute-class-precedence-list) 262 296 class)) 263 (dolist (class ( %class-precedence-list class))297 (dolist (class (class-precedence-list class)) 264 298 (when (typep class 'forward-referenced-class) 265 299 (return-from std-finalize-inheritance))) 266 (set-class-slots class 267 (funcall (if (eq (class-of class) (find-class 'standard-class)) 268 #'std-compute-slots 269 #'compute-slots) 270 class)) 300 (setf (class-slots class) 301 (funcall (if (eq (class-of class) (find-class 'standard-class)) 302 #'std-compute-slots 303 #'compute-slots) class)) 271 304 (let ((old-layout (class-layout class)) 272 305 (length 0) 273 306 (instance-slots '()) 274 307 (shared-slots '())) 275 (dolist (slot ( %class-slots class))308 (dolist (slot (class-slots class)) 276 309 (case (%slot-definition-allocation slot) 277 310 (:instance … … 293 326 (old-location (layout-slot-location old-layout slot-name))) 294 327 (unless old-location 295 (let* ((slot-definition (find slot-name ( %class-slots class) :key #'%slot-definition-name))328 (let* ((slot-definition (find slot-name (class-slots class) :key #'%slot-definition-name)) 296 329 (initfunction (%slot-definition-initfunction slot-definition))) 297 330 (when initfunction … … 393 426 (defun std-compute-slots (class) 394 427 (let* ((all-slots (mapappend #'class-direct-slots 395 ( %class-precedence-list class)))428 (class-precedence-list class))) 396 429 (all-names (remove-duplicates 397 430 (mapcar #'%slot-definition-name all-slots)))) … … 432 465 433 466 (defun find-slot-definition (class slot-name) 434 (dolist (slot ( %class-slots class) nil)467 (dolist (slot (class-slots class) nil) 435 468 (when (eq slot-name (%slot-definition-name slot)) 436 469 (return slot)))) … … 482 515 483 516 (defun std-slot-exists-p (instance slot-name) 484 (not (null (find slot-name ( %class-slots (class-of instance))517 (not (null (find slot-name (class-slots (class-of instance)) 485 518 :key #'%slot-definition-name)))) 486 519 … … 500 533 (declare (ignore metaclass)) 501 534 (let ((class (std-allocate-instance (find-class 'standard-class)))) 502 (%set-class-name class name) 503 (setf (class-direct-subclasses class) ()) 504 (setf (class-direct-methods class) ()) 535 (%set-class-name name class) 536 (%set-class-layout nil class) 537 (%set-class-direct-subclasses () class) 538 (%set-class-direct-methods () class) 505 539 (%set-class-documentation class documentation) 506 540 (std-after-initialization-for-classes class … … 538 572 (getf canonical-slot :name)) 539 573 540 (defun ensure-class (name &rest all-keys & allow-other-keys)574 (defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys) 541 575 ;; Check for duplicate slots. 576 (remf all-keys :metaclass) 542 577 (let ((slots (getf all-keys :direct-slots))) 543 578 (dolist (s1 slots) … … 564 599 (error "Attempt to define a subclass of a built-in-class: ~S" class)))) 565 600 (let ((old-class (find-class name nil))) 566 (cond ((and old-class (eq name ( %class-name old-class)))601 (cond ((and old-class (eq name (class-name old-class))) 567 602 (cond ((typep old-class 'built-in-class) 568 603 (error "The symbol ~S names a built-in class." name)) … … 583 618 old-class))) 584 619 (t 585 (let ((class (apply #'make-instance-standard-class 586 (find-class 'standard-class) 620 (let ((class (apply (if metaclass 621 #'make-instance 622 #'make-instance-standard-class) 623 (or metaclass 624 (find-class 'standard-class)) 587 625 :name name all-keys))) 588 626 (%set-find-class name class) … … 832 870 gf) 833 871 (progn 834 (when (fboundp function-name) 872 (when (and (null *clos-booting*) 873 (fboundp function-name)) 835 874 (error 'program-error 836 875 :format-control "~A already names an ordinary function, macro, or special operator." … … 1781 1820 ))) 1782 1821 1783 (fmakunbound 'class-name) 1784 (fmakunbound '(setf class-name)) 1785 1786 (defgeneric class-name (class)) 1787 1788 (defmethod class-name ((class class)) 1789 (%class-name class)) 1790 1791 (defgeneric (setf class-name) (new-value class)) 1792 1793 (defmethod (setf class-name) (new-value (class class)) 1794 (%set-class-name class new-value)) 1795 1796 (when (autoloadp 'class-precedence-list) 1797 (fmakunbound 'class-precedence-list)) 1798 1799 (defgeneric class-precedence-list (class)) 1800 1801 (defmethod class-precedence-list ((class class)) 1802 (%class-precedence-list class)) 1822 (defmacro redefine-class-forwarder (name slot &optional alternative-name) 1823 (let* (($name (if (consp name) (cadr name) name)) 1824 (%name (intern (concatenate 'string 1825 "%" 1826 (if (consp name) 1827 (symbol-name 'set-) "") 1828 (symbol-name $name)) 1829 (find-package "SYS")))) 1830 (unless alternative-name 1831 (setf alternative-name name)) 1832 (if (consp name) 1833 `(progn ;; setter 1834 (defgeneric ,alternative-name (new-value class)) 1835 (defmethod ,alternative-name (new-value (class built-in-class)) 1836 (,%name new-value class)) 1837 (defmethod ,alternative-name (new-value (class forward-referenced-class)) 1838 (,%name new-value class)) 1839 (defmethod ,alternative-name (new-value (class structure-class)) 1840 (,%name new-value class)) 1841 (defmethod ,alternative-name (new-value (class standard-class)) 1842 (setf (slot-value class ',slot) new-value)) 1843 ,@(unless (eq name alternative-name) 1844 `((setf (get ',$name 'SETF-FUNCTION) 1845 (symbol-function ',alternative-name)))) 1846 ) 1847 `(progn ;; getter 1848 (defgeneric ,alternative-name (class)) 1849 (defmethod ,alternative-name ((class built-in-class)) 1850 (,%name class)) 1851 (defmethod ,alternative-name ((class forward-referenced-class)) 1852 (,%name class)) 1853 (defmethod ,alternative-name ((class structure-class)) 1854 (,%name class)) 1855 (defmethod ,alternative-name ((class standard-class)) 1856 (slot-value class ',slot)) 1857 ,@(unless (eq name alternative-name) 1858 `((setf (symbol-function ',$name) 1859 (symbol-function ',alternative-name)))) 1860 ) ))) 1861 1862 (redefine-class-forwarder class-name name) 1863 (redefine-class-forwarder (setf class-name) name) 1864 (redefine-class-forwarder class-slots slots) 1865 (redefine-class-forwarder (setf class-slots) slots) 1866 (redefine-class-forwarder class-direct-slots direct-slots) 1867 (redefine-class-forwarder (setf class-direct-slots) direct-slots) 1868 (redefine-class-forwarder class-layout layout) 1869 (redefine-class-forwarder (setf class-layout) layout) 1870 (redefine-class-forwarder class-direct-superclasses direct-superclasses) 1871 (redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses) 1872 (redefine-class-forwarder class-direct-subclasses direct-subclasses) 1873 (redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses) 1874 (redefine-class-forwarder class-direct-methods direct-methods !class-direct-methods) 1875 (redefine-class-forwarder (setf class-direct-methods) direct-methods !!class-direct-methods) 1876 (redefine-class-forwarder class-precedence-list class-precedence-list) 1877 (redefine-class-forwarder (setf class-precedence-list) class-precedence-list) 1878 (redefine-class-forwarder class-finalized-p finalized-p) 1879 (redefine-class-forwarder (setf class-finalized-p) finalized-p) 1880 (redefine-class-forwarder class-default-initargs default-initargs) 1881 (redefine-class-forwarder (setf class-default-initargs) default-initargs) 1882 (redefine-class-forwarder class-direct-default-initargs direct-default-initargs) 1883 (redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs) 1803 1884 1804 1885 … … 1951 2032 1952 2033 (defmethod slot-exists-p-using-class ((class structure-class) instance slot-name) 1953 (dolist (dsd ( %class-slots class))2034 (dolist (dsd (class-slots class)) 1954 2035 (when (eq (sys::dsd-name dsd) slot-name) 1955 2036 (return-from slot-exists-p-using-class t))) … … 1970 2051 (defmethod slot-missing ((class t) instance slot-name operation &optional new-value) 1971 2052 (declare (ignore new-value)) 2053 (mapcar #'print (mapcar #'frame-to-string (sys::backtrace))) 1972 2054 (error "The slot ~S is missing from the class ~S." slot-name class)) 1973 2055 … … 1987 2069 (defmethod allocate-instance ((class structure-class) &rest initargs) 1988 2070 (declare (ignore initargs)) 1989 (%make-structure ( %class-name class)1990 (make-list (length ( %class-slots class))2071 (%make-structure (class-name class) 2072 (make-list (length (class-slots class)) 1991 2073 :initial-element +slot-unbound+))) 1992 2074 … … 2013 2095 `(,instance ,@initargs) 2014 2096 (list instance))))) 2015 (slots ( %class-slots (class-of instance))))2097 (slots (class-slots (class-of instance)))) 2016 2098 (do* ((tail initargs (cddr tail)) 2017 2099 (initarg (car tail) (car tail))) … … 2096 2178 :format-control "Invalid initarg ~S." 2097 2179 :format-arguments (list initarg)))) 2098 (dolist (slot ( %class-slots (class-of instance)))2180 (dolist (slot (class-slots (class-of instance))) 2099 2181 (let ((slot-name (%slot-definition-name slot))) 2100 2182 (multiple-value-bind (init-key init-value foundp) … … 2121 2203 (defmethod change-class ((old-instance standard-object) (new-class standard-class) 2122 2204 &rest initargs) 2123 (let ((old-slots ( %class-slots (class-of old-instance)))2124 (new-slots ( %class-slots new-class))2205 (let ((old-slots (class-slots (class-of old-instance))) 2206 (new-slots (class-slots new-class)) 2125 2207 (new-instance (allocate-instance new-class))) 2126 2208 ;; "The values of local slots specified by both the class CTO and the class … … 2154 2236 (slot-exists-p old slot-name)) 2155 2237 (mapcar #'%slot-definition-name 2156 ( %class-slots (class-of new))))))2238 (class-slots (class-of new)))))) 2157 2239 (check-initargs new added-slots initargs) 2158 2240 (apply #'shared-initialize new added-slots initargs))) … … 2341 2423 (defmethod make-load-form ((class class) &optional environment) 2342 2424 (declare (ignore environment)) 2343 (let ((name ( %class-name class)))2425 (let ((name (class-name class))) 2344 2426 (unless (and name (eq (find-class name nil) class)) 2345 2427 (error 'simple-type-error … … 2356 2438 (error "Method combination error in CLOS dispatch:~% ~A" message))) 2357 2439 2440 (fmakunbound 'no-applicable-method) 2358 2441 (defgeneric no-applicable-method (generic-function &rest args)) 2359 2442 … … 2394 2477 (defgeneric function-keywords (method)) 2395 2478 2479 (setf *clos-booting* nil) 2396 2480 2397 2481 (provide 'clos)
Note: See TracChangeset
for help on using the changeset viewer.