Ignore:
Timestamp:
03/28/10 20:13:14 (12 years ago)
Author:
ehuelsmann
Message:

Re #38: Merge the METACLASS branch to trunk.

File:
1 edited

Legend:

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

    r12516 r12576  
    5454(export '(class-precedence-list class-slots))
    5555
    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
    58102
    59103(defmacro push-on-end (value location)
     
    86130            (mapplist fun (cddr x)))))
    87131
    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)
    97132(defsetf std-instance-layout %set-std-instance-layout)
    98133(defsetf standard-instance-access %set-standard-instance-access)
     
    254289;;; finalize-inheritance
    255290
     291(defun std-compute-class-default-initargs (class)
     292  (mapcan #'(lambda (c)
     293              (copy-list
     294               (class-direct-default-initargs c)))
     295          (class-precedence-list class)))
     296
    256297(defun std-finalize-inheritance (class)
    257   (set-class-precedence-list
    258    class
     298  (setf (class-precedence-list class)
    259299   (funcall (if (eq (class-of class) (find-class 'standard-class))
    260300                #'std-compute-class-precedence-list
    261301                #'compute-class-precedence-list)
    262302            class))
    263   (dolist (class (%class-precedence-list class))
     303  (dolist (class (class-precedence-list class))
    264304    (when (typep class 'forward-referenced-class)
    265305      (return-from std-finalize-inheritance)))
    266   (set-class-slots class
     306  (setf (class-slots class)
    267307                   (funcall (if (eq (class-of class) (find-class 'standard-class))
    268308                                #'std-compute-slots
    269                                 #'compute-slots)
    270                             class))
     309                     #'compute-slots) class))
    271310  (let ((old-layout (class-layout class))
    272311        (length 0)
    273312        (instance-slots '())
    274313        (shared-slots '()))
    275     (dolist (slot (%class-slots class))
     314    (dolist (slot (class-slots class))
    276315      (case (%slot-definition-allocation slot)
    277316        (:instance
     
    293332               (old-location (layout-slot-location old-layout slot-name)))
    294333          (unless old-location
    295             (let* ((slot-definition (find slot-name (%class-slots class) :key #'%slot-definition-name))
     334            (let* ((slot-definition (find slot-name (class-slots class) :key #'%slot-definition-name))
    296335                   (initfunction (%slot-definition-initfunction slot-definition)))
    297336              (when initfunction
     
    299338    (setf (class-layout class)
    300339          (make-layout class (nreverse instance-slots) (nreverse shared-slots))))
    301   (setf (class-default-initargs class) (compute-class-default-initargs class))
     340  (setf (class-default-initargs class)
     341        (std-compute-class-default-initargs class))
    302342  (setf (class-finalized-p class) t))
    303343
     
    393433(defun std-compute-slots (class)
    394434  (let* ((all-slots (mapappend #'class-direct-slots
    395                                (%class-precedence-list class)))
     435                               (class-precedence-list class)))
    396436         (all-names (remove-duplicates
    397437                     (mapcar #'%slot-definition-name all-slots))))
     
    432472
    433473(defun find-slot-definition (class slot-name)
    434   (dolist (slot (%class-slots class) nil)
     474  (dolist (slot (class-slots class) nil)
    435475    (when (eq slot-name (%slot-definition-name slot))
    436476      (return slot))))
     
    482522
    483523(defun std-slot-exists-p (instance slot-name)
    484   (not (null (find slot-name (%class-slots (class-of instance))
     524  (not (null (find slot-name (class-slots (class-of instance))
    485525                   :key #'%slot-definition-name))))
    486526
     
    500540  (declare (ignore metaclass))
    501541  (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) ())
     542    (%set-class-name name class)
     543    (%set-class-layout nil class)
     544    (%set-class-direct-subclasses ()  class)
     545    (%set-class-direct-methods ()  class)
    505546    (%set-class-documentation class documentation)
    506547    (std-after-initialization-for-classes class
     
    538579  (getf canonical-slot :name))
    539580
    540 (defun ensure-class (name &rest all-keys &allow-other-keys)
     581(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
    541582  ;; Check for duplicate slots.
     583  (remf all-keys :metaclass)
    542584  (let ((slots (getf all-keys :direct-slots)))
    543585    (dolist (s1 slots)
     
    564606        (error "Attempt to define a subclass of a built-in-class: ~S" class))))
    565607  (let ((old-class (find-class name nil)))
    566     (cond ((and old-class (eq name (%class-name old-class)))
     608    (cond ((and old-class (eq name (class-name old-class)))
    567609           (cond ((typep old-class 'built-in-class)
    568610                  (error "The symbol ~S names a built-in class." name))
     
    583625                  old-class)))
    584626          (t
    585            (let ((class (apply #'make-instance-standard-class
    586                                (find-class 'standard-class)
     627           (let ((class (apply (if metaclass
     628                                   #'make-instance
     629                                   #'make-instance-standard-class)
     630                               (or metaclass
     631                                   (find-class 'standard-class))
    587632                               :name name all-keys)))
    588633             (%set-find-class name class)
     
    832877          gf)
    833878        (progn
    834           (when (fboundp function-name)
     879          (when (and (null *clos-booting*)
     880                     (fboundp function-name))
    835881            (error 'program-error
    836882                   :format-control "~A already names an ordinary function, macro, or special operator."
     
    17811827                   )))
    17821828
    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))
     1829(defmacro redefine-class-forwarder (name slot &optional alternative-name)
     1830  (let* (($name (if (consp name) (cadr name) name))
     1831         (%name (intern (concatenate 'string
     1832                                     "%"
     1833                                     (if (consp name)
     1834                                         (symbol-name 'set-) "")
     1835                                     (symbol-name $name))
     1836                        (find-package "SYS"))))
     1837    (unless alternative-name
     1838      (setf alternative-name name))
     1839    (if (consp name)
     1840        `(progn ;; setter
     1841           (defgeneric ,alternative-name (new-value class))
     1842           (defmethod ,alternative-name (new-value (class built-in-class))
     1843             (,%name new-value class))
     1844           (defmethod ,alternative-name (new-value (class forward-referenced-class))
     1845             (,%name new-value class))
     1846           (defmethod ,alternative-name (new-value (class structure-class))
     1847             (,%name new-value class))
     1848           (defmethod ,alternative-name (new-value (class standard-class))
     1849             (setf (slot-value class ',slot) new-value))
     1850           ,@(unless (eq name alternative-name)
     1851                     `((setf (get ',$name 'SETF-FUNCTION)
     1852                             (symbol-function ',alternative-name))))
     1853           )
     1854        `(progn ;; getter
     1855           (defgeneric ,alternative-name (class))
     1856           (defmethod ,alternative-name ((class built-in-class))
     1857             (,%name class))
     1858           (defmethod ,alternative-name ((class forward-referenced-class))
     1859             (,%name class))
     1860           (defmethod ,alternative-name ((class structure-class))
     1861             (,%name class))
     1862           (defmethod ,alternative-name ((class standard-class))
     1863             (slot-value class ',slot))
     1864           ,@(unless (eq name alternative-name)
     1865                     `((setf (symbol-function ',$name)
     1866                             (symbol-function ',alternative-name))))
     1867           ) )))
     1868
     1869(redefine-class-forwarder class-name name)
     1870(redefine-class-forwarder (setf class-name) name)
     1871(redefine-class-forwarder class-slots slots)
     1872(redefine-class-forwarder (setf class-slots) slots)
     1873(redefine-class-forwarder class-direct-slots direct-slots)
     1874(redefine-class-forwarder (setf class-direct-slots) direct-slots)
     1875(redefine-class-forwarder class-layout layout)
     1876(redefine-class-forwarder (setf class-layout) layout)
     1877(redefine-class-forwarder class-direct-superclasses direct-superclasses)
     1878(redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses)
     1879(redefine-class-forwarder class-direct-subclasses direct-subclasses)
     1880(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses)
     1881(redefine-class-forwarder class-direct-methods direct-methods !class-direct-methods)
     1882(redefine-class-forwarder (setf class-direct-methods) direct-methods !!class-direct-methods)
     1883(redefine-class-forwarder class-precedence-list precedence-list)
     1884(redefine-class-forwarder (setf class-precedence-list) precedence-list)
     1885(redefine-class-forwarder class-finalized-p finalized-p)
     1886(redefine-class-forwarder (setf class-finalized-p) finalized-p)
     1887(redefine-class-forwarder class-default-initargs default-initargs)
     1888(redefine-class-forwarder (setf class-default-initargs) default-initargs)
     1889(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
     1890(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
    18031891
    18041892
     
    19512039
    19522040(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
    1953   (dolist (dsd (%class-slots class))
     2041  (dolist (dsd (class-slots class))
    19542042    (when (eq (sys::dsd-name dsd) slot-name)
    19552043      (return-from slot-exists-p-using-class t)))
     
    19872075(defmethod allocate-instance ((class structure-class) &rest initargs)
    19882076  (declare (ignore initargs))
    1989   (%make-structure (%class-name class)
    1990                    (make-list (length (%class-slots class))
     2077  (%make-structure (class-name class)
     2078                   (make-list (length (class-slots class))
    19912079                              :initial-element +slot-unbound+)))
    19922080
     
    20132101     `(,instance ,@initargs)
    20142102         (list instance)))))
    2015     (slots (%class-slots (class-of instance))))
     2103    (slots (class-slots (class-of instance))))
    20162104      (do* ((tail initargs (cddr tail))
    20172105            (initarg (car tail) (car tail)))
     
    20962184       :format-control "Invalid initarg ~S."
    20972185       :format-arguments (list initarg))))
    2098   (dolist (slot (%class-slots (class-of instance)))
     2186  (dolist (slot (class-slots (class-of instance)))
    20992187    (let ((slot-name (%slot-definition-name slot)))
    21002188      (multiple-value-bind (init-key init-value foundp)
     
    21212209(defmethod change-class ((old-instance standard-object) (new-class standard-class)
    21222210                         &rest initargs)
    2123   (let ((old-slots (%class-slots (class-of old-instance)))
    2124         (new-slots (%class-slots new-class))
     2211  (let ((old-slots (class-slots (class-of old-instance)))
     2212        (new-slots (class-slots new-class))
    21252213        (new-instance (allocate-instance new-class)))
    21262214    ;; "The values of local slots specified by both the class CTO and the class
     
    21542242                       (slot-exists-p old slot-name))
    21552243                    (mapcar #'%slot-definition-name
    2156                             (%class-slots (class-of new))))))
     2244                            (class-slots (class-of new))))))
    21572245    (check-initargs new added-slots initargs)
    21582246    (apply #'shared-initialize new added-slots initargs)))
     
    23412429(defmethod make-load-form ((class class) &optional environment)
    23422430  (declare (ignore environment))
    2343   (let ((name (%class-name class)))
     2431  (let ((name (class-name class)))
    23442432    (unless (and name (eq (find-class name nil) class))
    23452433      (error 'simple-type-error
     
    23562444    (error "Method combination error in CLOS dispatch:~%    ~A" message)))
    23572445
     2446(fmakunbound 'no-applicable-method)
    23582447(defgeneric no-applicable-method (generic-function &rest args))
    23592448
     
    23942483(defgeneric function-keywords (method))
    23952484
     2485(setf *clos-booting* nil)
     2486
    23962487(defgeneric class-prototype (class))
    23972488
Note: See TracChangeset for help on using the changeset viewer.