Coverage report: /home/ellis/comp/core/lib/obj/meta/filtered.lisp

KindCoveredAll%
expression0370 0.0
branch046 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; obj/meta/filtered.lisp --- Filtered generic functions
2
 
3
 ;; see https://github.com/pcostanza/filtered-functions
4
 
5
 ;; ref: https://www.p-cos.net/documents/filtered-dispatch.pdf
6
 #| ;; factorial as a generic function
7
 (defmethod fac ((n number))
8
  (* n (fac (- n 1))))
9
 
10
 (defmethod fac ((n (eql 0)))
11
   1)
12
 |#
13
 ;;; Code:
14
 (in-package :obj/meta/filtered)
15
 
16
 (defgeneric generic-function-filter-expression (gf)
17
   (:method ((gf generic-function)) (constantly t)))
18
 
19
 (defclass simple-filtered-function (standard-generic-function)
20
   ((filter-expression :initarg :filter-expression
21
                       :reader generic-function-filter-expression))
22
   (:metaclass sb-mop:funcallable-standard-class))
23
 
24
 (defmethod compute-applicable-methods-using-classes ((ff simple-filtered-function) classes)
25
   (declare (ignore classes))
26
   (values '() nil))
27
 
28
 (defmethod compute-applicable-methods ((ff simple-filtered-function) required-args)
29
   (let* ((filter-expression (generic-function-filter-expression ff))
30
          (filter-functions (apply filter-expression required-args)))
31
     (cond ((consp filter-functions)
32
            (loop for arg in required-args
33
                  for filter-function = (pop filter-functions)
34
                  collect (if filter-function
35
                            (funcall filter-function arg)
36
                            arg)
37
                  into filtered-args
38
                  finally (return (call-next-method ff filtered-args))))
39
           ((null filter-functions) '())
40
           ((eq filter-functions 't) (call-next-method))
41
           (t (call-next-method ff (cons (funcall filter-functions (first required-args))
42
                                         (rest required-args)))))))
43
 
44
 (defclass filtered-function (standard-generic-function)
45
   ((filter-groups :initform '() :reader %filter-groups))
46
   (:metaclass sb-mop:funcallable-standard-class))
47
 
48
 (defun check-filters (ff filters)
49
   (when (assoc nil filters)
50
     (error "NIL is not a valid filter key in filtered function ~S." ff))
51
   (loop for (first . rest) on (mapcar #'first filters)
52
         when (member first rest)
53
         do (error "Duplicate filter specification ~S in filtered function ~S." first ff))
54
   (loop for (key . filter) in filters
55
         unless (or (symbolp filter) (functionp filter))
56
         do (error "~S is not a valid function designator for filter ~S in filtered function ~S."
57
                   filter key ff)))
58
 
59
 (defmethod initialize-instance :after ((ff filtered-function) &key filters)
60
   (check-filters ff filters)
61
   (loop with initargs = `(,@(handler-case
62
                                 (list :lambda-list
63
                                       (sb-mop:generic-function-lambda-list ff)
64
                                       :argument-precedence-order
65
                                       (sb-mop:generic-function-argument-precedence-order ff))
66
                               (error () '()))
67
                           :method-class ,(sb-mop:generic-function-method-class ff)
68
                           :method-combination ,(sb-mop:generic-function-method-combination ff))
69
         for (key . filter) in filters
70
         collect (cons key (apply #'make-instance
71
                                  'simple-filtered-function
72
                                  :filter-expression filter
73
                                  initargs)) into filter-groups
74
         finally
75
         (setf (slot-value ff 'filter-groups) filter-groups)))
76
 
77
 (defmethod reinitialize-instance :after
78
   ((ff filtered-function) &rest initargs &key (filters '() filtersp))
79
   (if filtersp
80
     (loop initially (check-filters ff filters)
81
           with initargs = `(,@(handler-case
82
                                   (list :lambda-list
83
                                         (sb-mop:generic-function-lambda-list ff)
84
                                         :argument-precedence-order
85
                                         (sb-mop:generic-function-argument-precedence-order ff))
86
                                 (error () '()))
87
                             :method-class ,(sb-mop:generic-function-method-class ff)
88
                             :method-combination ,(sb-mop:generic-function-method-combination ff))
89
           with old-filter-groups = (%filter-groups ff)
90
           for (key . filter) in filters
91
           for old-filter-group = (cdr (assoc key old-filter-groups))
92
           collect (cons key (if old-filter-group
93
                               (apply #'reinitialize-instance
94
                                      old-filter-group
95
                                      :filter-expression filter
96
                                      initargs)
97
                               (apply #'make-instance
98
                                      'simple-filtered-function
99
                                      :filter-expression filter
100
                                      initargs))) into filter-groups
101
           finally
102
           (setf (slot-value ff 'filter-groups) filter-groups))
103
     (loop for (nil . filter-group) in (%filter-groups ff)
104
           do (apply #'reinitialize-instance filter-group initargs))))
105
 
106
 (defgeneric generic-function-filters (ff)
107
   (:method ((ff filtered-function))
108
    (loop for (key . filter-group) in (%filter-groups ff)
109
          collect (cons key (generic-function-filter-expression filter-group)))))
110
 
111
 (defgeneric (setf generic-function-filters) (new-filters ff)
112
   (:argument-precedence-order ff new-filters)
113
   (:method ((new-filters list) (ff filtered-function))
114
    (reinitialize-instance ff :filters new-filters)
115
    new-filters))
116
 
117
 (defvar *generic-functions*)
118
 
119
 (defmethod compute-applicable-methods-using-classes ((ff filtered-function) classes)
120
   (declare (ignore classes))
121
   (if *generic-functions*
122
     (values '() nil)
123
     (call-next-method)))
124
 
125
 (defmethod compute-applicable-methods ((ff filtered-function) args)
126
   (if *generic-functions*
127
     (append
128
      (loop for ff in *generic-functions*
129
            append (compute-applicable-methods ff args))
130
      (call-next-method))
131
     (call-next-method)))
132
 
133
 (defmethod compute-discriminating-function ((ff filtered-function))
134
   (flet ((compute-discriminator ()
135
            (loop with gfs
136
                  for (nil . gf) in (%filter-groups ff)
137
                  when (sb-mop:generic-function-methods gf) do (push gf gfs)
138
                  finally
139
                  (return
140
                   (if (sb-mop:generic-function-methods ff)
141
                     (let ((original-discriminator (call-next-method)))
142
                       (lambda (&rest args)
143
                         (let ((*generic-functions* gfs))
144
                           (apply original-discriminator args))))
145
                     (cond ((null gfs)
146
                            (lambda (&rest args)
147
                              (apply #'no-applicable-method ff args)))
148
                           ((null (cdr gfs))
149
                            (compute-discriminating-function (car gfs)))
150
                           (t (let ((original-discriminator (call-next-method)))
151
                                (lambda (&rest args)
152
                                  (let ((*generic-functions* gfs))
153
                                    (apply original-discriminator args)))))))))))
154
     (if (eq (class-of ff) (find-class 'filtered-function))
155
       (lambda (&rest args)
156
         (let ((discriminator (compute-discriminator)))
157
           (sb-mop:set-funcallable-instance-function ff discriminator)
158
           (apply discriminator args)))
159
       (compute-discriminator))))
160
 
161
 (defgeneric method-filter (method)
162
   (:method ((method method)) nil))
163
 
164
 (defclass filtered-method (standard-method)
165
   ((filter :initform nil :reader method-filter)))
166
 
167
 (defmethod initialize-instance :after ((method filtered-method) &key qualifiers)
168
   (when (member (first qualifiers) '(:before :after :around))
169
     (pop qualifiers))
170
   (when (eq (first qualifiers) :filter)
171
     (pop qualifiers)
172
     (unless qualifiers
173
       (error "Filter qualifier is not followed by a filter designator in method ~S." method))
174
     (unless (first qualifiers)
175
       (error "NIL is not a valid filter designator in method ~S." method))
176
     (setf (slot-value method 'filter)
177
           (pop qualifiers)))
178
   (when qualifiers
179
     (error "Invalid qualifiers ~S for method ~S." qualifiers method)))
180
 
181
 (defmethod add-method ((ff filtered-function) method)
182
   (let ((filter (method-filter method)))
183
     (if filter
184
       (let ((spec (assoc filter (%filter-groups ff))))
185
         (cond (spec (add-method (cdr spec) method))
186
               (t (cerror "Try again."
187
                          "Invalid filter ~S in method ~S for filtered function ~S." filter method ff)
188
                  (add-method ff method)))
189
         (reinitialize-instance ff))
190
       (call-next-method))))
191
 
192
 (defmethod remove-method ((ff filtered-function) method)
193
   (let ((filter (method-filter method)))
194
     (if filter
195
       (let ((spec (assoc filter (%filter-groups ff))))
196
         (when spec
197
           (remove-method (cdr spec) method)
198
           (reinitialize-instance ff)))
199
       (call-next-method))))
200
 
201
 (define-method-combination filtered ()
202
   ((methods * :required t))
203
   (:generic-function gf)
204
   (loop with after
205
         for method in methods
206
         for (qualifier) = (method-qualifiers method)
207
         if (eq qualifier :around) collect method into around
208
         else if (eq qualifier :before) collect method into before
209
         else if (eq qualifier :after) do (push method after)
210
         else collect method into primary
211
         finally (unless primary
212
                   (method-combination-error 
213
                    "No applicable primary method for generic function ~S." gf))
214
         (return 
215
          (flet ((call-methods (methods)
216
                   (loop for method in methods collect `(call-method ,method))))
217
            (let* ((inner-form (if (or before after (rest primary))
218
                                 `(multiple-value-prog1
219
                                      (progn ,@(call-methods before)
220
                                        (call-method ,(first primary) ,(rest primary)))
221
                                    ,@(call-methods (reverse after)))
222
                                 `(call-method ,(first primary))))
223
                   (outer-form (if around
224
                                 `(call-method ,(first around)
225
                                               (,@(rest around)
226
                                                (make-method ,inner-form)))
227
                                 inner-form)))
228
              outer-form)))))
229
 
230
 (defmacro define-filtered-function (name (&rest lambda-list) &body options)
231
   `(progn
232
      (defgeneric ,name ,lambda-list
233
        ,@(unless (member :generic-function-class options :key #'first)
234
            '((:generic-function-class filtered-function)))
235
        ,@(unless (member :method-class options :key #'first)
236
            '((:method-class filtered-method)))
237
        ,@(unless (member :method-combination options :key #'first)
238
            '((:method-combination filtered)))
239
        ,@(remove :filters options :key #'first))
240
      (setf (generic-function-filters (fdefinition ',name))
241
            ,(let ((filters-option (rest (assoc :filters options)))
242
                   (required-lambda-list (loop for arg in lambda-list
243
                                               until (member arg lambda-list-keywords)
244
                                               collect arg)))
245
               `(list ,@(loop for (key . body) in filters-option
246
                              collect `(cons ',key (lambda ,required-lambda-list
247
                                                     (declare (ignorable ,@required-lambda-list))
248
                                                     ,@body))))))
249
      ',name))