Ignore:
Timestamp:
01/06/12 22:45:48 (11 years ago)
Author:
ehuelsmann
Message:

Patch by Rudi Schlatte: Make method combinations real classes.

File:
1 edited

Legend:

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

    r13725 r13726  
    827827                 ,@(canonicalize-defclass-options options)))
    828828
    829 (defstruct method-combination
    830   name
    831   documentation)
    832 
    833 (defstruct (short-method-combination
    834              (:include method-combination))
    835   operator
    836   identity-with-one-argument)
    837 
    838 (defstruct (long-method-combination
    839              (:include method-combination))
    840   lambda-list
    841   method-group-specs
    842   args-lambda-list
    843   generic-function-symbol
    844   function
    845   arguments
    846   declarations
    847   forms)
    848 
    849829(defun expand-long-defcombin (name args)
    850830  (destructuring-bind (lambda-list method-groups &rest body) args
     
    854834            (list ,@(mapcar #'canonicalize-method-group-spec method-groups))
    855835            ',body)))
     836
     837;;; The class method-combination and its subclasses are defined in
     838;;; StandardClass.java, but we cannot use make-instance and slot-value
     839;;; yet.
     840(defun make-short-method-combination (&key name documentation operator identity-with-one-argument)
     841  (let ((instance (std-allocate-instance (find-class 'short-method-combination))))
     842    (when name (setf (std-slot-value instance 'sys::name) name))
     843    (when documentation
     844      (setf (std-slot-value instance 'documentation) documentation))
     845    (when operator (setf (std-slot-value instance 'operator) operator))
     846    (when identity-with-one-argument
     847      (setf (std-slot-value instance 'identity-with-one-argument)
     848            identity-with-one-argument))
     849    instance))
     850
     851(defun make-long-method-combination (&key name documentation lambda-list
     852                                       method-group-specs args-lambda-list
     853                                       generic-function-symbol function
     854                                       arguments declarations forms)
     855  (let ((instance (std-allocate-instance (find-class 'long-method-combination))))
     856    (when name (setf (std-slot-value instance 'sys::name) name))
     857    (when documentation
     858      (setf (std-slot-value instance 'documentation) documentation))
     859    (when lambda-list
     860        (setf (std-slot-value instance 'sys::lambda-list) lambda-list))
     861    (when method-group-specs
     862        (setf (std-slot-value instance 'method-group-specs) method-group-specs))
     863    (when args-lambda-list
     864        (setf (std-slot-value instance 'args-lambda-list) args-lambda-list))
     865    (when generic-function-symbol
     866        (setf (std-slot-value instance 'generic-function-symbol)
     867              generic-function-symbol))
     868    (when function
     869        (setf (std-slot-value instance 'function) function))
     870    (when arguments
     871        (setf (std-slot-value instance 'arguments) arguments))
     872    (when declarations
     873        (setf (std-slot-value instance 'declarations) declarations))
     874    (when forms
     875        (setf (std-slot-value instance 'forms) forms))
     876    instance))
     877
     878(defun method-combination-name (method-combination)
     879  (check-type method-combination method-combination)
     880  (std-slot-value method-combination 'sys::name))
     881
     882(defun method-combination-documentation (method-combination)
     883  (check-type method-combination method-combination)
     884  (std-slot-value method-combination 'documentation))
     885
     886(defun short-method-combination-operator (method-combination)
     887  (check-type method-combination short-method-combination)
     888  (std-slot-value method-combination 'operator))
     889
     890(defun short-method-combination-identity-with-one-argument (method-combination)
     891  (check-type method-combination short-method-combination)
     892  (std-slot-value method-combination 'identity-with-one-argument))
     893
     894(defun long-method-combination-lambda-list (method-combination)
     895  (check-type method-combination long-method-combination)
     896  (std-slot-value method-combination 'sys::lambda-list))
     897
     898(defun long-method-combination-method-group-specs (method-combination)
     899  (check-type method-combination long-method-combination)
     900  (std-slot-value method-combination 'method-group-specs))
     901
     902(defun long-method-combination-args-lambda-list (method-combination)
     903  (check-type method-combination long-method-combination)
     904  (std-slot-value method-combination 'args-lambda-list))
     905
     906(defun long-method-combination-generic-function-symbol (method-combination)
     907  (check-type method-combination long-method-combination)
     908  (std-slot-value method-combination 'generic-function-symbol))
     909
     910(defun long-method-combination-function (method-combination)
     911  (check-type method-combination long-method-combination)
     912  (std-slot-value method-combination 'function))
     913
     914(defun long-method-combination-arguments (method-combination)
     915  (check-type method-combination long-method-combination)
     916  (std-slot-value method-combination 'arguments))
     917
     918(defun long-method-combination-declarations (method-combination)
     919  (check-type method-combination long-method-combination)
     920  (std-slot-value method-combination 'declarations))
     921
     922(defun long-method-combination-forms (method-combination)
     923  (check-type method-combination long-method-combination)
     924  (std-slot-value method-combination 'forms))
     925
    856926
    857927(defun expand-short-defcombin (whole)
Note: See TracChangeset for help on using the changeset viewer.