src/pattern-specializer.lisp

   1 ;;;; pattern-specializer.lisp --- Implementation of pattern specializers.
   2 ;;;;
   3 ;;;; Copyright (C) 2014 Jan Moringen
   4 ;;;;
   5 ;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
   6
   7 (cl:in-package #:pattern-specializer)
   8
   9 ;;; `pattern-specializer' class
  10
  11 (defclass pattern-specializer (specializer)
  12   ((pattern        :initarg  :pattern
  13                    :reader   specializer-pattern)
  14    (direct-methods :type     list
  15                    :initform '()
  16                    :reader   specializer-direct-methods
  17                    :accessor specializer-%direct-methods))
  18   (:default-initargs
  19    :pattern (required-argument :pattern)))
  20
  21 (defun specializer-parsed-pattern (specializer)
  22   (optima::parse-pattern (specializer-pattern specializer)))
  23
  24 (defun specializer-pattern-variables (specializer)
  25   (optima::pattern-variables (specializer-parsed-pattern specializer)))
  26
  27 ;; TODO why did i need this again?
  28 (defmethod class-name ((class (eql (find-class 'pattern-specializer))))
  29   'pattern-specializer)
  30
  31 (defmethod add-direct-method ((specializer pattern-specializer)
  32                               (method      t))
  33   (pushnew method (specializer-%direct-methods specializer)))
  34
  35 (defmethod remove-direct-method ((specializer pattern-specializer)
  36                                  (method      t))
  37   (removef (specializer-%direct-methods specializer) method :count 1))
  38
  39 (defmethod print-object ((object pattern-specializer) stream)
  40   (print-unreadable-object (object stream :type t :identity t)
  41     (princ (specializer-pattern object) stream)))
  42
  43 ;;;
  44
  45 (defvar *pattern-specializer-table*
  46   (make-hash-table :test 'equal :weakness :key-and-value))
  47
  48 (defun ensure-pattern-specializer (pattern)
  49   (ensure-gethash pattern *pattern-specializer-table*
  50                   (make-instance 'pattern-specializer :pattern pattern)))
  51
  52 ;;; pattern-method
  53
  54 ;; Forward definition. Actual definition is below.
  55 (defclass pattern-generic-function (standard-generic-function)
  56   ()
  57   (:metaclass funcallable-standard-class))
  58
  59 (defclass pattern-method (standard-method)
  60   ())
  61
  62 (defmethod method-pattern-specializers ((gf pattern-generic-function)
  63                                         (method pattern-method))
  64   (remove-if-not (of-type 'pattern-specializer)
  65                  (mapcar (curry #'parse-specializer-using-class gf) ; TODO necessary?
  66                          (method-specializers method))))
  67
  68 (defmethod make-method-lambda-using-specializers
  69     ((gf pattern-generic-function) (method pattern-method) qualifiers specializers
  70      lambda-expression environment)
  71
  72   ;; This transforms LAMBDA-EXPRESSION of the form
  73   ;;
  74   ;;   (lambda (arg1 arg2 …) BODY)
  75   ;;
  76   ;; into
  77   ;;
  78   ;;   (lambda (arg1 arg2 …
  79   ;;            &key
  80   ;;            ((:PATTERN-VAR1 PATTERN-VAR1)) ((:PATTERN-VAR2 PATTERN-VAR2)) …
  81   ;;            &allow-other-keys)
  82   ;;     BODY)
  83   ;;
  84   ;; TODO obviously, this has to parse the original lambda-list
  85   ;; properly in the future.
  86   (destructuring-bind (operator lambda-list &body body) lambda-expression
  87     (declare (ignore operator))
  88     (multiple-value-bind (required optional rest keyword allow-other-keys-p)
  89         (parse-ordinary-lambda-list lambda-list :normalize nil)
  90       (flet ((make-keyword-parameter (variable)
  91                (list `((,(make-keyword variable) ,variable)))))
  92         (let* ((variables (mappend #'specializer-pattern-variables ; TODO this stuff is repeated in make-method-matching-form
  93                                    (remove-if-not (of-type 'pattern-specializer)
  94                                                   (mapcar (curry #'parse-specializer-using-class gf)
  95                                                           specializers))))
  96                (new-lambda-list `(,@required
  97                                   ,@(when optional
  98                                       `(&optional ,@optional))
  99                                   ,@(when rest
 100                                       `(&rest ,rest))
 101                                   ,@(when (or keyword variables)
 102                                       `(&key ,@keyword
 103                                              ,@(mapcan #'make-keyword-parameter variables)))
 104                                   ,@(when allow-other-keys-p
 105                                       '(&allow-other-keys))))
 106                (new-lambda-expression `(lambda ,new-lambda-list ,@body)))
 107
 108           (format t "make-method-lambda-using-specializers~%  ~A~%  ~A~%  ~A~%  ~A~%=>"
 109                   gf method specializers lambda-expression)
 110           (print new-lambda-list)
 111           (print new-lambda-expression)
 112
 113           (call-next-method
 114            gf method qualifiers specializers new-lambda-expression environment))))))
 115
 116 (defgeneric method-more-specific-p (gf method1 method2))
 117
 118 (defmethod method-more-specific-p ((gf      pattern-generic-function)
 119                                    (method1 pattern-method)
 120                                    (method2 pattern-method))
 121   (let* ((specializers1 (method-pattern-specializers gf method1))
 122          (specializers2 (method-pattern-specializers gf method2))
 123          (more-index (mismatch specializers1 specializers2
 124                                :test (complement #'pattern-more-specific-p)
 125                                :key #'specializer-parsed-pattern))
 126          (less-index (mismatch specializers1 specializers2
 127                                :test #'pattern-more-specific-p
 128                                :key #'specializer-parsed-pattern)))
 129     (or (and more-index (not less-index))
 130         (and more-index (< more-index less-index)))))
 131
 132 (defun in-same-cluster-p (gf method1 method2)
 133   (or (equal (mapcar #'specializer-pattern
 134                      (method-pattern-specializers gf method1))
 135              (mapcar #'specializer-pattern
 136                      (method-pattern-specializers gf method2)))
 137       (method-more-specific-p gf method1 method2)
 138       (method-more-specific-p gf method2 method1)))
 139
 140 (defun cluster-methods (gf methods)
 141   (let ((clusters '()))
 142     (dolist (method1 methods)
 143       (dolist (cluster clusters (push (list (list method1)) clusters))
 144         (when (every (lambda (entry) (in-same-cluster-p gf method1 (first entry)))
 145                      cluster)
 146           (dolist (entry cluster
 147                          (nconcf cluster (list (list method1))))
 148             (when (equal (mapcar #'specializer-pattern ; TODO repeated in in-same-cluster-p
 149                                  (method-pattern-specializers gf method1))
 150                          (mapcar #'specializer-pattern
 151                                  (method-pattern-specializers gf (first entry))))
 152               (nconcf entry (list method1))
 153               (return)))
 154           (return))))
 155     (mapcar (lambda (cluster)
 156               (stable-sort cluster (lambda (entry1 entry2)
 157                                      (method-more-specific-p gf (first entry1) (first entry2)))))
 158             clusters)))
 159
 160 ;;; pattern-generic-function
 161
 162 (defclass pattern-generic-function (standard-generic-function)
 163   ()
 164   (:metaclass funcallable-standard-class)
 165   (:default-initargs
 166    :method-class (find-class 'pattern-method)))
 167
 168 (defmethod parse-specializer-using-class
 169     ((gf pattern-generic-function) (specializer-name t))
 170   (if (typep specializer-name '(cons (eql pattern)))
 171       (let ((pattern (second specializer-name)))
 172         (ensure-pattern-specializer pattern))
 173       (call-next-method)))
 174
 175 (defmethod parse-specializer-using-class
 176     ((gf pattern-generic-function) (specializer-name pattern-specializer))
 177   specializer-name)
 178
 179 (defmethod unparse-specializer-using-class
 180     ((gf pattern-generic-function) (specializer pattern-specializer))
 181   `(pattern ,(specializer-pattern specializer)))
 182
 183 (defmethod make-specializer-form-using-class or
 184     ((proto-generic-function pattern-generic-function)
 185      (proto-method pattern-method)
 186      (specializer-name cons)
 187      (environment t))
 188   (when (typep specializer-name '(cons (eql pattern)))
 189     `(sb-pcl:parse-specializer-using-class ; TODO packages
 190       (sb-pcl:class-prototype (find-class ',(type-of proto-generic-function)))
 191       ',specializer-name)))
 192
 193 (defun make-matching-lambda-form (gf methods)
 194   (let ((arity (when-let ((first-method (first methods)))
 195                  (length (method-specializers first-method))))
 196         (clusters (cluster-methods gf methods)))
 197    (labels ((specializer-pattern1 (specializer)
 198               (typecase specializer
 199                 (pattern-specializer (specializer-pattern specializer))
 200                 (t                   '*)))
 201             (method-variables (method)
 202               (mappend #'specializer-pattern-variables
 203                        (method-pattern-specializers gf method)))
 204             (cluster-clause (most-specific-method other-methods)
 205               (let ((specializers (method-specializers most-specific-method)))
 206                 `(,(case arity
 207                      (1 (specializer-pattern1 (first specializers)))
 208                      (t (mapcar #'specializer-pattern1 specializers)))
 209                   (values
 210                    '(,most-specific-method ,@other-methods)
 211                    (list ,@(method-variables most-specific-method))))))
 212             (cluster-clauses (cluster)
 213               (loop :for ((head-first . head-rest) . rest) :on cluster
 214                     :collect (cluster-clause
 215                               head-first (reduce #'append rest
 216                                                  :initial-value head-rest)))))
 217      `(lambda ,(case arity
 218                  (1 '(arg))
 219                  (t '(&rest args)))
 220         ,(case arity
 221            (1 '(format t "dispatch: ~A~%" arg))
 222            (t '(format t "dispatch: ~A~%" args)))
 223         (,@(case arity
 224              (1 `(optima:match arg))
 225              (t `(optima:multiple-value-match (values-list args))))
 226          ,@(loop :for cluster :in clusters
 227                  :appending (cluster-clauses cluster)))))))
 228
 229 (defun make-method-interpreting-function (gf)
 230   (format t "~&method-interpreting-function: ~A~%" gf)
 231   (let* ((methods (generic-function-methods gf))
 232          (f (compile nil (print (make-matching-lambda-form gf methods)))))
 233     (named-lambda method-pattern-matching-function (&rest args) ; TODO just return the (compile …) above after debugging
 234       (apply f args))))
 235
 236 (defmethod compute-discriminating-function
 237     ((gf pattern-generic-function))
 238   (lambda (&rest args)
 239     (format t "~&discriminating function: ~A~%" args)
 240     (labels ((make-effective-method-form (spec)
 241                `(lambda (&rest args)
 242                   (locally
 243                       (declare (sb-ext:disable-package-locks make-method call-method))
 244                     (macrolet ((make-method (spec)
 245                                  (let ((make-effective-method-function ,#'make-effective-method-function))
 246                                    (make-instance 'standard-method
 247                                                   :specializers nil ; TODO
 248                                                   :qualifiers nil ; TODO
 249                                                   :function (let ((f (funcall make-effective-method-function spec)))
 250                                                               (lambda (a n)
 251                                                                 (apply f a))))))
 252                                (call-method (method next-methods)
 253                                  ;; TODO we could do method-specific parsing here
 254                                  ;; TODO can we extract the method-function like ,(method-function method)?
 255                                  `(progn
 256                                     (format t "~& trying to call~%  ~A~%  ~A~%  ~A~%"
 257                                             ,method args (list ,@next-methods))
 258                                     (funcall (method-function ,method) args (list ,@next-methods)))))
 259                       ,spec))))
 260              (make-effective-method-function (spec)
 261                (compile nil (make-effective-method-form spec))))
 262       (let* ((function2     (make-method-interpreting-function gf))
 263              (function4     (lambda (&rest args)
 264                (multiple-value-bind (methods variables) (apply function2 args)
 265
 266                  (loop :for spec :in (method-pattern-specializers gf (first methods))
 267                        :for gen :in (mapcar #'class-of args)
 268                        :do (print (list spec gen (multiple-value-list (specializer-accepts-generalizer-p
 269                                                                        gf spec gen)))))
 270
 271                 (let ((function3 (progn
 272                                    (format t "~&  methods~%  ~A~&  variables~&  ~A~%" methods variables)
 273                                    (multiple-value-bind (effective-method options)
 274                                        (compute-effective-method
 275                                         gf (sb-mop::generic-function-method-combination gf) methods)
 276                                      (format t "~&  effective method:~&  ")
 277                                      (print effective-method)
 278                                      (format t "~&  options:~&  ")
 279                                      (print options)
 280                                      (make-effective-method-function effective-method)))))
 281                   (apply function3 (append args (loop :for value :in variables
 282                                                       :for name :in (when methods
 283                                                                       (mappend
 284                                                                        #'specializer-pattern-variables
 285                                                                        (method-pattern-specializers gf (first methods))))
 286                                                       :collect (make-keyword name)
 287                                                       :collect value))))))))
 288         (set-funcallable-instance-function gf function4) ; TODO seems to be wrong
 289         (apply function4 args)))))