Changeset 12752
- Timestamp:
- 06/13/10 21:33:04 (13 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java
r12749 r12752 91 91 } 92 92 93 public static S lotDefinitioncheckSlotDefinition(LispObject obj) {94 if (obj instanceof S lotDefinition) return (SlotDefinition)obj;95 return (S lotDefinition)type_error(obj, Symbol.SLOT_DEFINITION);93 public static StandardObject checkSlotDefinition(LispObject obj) { 94 if (obj instanceof StandardObject) return (StandardObject)obj; 95 return (StandardObject)type_error(obj, Symbol.SLOT_DEFINITION); 96 96 } 97 97 -
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r12749 r12752 61 61 (find-class 'standard-generic-function)) 62 62 (defconstant +the-T-class+ (find-class 'T)) 63 (defconstant +the-slot-definition-class+ (find-class 'slot-definition)) 63 64 (defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition)) 64 65 (defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition)) … … 262 263 `(function (lambda () ,initform))) 263 264 265 (defun slot-definition-allocation (slot-definition) 266 (%slot-definition-allocation slot-definition)) 267 268 (defun slot-definition-initargs (slot-definition) 269 (%slot-definition-initargs slot-definition)) 270 271 (defun slot-definition-initform (slot-definition) 272 (%slot-definition-initform slot-definition)) 273 274 (defun slot-definition-initfunction (slot-definition) 275 (%slot-definition-initfunction slot-definition)) 276 277 (defun slot-definition-name (slot-definition) 278 (%slot-definition-name slot-definition)) 279 264 280 (defun init-slot-definition (slot &key name 265 281 (initargs ()) … … 328 344 (shared-slots '())) 329 345 (dolist (slot (class-slots class)) 330 (case ( %slot-definition-allocation slot)346 (case (slot-definition-allocation slot) 331 347 (:instance 332 348 (set-slot-definition-location slot length) 333 349 (incf length) 334 (push ( %slot-definition-name slot) instance-slots))350 (push (slot-definition-name slot) instance-slots)) 335 351 (:class 336 352 (unless (%slot-definition-location slot) … … 338 354 (set-slot-definition-location slot 339 355 (if (eq allocation-class class) 340 (cons ( %slot-definition-name slot) +slot-unbound+)341 (slot-location allocation-class ( %slot-definition-name slot))))))356 (cons (slot-definition-name slot) +slot-unbound+) 357 (slot-location allocation-class (slot-definition-name slot)))))) 342 358 (push (%slot-definition-location slot) shared-slots)))) 343 359 (when old-layout … … 347 363 (old-location (layout-slot-location old-layout slot-name))) 348 364 (unless old-location 349 (let* ((slot-definition (find slot-name (class-slots class) :key #' %slot-definition-name))350 (initfunction ( %slot-definition-initfunction slot-definition)))365 (let* ((slot-definition (find slot-name (class-slots class) :key #'slot-definition-name)) 366 (initfunction (slot-definition-initfunction slot-definition))) 351 367 (when initfunction 352 368 (setf (cdr location) (funcall initfunction)))))))) … … 450 466 (class-precedence-list class))) 451 467 (all-names (remove-duplicates 452 (mapcar #' %slot-definition-name all-slots))))468 (mapcar #'slot-definition-name all-slots)))) 453 469 (mapcar #'(lambda (name) 454 470 (funcall … … 458 474 class 459 475 (remove name all-slots 460 :key #' %slot-definition-name476 :key #'slot-definition-name 461 477 :test-not #'eq))) 462 478 all-names))) … … 464 480 (defun std-compute-effective-slot-definition (class direct-slots) 465 481 (let ((initer (find-if-not #'null direct-slots 466 :key #' %slot-definition-initfunction)))482 :key #'slot-definition-initfunction))) 467 483 (make-effective-slot-definition 468 484 class 469 :name ( %slot-definition-name (car direct-slots))485 :name (slot-definition-name (car direct-slots)) 470 486 :initform (if initer 471 ( %slot-definition-initform initer)487 (slot-definition-initform initer) 472 488 nil) 473 489 :initfunction (if initer 474 ( %slot-definition-initfunction initer)490 (slot-definition-initfunction initer) 475 491 nil) 476 492 :initargs (remove-duplicates 477 (mapappend #' %slot-definition-initargs493 (mapappend #'slot-definition-initargs 478 494 direct-slots)) 479 :allocation ( %slot-definition-allocation (car direct-slots))495 :allocation (slot-definition-allocation (car direct-slots)) 480 496 :allocation-class (%slot-definition-allocation-class (car direct-slots))))) 481 497 … … 488 504 (defun find-slot-definition (class slot-name) 489 505 (dolist (slot (class-slots class) nil) 490 (when (eq slot-name ( %slot-definition-name slot))506 (when (eq slot-name (slot-definition-name slot)) 491 507 (return slot)))) 492 508 … … 538 554 (defun std-slot-exists-p (instance slot-name) 539 555 (not (null (find slot-name (class-slots (class-of instance)) 540 :key #' %slot-definition-name))))556 :key #'slot-definition-name)))) 541 557 542 558 (defun slot-exists-p (object slot-name) … … 546 562 547 563 (defun instance-slot-p (slot) 548 (eq ( %slot-definition-allocation slot) :instance))564 (eq (slot-definition-allocation slot) :instance)) 549 565 550 566 (defun make-instance-standard-class (metaclass … … 588 604 (dolist (direct-slot slots) 589 605 (dolist (reader (%slot-definition-readers direct-slot)) 590 (add-reader-method class reader ( %slot-definition-name direct-slot)))606 (add-reader-method class reader (slot-definition-name direct-slot))) 591 607 (dolist (writer (%slot-definition-writers direct-slot)) 592 (add-writer-method class writer ( %slot-definition-name direct-slot)))))608 (add-writer-method class writer (slot-definition-name direct-slot))))) 593 609 (setf (class-direct-default-initargs class) direct-default-initargs) 594 610 (funcall (if (eq (class-of class) +the-standard-class+) … … 2161 2177 (defun valid-initarg-p (initarg slots) 2162 2178 (dolist (slot slots nil) 2163 (let ((valid-initargs ( %slot-definition-initargs slot)))2179 (let ((valid-initargs (slot-definition-initargs slot))) 2164 2180 (when (memq initarg valid-initargs) 2165 2181 (return t))))) … … 2218 2234 :format-arguments (list initarg)))) 2219 2235 (dolist (slot (class-slots (class-of instance))) 2220 (let ((slot-name ( %slot-definition-name slot)))2236 (let ((slot-name (slot-definition-name slot))) 2221 2237 (multiple-value-bind (init-key init-value foundp) 2222 (get-properties all-keys ( %slot-definition-initargs slot))2238 (get-properties all-keys (slot-definition-initargs slot)) 2223 2239 (if foundp 2224 2240 (setf (std-slot-value instance slot-name) init-value) 2225 2241 (unless (std-slot-boundp instance slot-name) 2226 (let ((initfunction ( %slot-definition-initfunction slot)))2242 (let ((initfunction (slot-definition-initfunction slot))) 2227 2243 (when (and initfunction (or (eq slot-names t) 2228 2244 (memq slot-name slot-names))) … … 2261 2277 (dolist (new-slot new-slots) 2262 2278 (when (instance-slot-p new-slot) 2263 (let* ((slot-name ( %slot-definition-name new-slot))2264 (old-slot (find slot-name old-slots :key #' %slot-definition-name)))2279 (let* ((slot-name (slot-definition-name new-slot)) 2280 (old-slot (find slot-name old-slots :key #'slot-definition-name))) 2265 2281 ;; "The values of slots specified as shared in the class CFROM and as 2266 2282 ;; local in the class CTO are retained." … … 2285 2301 (remove-if #'(lambda (slot-name) 2286 2302 (slot-exists-p old slot-name)) 2287 (mapcar #' %slot-definition-name2303 (mapcar #'slot-definition-name 2288 2304 (class-slots (class-of new)))))) 2289 2305 (check-initargs new added-slots initargs) … … 2376 2392 ;;; Slot definition accessors 2377 2393 2378 (export '(slot-definition-allocation 2394 (mapcar (lambda (sym) 2395 (fmakunbound sym) ;;we need to redefine them as GFs 2396 (export sym)) 2397 '(slot-definition-allocation 2379 2398 slot-definition-initargs 2380 2399 slot-definition-initform … … 2384 2403 (defgeneric slot-definition-allocation (slot-definition) 2385 2404 (:method ((slot-definition slot-definition)) 2386 (%slot-definition-allocation slot-definition))) 2405 (let ((cl (class-of slot-definition))) 2406 (case cl 2407 ((+the-slot-definition-class+ 2408 +the-direct-slot-definition-class+ 2409 +the-effective-slot-definition-class+) 2410 (%slot-definition-allocation slot-definition)) 2411 (t (slot-value slot-definition 'sys::allocation)))))) 2387 2412 2388 2413 (defgeneric slot-definition-initargs (slot-definition) 2389 2414 (:method ((slot-definition slot-definition)) 2390 (%slot-definition-initargs slot-definition))) 2415 (let ((cl (class-of slot-definition))) 2416 (case cl 2417 ((+the-slot-definition-class+ 2418 +the-direct-slot-definition-class+ 2419 +the-effective-slot-definition-class+) 2420 (%slot-definition-initargs slot-definition)) 2421 (t (slot-value slot-definition 'sys::initargs)))))) 2391 2422 2392 2423 (defgeneric slot-definition-initform (slot-definition) 2393 2424 (:method ((slot-definition slot-definition)) 2394 (%slot-definition-initform slot-definition))) 2425 (let ((cl (class-of slot-definition))) 2426 (case cl 2427 ((+the-slot-definition-class+ 2428 +the-direct-slot-definition-class+ 2429 +the-effective-slot-definition-class+) 2430 (%slot-definition-initform slot-definition)) 2431 (t (slot-value slot-definition 'sys::initform)))))) 2395 2432 2396 2433 (defgeneric slot-definition-initfunction (slot-definition) 2397 2434 (:method ((slot-definition slot-definition)) 2398 (%slot-definition-initfunction slot-definition))) 2435 (let ((cl (class-of slot-definition))) 2436 (case cl 2437 ((+the-slot-definition-class+ 2438 +the-direct-slot-definition-class+ 2439 +the-effective-slot-definition-class+) 2440 (%slot-definition-initfunction slot-definition)) 2441 (t (slot-value slot-definition 'sys::initfunction)))))) 2399 2442 2400 2443 (defgeneric slot-definition-name (slot-definition) 2401 2444 (:method ((slot-definition slot-definition)) 2402 (%slot-definition-name slot-definition))) 2445 (let ((cl (class-of slot-definition))) 2446 (case cl 2447 ((+the-slot-definition-class+ 2448 +the-direct-slot-definition-class+ 2449 +the-effective-slot-definition-class+) 2450 (%slot-definition-name slot-definition)) 2451 (t (slot-value slot-definition 'sys::name)))))) 2403 2452 2404 2453 ;;; No %slot-definition-type.
Note: See TracChangeset
for help on using the changeset viewer.