Changeset 13203


Ignore:
Timestamp:
02/05/11 22:58:42 (11 years ago)
Author:
ehuelsmann
Message:

Create ATOMIC-DEFGENERIC macro, in order to eliminate FMAKUNBOUND calls
and the resulting windows where no function is bound to symbols which
are the most essential building blocks in CLOS/AMOP.

Note: This change should help making CLOS bootstrapping less
confusing and less tedious to hack.

File:
1 edited

Legend:

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

    r13202 r13203  
    470470        (std-compute-class-default-initargs class))
    471471  (setf (class-finalized-p class) t))
     472
     473(declaim (notinline finalize-inheritance))
     474(defun finalize-inheritance (class)
     475  (std-finalize-inheritance class))
     476
    472477
    473478;;; Class precedence lists
     
    22502255                   )))
    22512256
     2257(defmacro atomic-defgeneric (function-name &rest rest)
     2258  "Macro to define a generic function and 'swap it into place' after
     2259it's been fully defined with all its methods.
     2260
     2261Note: the user should really use the (:method ..) method description
     2262way of defining methods; there's not much use in atomically defining
     2263generic functions without providing sensible behaviour..."
     2264  (let ((temp-sym (gensym)))
     2265    `(progn
     2266       (defgeneric ,temp-sym ,@rest)
     2267       (let ((gf (symbol-function ',temp-sym)))
     2268         (setf ,(if (and (consp function-name)
     2269                         (eq (car function-name) 'setf))
     2270                    `(get ',(second function-name) 'setf-function)
     2271                  `(symbol-function ',function-name)) gf)
     2272         (%set-generic-function-name gf ',function-name)
     2273         gf))))
     2274
    22522275(defmacro redefine-class-forwarder (name slot)
    22532276  "Define a generic function on a temporary symbol as an accessor
     
    22632286                                         (symbol-name 'set-) "")
    22642287                                     (symbol-name $name))
    2265                         (find-package "SYS")))
    2266          (alternative-name (gensym)))
    2267     (if (consp name)
    2268         `(progn ;; setter
    2269            (defgeneric ,alternative-name (new-value class))
    2270            (defmethod ,alternative-name (new-value (class built-in-class))
    2271              (,%name new-value class))
    2272            (defmethod ,alternative-name (new-value (class forward-referenced-class))
    2273              (,%name new-value class))
    2274            (defmethod ,alternative-name (new-value (class structure-class))
    2275              (,%name new-value class))
    2276            (defmethod ,alternative-name (new-value (class standard-class))
    2277              (setf (slot-value class ',slot) new-value))
    2278            (let ((gf (symbol-function ',alternative-name)))
    2279              (setf (get ',$name 'SETF-FUNCTION) gf)
    2280              (%set-generic-function-name gf ',name)))
    2281         `(progn ;; getter
    2282            (defgeneric ,alternative-name (class))
    2283            (defmethod ,alternative-name ((class built-in-class))
    2284              (,%name class))
    2285            (defmethod ,alternative-name ((class forward-referenced-class))
    2286              (,%name class))
    2287            (defmethod ,alternative-name ((class structure-class))
    2288              (,%name class))
    2289            (defmethod ,alternative-name ((class standard-class))
    2290              (slot-value class ',slot))
    2291            (let ((gf (symbol-function ',alternative-name)))
    2292              (setf (symbol-function ',$name) gf)
    2293              (%set-generic-function-name gf ',name))))))
     2288                        (find-package "SYS"))))
     2289    `(atomic-defgeneric ,name (;; splice a new-value parameter for setters
     2290                               ,@(when (consp name) (list 'new-value))
     2291                               class)
     2292         ,@(mapcar (if (consp name)
     2293                       #'(lambda (class-name)
     2294                           `(:method (new-value (class ,class-name))
     2295                                     (,%name new-value class)))
     2296                     #'(lambda (class-name)
     2297                         `(:method ((class ,class-name))
     2298                                   (,%name class))))
     2299                   '(built-in-class
     2300                     forward-referenced-class
     2301                     structure-class))
     2302         (:method (,@(when (consp name) (list 'new-value))
     2303                   (class standard-class))
     2304             ,(if (consp name)
     2305                  `(setf (slot-value class ',slot) new-value)
     2306                `(slot-value class ',slot))))))
     2307
    22942308
    22952309(redefine-class-forwarder class-name name)
     
    23282342  +the-effective-slot-definition-class+)
    23292343
    2330 (fmakunbound 'documentation)
    2331 (defgeneric documentation (x doc-type))
    2332 
    2333 (defgeneric (setf documentation) (new-value x doc-type))
    2334 
    2335 (defmethod documentation ((x symbol) doc-type)
    2336   (%documentation x doc-type))
    2337 
    2338 (defmethod (setf documentation) (new-value (x symbol) doc-type)
    2339   (%set-documentation x doc-type new-value))
    2340 
    2341 (defmethod documentation ((x function) doc-type)
    2342   (%documentation x doc-type))
    2343 
    2344 (defmethod (setf documentation) (new-value (x function) doc-type)
    2345   (%set-documentation x doc-type new-value))
     2344(atomic-defgeneric documentation (x doc-type)
     2345    (:method ((x symbol) doc-type)
     2346        (%documentation x doc-type))
     2347    (:method ((x function) doc-type)
     2348        (%documentation x doc-type)))
     2349
     2350(atomic-defgeneric (setf documentation) (new-value x doc-type)
     2351    (:method (new-value (x symbol) doc-type)
     2352        (%set-documentation x doc-type new-value))
     2353    (:method (new-value (x function) doc-type)
     2354        (%set-documentation x doc-type new-value)))
     2355
    23462356
    23472357;; FIXME This should be a weak hashtable!
     
    27512761;;; Finalize inheritance
    27522762
    2753 (defgeneric finalize-inheritance (class))
    2754 
    2755 (defmethod finalize-inheritance ((class standard-class))
    2756   (std-finalize-inheritance class))
     2763(atomic-defgeneric finalize-inheritance (class)
     2764    (:method ((class standard-class))
     2765       (std-finalize-inheritance class)))
    27572766
    27582767;;; Class precedence lists
     
    28012810
    28022811;;; Slot definition accessors
    2803 
    2804 (map nil (lambda (sym)
    2805      (fmakunbound sym) ;;we need to redefine them as GFs
    2806      (fmakunbound `(setf ,sym))
    2807      (export sym))
    2808   '(slot-definition-allocation
    2809     slot-definition-initargs
    2810     slot-definition-initform
    2811     slot-definition-initfunction
    2812     slot-definition-name
    2813     slot-definition-readers
    2814     slot-definition-writers
    2815     slot-definition-allocation-class))
    28162812
    28172813(defmacro slot-definition-dispatch (slot-definition std-form generic-form)
     
    28242820       (t ,generic-form))))
    28252821
    2826 (defgeneric slot-definition-allocation (slot-definition)
     2822(atomic-defgeneric slot-definition-allocation (slot-definition)
    28272823  (:method ((slot-definition slot-definition))
    28282824    (slot-definition-dispatch slot-definition
     
    28302826      (slot-value slot-definition 'sys::allocation))))
    28312827
    2832 (defgeneric (setf slot-definition-allocation) (value slot-definition)
     2828(atomic-defgeneric (setf slot-definition-allocation) (value slot-definition)
    28332829  (:method (value (slot-definition slot-definition))
    28342830    (slot-definition-dispatch slot-definition
     
    28362832      (setf (slot-value slot-definition 'sys::allocation) value))))
    28372833
    2838 (defgeneric slot-definition-initargs (slot-definition)
     2834(atomic-defgeneric slot-definition-initargs (slot-definition)
    28392835  (:method ((slot-definition slot-definition))
    28402836    (slot-definition-dispatch slot-definition
     
    28422838      (slot-value slot-definition 'sys::initargs))))
    28432839
    2844 (defgeneric (setf slot-definition-initargs) (value slot-definition)
     2840(atomic-defgeneric (setf slot-definition-initargs) (value slot-definition)
    28452841  (:method (value (slot-definition slot-definition))
    28462842    (slot-definition-dispatch slot-definition
     
    28482844      (setf (slot-value slot-definition 'sys::initargs) value))))
    28492845
    2850 (defgeneric slot-definition-initform (slot-definition)
     2846(atomic-defgeneric slot-definition-initform (slot-definition)
    28512847  (:method ((slot-definition slot-definition))
    28522848    (slot-definition-dispatch slot-definition
     
    28542850      (slot-value slot-definition 'sys::initform))))
    28552851
    2856 (defgeneric (setf slot-definition-initform) (value slot-definition)
     2852(atomic-defgeneric (setf slot-definition-initform) (value slot-definition)
    28572853  (:method (value (slot-definition slot-definition))
    28582854    (slot-definition-dispatch slot-definition
     
    28602856      (setf (slot-value slot-definition 'sys::initform) value))))
    28612857
    2862 (defgeneric slot-definition-initfunction (slot-definition)
     2858(atomic-defgeneric slot-definition-initfunction (slot-definition)
    28632859  (:method ((slot-definition slot-definition))
    28642860    (slot-definition-dispatch slot-definition
     
    28662862      (slot-value slot-definition 'sys::initfunction))))
    28672863
    2868 (defgeneric (setf slot-definition-initfunction) (value slot-definition)
     2864(atomic-defgeneric (setf slot-definition-initfunction) (value slot-definition)
    28692865  (:method (value (slot-definition slot-definition))
    28702866    (slot-definition-dispatch slot-definition
     
    28722868      (setf (slot-value slot-definition 'sys::initfunction) value))))
    28732869
    2874 (defgeneric slot-definition-name (slot-definition)
     2870(atomic-defgeneric slot-definition-name (slot-definition)
    28752871  (:method ((slot-definition slot-definition))
    28762872    (slot-definition-dispatch slot-definition
     
    28782874      (slot-value slot-definition 'sys::name))))
    28792875
    2880 (defgeneric (setf slot-definition-name) (value slot-definition)
     2876(atomic-defgeneric (setf slot-definition-name) (value slot-definition)
    28812877  (:method (value (slot-definition slot-definition))
    28822878    (slot-definition-dispatch slot-definition
     
    28842880      (setf (slot-value slot-definition 'sys::name) value))))
    28852881
    2886 (defgeneric slot-definition-readers (slot-definition)
     2882(atomic-defgeneric slot-definition-readers (slot-definition)
    28872883  (:method ((slot-definition slot-definition))
    28882884    (slot-definition-dispatch slot-definition
     
    28902886      (slot-value slot-definition 'sys::readers))))
    28912887
    2892 (defgeneric (setf slot-definition-readers) (value slot-definition)
     2888(atomic-defgeneric (setf slot-definition-readers) (value slot-definition)
    28932889  (:method (value (slot-definition slot-definition))
    28942890    (slot-definition-dispatch slot-definition
     
    28962892      (setf (slot-value slot-definition 'sys::readers) value))))
    28972893
    2898 (defgeneric slot-definition-writers (slot-definition)
     2894(atomic-defgeneric slot-definition-writers (slot-definition)
    28992895  (:method ((slot-definition slot-definition))
    29002896    (slot-definition-dispatch slot-definition
     
    29022898      (slot-value slot-definition 'sys::writers))))
    29032899
    2904 (defgeneric (setf slot-definition-writers) (value slot-definition)
     2900(atomic-defgeneric (setf slot-definition-writers) (value slot-definition)
    29052901  (:method (value (slot-definition slot-definition))
    29062902    (slot-definition-dispatch slot-definition
     
    29082904      (setf (slot-value slot-definition 'sys::writers) value))))
    29092905
    2910 (defgeneric slot-definition-allocation-class (slot-definition)
     2906(atomic-defgeneric slot-definition-allocation-class (slot-definition)
    29112907  (:method ((slot-definition slot-definition))
    29122908    (slot-definition-dispatch slot-definition
     
    29142910      (slot-value slot-definition 'sys::allocation-class))))
    29152911
    2916 (defgeneric (setf slot-definition-allocation-class) (value slot-definition)
     2912(atomic-defgeneric (setf slot-definition-allocation-class)
     2913                       (value slot-definition)
    29172914  (:method (value (slot-definition slot-definition))
    29182915    (slot-definition-dispatch slot-definition
     
    29202917      (setf (slot-value slot-definition 'sys::allocation-class) value))))
    29212918
    2922 (defgeneric slot-definition-location (slot-definition)
     2919(atomic-defgeneric slot-definition-location (slot-definition)
    29232920  (:method ((slot-definition slot-definition))
    29242921    (slot-definition-dispatch slot-definition
     
    29262923      (slot-value slot-definition 'sys::location))))
    29272924
    2928 (defgeneric (setf slot-definition-location) (value slot-definition)
     2925(atomic-defgeneric (setf slot-definition-location) (value slot-definition)
    29292926  (:method (value (slot-definition slot-definition))
    29302927    (slot-definition-dispatch slot-definition
     
    30193016    (error "Method combination error in CLOS dispatch:~%    ~A" message)))
    30203017
    3021 (fmakunbound 'no-applicable-method)
    3022 (defgeneric no-applicable-method (generic-function &rest args))
    3023 
    3024 (defmethod no-applicable-method (generic-function &rest args)
    3025   (error "There is no applicable method for the generic function ~S when called with arguments ~S."
    3026          generic-function
    3027          args))
     3018
     3019(atomic-defgeneric no-applicable-method (generic-function &rest args)
     3020  (:method (generic-function &rest args)
     3021      (error "There is no applicable method for the generic function ~S ~
     3022              when called with arguments ~S."
     3023             generic-function
     3024             args)))
     3025
     3026
    30283027
    30293028(defgeneric find-method (generic-function
Note: See TracChangeset for help on using the changeset viewer.