Changeset 12982 for trunk/abcl/src/org


Ignore:
Timestamp:
10/19/10 20:16:09 (11 years ago)
Author:
ehuelsmann
Message:

Commit DEFINE-METHOD-COMBINATION support as integrated
by Mark Evenson; based on testing with SBCL's tests,
I've added a single quote. Other than that, it 'mostly works'.

By having this on trunk, everybody can help adding tests and
fixing issues... (hint, hint!)

File:
1 edited

Legend:

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

    r12805 r12982  
    22;;;
    33;;; Copyright (C) 2003-2007 Peter Graves
     4;;; Copyright (C) 2010 Mark Evenson
    45;;; $Id$
    56;;;
     
    3132
    3233;;; Originally based on Closette.
    33 
     34     
    3435;;; Closette Version 1.0 (February 10, 1991)
    3536;;;
     
    741742                 ,@(canonicalize-defclass-options options)))
    742743
    743 (eval-when (:compile-toplevel :load-toplevel :execute)
    744   (defstruct method-combination
    745     name
    746     operator
    747     identity-with-one-argument
    748     documentation)
    749 
    750   (defun expand-short-defcombin (whole)
    751     (let* ((name (cadr whole))
    752            (documentation
    753             (getf (cddr whole) :documentation ""))
    754            (identity-with-one-arg
    755             (getf (cddr whole) :identity-with-one-argument nil))
    756            (operator
    757             (getf (cddr whole) :operator name)))
    758       `(progn
    759          (setf (get ',name 'method-combination-object)
    760                (make-method-combination :name ',name
    761                                         :operator ',operator
    762                                         :identity-with-one-argument ',identity-with-one-arg
    763                                         :documentation ',documentation))
    764          ',name)))
    765 
    766   (defun expand-long-defcombin (whole)
    767     (declare (ignore whole))
    768     (error "The long form of DEFINE-METHOD-COMBINATION is not implemented.")))
    769 
    770 (defmacro define-method-combination (&whole form &rest args)
    771   (declare (ignore args))
     744(defstruct method-combination
     745  name
     746  documentation)
     747
     748(defstruct (short-method-combination
     749             (:include method-combination))
     750  operator
     751  identity-with-one-argument)
     752
     753(defstruct (long-method-combination
     754             (:include method-combination))
     755  lambda-list
     756  method-group-specs
     757  args-lambda-list
     758  generic-function-symbol
     759  function
     760  arguments
     761  declarations
     762  forms)
     763
     764(defun expand-long-defcombin (name args)
     765  (destructuring-bind (lambda-list method-groups &rest body) args
     766    `(apply #'define-long-form-method-combination
     767            ',name
     768            ',lambda-list
     769            (list ,@(mapcar #'canonicalize-method-group-spec method-groups))
     770            ',body)))
     771
     772(defun expand-short-defcombin (whole)
     773  (let* ((name (cadr whole))
     774         (documentation
     775          (getf (cddr whole) :documentation ""))
     776         (identity-with-one-arg
     777          (getf (cddr whole) :identity-with-one-argument nil))
     778         (operator
     779          (getf (cddr whole) :operator name)))
     780    `(progn
     781       (setf (get ',name 'method-combination-object)
     782             (make-short-method-combination
     783              :name ',name
     784              :operator ',operator
     785              :identity-with-one-argument ',identity-with-one-arg
     786              :documentation ',documentation))
     787       ',name)))
     788
     789(defmacro define-method-combination (&whole form name &rest args)
    772790  (if (and (cddr form)
    773791           (listp (caddr form)))
    774       (expand-long-defcombin form)
     792      (expand-long-defcombin name args)
    775793      (expand-short-defcombin form)))
    776794
     
    784802(define-method-combination or     :identity-with-one-argument t)
    785803(define-method-combination progn  :identity-with-one-argument t)
     804
     805;;;
     806;;; long form of define-method-combination (from Sacla and XCL)
     807;;;
     808(defun define-method-combination-type (name &rest initargs)
     809    (setf (get name 'method-combination-object)
     810          (apply 'make-long-method-combination initargs)))
     811
     812(defun method-group-p (selecter qualifiers)
     813  ;; selecter::= qualifier-pattern | predicate
     814  (etypecase selecter
     815    (list (or (equal selecter qualifiers)
     816              (let ((last (last selecter)))
     817                (when (eq '* (cdr last))
     818                  (let* ((prefix `(,@(butlast selecter) ,(car last)))
     819                         (pos (mismatch prefix qualifiers)))
     820                    (or (null pos) (= pos (length prefix))))))))
     821    ((eql *) t)
     822    (symbol (funcall (symbol-function selecter) qualifiers))))
     823
     824(defun check-variable-name (name)
     825  (flet ((valid-variable-name-p (name)
     826                                (and (symbolp name) (not (constantp name)))))
     827    (assert (valid-variable-name-p name))))
     828
     829(defun canonicalize-method-group-spec (spec)
     830  ;; spec ::= (name {qualifier-pattern+ | predicate} [[long-form-option]])
     831  ;; long-form-option::= :description description | :order order |
     832  ;;                     :required required-p
     833  ;; a canonicalized-spec is a simple plist.
     834  (let* ((rest spec)
     835         (name (prog2 (check-variable-name (car rest))
     836                 (car rest)
     837                 (setq rest (cdr rest))))
     838         (option-names '(:description :order :required))
     839         (selecters (let ((end (or (position-if #'(lambda (it)
     840                                                   (member it option-names))
     841                                                rest)
     842                                   (length rest))))
     843                      (prog1 (subseq rest 0 end)
     844                        (setq rest (subseq rest end)))))
     845         (description (getf rest :description ""))
     846         (order (getf rest :order :most-specific-first))
     847         (required-p (getf rest :required)))
     848    `(list :name ',name
     849           :predicate (lambda (qualifiers)
     850                        (loop for item in ',selecters
     851                          thereis (method-group-p item qualifiers)))
     852           :description ',description
     853           :order ',order
     854           :required ',required-p)))
     855
     856(defun extract-required-part (lambda-list)
     857  (flet ((skip (key lambda-list)
     858               (if (eq (first lambda-list) key)
     859                   (cddr lambda-list)
     860                   lambda-list)))
     861    (ldiff (skip '&environment (skip '&whole lambda-list))
     862           (member-if #'(lambda (it) (member it lambda-list-keywords))
     863                      lambda-list))))
     864
     865(defun extract-specified-part (key lambda-list)
     866  (case key
     867    ((&eval &whole)
     868     (list (second (member key lambda-list))))
     869    (t
     870     (let ((here (cdr (member key lambda-list))))
     871       (ldiff here
     872              (member-if #'(lambda (it) (member it lambda-list-keywords))
     873                         here))))))
     874
     875(defun extract-optional-part (lambda-list)
     876  (extract-specified-part '&optional lambda-list))
     877
     878(defun parse-define-method-combination-arguments-lambda-list (lambda-list)
     879  ;; Define-method-combination Arguments Lambda Lists
     880  ;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm
     881  (let ((required (extract-required-part lambda-list))
     882        (whole    (extract-specified-part '&whole    lambda-list))
     883        (optional (extract-specified-part '&optional lambda-list))
     884        (rest     (extract-specified-part '&rest     lambda-list))
     885        (keys     (extract-specified-part '&key      lambda-list))
     886        (aux      (extract-specified-part '&aux      lambda-list)))
     887    (values (first whole)
     888            required
     889            (mapcar #'(lambda (spec)
     890                       (if (consp spec)
     891                           `(,(first spec) ,(second spec) ,@(cddr spec))
     892                           `(,spec nil)))
     893                    optional)
     894            (first rest)
     895            (mapcar #'(lambda (spec)
     896                       (let ((key (if (consp spec) (car spec) spec))
     897                             (rest (when (consp spec) (rest spec))))
     898                         `(,(if (consp key) key `(,(make-keyword key) ,key))
     899                           ,(car rest)
     900                           ,@(cdr rest))))
     901                    keys)
     902            (mapcar #'(lambda (spec)
     903                       (if (consp spec)
     904                           `(,(first spec) ,(second spec))
     905                           `(,spec nil)))
     906                    aux))))
     907
     908(defmacro getk (plist key init-form)
     909  "Similar to getf except eval and return INIT-FORM if KEY has no value in PLIST."
     910  (let ((not-exist (gensym))
     911        (value (gensym)))
     912    `(let ((,value (getf ,plist ,key ,not-exist)))
     913       (if (eq ,not-exist ,value) ,init-form ,value))))
     914
     915(defconstant +gf-args-var+ (make-symbol "GF-ARGS-VAR"))
     916
     917(defmacro with-args-lambda-list (args-lambda-list generic-function-symbol
     918                                                  &body forms)
     919  (let ((gf-lambda-list (gensym))
     920        (nrequired (gensym))
     921        (noptional (gensym))
     922        (rest-args (gensym)))
     923    (multiple-value-bind (whole required optional rest keys aux)
     924        (parse-define-method-combination-arguments-lambda-list args-lambda-list)
     925      `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'lambda-list))
     926              (,nrequired (length (extract-required-part ,gf-lambda-list)))
     927              (,noptional (length (extract-optional-part ,gf-lambda-list)))
     928              (,rest-args (subseq ,+gf-args-var+ (+ ,nrequired ,noptional)))
     929              ,@(when whole `((,whole ,+gf-args-var+)))
     930              ,@(loop for var in required and i upfrom 0
     931                  collect `(,var (when (< ,i ,nrequired)
     932                                   (nth ,i ,+gf-args-var+))))
     933              ,@(loop for (var init-form) in optional and i upfrom 0
     934                  collect
     935                  `(,var (if (< ,i ,noptional)
     936                             (nth (+ ,nrequired ,i) ,+gf-args-var+)
     937                             ,init-form)))
     938              ,@(when rest `((,rest ,rest-args)))
     939              ,@(loop for ((key var) init-form) in keys and i upfrom 0
     940                  collect `(,var (getk ,rest-args ',key ,init-form)))
     941              ,@(loop for (var init-form) in aux and i upfrom 0
     942                  collect `(,var ,init-form)))
     943         ,@forms))))
     944
     945(defmacro with-method-groups (method-group-specs methods-form &body forms)
     946  (flet ((grouping-form (spec methods-var)
     947                        (let ((predicate (coerce-to-function (getf spec :predicate)))
     948                              (group (gensym))
     949                              (leftovers (gensym))
     950                              (method (gensym)))
     951                          `(let ((,group '())
     952                                 (,leftovers '()))
     953                             (dolist (,method ,methods-var)
     954                               (if (funcall ,predicate (method-qualifiers ,method))
     955                                   (push ,method ,group)
     956                                   (push ,method ,leftovers)))
     957                             (ecase ,(getf spec :order)
     958                               (:most-specific-last )
     959                               (:most-specific-first (setq ,group (nreverse ,group))))
     960                             ,@(when (getf spec :required)
     961                                 `((when (null ,group)
     962                                     (error "Method group ~S must not be empty."
     963                                            ',(getf spec :name)))))
     964                             (setq ,methods-var (nreverse ,leftovers))
     965                             ,group))))
     966    (let ((rest (gensym))
     967          (method (gensym)))
     968      `(let* ((,rest ,methods-form)
     969              ,@(mapcar #'(lambda (spec)
     970                           `(,(getf spec :name) ,(grouping-form spec rest)))
     971                        method-group-specs))
     972         (dolist (,method ,rest)
     973           (invalid-method-error ,method
     974                                 "Method ~S with qualifiers ~S does not belong to any method group."
     975                                 ,method (method-qualifiers ,method)))
     976         ,@forms))))
     977
     978(defun method-combination-type-lambda
     979  (&key name lambda-list args-lambda-list generic-function-symbol
     980        method-group-specs declarations forms &allow-other-keys)
     981  (let ((methods (gensym)))
     982    `(lambda (,generic-function-symbol ,methods ,@lambda-list)
     983       ,@declarations
     984       (let ((*message-prefix* ,(format nil "METHOD COMBINATION TYPE ~S: " name)))
     985         (with-method-groups ,method-group-specs
     986           ,methods
     987           ,@(if (null args-lambda-list)
     988                 forms
     989                 `((with-args-lambda-list ,args-lambda-list
     990                     ,generic-function-symbol
     991                     ,@forms))))))))
     992
     993(defun declarationp (expr)
     994  (and (consp expr) (eq (car expr) 'DECLARE)))
     995
     996(defun long-form-method-combination-args (args)
     997  ;; define-method-combination name lambda-list (method-group-specifier*) args
     998  ;; args ::= [(:arguments . args-lambda-list)]
     999  ;;          [(:generic-function generic-function-symbol)]
     1000  ;;          [[declaration* | documentation]] form*
     1001  (let ((rest args))
     1002    (labels ((nextp (key) (and (consp (car rest)) (eq key (caar rest))))
     1003             (args-lambda-list ()
     1004               (when (nextp :arguments)
     1005                 (prog1 (cdr (car rest)) (setq rest (cdr rest)))))
     1006             (generic-function-symbol ()
     1007                (if (nextp :generic-function)
     1008                    (prog1 (second (car rest)) (setq rest (cdr rest)))
     1009                    (gensym)))
     1010             (declaration* ()
     1011               (let ((end (position-if-not #'declarationp rest)))
     1012                 (when end
     1013                   (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest))))))
     1014             (documentation? ()
     1015               (when (stringp (car rest))
     1016                 (prog1 (car rest) (setq rest (cdr rest)))))
     1017             (form* () rest))
     1018      (let ((declarations '()))
     1019        `(:args-lambda-list ,(args-lambda-list)
     1020                            :generic-function-symbol ,(generic-function-symbol)
     1021                            :documentation ,(prog2 (setq declarations (declaration*))
     1022                                              (documentation?))
     1023                            :declarations (,@declarations ,@(declaration*))
     1024                            :forms ,(form*))))))
     1025
     1026(defun define-long-form-method-combination (name lambda-list method-group-specs
     1027                                                 &rest args)
     1028  (let* ((initargs `(:name ,name
     1029                     :lambda-list ,lambda-list
     1030                     :method-group-specs ,method-group-specs
     1031                     ,@(long-form-method-combination-args args)))
     1032         (lambda-expression (apply #'method-combination-type-lambda initargs)))
     1033    (apply #'define-method-combination-type name
     1034           `(,@initargs
     1035;;              :function ,(compile nil lambda-expression)
     1036             :function ,(coerce-to-function lambda-expression)))
     1037    name))
    7861038
    7871039(defstruct eql-specializer
     
    15811833         (arounds '())
    15821834         around
    1583          emf-form)
    1584     (dolist (m methods)
    1585       (let ((qualifiers (method-qualifiers m)))
    1586         (cond ((null qualifiers)
    1587                (if (eq mc-name 'standard)
    1588                    (push m primaries)
    1589                    (error "Method combination type mismatch.")))
    1590               ((cdr qualifiers)
    1591                (error "Invalid method qualifiers."))
    1592               ((eq (car qualifiers) :around)
    1593                (push m arounds))
    1594               ((eq (car qualifiers) mc-name)
    1595                (push m primaries))
    1596               ((memq (car qualifiers) '(:before :after)))
    1597               (t
    1598                (error "Invalid method qualifiers.")))))
     1835         emf-form
     1836         (long-method-combination-p
     1837          (typep (get mc-name 'method-combination-object) 'long-method-combination)))
     1838    (unless long-method-combination-p
     1839      (dolist (m methods)
     1840        (let ((qualifiers (method-qualifiers m)))
     1841          (cond ((null qualifiers)
     1842                 (if (eq mc-name 'standard)
     1843                     (push m primaries)
     1844                     (error "Method combination type mismatch.")))
     1845                ((cdr qualifiers)
     1846                 (error "Invalid method qualifiers."))
     1847                ((eq (car qualifiers) :around)
     1848                 (push m arounds))
     1849                ((eq (car qualifiers) mc-name)
     1850                 (push m primaries))
     1851                ((memq (car qualifiers) '(:before :after)))
     1852                (t
     1853                 (error "Invalid method qualifiers."))))))
    15991854    (unless (eq order :most-specific-last)
    16001855      (setf primaries (nreverse primaries)))
    16011856    (setf arounds (nreverse arounds))
    16021857    (setf around (car arounds))
    1603     (when (null primaries)
     1858    (when (and (null primaries) (not long-method-combination-p))
    16041859      (error "No primary methods for the generic function ~S." gf))
    16051860    (cond
     
    16121867               gf (remove around methods))))
    16131868         (setf emf-form
    1614 ;;;           `(lambda (args)
    1615 ;;;          (funcall ,(%method-function around) args ,next-emfun))
    1616                (generate-emf-lambda (%method-function around) next-emfun)
    1617                )))
     1869               (generate-emf-lambda (%method-function around) next-emfun))))
    16181870      ((eq mc-name 'standard)
    16191871       (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
     
    16251877                 ((and (null befores) (null reverse-afters))
    16261878                  (let ((fast-function (%method-fast-function (car primaries))))
    1627 
    16281879                    (if fast-function
    16291880                        (ecase (length (gf-required-args gf))
     
    16361887                               (declare (optimize speed))
    16371888                               (funcall fast-function (car args) (cadr args)))))
    1638                         ;;                               `(lambda (args)
    1639                         ;;                                  (declare (optimize speed))
    1640                         ;;                                  (funcall ,(%method-function (car primaries)) args ,next-emfun))
    16411889                        (generate-emf-lambda (%method-function (car primaries))
    16421890                                             next-emfun))))
    16431891                 (t
    16441892                  (let ((method-function (%method-function (car primaries))))
    1645 
    16461893                    #'(lambda (args)
    16471894                        (declare (optimize speed))
     
    16521899                          (dolist (after reverse-afters)
    16531900                            (funcall (%method-function after) args nil))))))))))
    1654           (t
    1655            (let ((mc-obj (get mc-name 'method-combination-object)))
    1656              (unless mc-obj
    1657                (error "Unsupported method combination type ~A." mc-name))
    1658              (let* ((operator (method-combination-operator mc-obj))
    1659                     (ioa (method-combination-identity-with-one-argument mc-obj)))
    1660                (setf emf-form
    1661                      (if (and (null (cdr primaries))
    1662                               (not (null ioa)))
    1663 ;;                          `(lambda (args)
    1664 ;;                             (funcall ,(%method-function (car primaries)) args nil))
    1665                          (generate-emf-lambda (%method-function (car primaries)) nil)
    1666                          `(lambda (args)
    1667                             (,operator ,@(mapcar
    1668                                           (lambda (primary)
    1669                                             `(funcall ,(%method-function primary) args nil))
    1670                                           primaries)))))))))
    1671     (or (ignore-errors (autocompile emf-form))
     1901      (long-method-combination-p
     1902       (let* ((mc-obj (get mc-name 'method-combination-object))
     1903              (function (long-method-combination-function mc-obj))
     1904              (arguments (rest (slot-value gf 'method-combination))))
     1905         (assert (typep mc-obj 'long-method-combination))
     1906         (assert function)
     1907         (setf emf-form
     1908               (let ((result (if arguments
     1909                                 (apply function gf methods arguments)
     1910                                 (funcall function gf methods))))
     1911                 `(lambda (args)
     1912                    (let ((gf-args-var args))
     1913                      (macrolet ((call-method (method &optional next-method-list)
     1914                                   `(funcall ,(%method-function method) args nil)))
     1915                        ,result)))))))
     1916      (t
     1917       (let ((mc-obj (get mc-name 'method-combination-object)))
     1918         (unless (typep mc-obj 'short-method-combination)
     1919           (error "Unsupported method combination type ~A."
     1920                  mc-name))
     1921         (let* ((operator (short-method-combination-operator mc-obj))
     1922                (ioa (short-method-combination-identity-with-one-argument mc-obj)))
     1923           (setf emf-form
     1924                 (if (and (null (cdr primaries))
     1925                          (not (null ioa)))
     1926                     (generate-emf-lambda (%method-function (car primaries)) nil)
     1927                     `(lambda (args)
     1928                        (,operator ,@(mapcar
     1929                                      (lambda (primary)
     1930                                        `(funcall ,(%method-function primary) args nil))
     1931                                      primaries)))))))))
     1932    (assert (not (null emf-form)))
     1933    (or #+nil (ignore-errors (autocompile emf-form))
    16721934        (coerce-to-function emf-form))))
    16731935
     
    24562718                              (generic-function-argument-precedence-order gf)))
    24572719
     2720;;; XXX AMOP has COMPUTE-EFFECTIVE-METHOD
    24582721(defgeneric compute-effective-method-function (gf methods))
    24592722(defmethod compute-effective-method-function ((gf standard-generic-function) methods)
Note: See TracChangeset for help on using the changeset viewer.