Changeset 13983


Ignore:
Timestamp:
06/24/12 11:04:25 (9 years ago)
Author:
rschlatte
Message:

Implement find-method-combination

  • Store method combination as an object of type 'method-combination.
  • We use singleton objects if there are no options supplied to the method combination (the majority of cases), otherwise we cons up a fresh method-combination object with the same name that holds the options.
Location:
trunk/abcl/src/org/armedbear/lisp
Files:
5 edited

Legend:

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

    r13956 r13983  
    775775           new SlotDefinition(Symbol._DOCUMENTATION,
    776776                              list(Symbol.METHOD_COMBINATION_DOCUMENTATION),
    777                               constantlyNil, list(internKeyword("DOCUMENTATION")))));
     777                              constantlyNil, list(internKeyword("DOCUMENTATION"))),
     778           new SlotDefinition(PACKAGE_MOP.intern("OPTIONS"),
     779                              NIL, constantlyNil,
     780                              list(internKeyword("OPTIONS")))));
    778781    SHORT_METHOD_COMBINATION.setCPL(SHORT_METHOD_COMBINATION,
    779782                                    METHOD_COMBINATION, METAOBJECT,
  • trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java

    r13970 r13983  
    6363      StandardClass.STANDARD_METHOD;
    6464    slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] =
    65       Symbol.STANDARD;
     65      Symbol.STANDARD; // fixed up by shared-initialize :after in clos.lisp
    6666    slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] =
    6767      NIL;
     
    113113      StandardClass.STANDARD_METHOD;
    114114    slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] =
    115       Symbol.STANDARD;
     115      Symbol.STANDARD; // fixed up by shared-initialize :after in clos.lisp
    116116    slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] =
    117117      NIL;
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13980 r13983  
    185185  ;; Make the result of class-direct-subclasses for the pre-built
    186186  ;; classes agree with AMOP Table 5.1 (pg. 141).  This could be done in
    187   ;; StandardClass.java where these classes are defined, but here it's
    188   ;; less painful
     187  ;; StandardClass.java where these classes are defined, but it's less
     188  ;; painful to do it Lisp-side.
    189189  (flet ((add-subclasses (class subclasses)
    190190           (when (atom subclasses) (setf subclasses (list subclasses)))
     
    198198                    '(generic-function method method-combination
    199199                      slot-definition specializer))
     200    (add-subclasses 'method-combination
     201                    '(long-method-combination short-method-combination))
    200202    (add-subclasses 'funcallable-standard-object 'generic-function)
    201203    (add-subclasses 'generic-function 'standard-generic-function)
     
    912914    (setf (std-slot-value instance 'declarations) declarations)
    913915    (setf (std-slot-value instance 'forms) forms)
     916    (setf (std-slot-value instance 'options) nil)
    914917    instance))
    915918
     
    980983         (setf (std-slot-value instance 'identity-with-one-argument)
    981984               ',identity-with-one-arg)
     985         (setf (std-slot-value instance 'options) nil)
    982986         (setf (get ',name 'method-combination-object) instance)
    983987         ',name))))
     
    10021006;;; long form of define-method-combination (from Sacla and XCL)
    10031007;;;
    1004 (defun define-method-combination-type (name &rest initargs)
    1005     (setf (get name 'method-combination-object)
    1006           (apply '%make-long-method-combination initargs)))
    1007 
    10081008(defun method-group-p (selecter qualifiers)
    10091009  ;; selecter::= qualifier-pattern | predicate
     
    12851285                     ,@(long-form-method-combination-args args)))
    12861286         (lambda-expression (apply #'method-combination-type-lambda initargs)))
    1287     (apply #'define-method-combination-type name
    1288            `(,@initargs
    1289 ;;              :function ,(compile nil lambda-expression)
    1290              :function ,(coerce-to-function lambda-expression)))
     1287    (setf (get name 'method-combination-object)
     1288          (apply '%make-long-method-combination
     1289                 :function (coerce-to-function lambda-expression) initargs))
    12911290    name))
     1291
     1292(defun std-find-method-combination (gf name options)
     1293  (declare (ignore gf))
     1294  (when (and (eql name 'standard) options)
     1295    ;; CLHS DEFGENERIC
     1296    (error "The standard method combination does not accept any arguments."))
     1297  (let ((mc (get name 'method-combination-object)))
     1298    (cond
     1299      ((null mc) (error "Method combination ~S not found" name))
     1300      ((null options) mc)
     1301      ((typep mc 'short-method-combination)
     1302       (make-instance
     1303        'short-method-combination
     1304        :name name
     1305        :documentation (method-combination-documentation mc)
     1306        :operator (short-method-combination-operator mc)
     1307        :identity-with-one-argument
     1308        (short-method-combination-identity-with-one-argument mc)
     1309        :options options))
     1310      ((typep mc 'long-method-combination)
     1311       (make-instance
     1312        'long-method-combination
     1313        :name name
     1314        :documentation (method-combination-documentation mc)
     1315        :lambda-list (long-method-combination-lambda-list mc)
     1316        :method-group-specs (long-method-combination-method-group-specs mc)
     1317        :args-lambda-list (long-method-combination-args-lambda-list mc)
     1318        :generic-function-symbol (long-method-combination-generic-function-symbol mc)
     1319        :function (long-method-combination-function mc)
     1320        :arguments (long-method-combination-arguments mc)
     1321        :declarations (long-method-combination-declarations mc)
     1322        :forms (long-method-combination-forms mc)
     1323        :options options)))))
     1324
     1325(declaim (notinline find-method-combination))
     1326(defun find-method-combination (gf name options)
     1327  (std-find-method-combination gf name options))
     1328
     1329(defconstant +the-standard-method-combination+
     1330  (let ((instance (std-allocate-instance (find-class 'method-combination))))
     1331    (setf (std-slot-value instance 'sys::name) 'standard)
     1332    (setf (std-slot-value instance 'sys:%documentation)
     1333          "The standard method combination.")
     1334    (setf (std-slot-value instance 'options) nil)
     1335    instance)
     1336  "The standard method combination.
     1337Do not use this object for identity since it changes between
     1338compile-time and run-time.  To detect the standard method combination,
     1339compare the method combination name to the symbol 'standard.")
     1340(setf (get 'standard 'method-combination-object) +the-standard-method-combination+)
    12921341
    12931342(defparameter *eql-specializer-table* (make-hash-table :test 'eql))
     
    13851434  (sys:%generic-function-method-combination gf))
    13861435(defun (setf generic-function-method-combination) (new-value gf)
     1436  (assert (typep new-value 'method-combination))
    13871437  (set-generic-function-method-combination gf new-value))
    13881438
     
    15351585                                (generic-function-class +the-standard-generic-function-class+)
    15361586                                (method-class +the-standard-method-class+)
    1537                                 (method-combination 'standard)
     1587                                (method-combination +the-standard-method-combination+ mc-p)
    15381588                                argument-precedence-order
    15391589                                documentation
     
    15671617                   :format-control "~A already names an ordinary function, macro, or special operator."
    15681618                   :format-arguments (list function-name)))
     1619          (when mc-p
     1620            (error "Preliminary ensure-method does not support :method-combination argument."))
    15691621          (setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+)
    15701622                              #'make-instance-standard-generic-function
     
    19832035
    19842036(defun fast-callable-p (gf)
    1985   (and (eq (generic-function-method-combination gf) 'standard)
     2037  (and (eq (method-combination-name (generic-function-method-combination gf))
     2038           'standard)
    19862039       (null (intersection (%generic-function-lambda-list gf)
    19872040                           '(&rest &optional &key &allow-other-keys &aux)))))
     
    20422095             ((= number-required 1)
    20432096              (cond
    2044                 ((and (eq (sys:%generic-function-method-combination gf) 'standard)
     2097                ((and (eq (method-combination-name (sys:%generic-function-method-combination gf)) 'standard)
    20452098                      (= (length (sys:%generic-function-methods gf)) 1))
    20462099                 (let* ((method (%car (sys:%generic-function-methods gf)))
     
    23192372          next-method-list))
    23202373
    2321 (defun std-compute-effective-method (gf mc methods)
    2322   (let* ((mc-name (if (atom mc) mc (%car mc)))
    2323          (options (if (atom mc) '() (%cdr mc)))
     2374(defun std-compute-effective-method (gf method-combination methods)
     2375  (assert (typep method-combination 'method-combination))
     2376  (let* ((mc-name (method-combination-name method-combination))
     2377         (options (slot-value method-combination 'options))
    23242378         (order (car options))
    23252379         (primaries '())
     
    23282382         emf-form
    23292383         (long-method-combination-p
    2330           (typep (get mc-name 'method-combination-object) 'long-method-combination)))
     2384          (typep method-combination 'long-method-combination)))
    23312385    (unless long-method-combination-p
    23322386      (dolist (m methods)
     
    23352389                 (if (eq mc-name 'standard)
    23362390                     (push m primaries)
    2337                      (error "Method combination type mismatch.")))
     2391                     (error "Method combination type mismatch: missing qualifier for method combination ~S." method-combination)))
    23382392                ((cdr qualifiers)
    23392393                 (error "Invalid method qualifiers."))
     
    23582412                   #'std-compute-effective-method
    23592413                   #'compute-effective-method)
    2360                gf (generic-function-method-combination gf)
    2361                (remove around methods))))
     2414               gf method-combination (remove around methods))))
    23622415         (setf emf-form
    2363                (generate-emf-lambda (std-method-function around) next-emfun))))
     2416               (generate-emf-lambda (method-function around) next-emfun))))
    23642417      ((eq mc-name 'standard)
    23652418       (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
     
    23842437                                             next-emfun))))
    23852438                 (t
    2386                   (let ((method-function (std-method-function (car primaries))))
     2439                  (let ((method-function (method-function (car primaries))))
    23872440                    #'(lambda (args)
    23882441                        (declare (optimize speed))
    23892442                        (dolist (before befores)
    2390                           (funcall (std-method-function before) args nil))
     2443                          (funcall (method-function before) args nil))
    23912444                        (multiple-value-prog1
    23922445                            (funcall method-function args next-emfun)
    23932446                          (dolist (after reverse-afters)
    2394                             (funcall (std-method-function after) args nil))))))))))
     2447                            (funcall (method-function after) args nil))))))))))
    23952448      (long-method-combination-p
    2396        (let* ((mc-obj (get mc-name 'method-combination-object))
    2397               (function (long-method-combination-function mc-obj))
    2398               (arguments (rest (slot-value gf 'method-combination))))
    2399          (assert (typep mc-obj 'long-method-combination))
     2449       (let ((function (long-method-combination-function method-combination))
     2450             (arguments (slot-value method-combination 'options)))
    24002451         (assert function)
    24012452         (setf emf-form
     
    24042455                   (funcall function gf methods)))))
    24052456      (t
    2406        (let ((mc-obj (get mc-name 'method-combination-object)))
    2407          (unless (typep mc-obj 'short-method-combination)
    2408            (error "Unsupported method combination type ~A."
    2409                   mc-name))
    2410          (let* ((operator (short-method-combination-operator mc-obj))
    2411                 (ioa (short-method-combination-identity-with-one-argument mc-obj)))
    2412            (setf emf-form
    2413                  (if (and (null (cdr primaries))
    2414                           (not (null ioa)))
    2415                      (generate-emf-lambda (std-method-function (car primaries)) nil)
    2416                      `(lambda (args)
    2417                         (,operator ,@(mapcar
    2418                                       (lambda (primary)
    2419                                         `(funcall ,(std-method-function primary) args nil))
    2420                                       primaries)))))))))
     2457       (unless (typep method-combination 'short-method-combination)
     2458         (error "Unsupported method combination type ~A." mc-name))
     2459       (let ((operator (short-method-combination-operator method-combination))
     2460             (ioa (short-method-combination-identity-with-one-argument method-combination)))
     2461         (setf emf-form
     2462               (if (and ioa (null (cdr primaries)))
     2463                   (generate-emf-lambda (method-function (car primaries)) nil)
     2464                   `(lambda (args)
     2465                      (,operator ,@(mapcar
     2466                                    (lambda (primary)
     2467                                      `(funcall ,(method-function primary) args nil))
     2468                                    primaries))))))))
    24212469    (assert (not (null emf-form)))
    24222470    (or #+nil (ignore-errors (autocompile emf-form))
     
    40664114    (set-generic-function-argument-precedence-order
    40674115     instance (or argument-precedence-order required-args)))
     4116  (when (eq (generic-function-method-combination instance) 'standard)
     4117    ;; fix up "naked" (make-instance 'standard-generic-function) -- gfs
     4118    ;; created via defgeneric have that slot initalized properly
     4119    (set-generic-function-method-combination instance
     4120                                             +the-standard-method-combination+))
    40684121  (finalize-standard-generic-function instance))
    40694122
     
    41294182  (:method ((method standard-accessor-method))
    41304183    (std-accessor-method-slot-definition method)))
     4184
     4185
     4186;;; find-method-combination
     4187
     4188;;; AMOP pg. 191
     4189(atomic-defgeneric find-method-combination (gf name options)
     4190  (:method (gf (name symbol) options)
     4191    (std-find-method-combination gf name options)))
    41314192
    41324193;;; specializer-direct-method and friends.
     
    42274288                                                  lambda-list
    42284289                                                  (method-class +the-standard-method-class+)
     4290                                                  (method-combination +the-standard-method-combination+)
    42294291                                                &allow-other-keys)
    42304292  (setf all-keys (copy-list all-keys))  ; since we modify it
     
    42444306    (error "The method class ~S is incompatible with the existing methods of ~S."
    42454307           method-class generic-function))
     4308  (unless (typep method-combination 'method-combination)
     4309    (setf method-combination
     4310          (find-method-combination generic-function
     4311                                   (car method-combination)
     4312                                   (cdr method-combination))))
    42464313  (apply #'reinitialize-instance generic-function
    4247          :method-class method-class all-keys)
     4314         :method-combination method-combination
     4315         :method-class method-class
     4316         all-keys)
    42484317  generic-function)
    42494318
     
    42534322                                                &key (generic-function-class +the-standard-generic-function-class+)
    42544323                                                  (method-class +the-standard-method-class+)
    4255                                                   (method-combination 'standard)
     4324                                                  (method-combination +the-standard-method-combination+)
    42564325                                                &allow-other-keys)
    42574326  (setf all-keys (copy-list all-keys))  ; since we modify it
     
    42604329    (setf generic-function-class (find-class generic-function-class)))
    42614330  (unless (classp method-class) (setf method-class (find-class method-class)))
     4331  (unless (typep method-combination 'method-combination)
     4332    (setf method-combination
     4333          (find-method-combination (class-prototype generic-function-class)
     4334                                   (car method-combination)
     4335                                   (cdr method-combination))))
    42624336  (when (and (null *clos-booting*) (fboundp function-name))
    42634337    (if (autoloadp function-name)
  • trunk/abcl/src/org/armedbear/lisp/mop.lisp

    r13979 r13983  
    122122          remove-direct-method
    123123
     124          find-method-combination
     125
    124126          extract-lambda-list
    125127          extract-specializer-names
  • trunk/abcl/src/org/armedbear/lisp/print-object.lisp

    r13930 r13983  
    7575  method)
    7676
     77(defmethod print-object ((method-combination method-combination) stream)
     78  (print-unreadable-object (method-combination stream :identity t)
     79    (format stream "~A ~S" (class-name (class-of method-combination))
     80            (mop::method-combination-name method-combination)))
     81  method-combination)
     82
    7783(defmethod print-object ((restart restart) stream)
    7884  (if *print-escape*
Note: See TracChangeset for help on using the changeset viewer.