home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part05 / meth-combi.l next >
Encoding:
Text File  |  1987-07-30  |  19.5 KB  |  494 lines
  1. ;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;;
  26. ;;; User-defined method combination.  A first try.
  27. ;;;
  28. ;;; For compatibility with New Flavors, the following functions macros and
  29. ;;; variables have the same meaning.
  30. ;;;   define-simple-method-combination
  31. ;;;   define-method-combination
  32. ;;;   call-component-method
  33. ;;;   call-component-methods
  34. ;;;   *combined-method-arguments*
  35. ;;;   *combined-method-apply*
  36. ;;;
  37. ;;; In define-method-combination the arguments have the following meanings:
  38. ;;;
  39. ;;;   name             the name of this method combination type (symbol)
  40. ;;;   parameters       like a defmacro lambda list, it is matched with
  41. ;;;                    the value specified by the :method-combination
  42. ;;;                    option to make-specializable
  43. ;;;   method-patterns  a list of method-patterns specifications that are
  44. ;;;                    used to select some subset of the methods defined
  45. ;;;                    on the discriminator.  Each method pattern specifies
  46. ;;;                    a variable which is bound to a list of the methods
  47. ;;;                    it selects.
  48. ;;;   body             forms evaluated with the variables specified by
  49. ;;;                    the method patterns bound to produce the body of
  50. ;;;                    the combined method.  (see call-component-methods).
  51. ;;;
  52. ;;;  Body can be preceded by any number of options which take the form:
  53. ;;;    (<option-name> . <option-args>)
  54. ;;;
  55. ;;;  Currently, the defined options are:
  56. ;;;
  57. ;;;   :causes-combination-predicate
  58. ;;;       The only argument, should be a function of one argument.  It
  59. ;;;       will be called on a method (of the discriminator) and should
  60. ;;;       return T if that method causes the discriminator to combine
  61. ;;;       its methods.
  62. ;;;
  63. ;;; A method-patterns looks like:
  64. ;;;                    
  65. ;;;   (<var> <printer> <filter> <order> <pattern-1> <pattern-2> ..)
  66. ;;;
  67. ;;;      <var>      is the variable to which the selected methods
  68. ;;;                 are bound
  69. ;;;      <printer>  is ignored
  70. ;;;      <filter>   one of :every, :first, :last or :remove-duplicates
  71. ;;;      <order>    :most-specific-first or :most-specific-last
  72. ;;;
  73. ;;;      Methods matching any of the patterns are selected.  The patterns
  74. ;;;      are matched against the method-combination-options of the method
  75. ;;;      as specified in the defmeth.
  76. ;;; 
  77.  
  78. (in-package 'pcl)
  79.  
  80. ;;;
  81. ;;; The method combination type of a particular method combination is stored
  82. ;;; as a symbol (the name of the method-combination) in the discriminator (in
  83. ;;; the method-combination-type slot).  Information about that particular
  84. ;;; method-combination-type is stored on the property list of the type symbol
  85. ;;; 
  86. (defun get-method-combination-info (type &optional no-error-p)
  87.   (or (get type 'method-combination)
  88.       (if no-error-p () (error "No method combination named ~S." type))))
  89.  
  90. (defun set-method-combination-info (type combiner predicate)
  91.   (setf (get type 'method-combination) (list type combiner predicate)))
  92.  
  93. (defmeth method-combiner ((discriminator method-combination-mixin))
  94.   (cadr (get-method-combination-info
  95.           (method-combination-type discriminator))))
  96.  
  97. (defmeth method-causes-combination-predicate
  98.          ((discriminator method-combination-mixin))
  99.   (caddr (get-method-combination-info
  100.            (method-combination-type discriminator))))
  101.  
  102.  
  103.  
  104.  
  105.   ;;   
  106. ;;;;;; COMBINED-METHOD class
  107.   ;;   
  108.  
  109. (ndefstruct (combined-method (:class class)
  110.                              (:include (method)))
  111.   (deactivated-methods ()))
  112.  
  113. (defmeth automatically-defined-p ((m combined-method)) (ignore m) t)
  114.  
  115. (defmeth method-options ((m combined-method)) (ignore m) '(:combined))
  116.                                                 
  117. (defmeth method-causes-combination-p ((m combined-method)) (ignore m) nil)
  118.  
  119. (defmacro define-simple-method-combination (name operator
  120.                                             &optional single-arg-is-value
  121.                                                       (pretty-name
  122.                                                         (string-downcase
  123.                                                           name)))
  124.   `(define-method-combination ,name
  125.                               (&optional (order :most-specific-first))
  126.              ((methods ,pretty-name :every order () (,name) :default))
  127.      `(call-component-methods ,methods
  128.                               :operator ,',operator
  129.                               :single-arg-is-value ,',single-arg-is-value)))
  130.  
  131. (defmacro define-method-combination (name parameters method-patterns
  132.                                      &body body)
  133.   (check-type parameters list)
  134.   (check-type method-patterns (and list (not null)))
  135.   (make-method-combination name parameters method-patterns body))
  136.  
  137.  
  138. (defvar *combined-method-arguments*)
  139. (defvar *combined-method-apply*)
  140. (defvar *combined-method-template*)
  141.  
  142. ;;;
  143. ;;; Generate a form that calls a single method.
  144. ;;; With no keyword arguments, uses the value of *combined-methods-arguments*
  145. ;;; as the arguments to the call;
  146. ;;; With :ARGLIST, uses that instead;
  147. ;;; With :ARGLIST and :APPLY T, uses APPLY instead of FUNCALL
  148. ;;; With just :APPLY, it is the single argument to apply to.
  149. ;;;
  150. ;;; When called with *combined-method-template* bound, generates calls to
  151. ;;; the value of variables gotten from *combined-method-template* instead
  152. ;;; of to the actual methods themselves.  This is used to build templates
  153. ;;; for combined methods.
  154. ;;;
  155. (defmacro call-component-method
  156.           (method &key (apply nil apply-p)
  157.                        (arglist 
  158.                          (if apply-p
  159.                              (prog1 (list apply) (setq apply t))
  160.                              (prog1 *combined-method-arguments*
  161.                                     (setq apply *combined-method-apply*)))))
  162.   (call-component-method-internal method apply arglist))
  163.  
  164. (defmacro call-component-methods (methods &key (operator 'progn)
  165.                                                (single-arg-is-value nil))
  166.   (call-component-methods-internal methods operator single-arg-is-value))
  167.  
  168. (defmeth call-component-method-internal
  169.          (method &optional (apply *combined-method-apply*)
  170.                            (arglist *combined-method-arguments*))
  171.   (when method
  172.     `(,(if apply 'apply 'funcall)
  173.       ,(if (boundp '*combined-method-template*)
  174.        (let ((gensym (cdr (assq method *combined-method-template*))))
  175.          (if gensym
  176.          `(the function ,gensym)
  177.          (error "*combined-method-template* out of sync??")))
  178.        `',(method-function method))
  179.       ,@arglist)))
  180.   
  181. (defmeth call-component-methods-internal (methods
  182.                       operator single-arg-is-value)
  183.   (when methods
  184.     (if (and single-arg-is-value (null (cdr methods)))
  185.     (call-component-method-internal (car methods))
  186.     `(,operator
  187.       ,@(iterate ((method in methods))
  188.           (collect (call-component-method-internal method)))))))
  189.  
  190. (defmeth call-component-method-equal (discriminator call-1 call-2)
  191.   ;; If the options are the same (the part that the macros control the
  192.   ;; processing of); and the individual calls are the same the part the
  193.   ;; methods themselves control the processing of.
  194.   (and (equal (cddr call-1) (cddr call-2))
  195.        (if (eq (car call-1) 'call-component-method)
  196.        (cond ((null (cadr call-1)) (null (cadr call-2)))
  197.          ((null (cadr call-2)) (null (cadr call-1)))
  198.          (t
  199.           (call-component-method-equal-internal
  200.             discriminator (cadr call-1) (cadr call-2))))
  201.            (iterate ((meth-1 on (cadr call-1))
  202.                      (meth-2 on (cadr call-2)))
  203.          (when (or (and (cdr meth-1) (null (cdr meth-2)))
  204.                (and (cdr meth-2) (null (cdr meth-1)))
  205.                (null (call-component-method-equal-internal
  206.                    discriminator (car meth-1) (car meth-2))))
  207.            (return nil))))))
  208.  
  209. (defmeth call-component-method-equal-internal (discriminator meth-1 meth-2)
  210.   (ignore discriminator meth-1 meth-2)
  211.   t)
  212.  
  213.  
  214.  
  215. (defvar *method-combination-filters*
  216.         '(:every :first :last :remove-duplicates))
  217.  
  218. (defvar *method-combination-orders*
  219.         '(:most-specific-first :most-specific-last))
  220.  
  221. (defun make-method-combination (name parameters method-patterns body)
  222.   (let ((causes-combination-predicate 'true)
  223.         (combiner (make-symbol (string-append name " Method Combiner"))))
  224.     ;; Error check and canonicalize the arguments.
  225.     (unless (symbolp name)
  226.       (error "The name of a method combination type must be a symbol, but ~S~
  227.             was specified."
  228.              name))
  229.     ;; Check the various sub-parts of each method-patterns.  Canonicalize
  230.     ;; each method-pattern by adding the () pattern to it if it has no
  231.     ;; other patterns.
  232.     (iterate ((method-patterns-loc on method-patterns))
  233.       (destructuring-bind (var printer filter order . patterns)
  234.                           (car method-patterns-loc)
  235.         (check-symbol-variability var "bind (in a method-patterns)")
  236.         (or (null (keywordp filter))
  237.             (memq filter *method-combination-filters*)
  238.             (error "A method-patterns filter must be one of: ~S~%not ~S."
  239.                    *method-combination-filters* filter))
  240.         (or (null (keywordp order))
  241.             (memq order *method-combination-orders*)
  242.             (error "A method-patterns order must be one of: ~S~%not ~S."
  243.                    *method-combination-orders* filter))
  244.         (if (null patterns)
  245.             (setf (car method-patterns-loc)
  246.                   (append (car method-patterns-loc) (list nil)))
  247.             (iterate ((pattern in patterns))
  248.               (or (listp pattern)
  249.                   (eq pattern ':default)
  250.                   (error "A method-pattern must be a list.~%~
  251.                          In the method-patterns ~S, ~S is an invalid pattern."
  252.                          (car method-patterns-loc) pattern))))))
  253.     (iterate ()
  254.       (while (and body (listp (car body))))
  255.       (case (caar body)
  256.         (:causes-combination-predicate
  257.           (setq causes-combination-predicate (cadr (pop body))))
  258.         (otherwise (return))))
  259.  
  260.     `(progn 
  261.        ,(make-combiner-definer
  262.           combiner name parameters method-patterns body)
  263.        (setf (get ',name 'combined-method-templates) ())
  264.        (set-method-combination-info ',name
  265.                                     ',combiner
  266.                                     ',causes-combination-predicate))))
  267.  
  268. (defun make-combiner-definer
  269.        (combiner name parameters method-patterns body)
  270.   (ignore name)
  271.   `(defun ,combiner (.discriminator. .methods. .params.)
  272.      .discriminator.
  273.      (apply
  274.        #'(lambda ,parameters
  275.            (let ,(iterate (((var) in method-patterns)) (collect `(,var nil)))
  276.              (do ((.method. (pop .methods.) (pop .methods.)))
  277.                  ((null .method.))
  278.                (cond 
  279.                  ,@(iterate (((var nil fil ord . pats) in method-patterns))
  280.                      (collect
  281.                `((and ,(ecase fil
  282.                  (:first
  283.                    `(if (eq ,ord :most-specific-first)
  284.                     (null ,var)
  285.                     't))
  286.                  (:last
  287.                    `(if (eq ,ord :most-specific-first)
  288.                     t
  289.                     (null ,var)))
  290.                  (:every
  291.                    't))
  292.                   (method-matches-patterns-p .method. ',pats))
  293.                          (push .method. ,var))))))
  294.          ,@(iterate (((var nil fil ord) in method-patterns))
  295.          (cond ((memq fil '(:first :last))
  296.             (collect `(setq ,var (car ,var))))
  297.                ((eq ord ':most-specific-first)
  298.             (collect `(setq ,var (nreverse ,var))))))
  299.              ,@body))
  300.        .params.)))
  301.  
  302.  
  303. (defmeth method-matches-patterns-p (method patterns)
  304.   (iterate ((pattern in patterns))
  305.     (when (method-matches-pattern-p method pattern)
  306.       (return t))))
  307.  
  308. (defmeth method-matches-pattern-p (method pattern)
  309.   (iterate ((pats = pattern (cdr pats))
  310.             (opts = (method-options method) (cdr opts)))
  311.     (if (symbolp pats)
  312.         ;; Special case this because it means we have to blow out of
  313.         ;; iterate.  Should iterate should know about dotted lists.
  314.         (return (or (eq pats '*) (eq pats opts)))
  315.         (unless (or (eq (car pats) '*)
  316.                     (equal (car pats) (car opts)))
  317.           (return nil)))    
  318.     (finally (return t))))
  319.  
  320. (defun patterns-keywords (patterns)
  321.   (let ((keywords ()))
  322.     (iterate ((pattern in patterns))
  323.       (iterate ((elem in pattern))
  324.         (when (keywordp elem) (push elem keywords))))
  325.     keywords))
  326.  
  327. (defun check-symbol-variability (symbol verb)
  328.   (cond ((not (symbolp symbol))
  329.          (error "Attempt to ~A ~S which is not a symbol" verb symbol))
  330.         ((or (null symbol) (eq symbol 't))
  331.          (error "Attempt to ~A ~S" verb symbol))
  332.         ((eq (symbol-package symbol) (find-package 'keyword))
  333.          (error "Attempt to ~A ~S, which is a keyword" verb symbol))
  334.         ((constantp symbol)
  335.          (error "Attempt to ~A ~S, which is a constant" verb symbol))))
  336.  
  337. (defun cpl-filter-= (cpl1 cpl2 discriminator)
  338.   (macrolet ((has-method-on-discriminator-p (class)
  339.            `(memq discriminator (class-direct-discriminators ,class))))
  340.     (prog ()
  341.        restart
  342.           (cond ((null cpl1)
  343.          (if (null cpl2)
  344.              (return t)
  345.              (return nil)))
  346.                 ((null cpl2)
  347.                  (return nil)))
  348.           (unless (has-method-on-discriminator-p (car cpl1))
  349.             (pop cpl1)
  350.             (go restart))
  351.           (unless (has-method-on-discriminator-p (car cpl2))
  352.             (pop cpl2)
  353.             (go restart))
  354.           (if (neq (pop cpl1) (pop cpl2))
  355.               (return nil)
  356.           (go restart)))))
  357.  
  358.  
  359. ;;;   class-discriminators-which-combine-methods
  360. ;;;   discriminator-methods-combine-p
  361.  
  362. (defmeth combine-methods ((class class) &optional discriminators)
  363.   (let ((cpl (class-class-precedence-list class))
  364.         (method nil)
  365.         (method-cpl nil)
  366.         (combined-method nil))
  367.   
  368.     (iterate ((disc in discriminators))
  369.       (setq method (lookup-method disc class)
  370.         method-cpl (and method
  371.                 (not (combined-method-p method))
  372.                 (class-class-precedence-list
  373.                   (car (method-type-specifiers method)))))
  374.       (unless (cpl-filter-= cpl method-cpl disc)
  375.     (dolist (other-method (discriminator-methods disc))
  376.       (when (and (combined-method-p other-method)
  377.              (eq (car (method-type-specifiers other-method))
  378.              class))
  379.         (remove-method disc other-method)))
  380.     (multiple-value-bind (arguments apply-p body)
  381.         (combine-methods-internal class disc cpl)
  382.       (setq combined-method 
  383.         (make 'combined-method
  384.               :function (compile-combined-method
  385.                   disc arguments apply-p body)
  386.               :arglist arguments
  387.               :type-specifiers (cons class
  388.                          (cdr (method-type-specifiers
  389.                             method)))))
  390.       (add-method disc combined-method nil))))))
  391.  
  392. (defmeth combine-methods-internal (class discriminator cpl)
  393.   (ignore class)
  394.   (let ((methods (iterate ((c in cpl))
  395.                    (join
  396.              (iterate ((m in (discriminator-methods discriminator)))
  397.                (when (and (eq (car (method-type-specifiers m)) c)
  398.                   (not (combined-method-p m)))
  399.              (collect m)))))))
  400.     (multiple-value-bind (required restp)
  401.         (compute-discriminating-function-arglist-info discriminator)
  402.       (let ((*combined-method-arguments*
  403.               (make-discriminating-function-arglist required restp))
  404.             (*combined-method-apply* restp))
  405.         (values *combined-method-arguments*
  406.                 *combined-method-apply*
  407.                 (funcall (method-combiner discriminator)
  408.                          discriminator methods ()))))))
  409.  
  410.  
  411.   ;;   
  412. ;;;;;; COMPILE-COMBINED-METHOD
  413.   ;;   
  414.  
  415. (defmeth compile-combined-method ((discriminator method-combination-mixin)
  416.                                   *combined-method-arguments*
  417.                                   *combined-method-apply*
  418.                                   body)
  419.   (multiple-value-bind (constructor methods-called)
  420.       (compile-combined-method-internal discriminator body)
  421.     (apply constructor (mapcar #'method-function methods-called))))
  422.  
  423. (defmeth compile-combined-method-internal (discriminator body)
  424.   (let* ((combination-type (method-combination-type discriminator))
  425.          (templates (get combination-type 'combined-method-templates))
  426.          (methods-called ())
  427.          (walked-body 
  428.            (walk-form body
  429.              :walk-function
  430.              #'(lambda (form context &aux temp)
  431.                  (ignore context)
  432.                  (values form
  433.                          (and (eq context 'eval)
  434.                               (listp form)
  435.                               (setq temp (car form))
  436.                               (cond ((eq temp 'call-component-method)
  437.                                      (push (cadr form) methods-called))
  438.                                     ((eq temp 'call-component-methods)
  439.                                      (setq methods-called
  440.                                            (append (cadr form)
  441.                                                    methods-called))))))))))
  442.     (setq methods-called (remove nil methods-called))
  443.     (iterate ((entry in templates))
  444.       (when (combined-method-equal discriminator (car entry) walked-body)
  445.         (return (values (cdr entry) methods-called)))
  446.       (finally    
  447.         (let* ((*combined-method-template*
  448.                  (iterate ((method in methods-called))
  449.                    (collect (cons method (gensym)))))
  450.                (new-constructor
  451.                  (compile ()
  452.                           `(lambda
  453.                              ,(mapcar #'cdr *combined-method-template*)
  454.                              #'(lambda ,*combined-method-arguments*
  455.                                  ,(walk-form walked-body))))))
  456.           (push (cons walked-body new-constructor)
  457.                 (get combination-type 'combined-method-templates))
  458.           (return (values new-constructor methods-called)))))))
  459.   
  460. (defmeth combined-method-equal (discriminator comb-meth-1 comb-meth-2)
  461.   (cond ((atom comb-meth-1) (eq comb-meth-1 comb-meth-2))
  462.         ((memq (car comb-meth-1)
  463.                '(call-component-method call-component-methods))
  464.          (and (eq (car comb-meth-1) (car comb-meth-2))
  465.               (call-component-method-equal
  466.                 discriminator comb-meth-1 comb-meth-2)))
  467.         (t
  468.          (and (combined-method-equal
  469.                 discriminator (car comb-meth-1) (car comb-meth-2))
  470.               (combined-method-equal
  471.                 discriminator (cdr comb-meth-1) (cdr comb-meth-2))))))
  472.  
  473.  
  474.  
  475. (defmeth discriminator-changed ((discriminator method-combination-mixin)
  476.                 (method combined-method)
  477.                 added-p)
  478.   (ignore discriminator method added-p))
  479.  
  480. (defmeth discriminator-changed ((discriminator method-combination-mixin)
  481.                 method
  482.                 added-p)
  483.   (when (methods-combine-p discriminator)
  484.     (let ((class (car (method-type-specifiers method))))
  485.       (when (classp class)
  486.     (labels ((walk-tree (class)
  487.            (combine-methods class (list discriminator))
  488.            (dolist (subclass (class-direct-subclasses class))
  489.              (walk-tree subclass))))
  490.       (walk-tree class)))))
  491.   (run-super))
  492.  
  493.  
  494.