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-generalizer' class
11 (defstruct (pattern-generalizer
12 (:constructor make-pattern-generalizer (specializers key variables &optional next))
14 (specializers nil :type list :read-only t)
15 (key nil :type t :read-only t)
16 (variables nil :type list :read-only t)
19 (defmethod specializable:generalizer-equal-hash-key
20 ((generic-function specializable:specializable-generic-function)
21 (generalizer pattern-generalizer))
22 (let ((key (pattern-generalizer-key generalizer)))
23 (if-let ((next (pattern-generalizer-next generalizer))) ; TODO compute lazily?
24 (cons key (specializable:generalizer-equal-hash-key
25 generic-function next))
28 (defmethod specializable::generalizer-args
29 ((generic-function specializable:specializable-generic-function)
30 (generalizer pattern-generalizer))
31 (pattern-generalizer-variables generalizer))
33 ;;; `pattern-specializer' class
35 (defclass pattern-specializer (specializable:extended-specializer)
36 ((pattern :initarg :pattern
37 :reader specializer-pattern))
39 :pattern (required-argument :pattern)))
41 (defmethod print-object ((object pattern-specializer) stream)
42 (print-unreadable-object (object stream :type t :identity t)
43 (princ (specializer-pattern object) stream)))
45 (defun specializer-parsed-pattern (specializer)
46 (optima.core:parse-pattern (specializer-pattern specializer)))
48 (defun specializer-pattern-variables (specializer)
49 (optima.core:pattern-variables (specializer-parsed-pattern specializer)))
51 (specializable:define-extended-specializer pattern (generic-function pattern)
52 (declare (ignore generic-function))
53 (make-instance 'pattern-specializer :pattern pattern))
55 ;; Parsing is handled by `define-extended-specializer' above
57 (defmethod unparse-specializer-using-class
58 ((gf specializable:specializable-generic-function) (specializer pattern-specializer))
59 `(pattern ,(specializer-pattern specializer)))
61 (defmethod make-specializer-form-using-class or
62 ((proto-generic-function specializable:specializable-generic-function) ; TODO should work for all specializable generic functions
63 (proto-method specializable:specializable-method)
64 (specializer-name cons)
66 (when (typep specializer-name '(cons (eql pattern)))
67 `(sb-pcl:parse-specializer-using-class ; TODO packages
68 (sb-pcl:class-prototype (find-class ',(type-of proto-generic-function)))
71 ;;; Equality and ordering
73 (defmethod sb-pcl::same-specializer-p ((specializer1 pattern-specializer)
74 (specializer2 pattern-specializer))
75 (let ((pattern1 (specializer-parsed-pattern specializer1))
76 (pattern2 (specializer-parsed-pattern specializer2)))
77 (eq (pattern-more-specific-p pattern1 pattern2) '=)))
79 ;; TODO should (pattern SOME-CLASS) be `same-specializer-p' to SOME-CLASS?
81 (defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
82 (specializer1 pattern-specializer)
83 (specializer2 pattern-specializer)
85 (pattern-more-specific-p
86 (specializer-parsed-pattern specializer1)
87 (specializer-parsed-pattern specializer2)))
90 (defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
92 (specializer2 pattern-specializer)
97 (defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
98 (specializer1 pattern-specializer)
103 (defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
105 (specializer2 pattern-specializer)
107 (multiple-value-bind (result definitivep)
108 (specializable:specializer-accepts-generalizer-p
109 generic-function specializer2 specializer1)
111 ((and result definitivep) '<)
114 ;; TODO can this be avoided?
115 (defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
118 (generalizer pattern-generalizer))
119 (let ((next (pattern-generalizer-next generalizer)))
122 (specializable:specializer< generic-function specializer1 specializer2 next))
123 ((multiple-value-bind (result1 definitivep1)
124 (subtypep specializer1 specializer2)
125 (multiple-value-bind (result2 definitivep2)
126 (subtypep specializer2 specializer1)
128 ((not (and definitivep1 definitivep2)))
129 ((and result1 result2) '=)
134 ;;; Accepting objects and generalizers
136 (defmethod specializable:specializer-accepts-p ((specializer pattern-specializer) object)
137 ;; TODO store in specializer later
138 (let* ((accept-form (with-gensyms (object)
140 (optima:match ,object
141 (,(specializer-pattern specializer)
142 (declare (ignore ,@(specializer-pattern-variables specializer)))
144 (accept-function (compile nil accept-form)))
145 (funcall accept-function object)))
147 (defmethod specializable:specializer-accepts-generalizer-p ((gf specializable:specializable-generic-function)
148 (specializer pattern-specializer)
149 (generalizer pattern-generalizer))
150 (values (find specializer (pattern-generalizer-specializers generalizer)) t))
152 (defmethod specializable:specializer-accepts-generalizer-p ((gf specializable:specializable-generic-function)
154 (generalizer pattern-generalizer))
155 (when-let ((next (pattern-generalizer-next generalizer))) ; TODO needed?
156 (specializable:specializer-accepts-generalizer-p gf specializer next)))
158 (defmethod specializable:specializer-accepts-generalizer-p ((gf specializable:specializable-generic-function)
159 (specializer pattern-specializer)
161 (specializer-accepts-generalizer-p-using-pattern
162 gf specializer (specializer-parsed-pattern specializer) generalizer))
164 (defmethod specializer-accepts-generalizer-p-using-pattern
165 ((gf specializable:specializable-generic-function)
166 (specializer pattern-specializer)
167 (pattern optima.core:variable-pattern)
171 (defmethod specializer-accepts-generalizer-p-using-pattern
172 ((gf specializable:specializable-generic-function)
173 (specializer pattern-specializer)
174 (pattern optima.core:and-pattern)
176 (let ((definitivep t))
179 (mapc (lambda (subpattern)
180 (multiple-value-bind (result definitivep)
181 (specializer-accepts-generalizer-p-using-pattern
182 gf specializer subpattern generalizer)
184 (setf definitivep t) ; TODO correct?
187 (setf definitivep nil))))
188 (optima::complex-pattern-subpatterns pattern)))
191 (defmethod specializer-accepts-generalizer-p-using-pattern
192 ((gf specializable:specializable-generic-function)
193 (specializer pattern-specializer)
194 (pattern optima.core:or-pattern)
196 (error "not implemented"))
198 (defmethod specializer-accepts-generalizer-p-using-pattern
199 ((gf specializable:specializable-generic-function)
200 (specializer pattern-specializer)
201 (pattern optima.core:not-pattern)
203 (multiple-value-bind (result definitivep)
204 (specializer-accepts-generalizer-p-using-pattern
205 gf specializer (optima.core:not-pattern-subpattern pattern) generalizer)
206 (values (not result) definitivep)))
208 (defmethod specializer-accepts-generalizer-p-using-pattern
209 ((gf specializable:specializable-generic-function)
210 (specializer pattern-specializer)
211 (pattern optima.core:cons-pattern)
213 (multiple-value-bind (result definitivep) (subtypep generalizer 'cons)
215 (values t (and definitivep (subpatterns-unrestricted-p pattern)))
216 (values nil definitivep))))
218 (defmethod specializer-accepts-generalizer-p-using-pattern
219 ((gf specializable:specializable-generic-function)
220 (specializer pattern-specializer)
221 (pattern optima.core:class-pattern)
223 (multiple-value-bind (result definitivep)
224 (specializable:specializer-accepts-generalizer-p
225 gf (find-class (optima.core:class-pattern-class-name pattern)) generalizer)
227 (values t (and definitivep (subpatterns-unrestricted-p pattern)))
228 (values nil definitivep))))
230 (defmethod specializer-accepts-generalizer-p-using-pattern
231 ((gf specializable:specializable-generic-function)
232 (specializer pattern-specializer)
233 (pattern optima.core:guard-pattern)
235 (values t nil)) ; TODO
237 ;; TODO why did i need this again?
238 (defmethod class-name ((class (eql (find-class 'pattern-specializer))))
239 'pattern-specializer)
240 ;; at least this one is for slime
241 (defmethod class-name ((class pattern-specializer))
242 'pattern-specializer)
246 ;; Forward definition. Actual definition is below.
247 (defclass pattern-generic-function (specializable:specializable-generic-function)
249 (:metaclass funcallable-standard-class))
251 (defclass pattern-method (standard-method)
254 (defmethod method-pattern-specializers ((gf pattern-generic-function)
255 (method pattern-method))
256 (remove-if-not (of-type 'pattern-specializer)
257 (mapcar (curry #'parse-specializer-using-class gf) ; TODO necessary?
258 (method-specializers method))))
260 (defmethod make-method-lambda-using-specializers
261 ((gf pattern-generic-function) (method pattern-method) qualifiers specializers
262 lambda-expression environment)
264 ;; This transforms LAMBDA-EXPRESSION of the form
266 ;; (lambda (arg1 arg2 …) BODY)
270 ;; (lambda (arg1 arg2 …
272 ;; ((:PATTERN-VAR1 PATTERN-VAR1)) ((:PATTERN-VAR2 PATTERN-VAR2)) …
273 ;; &allow-other-keys)
276 ;; where BODY contains uses of PATTERN-VAR1, PATTERN-VAR2, …
277 (destructuring-bind (operator lambda-list &body body) lambda-expression
278 (declare (ignore operator))
279 (multiple-value-bind (required optional rest keyword allow-other-keys-p)
280 (parse-ordinary-lambda-list lambda-list :normalize nil)
281 (flet ((make-keyword-parameter (variable)
282 (list `((,(make-keyword variable) ,variable)))))
283 (let* ((variables (mappend #'specializer-pattern-variables ; TODO this stuff is repeated in make-method-matching-form
284 (remove-if-not (of-type 'pattern-specializer)
285 (mapcar (curry #'parse-specializer-using-class gf)
287 (new-lambda-list `(,@required
289 `(&optional ,@optional))
292 ,@(when (or keyword variables)
294 ,@(mapcan #'make-keyword-parameter variables)))
295 ,@(when allow-other-keys-p
296 '(&allow-other-keys))))
297 (new-lambda-expression `(lambda ,new-lambda-list ,@body)))
299 gf method qualifiers specializers new-lambda-expression environment))))))
301 ;;; pattern-generic-function
303 (defclass pattern-generic-function (specializable:specializable-generic-function)
304 ((specializer-clusters :type list)
305 (generalizer-makers :type list #|of function|#))
306 (:metaclass funcallable-standard-class)
308 :method-class (find-class 'pattern-method))) ; TODO is pattern-method even needed?
310 (defmethod reinitialize-instance :after ((instance pattern-generic-function)
312 (slot-makunbound instance 'specializer-clusters)
313 (slot-makunbound instance 'generalizer-makers))
315 (defmethod generic-function-specializer-clusters ((generic-function pattern-generic-function))
316 (if (slot-boundp generic-function 'specializer-clusters) ; TODO ensure-slot-value
317 (slot-value generic-function 'specializer-clusters)
318 (setf (slot-value generic-function 'specializer-clusters)
319 ;; TODO copied from make-generalizer-makers
320 (when-let* ((methods (generic-function-methods generic-function))
321 (arity (when-let ((first-method (first methods)))
322 (length (method-specializers first-method)))) ; TODO improve
324 (loop :for i :below arity
325 :collect (let* ((specializers (mapcar (lambda (method)
326 (nth i (method-specializers method)))
328 (non-pattern-specializers
329 (remove-if (of-type 'pattern-specializer) specializers))
330 (pattern-specializers
331 (set-difference specializers non-pattern-specializers)))
332 (specializer-clusters generic-function pattern-specializers)))))))
334 (defmethod generic-function-generalizer-makers ((generic-function pattern-generic-function))
335 (if (slot-boundp generic-function 'generalizer-makers)
336 (slot-value generic-function 'generalizer-makers)
337 (setf (slot-value generic-function 'generalizer-makers)
338 (make-generalizer-makers generic-function))))
340 (defmethod specializable:generalizers-of-using-class ((generic-function pattern-generic-function) args)
344 :for maker :in (generic-function-generalizer-makers generic-function)
349 ((funcall maker arg))
350 ((not nexts) (first (setf nexts (nthcdr i (call-next-method)))))
351 (t (first nexts))))))
353 (defmethod specializable:generalizer-of-using-class ((generic-function pattern-generic-function) args)
354 ;; TODO: this is a hack -- the main specializer protocol calls the
355 ;; singular generalizer-of-using-class when there's only one
356 ;; specialized arg, to save on wasted effort. We can just about
357 ;; support it here, but it's very brittle.
358 (assert (specializable::first-arg-only-special-case generic-function))
359 (car (specializable:generalizers-of-using-class generic-function (list args))))
361 ;;; Specializer clustering
363 (defmethod in-same-cluster-p ((generic-function t) (specializer1 t) (specializer2 t))
366 (defmethod in-same-cluster-p ((generic-function specializable:specializable-generic-function)
367 (specializer1 pattern-specializer)
368 (specializer2 pattern-specializer))
369 (let ((pattern1 (specializer-parsed-pattern specializer1))
370 (pattern2 (specializer-parsed-pattern specializer2)))
371 (member (pattern-more-specific-p pattern1 pattern2) '(= < >))))
373 (defmethod in-same-cluster-p ((generic-function specializable:specializable-generic-function)
374 (specializer1 pattern-specializer)
375 (specializer2 class))
376 (specializable:specializer-accepts-generalizer-p
377 generic-function specializer1 specializer2))
379 (defmethod in-same-cluster-p ((generic-function specializable:specializable-generic-function)
381 (specializer1 pattern-specializer))
382 (specializable:specializer-accepts-generalizer-p
383 generic-function specializer1 specializer2))
385 (defun specializer-clusters (generic-function specializers)
386 (let ((clusters '()))
387 (dolist (specializer specializers)
388 (dolist (cluster clusters (push (list (list specializer)) clusters))
389 (when (every (lambda (entry)
391 generic-function specializer (first entry)))
393 (dolist (entry cluster (nconcf cluster (list (list specializer))))
394 (when (sb-pcl::same-specializer-p specializer (first entry))
395 (nconcf entry (list specializer))
398 (mapcar (lambda (cluster)
399 (stable-sort cluster (lambda (entry1 entry2)
400 (eq '< (specializable:specializer<
401 generic-function entry1 entry2 :TODO)))
405 ;;; Generalizers maker
407 (defun make-generalizer-maker-form (generic-function specializers clusters)
408 (labels ((cluster-element-clause (element rest)
409 (let* ((specializer (first element))
410 (variables (specializer-pattern-variables specializer)))
411 `(,(specializer-pattern specializer)
412 (make-pattern-generalizer
413 '(,@(mappend #'identity (list* element rest)))
414 ',(specializer-pattern specializer)
415 (list ,@(loop :for variable in (remove-if-not #'symbol-package variables) ; TODO hack
416 :collect (make-keyword variable)
417 :collect variable))))))
418 (cluster-clauses (cluster)
419 (loop :for (element . rest) :on cluster
420 :collect (cluster-element-clause element rest))))
423 ,@(mappend #'cluster-clauses clusters)
424 (t ,(make-pattern-generalizer '() nil '()))))))
426 (defun make-generalizer-maker (generic-function specializers clusters)
427 (let* ((non-pattern-specializers
428 (remove-if (of-type 'pattern-specializer) specializers))
429 (pattern-specializers
430 (set-difference specializers non-pattern-specializers)))
431 (values (compile nil (make-generalizer-maker-form
432 generic-function pattern-specializers clusters))
433 non-pattern-specializers)))
435 (defun make-generalizer-makers (generic-function)
436 (let* ((clusters (generic-function-specializer-clusters generic-function))
437 (methods (generic-function-methods generic-function))
438 (arity (when-let ((first-method (first methods)))
439 (length (method-specializers first-method)))) ; TODO improve
440 (any-non-pattern-specializers-p nil))
442 (loop :for i :below arity
443 :collect (multiple-value-bind
444 (generalizer-maker non-pattern-specializers-p)
445 (make-generalizer-maker
447 (mapcar (lambda (method)
448 (nth i (method-specializers method)))
451 (when non-pattern-specializers-p
452 (setf any-non-pattern-specializers-p t))
454 any-non-pattern-specializers-p)))