1 | /* |
---|
2 | * StandardObject.java |
---|
3 | * |
---|
4 | * Copyright (C) 2003-2006 Peter Graves |
---|
5 | * $Id: StandardObject.java 14499 2013-05-15 06:45:13Z rschlatte $ |
---|
6 | * |
---|
7 | * This program is free software; you can redistribute it and/or |
---|
8 | * modify it under the terms of the GNU General Public License |
---|
9 | * as published by the Free Software Foundation; either version 2 |
---|
10 | * of the License, or (at your option) any later version. |
---|
11 | * |
---|
12 | * This program is distributed in the hope that it will be useful, |
---|
13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
15 | * GNU General Public License for more details. |
---|
16 | * |
---|
17 | * You should have received a copy of the GNU General Public License |
---|
18 | * along with this program; if not, write to the Free Software |
---|
19 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
20 | * |
---|
21 | * As a special exception, the copyright holders of this library give you |
---|
22 | * permission to link this library with independent modules to produce an |
---|
23 | * executable, regardless of the license terms of these independent |
---|
24 | * modules, and to copy and distribute the resulting executable under |
---|
25 | * terms of your choice, provided that you also meet, for each linked |
---|
26 | * independent module, the terms and conditions of the license of that |
---|
27 | * module. An independent module is a module which is not derived from |
---|
28 | * or based on this library. If you modify this library, you may extend |
---|
29 | * this exception to your version of the library, but you are not |
---|
30 | * obligated to do so. If you do not wish to do so, delete this |
---|
31 | * exception statement from your version. |
---|
32 | */ |
---|
33 | |
---|
34 | package org.armedbear.lisp; |
---|
35 | |
---|
36 | import static org.armedbear.lisp.Lisp.*; |
---|
37 | |
---|
38 | public class StandardObject extends LispObject |
---|
39 | { |
---|
40 | protected Layout layout; |
---|
41 | protected LispObject[] slots; |
---|
42 | |
---|
43 | protected StandardObject() |
---|
44 | { |
---|
45 | layout = new Layout(StandardClass.STANDARD_OBJECT, NIL, NIL); |
---|
46 | } |
---|
47 | |
---|
48 | |
---|
49 | protected StandardObject(Layout layout) |
---|
50 | { |
---|
51 | this(layout, layout.getLength()); |
---|
52 | } |
---|
53 | |
---|
54 | protected StandardObject(Layout layout, int length) |
---|
55 | { |
---|
56 | this.layout = layout; |
---|
57 | slots = new LispObject[length]; |
---|
58 | for (int i = slots.length; i-- > 0;) |
---|
59 | slots[i] = UNBOUND_VALUE; |
---|
60 | } |
---|
61 | |
---|
62 | |
---|
63 | protected StandardObject(LispClass cls, int length) |
---|
64 | { |
---|
65 | layout = cls == null ? null : cls.getClassLayout(); |
---|
66 | slots = new LispObject[length]; |
---|
67 | for (int i = slots.length; i-- > 0;) |
---|
68 | slots[i] = UNBOUND_VALUE; |
---|
69 | } |
---|
70 | |
---|
71 | protected StandardObject(LispClass cls) |
---|
72 | { |
---|
73 | layout = cls == null ? null : cls.getClassLayout(); |
---|
74 | slots = new LispObject[layout == null ? 0 : layout.getLength()]; |
---|
75 | for (int i = slots.length; i-- > 0;) |
---|
76 | slots[i] = UNBOUND_VALUE; |
---|
77 | } |
---|
78 | |
---|
79 | @Override |
---|
80 | public LispObject getParts() |
---|
81 | { |
---|
82 | LispObject parts = NIL; |
---|
83 | if (layout != null) |
---|
84 | { |
---|
85 | if (layout.isInvalid()) |
---|
86 | { |
---|
87 | // Update instance. |
---|
88 | layout = updateLayout(); |
---|
89 | } |
---|
90 | } |
---|
91 | parts = parts.push(new Cons("LAYOUT", layout)); |
---|
92 | if (layout != null) |
---|
93 | { |
---|
94 | LispObject[] slotNames = layout.getSlotNames(); |
---|
95 | if (slotNames != null) |
---|
96 | { |
---|
97 | for (int i = 0; i < slotNames.length; i++) |
---|
98 | { |
---|
99 | parts = parts.push(new Cons(slotNames[i], slots[i])); |
---|
100 | } |
---|
101 | } |
---|
102 | } |
---|
103 | return parts.nreverse(); |
---|
104 | } |
---|
105 | |
---|
106 | public final LispObject getLispClass() |
---|
107 | { |
---|
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); |
---|
127 | } |
---|
128 | |
---|
129 | @Override |
---|
130 | public LispObject typeOf() |
---|
131 | { |
---|
132 | // "For objects of metaclass STRUCTURE-CLASS or STANDARD-CLASS, and for |
---|
133 | // conditions, TYPE-OF returns the proper name of the class returned by |
---|
134 | // CLASS-OF if it has a proper name, and otherwise returns the class |
---|
135 | // itself." |
---|
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 | |
---|
143 | // The proper name of a class is "a symbol that names the class whose |
---|
144 | // name is that symbol". |
---|
145 | if (name != NIL && name != UNBOUND_VALUE) |
---|
146 | { |
---|
147 | // TYPE-OF.9 |
---|
148 | final LispObject c2 = LispClass.findClass(name, false); |
---|
149 | if (c2 == c1) |
---|
150 | return name; |
---|
151 | } |
---|
152 | return c1; |
---|
153 | } |
---|
154 | |
---|
155 | @Override |
---|
156 | public LispObject classOf() |
---|
157 | { |
---|
158 | return layout.getLispClass(); |
---|
159 | } |
---|
160 | |
---|
161 | @Override |
---|
162 | public LispObject typep(LispObject type) |
---|
163 | { |
---|
164 | if (type == Symbol.STANDARD_OBJECT) |
---|
165 | return T; |
---|
166 | if (type == StandardClass.STANDARD_OBJECT) |
---|
167 | return T; |
---|
168 | LispObject cls = layout != null ? layout.getLispClass() : null; |
---|
169 | if (cls != null) |
---|
170 | { |
---|
171 | if (type == cls) |
---|
172 | return T; |
---|
173 | if (type == helperGetClassName()) |
---|
174 | return T; |
---|
175 | LispObject cpl = helperGetCPL(); |
---|
176 | while (cpl != NIL) |
---|
177 | { |
---|
178 | if (type == cpl.car()) |
---|
179 | 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 | |
---|
192 | cpl = cpl.cdr(); |
---|
193 | } |
---|
194 | } |
---|
195 | return super.typep(type); |
---|
196 | } |
---|
197 | |
---|
198 | @Override |
---|
199 | public String printObject() |
---|
200 | { |
---|
201 | final LispThread thread = LispThread.currentThread(); |
---|
202 | int maxLevel = Integer.MAX_VALUE; |
---|
203 | LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread); |
---|
204 | if (printLevel instanceof Fixnum) |
---|
205 | maxLevel = ((Fixnum)printLevel).value; |
---|
206 | LispObject currentPrintLevel = |
---|
207 | _CURRENT_PRINT_LEVEL_.symbolValue(thread); |
---|
208 | int currentLevel = Fixnum.getValue(currentPrintLevel); |
---|
209 | if (currentLevel >= maxLevel) |
---|
210 | return "#"; |
---|
211 | return unreadableString(typeOf().printObject()); |
---|
212 | } |
---|
213 | |
---|
214 | synchronized Layout updateLayout() |
---|
215 | { |
---|
216 | if (!layout.isInvalid()) return layout; |
---|
217 | Layout oldLayout = layout; |
---|
218 | LispObject cls = oldLayout.getLispClass(); |
---|
219 | Layout newLayout; |
---|
220 | |
---|
221 | if (cls instanceof LispClass) |
---|
222 | newLayout = ((LispClass)cls).getClassLayout(); |
---|
223 | else |
---|
224 | newLayout = (Layout)Symbol.CLASS_LAYOUT.execute(cls); |
---|
225 | |
---|
226 | Debug.assertTrue(!newLayout.isInvalid()); |
---|
227 | StandardObject newInstance = new StandardObject(newLayout); |
---|
228 | Debug.assertTrue(newInstance.layout == newLayout); |
---|
229 | LispObject added = NIL; |
---|
230 | LispObject discarded = NIL; |
---|
231 | LispObject plist = NIL; |
---|
232 | // Old local slots. |
---|
233 | LispObject[] oldSlotNames = oldLayout.getSlotNames(); |
---|
234 | for (int i = 0; i < oldSlotNames.length; i++) |
---|
235 | { |
---|
236 | LispObject slotName = oldSlotNames[i]; |
---|
237 | int j = newLayout.getSlotIndex(slotName); |
---|
238 | if (j >= 0) |
---|
239 | newInstance.slots[j] = slots[i]; |
---|
240 | else |
---|
241 | { |
---|
242 | discarded = discarded.push(slotName); |
---|
243 | if (slots[i] != UNBOUND_VALUE) |
---|
244 | { |
---|
245 | plist = plist.push(slotName); |
---|
246 | plist = plist.push(slots[i]); |
---|
247 | } |
---|
248 | } |
---|
249 | } |
---|
250 | // Old shared slots. |
---|
251 | LispObject rest = oldLayout.getSharedSlots(); // A list. |
---|
252 | if (rest != null) |
---|
253 | { |
---|
254 | while (rest != NIL) |
---|
255 | { |
---|
256 | LispObject location = rest.car(); |
---|
257 | LispObject slotName = location.car(); |
---|
258 | int i = newLayout.getSlotIndex(slotName); |
---|
259 | if (i >= 0) |
---|
260 | newInstance.slots[i] = location.cdr(); |
---|
261 | rest = rest.cdr(); |
---|
262 | } |
---|
263 | } |
---|
264 | // Go through all the new local slots to compute the added slots. |
---|
265 | LispObject[] newSlotNames = newLayout.getSlotNames(); |
---|
266 | for (int i = 0; i < newSlotNames.length; i++) |
---|
267 | { |
---|
268 | LispObject slotName = newSlotNames[i]; |
---|
269 | int j = oldLayout.getSlotIndex(slotName); |
---|
270 | if (j >= 0) |
---|
271 | continue; |
---|
272 | LispObject location = oldLayout.getSharedSlotLocation(slotName); |
---|
273 | if (location != null) |
---|
274 | continue; |
---|
275 | // Not found. |
---|
276 | added = added.push(slotName); |
---|
277 | } |
---|
278 | // Swap slots. |
---|
279 | LispObject[] tempSlots = slots; |
---|
280 | slots = newInstance.slots; |
---|
281 | newInstance.slots = tempSlots; |
---|
282 | // Swap layouts. |
---|
283 | Layout tempLayout = layout; |
---|
284 | layout = newInstance.layout; |
---|
285 | newInstance.layout = tempLayout; |
---|
286 | Debug.assertTrue(!layout.isInvalid()); |
---|
287 | // Call UPDATE-INSTANCE-FOR-REDEFINED-CLASS. |
---|
288 | Symbol.UPDATE_INSTANCE_FOR_REDEFINED_CLASS.execute(this, added, |
---|
289 | discarded, plist); |
---|
290 | return newLayout; |
---|
291 | } |
---|
292 | |
---|
293 | // Only handles instance slots (not shared slots). |
---|
294 | public LispObject getInstanceSlotValue(LispObject slotName) |
---|
295 | |
---|
296 | { |
---|
297 | Debug.assertTrue(layout != null); |
---|
298 | if (layout.isInvalid()) |
---|
299 | { |
---|
300 | // Update instance. |
---|
301 | layout = updateLayout(); |
---|
302 | } |
---|
303 | Debug.assertTrue(layout != null); |
---|
304 | int index = layout.getSlotIndex(slotName); |
---|
305 | if (index < 0) { |
---|
306 | // Not found. |
---|
307 | final LispThread thread = LispThread.currentThread(); |
---|
308 | // If the operation is slot-value, only the primary value [of |
---|
309 | // slot-missing] will be used by the caller, and all other values |
---|
310 | // will be ignored. |
---|
311 | LispObject value = thread.execute(Symbol.SLOT_MISSING, |
---|
312 | this.getLispClass(), this, |
---|
313 | slotName, Symbol.SLOT_VALUE); |
---|
314 | thread._values = null; |
---|
315 | return value; |
---|
316 | } |
---|
317 | return slots[index]; |
---|
318 | } |
---|
319 | |
---|
320 | // Only handles instance slots (not shared slots). |
---|
321 | public void setInstanceSlotValue(LispObject slotName, LispObject newValue) |
---|
322 | |
---|
323 | { |
---|
324 | Debug.assertTrue(layout != null); |
---|
325 | if (layout.isInvalid()) |
---|
326 | { |
---|
327 | // Update instance. |
---|
328 | layout = updateLayout(); |
---|
329 | } |
---|
330 | Debug.assertTrue(layout != null); |
---|
331 | int index = layout.getSlotIndex(slotName); |
---|
332 | if (index < 0) { |
---|
333 | // Not found. |
---|
334 | final LispThread thread = LispThread.currentThread(); |
---|
335 | // If the operation is setf or slot-makunbound, any values |
---|
336 | // [returned by slot-missing] will be ignored by the caller. |
---|
337 | thread.execute(Symbol.SLOT_MISSING, this.getLispClass(), this, |
---|
338 | slotName, Symbol.SETF, newValue); |
---|
339 | thread._values = null; |
---|
340 | } |
---|
341 | slots[index] = newValue; |
---|
342 | } |
---|
343 | |
---|
344 | final public static StandardObject checkStandardObject(LispObject first) |
---|
345 | { |
---|
346 | if (first instanceof StandardObject) |
---|
347 | return (StandardObject) first; |
---|
348 | return (StandardObject) type_error(first, Symbol.STANDARD_OBJECT); |
---|
349 | } |
---|
350 | |
---|
351 | private static final Primitive SWAP_SLOTS |
---|
352 | = new pf_swap_slots(); |
---|
353 | @DocString(name="swap-slots", |
---|
354 | args="instance-1 instance-2", |
---|
355 | returns="nil") |
---|
356 | private static final class pf_swap_slots extends Primitive |
---|
357 | { |
---|
358 | pf_swap_slots() |
---|
359 | { |
---|
360 | super("swap-slots", PACKAGE_SYS, true, "instance-1 instance-2"); |
---|
361 | } |
---|
362 | @Override |
---|
363 | public LispObject execute(LispObject first, LispObject second) |
---|
364 | { |
---|
365 | final StandardObject obj1 = checkStandardObject(first); |
---|
366 | final StandardObject obj2 = checkStandardObject(second); |
---|
367 | LispObject[] temp = obj1.slots; |
---|
368 | obj1.slots = obj2.slots; |
---|
369 | obj2.slots = temp; |
---|
370 | return NIL; |
---|
371 | } |
---|
372 | }; |
---|
373 | |
---|
374 | private static final Primitive STD_INSTANCE_LAYOUT |
---|
375 | = new pf_std_instance_layout(); |
---|
376 | @DocString(name="std-instance-layout") |
---|
377 | private static final class pf_std_instance_layout extends Primitive |
---|
378 | { |
---|
379 | pf_std_instance_layout() |
---|
380 | { |
---|
381 | super("std-instance-layout", PACKAGE_SYS, true); |
---|
382 | } |
---|
383 | @Override |
---|
384 | public LispObject execute(LispObject arg) |
---|
385 | { |
---|
386 | final StandardObject instance = checkStandardObject(arg); |
---|
387 | Layout layout = instance.layout; |
---|
388 | if (layout.isInvalid()) |
---|
389 | { |
---|
390 | // Update instance. |
---|
391 | layout = instance.updateLayout(); |
---|
392 | } |
---|
393 | return layout; |
---|
394 | } |
---|
395 | }; |
---|
396 | |
---|
397 | private static final Primitive _SET_STD_INSTANCE_LAYOUT |
---|
398 | = new pf__set_std_instance_layout(); |
---|
399 | @DocString(name="%set-std-instance-layout") |
---|
400 | private static final class pf__set_std_instance_layout extends Primitive |
---|
401 | { |
---|
402 | pf__set_std_instance_layout() |
---|
403 | { |
---|
404 | super("%set-std-instance-layout", PACKAGE_SYS, true); |
---|
405 | } |
---|
406 | @Override |
---|
407 | public LispObject execute(LispObject first, LispObject second) |
---|
408 | { |
---|
409 | checkStandardObject(first).layout = checkLayout(second); |
---|
410 | return second; |
---|
411 | } |
---|
412 | }; |
---|
413 | |
---|
414 | private static final Primitive STD_INSTANCE_CLASS |
---|
415 | = new pf_std_instance_class(); |
---|
416 | @DocString(name="std-instance-class") |
---|
417 | private static final class pf_std_instance_class extends Primitive |
---|
418 | { |
---|
419 | pf_std_instance_class() |
---|
420 | { |
---|
421 | super("std-instance-class", PACKAGE_SYS, true); |
---|
422 | } |
---|
423 | @Override |
---|
424 | public LispObject execute(LispObject arg) |
---|
425 | { |
---|
426 | return checkStandardObject(arg).layout.getLispClass(); |
---|
427 | } |
---|
428 | }; |
---|
429 | |
---|
430 | private static final Primitive STANDARD_INSTANCE_ACCESS |
---|
431 | = new pf_standard_instance_access(); |
---|
432 | @DocString(name="standard-instance-access", |
---|
433 | args="instance location", |
---|
434 | returns="value") |
---|
435 | private static final class pf_standard_instance_access extends Primitive |
---|
436 | { |
---|
437 | pf_standard_instance_access() |
---|
438 | { |
---|
439 | super("standard-instance-access", PACKAGE_SYS, true, |
---|
440 | "instance location"); |
---|
441 | } |
---|
442 | @Override |
---|
443 | public LispObject execute(LispObject first, LispObject second) |
---|
444 | { |
---|
445 | final StandardObject instance = checkStandardObject(first); |
---|
446 | if (instance.layout.isInvalid()) { |
---|
447 | // Update instance. |
---|
448 | instance.updateLayout(); |
---|
449 | } |
---|
450 | final int index; |
---|
451 | if (second instanceof Fixnum) { |
---|
452 | index = ((Fixnum)second).value; |
---|
453 | } else { |
---|
454 | return type_error(second, Symbol.INTEGER); |
---|
455 | } |
---|
456 | |
---|
457 | LispObject value; |
---|
458 | try { |
---|
459 | value = instance.slots[index]; |
---|
460 | } catch (ArrayIndexOutOfBoundsException e) { |
---|
461 | if (instance.slots.length > 0) |
---|
462 | return type_error(second, |
---|
463 | list(Symbol.INTEGER, Fixnum.ZERO, |
---|
464 | Fixnum.getInstance(instance.slots.length - 1))); |
---|
465 | else |
---|
466 | return program_error("The object " + instance.princToString() |
---|
467 | + " has no slots."); |
---|
468 | |
---|
469 | } |
---|
470 | // We let UNBOUND_VALUE escape here, since invoking |
---|
471 | // standard-instance-access on an unbound slot has undefined |
---|
472 | // consequences (AMOP pg. 239), and we use this behavior to |
---|
473 | // implement slot-boundp-using-class. |
---|
474 | return value; |
---|
475 | } |
---|
476 | }; |
---|
477 | |
---|
478 | private static final Primitive _SET_STANDARD_INSTANCE_ACCESS |
---|
479 | = new pf__set_standard_instance_access(); |
---|
480 | @DocString(name="%set-standard-instance-access", |
---|
481 | args="instance location new-value", |
---|
482 | returns="new-value") |
---|
483 | private static final class pf__set_standard_instance_access extends Primitive |
---|
484 | { |
---|
485 | pf__set_standard_instance_access() |
---|
486 | { |
---|
487 | super("%set-standard-instance-access", PACKAGE_SYS, true); |
---|
488 | } |
---|
489 | @Override |
---|
490 | public LispObject execute(LispObject first, LispObject second, |
---|
491 | LispObject third) |
---|
492 | { |
---|
493 | final StandardObject instance = checkStandardObject(first); |
---|
494 | if (instance.layout.isInvalid()) { |
---|
495 | // Update instance. |
---|
496 | instance.updateLayout(); |
---|
497 | } |
---|
498 | final int index; |
---|
499 | if (second instanceof Fixnum) { |
---|
500 | index = ((Fixnum)second).value; |
---|
501 | } else { |
---|
502 | return type_error(second, Symbol.INTEGER); |
---|
503 | } |
---|
504 | try { |
---|
505 | instance.slots[index] = third; |
---|
506 | } catch (ArrayIndexOutOfBoundsException e) { |
---|
507 | if (instance.slots.length > 0) |
---|
508 | return type_error(second, |
---|
509 | list(Symbol.INTEGER, Fixnum.ZERO, |
---|
510 | Fixnum.getInstance(instance.slots.length - 1))); |
---|
511 | else |
---|
512 | return program_error("The object " + instance.princToString() |
---|
513 | + " has no slots."); |
---|
514 | } |
---|
515 | return third; |
---|
516 | } |
---|
517 | }; |
---|
518 | |
---|
519 | private static final Primitive STD_SLOT_BOUNDP |
---|
520 | = new pf_std_slot_boundp(); |
---|
521 | @DocString(name="std-slot-boundp") |
---|
522 | private static final class pf_std_slot_boundp extends Primitive |
---|
523 | { |
---|
524 | pf_std_slot_boundp() |
---|
525 | { |
---|
526 | super(Symbol.STD_SLOT_BOUNDP, "instance slot-name"); |
---|
527 | } |
---|
528 | @Override |
---|
529 | public LispObject execute(LispObject first, LispObject second) |
---|
530 | { |
---|
531 | final StandardObject instance = checkStandardObject(first); |
---|
532 | Layout layout = instance.layout; |
---|
533 | if (layout.isInvalid()) |
---|
534 | { |
---|
535 | // Update instance. |
---|
536 | layout = instance.updateLayout(); |
---|
537 | } |
---|
538 | final LispObject index = layout.slotTable.get(second); |
---|
539 | if (index != null) |
---|
540 | { |
---|
541 | // Found instance slot. |
---|
542 | return instance.slots[((Fixnum)index).value] != UNBOUND_VALUE ? T : NIL; |
---|
543 | } |
---|
544 | // Check for shared slot. |
---|
545 | final LispObject location = layout.getSharedSlotLocation(second); |
---|
546 | if (location != null) |
---|
547 | return location.cdr() != UNBOUND_VALUE ? T : NIL; |
---|
548 | // Not found. |
---|
549 | final LispThread thread = LispThread.currentThread(); |
---|
550 | LispObject value = |
---|
551 | thread.execute(Symbol.SLOT_MISSING, instance.getLispClass(), |
---|
552 | instance, second, Symbol.SLOT_BOUNDP); |
---|
553 | // "If SLOT-MISSING is invoked and returns a value, a boolean |
---|
554 | // equivalent to its primary value is returned by SLOT-BOUNDP." |
---|
555 | thread._values = null; |
---|
556 | return value != NIL ? T : NIL; |
---|
557 | } |
---|
558 | }; |
---|
559 | |
---|
560 | @Override |
---|
561 | public LispObject SLOT_VALUE(LispObject slotName) |
---|
562 | { |
---|
563 | if (layout.isInvalid()) |
---|
564 | { |
---|
565 | // Update instance. |
---|
566 | layout = updateLayout(); |
---|
567 | } |
---|
568 | LispObject value; |
---|
569 | final LispObject index = layout.slotTable.get(slotName); |
---|
570 | if (index != null) |
---|
571 | { |
---|
572 | // Found instance slot. |
---|
573 | value = slots[((Fixnum)index).value]; |
---|
574 | } |
---|
575 | else |
---|
576 | { |
---|
577 | // Check for shared slot. |
---|
578 | LispObject location = layout.getSharedSlotLocation(slotName); |
---|
579 | if (location == null) |
---|
580 | return Symbol.SLOT_MISSING.execute(getLispClass(), this, slotName, |
---|
581 | Symbol.SLOT_VALUE); |
---|
582 | value = location.cdr(); |
---|
583 | } |
---|
584 | if (value == UNBOUND_VALUE) |
---|
585 | { |
---|
586 | value = Symbol.SLOT_UNBOUND.execute(getLispClass(), this, slotName); |
---|
587 | LispThread.currentThread()._values = null; |
---|
588 | } |
---|
589 | return value; |
---|
590 | } |
---|
591 | |
---|
592 | private static final Primitive STD_SLOT_VALUE |
---|
593 | = new pf_std_slot_value(); |
---|
594 | @DocString(name="std-slot-value") |
---|
595 | private static final class pf_std_slot_value extends Primitive |
---|
596 | { |
---|
597 | pf_std_slot_value() |
---|
598 | { |
---|
599 | super(Symbol.STD_SLOT_VALUE, "instance slot-name"); |
---|
600 | } |
---|
601 | @Override |
---|
602 | public LispObject execute(LispObject first, LispObject second) |
---|
603 | { |
---|
604 | return first.SLOT_VALUE(second); |
---|
605 | } |
---|
606 | }; |
---|
607 | |
---|
608 | @Override |
---|
609 | public void setSlotValue(LispObject slotName, LispObject newValue) |
---|
610 | { |
---|
611 | if (layout.isInvalid()) |
---|
612 | { |
---|
613 | // Update instance. |
---|
614 | layout = updateLayout(); |
---|
615 | } |
---|
616 | final LispObject index = layout.slotTable.get(slotName); |
---|
617 | if (index != null) |
---|
618 | { |
---|
619 | // Found instance slot. |
---|
620 | slots[((Fixnum)index).value] = newValue; |
---|
621 | return; |
---|
622 | } |
---|
623 | // Check for shared slot. |
---|
624 | LispObject location = layout.getSharedSlotLocation(slotName); |
---|
625 | if (location != null) |
---|
626 | { |
---|
627 | location.setCdr(newValue); |
---|
628 | return; |
---|
629 | } |
---|
630 | LispObject[] args = new LispObject[5]; |
---|
631 | args[0] = getLispClass(); |
---|
632 | args[1] = this; |
---|
633 | args[2] = slotName; |
---|
634 | args[3] = Symbol.SETF; |
---|
635 | args[4] = newValue; |
---|
636 | Symbol.SLOT_MISSING.execute(args); |
---|
637 | } |
---|
638 | |
---|
639 | private static final Primitive SET_STD_SLOT_VALUE |
---|
640 | = new pf_set_std_slot_value(); |
---|
641 | @DocString(name="set-std-slot-value") |
---|
642 | private static final class pf_set_std_slot_value extends Primitive |
---|
643 | { |
---|
644 | pf_set_std_slot_value() |
---|
645 | { |
---|
646 | super(Symbol.SET_STD_SLOT_VALUE, "instance slot-name new-value"); |
---|
647 | } |
---|
648 | @Override |
---|
649 | public LispObject execute(LispObject first, LispObject second, |
---|
650 | LispObject third) |
---|
651 | { |
---|
652 | first.setSlotValue(second, third); |
---|
653 | return third; |
---|
654 | } |
---|
655 | }; |
---|
656 | |
---|
657 | private static final Primitive _STD_ALLOCATE_INSTANCE |
---|
658 | = new pf__std_allocate_instance(); |
---|
659 | @DocString(name="%std-allocate-instance", |
---|
660 | args="class", |
---|
661 | returns="instance") |
---|
662 | private static final class pf__std_allocate_instance extends Primitive |
---|
663 | { |
---|
664 | pf__std_allocate_instance() |
---|
665 | { |
---|
666 | super("%std-allocate-instance", PACKAGE_SYS, true, "class"); |
---|
667 | } |
---|
668 | @Override |
---|
669 | public LispObject execute(LispObject arg) |
---|
670 | { |
---|
671 | if (arg == StandardClass.FUNCALLABLE_STANDARD_CLASS) { |
---|
672 | return new FuncallableStandardClass(); |
---|
673 | } else if (arg == StandardClass.STANDARD_CLASS) { |
---|
674 | return new StandardClass(); |
---|
675 | } else if (arg instanceof StandardClass) { |
---|
676 | StandardClass cls = (StandardClass)arg; |
---|
677 | Layout layout = cls.getClassLayout(); |
---|
678 | if (layout == null) { |
---|
679 | program_error("No layout for class " + cls.princToString() + "."); |
---|
680 | } |
---|
681 | return new StandardObject(cls, layout.getLength()); |
---|
682 | } else if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) { |
---|
683 | LispObject l = Symbol.CLASS_LAYOUT.execute(arg); |
---|
684 | if (! (l instanceof Layout)) { |
---|
685 | program_error("Invalid standard class layout for class " |
---|
686 | + arg.princToString() + "."); |
---|
687 | } |
---|
688 | return new StandardObject((Layout)l); |
---|
689 | } else { |
---|
690 | return type_error(arg, Symbol.STANDARD_CLASS); |
---|
691 | } |
---|
692 | } |
---|
693 | }; |
---|
694 | } |
---|