1 ;;;; pattern-specializer.lisp --- Implementation of pattern specializers.
3 ;;;; Copyright (C) 2014 Jan Moringen
5 ;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
7 (cl:in-package #:pattern-specializer)
9 ;;; `pattern-specializer' class
11 (defclass pattern-specializer (specializer)
12 ((pattern :initarg :pattern
13 :reader specializer-pattern)
14 (direct-methods :type list
16 :reader specializer-direct-methods
17 :accessor specializer-%direct-methods))
19 :pattern (required-argument :pattern)))
21 (defun specializer-parsed-pattern (specializer)
22 (optima::parse-pattern (specializer-pattern specializer)))
24 (defun specializer-pattern-variables (specializer)
25 (optima::pattern-variables (specializer-parsed-pattern specializer)))
27 ;; TODO why did i need this again?
28 (defmethod class-name ((class (eql (find-class 'pattern-specializer))))
31 (defmethod add-direct-method ((specializer pattern-specializer)
33 (pushnew method (specializer-%direct-methods specializer)))
35 (defmethod remove-direct-method ((specializer pattern-specializer)
37 (removef (specializer-%direct-methods specializer) method :count 1))
39 (defmethod print-object ((object pattern-specializer) stream)
40 (print-unreadable-object (object stream :type t :identity t)
41 (princ (specializer-pattern object) stream)))
45 (defvar *pattern-specializer-table*
46 (make-hash-table :test 'equal :weakness :key-and-value))
48 (defun ensure-pattern-specializer (pattern)
49 (ensure-gethash pattern *pattern-specializer-table*
50 (make-instance 'pattern-specializer :pattern pattern)))
54 ;; Forward definition. Actual definition is below.
55 (defclass pattern-generic-function (standard-generic-function)
57 (:metaclass funcallable-standard-class))
59 (defclass pattern-method (standard-method)
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))))
68 (defmethod make-method-lambda-using-specializers
69 ((gf pattern-generic-function) (method pattern-method) qualifiers specializers
70 lambda-expression environment)
72 ;; This transforms LAMBDA-EXPRESSION of the form
74 ;; (lambda (arg1 arg2 …) BODY)
78 ;; (lambda (arg1 arg2 …
80 ;; ((:PATTERN-VAR1 PATTERN-VAR1)) ((:PATTERN-VAR2 PATTERN-VAR2)) …
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)
96 (new-lambda-list `(,@required
98 `(&optional ,@optional))
101 ,@(when (or keyword variables)
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)))
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)
114 gf method qualifiers specializers new-lambda-expression environment))))))
116 (defgeneric method-more-specific-p (gf method1 method2))
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)))))
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)))
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)))
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))
155 (mapcar (lambda (cluster)
156 (stable-sort cluster (lambda (entry1 entry2)
157 (method-more-specific-p gf (first entry1) (first entry2)))))
160 ;;; pattern-generic-function
162 (defclass pattern-generic-function (standard-generic-function)
164 (:metaclass funcallable-standard-class)
166 :method-class (find-class 'pattern-method)))
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))
175 (defmethod parse-specializer-using-class
176 ((gf pattern-generic-function) (specializer-name pattern-specializer))
179 (defmethod unparse-specializer-using-class
180 ((gf pattern-generic-function) (specializer pattern-specializer))
181 `(pattern ,(specializer-pattern specializer)))
183 (defmethod make-specializer-form-using-class or
184 ((proto-generic-function pattern-generic-function)
185 (proto-method pattern-method)
186 (specializer-name cons)
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)))
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))
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)))
207 (1 (specializer-pattern1 (first specializers)))
208 (t (mapcar #'specializer-pattern1 specializers)))
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
221 (1 '(format t "dispatch: ~A~%" arg))
222 (t '(format t "dispatch: ~A~%" args)))
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)))))))
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
236 (defmethod compute-discriminating-function
237 ((gf pattern-generic-function))
239 (format t "~&discriminating function: ~A~%" args)
240 (labels ((make-effective-method-form (spec)
241 `(lambda (&rest args)
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)))
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)?
256 (format t "~& trying to call~% ~A~% ~A~% ~A~%"
257 ,method args (list ,@next-methods))
258 (funcall (method-function ,method) args (list ,@next-methods)))))
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)
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
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:~& ")
280 (make-effective-method-function effective-method)))))
281 (apply function3 (append args (loop :for value :in variables
282 :for name :in (when methods
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)))))