Changeset 13789


Ignore:
Timestamp:
01/17/12 20:15:57 (9 years ago)
Author:
rschlatte
Message:

Implement ensure-class-using-class.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13788 r13789  
    772772  (make-hash-table :test #'eq)
    773773  "Cached sets of allowable initargs, keyed on the class they belong to.")
    774 
    775 (defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
    776   ;; Check for duplicate slots.
    777   (remf all-keys :metaclass)
    778   (let ((slots (getf all-keys :direct-slots)))
    779     (dolist (s1 slots)
    780       (let ((name1 (canonical-slot-name s1)))
    781         (dolist (s2 (cdr (memq s1 slots)))
    782           (when (eq name1 (canonical-slot-name s2))
    783             (error 'program-error "Duplicate slot ~S" name1))))))
    784   ;; Check for duplicate argument names in :DEFAULT-INITARGS.
    785   (let ((names ()))
    786     (do* ((initargs (getf all-keys :direct-default-initargs) (cddr initargs))
    787           (name (car initargs) (car initargs)))
    788          ((null initargs))
    789       (push name names))
    790     (do* ((names names (cdr names))
    791           (name (car names) (car names)))
    792          ((null names))
    793       (when (memq name (cdr names))
    794         (error 'program-error
    795                :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS."
    796                :format-arguments (list name)))))
    797   (let ((old-class (find-class name nil)))
    798     (cond ((and old-class (eq name (class-name old-class)))
    799            (cond ((typep old-class 'built-in-class)
    800                   (error "The symbol ~S names a built-in class." name))
    801                  ((typep old-class 'forward-referenced-class)
    802                   (let ((new-class (apply #'make-instance-standard-class
    803                                           +the-standard-class+
    804                                           :name name all-keys)))
    805                     (%set-find-class name new-class)
    806                     (setf (class-direct-subclasses new-class)
    807                           (class-direct-subclasses old-class))
    808                     (dolist (subclass (class-direct-subclasses old-class))
    809                       (setf (class-direct-superclasses subclass)
    810                             (substitute new-class old-class
    811                                         (class-direct-superclasses subclass))))
    812                     (maybe-finalize-class-subtree new-class)
    813                     new-class))
    814                  (t
    815                   ;; We're redefining the class.
    816                   (apply #'reinitialize-instance old-class all-keys)
    817                   old-class)))
    818           (t
    819            (let ((class (apply (if metaclass
    820                                    #'make-instance
    821                                    #'make-instance-standard-class)
    822                                (or metaclass
    823                                    +the-standard-class+)
    824                                :name name all-keys)))
    825              (%set-find-class name class)
    826              class)))))
    827 
    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 
    835 (defmacro defclass (&whole form name direct-superclasses direct-slots &rest options)
    836   (unless (>= (length form) 3)
    837     (error 'program-error "Wrong number of arguments for DEFCLASS."))
    838   (check-declaration-type name)
    839   `(ensure-class ',name
    840                  :direct-superclasses
    841                  (canonicalize-direct-superclasses ',direct-superclasses)
    842                  :direct-slots
    843                  ,(canonicalize-direct-slots direct-slots)
    844                  ,@(canonicalize-defclass-options options)))
    845774
    846775(defun expand-long-defcombin (name args)
     
    25962525(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
    25972526
     2527;;; Class definition
     2528
     2529(defun check-duplicate-slots (slots)
     2530  (dolist (s1 slots)
     2531    (let ((name1 (canonical-slot-name s1)))
     2532      (dolist (s2 (cdr (memq s1 slots)))
     2533        (when (eq name1 (canonical-slot-name s2))
     2534          (error 'program-error "Duplicate slot ~S" name1))))))
     2535
     2536(defun check-duplicate-default-initargs (initargs)
     2537  (let ((names ()))
     2538    (do* ((initargs initargs (cddr initargs))
     2539          (name (car initargs) (car initargs)))
     2540         ((null initargs))
     2541      (push name names))
     2542    (do* ((names names (cdr names))
     2543          (name (car names) (car names)))
     2544         ((null names))
     2545      (when (memq name (cdr names))
     2546        (error 'program-error
     2547               :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS."
     2548               :format-arguments (list name))))))
     2549
     2550 ;;; AMOP pg. 182
     2551(defun ensure-class (name &rest all-keys &key &allow-other-keys)
     2552  (apply #'ensure-class-using-class (find-class name nil) name all-keys))
     2553
     2554;;; AMOP pg. 183ff.
     2555(defgeneric ensure-class-using-class (class name &key direct-default-initargs
     2556                                      direct-slots direct-superclasses name
     2557                                      metaclass &allow-other-keys))
     2558
     2559(defmethod ensure-class-using-class :before (class name  &key direct-slots
     2560                                             direct-default-initargs
     2561                                             &allow-other-keys)
     2562  (check-duplicate-slots direct-slots)
     2563  (check-duplicate-default-initargs direct-default-initargs))
     2564
     2565(defmethod ensure-class-using-class ((class null) name &rest all-keys
     2566                                     &key (metaclass +the-standard-class+)
     2567                                     direct-superclasses
     2568                                     &allow-other-keys)
     2569  (setf all-keys (copy-list all-keys))  ; since we modify it
     2570  (remf all-keys :metaclass)
     2571  (let ((class (apply (if (eq metaclass +the-standard-class+)
     2572                          #'make-instance-standard-class
     2573                          #'make-instance)
     2574                      metaclass :name name
     2575                      :direct-superclasses (canonicalize-direct-superclasses
     2576                                            direct-superclasses)
     2577                      all-keys)))
     2578    (%set-find-class name class)
     2579    class))
     2580
     2581(defmethod ensure-class-using-class ((class built-in-class) name &rest all-keys
     2582                                     &key &allow-other-keys)
     2583  (declare (ignore all-keys))
     2584  (error "The symbol ~S names a built-in class." name))
     2585
     2586 (defmethod ensure-class-using-class ((class forward-referenced-class) name
     2587                                      &key (metaclass +the-standard-class+)
     2588                                      direct-superclasses
     2589                                      &rest all-keys &key &allow-other-keys)
     2590   (setf all-keys (copy-list all-keys))  ; since we modify it
     2591   (remf all-keys :metaclass)
     2592   (change-class class metaclass)
     2593   (apply #'reinitialize-instance class
     2594          :direct-superclasses (canonicalize-direct-superclasses
     2595                                direct-superclasses)
     2596          all-keys)
     2597   class)
     2598
     2599(defmethod ensure-class-using-class ((class class) name
     2600                                     &key (metaclass +the-standard-class+ metaclassp)
     2601                                     direct-superclasses &rest all-keys
     2602                                     &allow-other-keys)
     2603  (setf all-keys (copy-list all-keys))  ; since we modify it
     2604  (remf all-keys :metaclass)
     2605  (when (and metaclassp (not (eq (class-of class) metaclass)))
     2606    (error 'program-error
     2607           "Trying to redefine class ~S with different metaclass."
     2608           (class-name class)))
     2609  (apply #'reinitialize-instance class
     2610         :direct-superclasses (canonicalize-direct-superclasses direct-superclasses)
     2611         all-keys)
     2612  class)
     2613
     2614(defun maybe-finalize-class-subtree (class)
     2615  (when (every #'class-finalized-p (class-direct-superclasses class))
     2616    (finalize-inheritance class)
     2617    (dolist (subclass (class-direct-subclasses class))
     2618      (maybe-finalize-class-subtree subclass))))
     2619
     2620(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options)
     2621  (unless (>= (length form) 3)
     2622    (error 'program-error "Wrong number of arguments for DEFCLASS."))
     2623  (check-declaration-type name)
     2624  `(ensure-class ',name
     2625                 :direct-superclasses
     2626                 (canonicalize-direct-superclasses ',direct-superclasses)
     2627                 :direct-slots
     2628                 ,(canonicalize-direct-slots direct-slots)
     2629                 ,@(canonicalize-defclass-options options)))
     2630
     2631
     2632
    25982633(defgeneric direct-slot-definition-class (class &rest initargs))
    25992634
  • trunk/abcl/src/org/armedbear/lisp/mop.lisp

    r13774 r13789  
    4444
    4545          ensure-class
     46          ensure-class-using-class
    4647
    4748          class-default-initargs
Note: See TracChangeset for help on using the changeset viewer.