/[de-setf-amqp]/macros.lisp
ViewVC logotype

Contents of /macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3 - (show annotations)
Tue Feb 23 09:05:39 2010 UTC (4 years, 1 month ago) by janderson
File size: 45367 byte(s)
Merge commit 'remotes/github/master' into remotes/git-svn
1 ;;; -*- Package: de.setf.amqp.implementation; -*-
2
3
4 (in-package :de.setf.amqp.implementation)
5
6 (document :file
7 (description "This file defines the macros to declare protocol objects and methods for the
8 'de.setf.amqp' library.")
9 (copyright
10 "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved"
11 "'de.setf.amqp' is free software: you can redistribute it and/or modify it under the terms of version 3
12 of the GNU Affero General Public License as published by the Free Software Foundation.
13
14 'setf.amqp' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
15 implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
16 See the Affero General Public License for more details.
17
18 A copy of the GNU Affero General Public License should be included with 'de.setf.amqp' as `AMQP:agpl.txt`.
19 If not, see the GNU [site](http://www.gnu.org/licenses/).")
20
21 (long-description "Several macros are used to define protocol entities
22
23 - `def-ensure-object` operates with a protocol object to retrieve or create the respective dependent
24 object, where the type is given abstractly while the instance is apways specific to the context's
25 version
26 - `def-ensure-method` operates with a protocol object similar to `def-ensure-object`, but with respect to
27 method instances.
28 - `def-amqp-abstract-class` defines a general protocol class. (see `classes.lisp`)
29 - `def-amqp-class` defines a version-specific object class. This includes the codecs and the constructors.
30 - `def-amqp-method` defines a version-specific method class. This includes the codecs and the constructors.
31 - `def-amqp-command` defines a combined request/response command suite."))
32
33
34 (defmacro def-ensure-instance ((context-class-name scoped-class-name type) &optional keyword-arguments &rest options)
35 "Define an AMQP interface method, named 'context-class-name.scoped-class-name' which ensures an instance of
36 the scoped class exist for the context class. The operator manages a cache to arrange that there is one of
37 each named type for the class instance. If keyargs are specified, they serve to index a set of cached
38 methods, otherwise the operator arrange that at most one method exist. If initialization arguments other than
39 any designators are passed, an existing instance is reinitialized to reflect the new values.
40 When no (matching) instance exists, the abstract type is resolved wrt to a version-specific concrete class
41 wrt the context, instantiated with any passed initialization arguments, and cached.
42 In addition to the interface operator, define elementary slot accessors which use the respective
43 valence and index keys to implement the index.
44
45 The macro serves to implement def-ensure-object and def-insure-method."
46
47 (let* ((keyargs (mapcar #'(lambda (arg) (etypecase arg (cons (first arg)) (symbol arg))) keyword-arguments))
48 (keytypes (mapcar #'(lambda (arg) (etypecase arg (cons (second arg)) (symbol t))) keyword-arguments))
49 (method-name.impl (cons-symbol *package* context-class-name "." scoped-class-name))
50 (method-name.amqp (cons-symbol :amqp method-name.impl))
51 (reader-name (cons-symbol *package* :get- context-class-name :- scoped-class-name
52 (ecase type (object nil) (method :-method))
53 (when (consp keyargs) :s)))
54 (writer-name (cons-symbol *package* :setf- context-class-name :- scoped-class-name
55 (ecase type (object nil) (method :-method))
56 (when (consp keyargs) :s)))
57 (ensure-name (cons-symbol :amqp :ensure- type))
58 (documentation (or (second (assoc :documentation options))
59 (format nil "Ensure an ~:(~a.~a~) instance~@[, cached by ~:(~a~)~]."
60 context-class-name scoped-class-name keyargs)))
61 (find-class-operator (cons-symbol *package* :class-find- type :-class))
62 #+(or ) ;; don't name a consturctor directly by class/method name
63 ;; the name should be used for the request operator
64 (constuctor (assoc :constructor options))
65 (reader (assoc :reader options))
66 (writer (assoc :writer options))
67 (ensure-object (assoc :ensure-object options))
68 (class.type (assoc (ecase type (object :class.object) (method :class.method)) options)))
69 `(progn
70 ;; (declare (ftype ... (setf x))) had no effect within the function
71 ;; the type here cannot be made specific, as some methods apply to
72 ;; more than one class and the eventual actual accessor definitions are
73 ;; non-specific. otherwise sbcl nortices the anamoly and complains
74 (declaim (ftype (function (t) t) ,reader-name)
75 (ftype (function (t t) t) ,writer-name))
76 (eval-when (:compile-toplevel :load-toplevel :execute)
77 (export '(,method-name.amqp ,ensure-name) :amqp))
78
79 ,(if reader ; define a standard function - it delegates to a generic
80 `(defun ,method-name.impl ,@(rest reader))
81 (if keyargs
82 `(defun ,method-name.impl (_::context &key ,@keyargs)
83 ,@(loop for name in keyargs
84 for type in keytypes
85 unless (eq type t)
86 collect `(assert-argument-type ,method-name.impl ,name ,type))
87 ,(if (and (= (length keytypes) 1) (subtypep (first keytypes) 'fixnum))
88 `(let ((_::cache (,reader-name _::context)))
89 (assert (and (>= ,(first keyargs) 0) (< ,(first keyargs) (length _::cache))) ()
90 "Invalid cache reference: ~d, ~a" ,(first keyargs) (type-of _::cache))
91 (aref _::cache ,(first keyargs)))
92 `(let ((key ,(if (cdr keyargs) `(list ,@keyargs) (first keyargs))))
93 ,@(when (cdr keyargs) `((declare (dynamic-extent key))))
94 (rest (assoc key (,reader-name _::context) :test #'equal)))))
95 `(defun ,method-name.impl (_::context &key)
96 (,reader-name _::context))))
97
98 ,(if writer ; define a standard function - it delegates to a generic
99 `(defun (setf ,method-name.impl) ,@(rest writer))
100 (if keyargs
101 `(defun (setf ,method-name.impl) (_::value _::context &key ,@keyargs)
102 ,@(loop for name in keyargs
103 for type in keytypes
104 unless (eq type t)
105 collect `(assert-argument-type (setf ,method-name.impl) ,name ,type))
106 (let* ((_::cache (,reader-name _::context)))
107 ,(if (and (= (length keytypes) 1) (subtypep (first keytypes) 'fixnum))
108 `(progn
109 (assert (and (>= ,(first keyargs) 0) (< ,(first keyargs) (length _::cache))) ()
110 "Invalid cache reference: ~d, ~a" ,(first keyargs) (type-of _::cache))
111 (setf (aref _::cache ,(first keyargs)) _::value))
112 `(let* ((key ,(if (cdr keyargs) `(list ,@keyargs) (first keyargs)))
113 (entry (assoc key _::cache :test #'equal)))
114 ,@(when (cdr keyargs) `((declare (dynamic-extent key))))
115 (if entry
116 (setf (rest entry) _::value)
117 (prog1 _::value
118 (,writer-name (acons ,(if (cdr keyargs) `(copy-list key) 'key)
119 _::value
120 _::cache)
121 _::context)))))))
122 `(defun (setf ,method-name.impl) (_::value _::context &key)
123 (,writer-name _::value _::context))))
124
125 ,(if ensure-object
126 `(defmethod ,ensure-name ,@(rest ensure-object))
127 `(defmethod ,ensure-name ((_::context ,context-class-name) (type (eql ',scoped-class-name))
128 &rest _::initargs)
129 (declare (dynamic-extent _::initargs))
130 (apply #',method-name.amqp _::context _::initargs)))
131
132 ,(if class.type
133 `(defmethod ,method-name.amqp ,@(rest class.type))
134 `(defmethod ,method-name.amqp ((_::context ,context-class-name) &rest _::initargs
135 &key ,@keyargs &allow-other-keys)
136 ,documentation
137 (declare (dynamic-extent _::initargs))
138 (let* ((_::instance
139 (,method-name.impl _::context ,@(loop for name in keyargs
140 append `(,(cons-symbol :keyword name) ,name)))))
141 (if _::instance
142 (if ,(if keyargs
143 `(loop for key in _::initargs by #'cddr
144 unless ,(if (cdr keyargs)
145 `(member key ',(mapcar #'(lambda (name)
146 (cons-symbol :keyword name))
147 keyargs))
148 `(eq key ',(cons-symbol :keyword (first keyargs))))
149 return t)
150 '_::initargs)
151 (apply #'reinitialize-instance _::instance _::initargs)
152 _::instance)
153 (setf _::instance
154 (apply #'make-instance (,find-class-operator _::context ',scoped-class-name)
155 :context _::context
156 _::initargs)
157 (,method-name.impl _::context ,@(loop for name in keyargs
158 append `(,(cons-symbol :keyword name) ,name)))
159 _::instance)))))
160 )))
161
162 (defmacro def-ensure-object ((context-class-name class-name) &optional keyargs &rest options)
163 "Define an AMQP interface method, named 'class-name.method-name' which ensures an instance of the given
164 method exist for the respective class. See def-ensure-instance."
165
166 `(def-ensure-instance (,context-class-name ,class-name object) ,keyargs
167 ,@options))
168
169
170 (defmacro def-ensure-method ((context-class-name method-name) &rest options)
171 "Define an AMQP interface method, named 'class-name.method-name' which ensures an instance of the given
172 method exist for the respective class. See def-ensure-instance. The methods are indexed in the object by
173 name only."
174
175 `(def-ensure-instance (,context-class-name ,method-name method) ()
176 ,@options))
177
178
179
180 (defmacro def-amqp-abstract-class (name supers slots &rest options)
181 (unless (assoc :documentation options)
182 (push `(:documentation ,(format nil "The AMQP protocol class ~:(~a~)." name))
183 options))
184 `(progn
185 (eval-when (:compile-toplevel :load-toplevel :execute)
186 (export '(,name) (symbol-package ',name)))
187 (defclass ,name ,supers ,slots ,@options)
188 (def-class-constructor ,name
189 (:method ((context amqp:object) &rest initargs)
190 (declare (dynamic-extent initargs))
191 (apply #'amqp:ensure-object context ',name initargs)))
192 (find-class ',name)))
193
194
195 (defmacro def-amqp-class (name supers slots properties arguments &rest options)
196 (let* ((exports `((export ',name ,(symbol-package name))))
197 (class-code (or (getf (rest (assoc 'id slots)) :initform)
198 (error "no class id code present")))
199 (abstract-version-class (first supers))
200 (abstract-protocol-class (second supers))
201 (version-package (symbol-package name))
202 (connection-class (cons-symbol version-package :connection))
203 (method-names (second (getf (rest (assoc 'method-names slots)) :initform)))
204 (length-var '_::length)
205 (buffer-var '_::buffer)
206 (frame-var '_::frame)
207 (reserved-slot-names nil))
208
209 ;; coerce protocol slots names to the :amqp package
210 (flet ((coerce-slot-name (sd)
211 (cons (cons-symbol :amqp (first sd)) (rest sd))))
212 (setf properties (mapcar #'coerce-slot-name properties)
213 arguments (mapcar #'coerce-slot-name arguments)))
214 (setf reserved-slot-names (remove nil (mapcar #'(lambda (sd)
215 (let ((name (first sd)))
216 (when (search "reserved" (string name) :test #'char-equal)
217 name)))
218 (append properties arguments))))
219
220 (setf slots (append slots
221 `((property-slot-names :initform ',(mapcar #'first properties)
222 :allocation :class)
223 (argument-slot-names :initform ',(mapcar #'first arguments)
224 :allocation :class))
225 (unless (assoc 'protocol-version slots)
226 `((protocol-version :initform ,(cons-symbol :keyword (package-name (symbol-package name)))
227 :reader class-protocol-version
228 :allocation :class)))
229 (mapcar #'(lambda (method-name)
230 `(,(cons-symbol :amqp method-name :-method)
231 :initform nil
232 :reader ,(cons-symbol *package* :get- name :- method-name :-method)
233 :writer ,(cons-symbol *package* :setf- name :- method-name :-method)))
234 method-names)
235 (mapcar #'(lambda (sd)
236 (destructuring-bind (slot-name &key accessor reader writer
237 &allow-other-keys)
238 sd
239 ;; coerce name to :amqp and generate accessors
240 (list* slot-name
241 :initarg (cons-symbol :keyword slot-name)
242 (if (or accessor reader writer)
243 (rest sd)
244 (let ((accessor (cons-symbol :amqp name :- slot-name)))
245 (push `(export ',accessor :amqp) exports)
246 `(:accessor ,accessor ,@(rest sd)))))))
247 ;; allow that the class itself and method share a property/argument
248 (remove-duplicates (append properties arguments) :key #'first :from-end nil))))
249
250
251 `(progn
252 (eval-when (:compile-toplevel :load-toplevel :execute)
253 (defclass ,name ,supers ,slots ,@options))
254 ,@(nreverse exports)
255
256 (defmethod connection-class-code-class-name ((connection ,connection-class) (class-code (eql ,class-code)))
257 ',abstract-protocol-class)
258
259 (defmethod connection-class-name-class-code ((connection ,connection-class) (class-code (eql ',abstract-protocol-class)))
260 ,class-code)
261
262 (defmethod class-find-object-class ((context-class ,abstract-version-class) (class-code (eql ,class-code)))
263 (find-class ',name))
264 (defmethod class-find-object-class ((context-class ,abstract-version-class) (class-name (eql ',abstract-protocol-class)))
265 (find-class ',name))
266
267 (defmethod amqp:ensure-object ((class ,abstract-version-class) (class-code (eql ,class-code)) &rest args)
268 (declare (dynamic-extent args))
269 (apply #'amqp:ensure-object class ',abstract-protocol-class args))
270
271 #+(or )
272 (defmethod class-initialize-class ((_::context-class amqp:object) (_::context ,name) &key
273 ,@(mapcar #'(lambda (name)
274 `(,name nil ,(cons-symbol *package* name :-s)))
275 unreserved-property-names))
276 ,@(mapcar #'(lambda (name)
277 `(when ,(cons-symbol *package* name :-s)
278 (setf (slot-value _::context ',name) ,name)))
279 unreserved-property-names)
280 (call-next-method))
281
282 (defmethod call-with-decoded-properties (op (class ,name) buffer &rest args)
283 ,(format nil "Decode ~a properties into a buffer." name)
284 (declare (dynamic-extent args))
285 ;; stack-allocate the initial list of the full property complement
286 (let ((decoded-args (list* ,@(reduce #'append (mapcar #'(lambda (sd)
287 (let ((name (first sd)))
288 (unless (find name reserved-slot-names)
289 ;; the initial value is nil. either it is
290 ;; set from the properties or it is removed
291 (list (cons-symbol :keyword name) nil))))
292 properties))
293 :class ',name
294 :weight (content-weight buffer)
295 :body-size (content-body-size buffer)
296 args)))
297 (declare (dynamic-extent decoded-args))
298 (assert (eql (content-header-class-id buffer) ,class-code) ()
299 "Invalid content header for class: ~d, ~s" (content-header-class-id buffer) ',name)
300 ;; massage the property list based on the buffer content
301 (with-property-decoders (buffer :start (class-property-offset class))
302 ,@(mapcar #'(lambda (sd)
303 (destructuring-bind (name &key (type (error "No type present: ~s . ~s" name sd))
304 &allow-other-keys) sd
305 ;; nb. must check the reserveds
306 ;; in order to maintain the flag position
307 (if (find name reserved-slot-names)
308 `(amqp:field ,type) ; just decoded to keep place
309 `(amqp:field ,type decoded-args ,(cons-symbol :keyword name)))))
310 properties))
311 (apply op class decoded-args)))
312
313 (defmethod call-with-encoded-properties (op (class ,name)
314 &key (body-size (class-body-size class))
315 (weight (class-weight class))
316 ,@(mapcar #'(lambda (sd)
317 (destructuring-bind (name &key &allow-other-keys) sd
318 ;; reserved properties are nil to suppress encoding
319 (if (search "reserved" (string name) :test #'char-equal)
320 `(,name nil ,(cons-symbol (symbol-package name) name :-s))
321 `(,name (slot-value class ',name)))))
322 properties))
323 ,(format nil "Encode ~a properties into a buffer." name)
324 ,@(let ((reserved-names (remove nil (mapcar #'(lambda (sd)
325 (destructuring-bind (name &key &allow-other-keys) sd
326 (when (search "reserved" (string name) :test #'char-equal)
327 (list name (cons-symbol (symbol-package name) name :-s)))))
328 properties))))
329 (loop for (var var-s) in reserved-names
330 collect `(when ,var-s
331 (error ,(format nil "~s is reserved and may not be specified." var)))))
332 (amqp:log :debug class "encoding: (~@{~s~^ ~})"
333 ,@(reduce #'append (mapcar #'(lambda (sd)
334 (destructuring-bind (name &key &allow-other-keys) sd
335 (unless (search "reserved" (string name) :test #'char-equal)
336 `(,(cons-symbol :keyword name) ,name))))
337 properties)))
338 (let* ((,length-var 0)
339 (,frame-var (claim-output-frame class))
340 (,buffer-var (frame-data ,frame-var)))
341 (declare (ignorable ,buffer-var))
342 (setf ,length-var
343 (with-property-encoders (,buffer-var :start (class-property-offset class))
344 ,@(mapcar #'(lambda (sd)
345 (destructuring-bind (name &key type &allow-other-keys) sd
346 (cond ((or (eq type 'amqp:bit)
347 (get type 'amqp:bit))
348 (error "Bit type not supported for properties: ~s." name))
349 (t
350 `(when ,name (amqp:field ,name ,type))))))
351 properties)))
352
353 (setf-content-header-class-id ,class-code ,buffer-var)
354 (setf-content-weight weight ,buffer-var)
355 (setf-content-body-size body-size ,buffer-var)
356 (setf-frame-size ,length-var ,frame-var)
357 (funcall op ,frame-var class))))))
358
359 (defmacro def-amqp-method ((class method-name) (amqp:method-name &rest supers) slots arguments &rest options)
360 (let* ((exports ())
361 (method-code (or (getf (rest (assoc 'id slots)) :initform)
362 (error "no id slot present: ~a." class)))
363 (length-var (gensym "length"))
364 (buffer-var (gensym "buffer"))
365 (frame-var (gensym "frame"))
366 (version-package (symbol-package class))
367 (connection-class (cons-symbol version-package :connection))
368 (class.method-name (cons-symbol version-package class "." method-name))
369 (amqp::class (cons-symbol :amqp class))
370 (amqp::class.method-name (cons-symbol :amqp class.method-name))
371 (decoded-operator (cons-symbol version-package :call-with-decoded- class.method-name :-arguments))
372 (encoded-operator (cons-symbol version-package :call-with-encoded- class.method-name :-arguments))
373 (unreserved-arguments nil))
374 (push `(export ',class.method-name (symbol-package ',class.method-name)) exports)
375 (flet ((coerce-slot-name (sd)
376 (if (eq (getf (rest sd) :allocation) :class)
377 sd
378 (cons (cons-symbol :amqp (first sd)) (rest sd)))))
379 (setf arguments (mapcar #'coerce-slot-name arguments)))
380 (setf unreserved-arguments (remove-if #'(lambda (sd) (search "reserved" (string (first sd)) :test #'char-equal)) arguments))
381 `(progn
382 (eval-when (:compile-toplevel :load-toplevel :execute)
383 (defclass ,class.method-name (,amqp::class.method-name ,@supers)
384 ,(list* `(argument-slot-names :initform ',(mapcar #'first arguments)
385 :allocation :class)
386 ;; initialize to quoted name; it's defined later
387 `(request-function :initform ',(cons-symbol :amqp :channel-request- amqp:method-name) ) ;:allocation :class)
388 `(response-function :initform (response-function ,(cons-symbol :amqp :channel-respond-to- amqp:method-name))
389 :allocation :class)
390 `(name :initform ',amqp:method-name :allocation :class)
391 '(header :initform nil)
392 '(data :initform nil)
393 (append slots
394 (mapcar #'(lambda (sd)
395 (destructuring-bind (slot-name &key accessor reader writer
396 &allow-other-keys)
397 sd
398 (list* slot-name
399 :initarg (cons-symbol :keyword slot-name)
400 (if (or accessor reader writer)
401 (rest sd)
402 (let ((accessor (cons-symbol :amqp amqp:method-name :- slot-name)))
403 (push `(export ',accessor :amqp) exports)
404 `(:accessor ,accessor ,@(rest sd)))))))
405 arguments)))
406 ,@options))
407 (c2mop:ensure-class ',amqp::class.method-name :direct-superclasses '(,amqp:method-name))
408 ;; (format *trace-output* "~&method defined: ~s" ',class.method-name)
409 ;; (pushnew ',class.method-name (amqp:class-methods (find-class ',class)))
410 ,@(nreverse exports)
411
412 ;; initialize unspecified slots from the respective class
413 ,@(when unreserved-arguments
414 `((defmethod class-initialize-method ((class ,class) (method ,class.method-name) &rest initargs &key
415 ,@(mapcar #'(lambda (sd)
416 (destructuring-bind (name &key &allow-other-keys) sd
417 `(,name (slot-value class ',name))))
418 unreserved-arguments))
419 (declare (dynamic-extent initargs))
420 (apply #'call-next-method class method
421 ,@(apply #'nconc (mapcar #'(lambda (sd)
422 (destructuring-bind (name &key &allow-other-keys) sd
423 `(,(cons-symbol :keyword name) ,name)))
424 unreserved-arguments))
425 initargs))))
426
427 ;; needs to be the specific, class.method combined name
428 (defmethod class-method-code-method-name ((class ,class) (method-code (eql ,method-code)))
429 ',class.method-name)
430
431 (defmethod class-method-name-method-code ((class ,class) (method-name (eql ',amqp:method-name)))
432 ,method-code)
433
434 (defmethod connection-method-code-method-name ((connection ,connection-class)
435 (class-name (eql ',amqp::class))
436 (method-code (eql ,method-code)))
437 ',amqp:method-name)
438
439 (defmethod connection-method-name-method-code ((connection ,connection-class)
440 (class-name (eql ',amqp::class))
441 (method-code (eql ',amqp:method-name)))
442 ',method-code)
443
444 ;; designators map to the generic name, but return the concrete class
445 (defmethod amqp:ensure-method ((class ,class) (method-code (eql ,method-code)) &rest initargs)
446 (declare (dynamic-extent initargs))
447 (apply #'amqp:ensure-method class ',amqp::method-name initargs))
448
449
450 (defmethod class-find-method-class ((class ,class) (method-code (eql ,method-code)))
451 (find-class ',class.method-name))
452 #+(or ) ; map just the general, not the context-specific
453 (defmethod class-find-method-class ((class ,class) (concrete-class (eql ',amqp::class.method-name)))
454 (find-class ',class.method-name))
455
456 (defmethod class-find-method-class ((class ,class) (concrete-class (eql ',amqp::method-name)))
457 (find-class ',class.method-name))
458
459
460 ;; decoding
461
462 (defmethod call-with-decoded-arguments (op (class ,class) (id (eql ,method-code)) buffer &rest args)
463 (declare (dynamic-extent args))
464 (apply #',decoded-operator op class (amqp:ensure-method class ',amqp::class.method-name) buffer
465 args))
466
467 (defmethod call-with-decoded-arguments (op (class ,class) (id (eql ',amqp:method-name)) buffer &rest args)
468 (declare (dynamic-extent args))
469 (apply #',decoded-operator op class (amqp:ensure-method class ',amqp::class.method-name) buffer
470 args))
471
472 (defmethod call-with-decoded-arguments (op (class ,class) (method ,class.method-name) buffer &rest args)
473 (declare (dynamic-extent args))
474 (apply #',decoded-operator op class method buffer
475 args))
476
477 (defun ,decoded-operator (op class method buffer &rest args)
478 (declare (dynamic-extent args)
479 (type frame-buffer buffer))
480 (assert-argument-type ,decoded-operator buffer frame-buffer)
481 (let ,(mapcar #'(lambda (sd) `(,(first sd) nil)) arguments)
482 ,@(let ((unusables (remove nil (mapcar #'(lambda (sd)
483 (let ((name (first sd)))
484 (when (search "reserved" (string name) :test #'char-equal)
485 name)))
486 arguments))))
487 (when unusables `((declare (ignorable ,@unusables)))))
488 (with-argument-decoders (buffer :start (method-argument-offset method))
489 ,@(let ((bits 0) (forms nil) (last-bits nil))
490 (mapcar #'(lambda (sd)
491 (destructuring-bind (name &key (type (error "No type present: ~s . ~s" class sd))
492 &allow-other-keys) sd
493 (cond ((or (eq type 'amqp:bit)
494 (get type 'amqp:bit))
495 (setf last-bits `(setf ,name (amqp:bit ,bits)))
496 (push last-bits forms)
497 (incf bits))
498 ;; nb. must (at least initially) decode the reserveds
499 ;; in order to maintain the position
500 (t
501 (when last-bits
502 (setf (cdr (last (third last-bits))) (list t))
503 (setf bits 0 last-bits nil))
504 (push `(setf ,name (amqp:field ,type)) forms)))))
505 arguments)
506 (when last-bits
507 (setf (cdr (last (third last-bits))) (list t))
508 (setf bits 0 last-bits nil))
509 (nreverse forms)))
510 (apply op class method
511 ,@(apply #'nconc
512 (mapcar #'(lambda (sd)
513 (destructuring-bind (name &key (initarg (intern (string name) :keyword))
514 &allow-other-keys) sd
515 (unless (search "reserved" (string name) :test #'char-equal)
516 `(,initarg ,name))))
517 arguments))
518 args)))
519
520
521 ;; encode and send method application to server
522 ,(let ((sender (cons-symbol :amqp :send- amqp:method-name)))
523 `(progn
524 (eval-when (:compile-toplevel :load-toplevel :execute)
525 (export ',sender :amqp))
526 (defmethod ,sender ((class ,class) &rest args)
527 (declare (dynamic-extent args))
528 ;; must use the generic name, to permit caching
529 (apply #'send-method ',amqp:method-name class args))))
530
531
532 ;; encoding
533
534 (defmethod call-with-encoded-arguments (op (class ,class) (id (eql ,method-code)) &rest args)
535 (declare (dynamic-extent args))
536 (apply #',encoded-operator op class (amqp:ensure-method class ',amqp::method-name) args))
537
538 (defmethod call-with-encoded-arguments (op (class ,class) (name (eql ',amqp:method-name)) &rest args)
539 (declare (dynamic-extent args))
540 (apply #',encoded-operator op class (amqp:ensure-method class ',amqp::method-name) args))
541
542 (defmethod call-with-encoded-arguments (op (class ,class) (method ,class.method-name) &rest args)
543 (declare (dynamic-extent args))
544 (apply #',encoded-operator op class method args))
545
546 (defun ,encoded-operator (op class method &key ,@(mapcar #'(lambda (sd)
547 (destructuring-bind (name &key initform &allow-other-keys) sd
548 (if (search "reserved" (string name) :test #'char-equal)
549 `(,name ,initform ,(cons-symbol (symbol-package name) name :-s))
550 `(,name (,(cons-symbol :amqp class "-" name) class)))
551 #+(or )
552 (if (search "reserved" (string name) :test #'char-equal)
553 `(,name (slot-value class ',name) ,(cons-symbol (symbol-package name) name :-s))
554 `(,name (slot-value class ',name)))))
555 arguments))
556 ;; generate an form to encode the argument fields into the buffer.
557 ;; arguments are defaulted to the class instance's fiedl values
558 ;; bit fields are combined when contiguous
559 ,@(let ((reserved-names (remove nil (mapcar #'(lambda (sd)
560 (destructuring-bind (name &key &allow-other-keys) sd
561 (when (search "reserved" (string name) :test #'char-equal)
562 (list name (cons-symbol (symbol-package name) name :-s)))))
563 arguments))))
564 (loop for (var var-s) in reserved-names
565 collect `(when ,var-s
566 (error ,(format nil "~s is reserved and may not be specified." var)))))
567 (amqp:log :debug class "encoding: ~a . (~@{~s~^ ~})"
568 ',class.method-name
569 ,@(reduce #'append (mapcar #'(lambda (sd)
570 (destructuring-bind (name &key &allow-other-keys) sd
571 (unless (search "reserved" (string name) :test #'char-equal)
572 `(,(cons-symbol :keyword name) ,name))))
573 arguments)))
574 (let* ((,length-var 0)
575 (,frame-var (claim-output-frame class))
576 (,buffer-var (frame-data ,frame-var)))
577 (declare (ignorable ,buffer-var))
578 (setf ,length-var
579 (with-argument-encoders (,buffer-var :start (method-argument-offset method))
580 ,@(let ((bits 0) (forms nil) (last-bit nil))
581 (mapcar #'(lambda (sd)
582 (destructuring-bind (name &key type &allow-other-keys) sd
583 (cond ((or (eq type 'amqp:bit)
584 (get type 'amqp:bit))
585 (setf last-bit (list 'amqp:bit name bits))
586 (push last-bit forms)
587 (incf bits))
588 (t
589 (when last-bit
590 (setf (cdr (last last-bit)) (list t))
591 (setf bits 0 last-bit nil))
592 (push `(amqp:field ,name ,type) forms)))))
593 arguments)
594 (when last-bit (setf (cdr (last last-bit)) (list t))
595 (setf bits 0 last-bit nil))
596 (nreverse forms))))
597 (setf-frame-type-class-name 'amqp:method ,frame-var)
598 (setf-frame-channel-number (channel-number class) ,frame-var)
599 (setf-frame-track-number (channel-track class) ,frame-var)
600 (setf-frame-size ,length-var ,frame-var)
601 (setf-frame-class-code (amqp:class-id class) ,frame-var)
602 (setf-frame-method-code ,method-code ,frame-var)
603 (funcall op ,frame-var class method)))
604
605 )))
606
607 #+mcl
608 ;;; 20100214: sbcl-1.0.35 decided today, that this passage shouldn't modify the "standard pprint dispatch table"
609 ;;; ok. hmmm. as the purpose of this is to print them reasonably for top-level debugging, which happens
610 ;;; in mcl, that's the way it is.
611 (progn
612 (defun pprint-def-amqp-method (xp list &rest args)
613 (declare (ignore args))
614 (funcall (formatter "~:<~1I~W~^ ~@_~W~^ ~@_~:/pprint-fill/~^ ~@:_~:/pprint-fill/~^ ~@:_(~{(~{~s~@{~%~3t~s ~s~}~})~^~%~2t~})~^~@{ ~_~W~^~}~:>")
615 xp list))
616
617 (set-pprint-dispatch '(cons (member def-amqp-class)) (pprint-dispatch '(defclass) nil))
618 (set-pprint-dispatch '(cons (member def-amqp-method)) 'pprint-def-amqp-method))
619
620
621 (defmacro def-amqp-command (name lambda-list &rest options)
622 "Define the generic class and operator for an amqp method.
623
624 NAME : symbol : The abstract protocol method name. Each version specializes it
625 to implement the specific codecs and behaviour. It serves to define an
626 amqp:method specialization and a generic function.
627 LAMBDA-LIST : list : The lambda specifies generic function arguments. The
628 initial, required argument serves to specialze the method's class. The
629 remainder, keyword arguments, comprise the union of the fields from all
630 versions' methods.
631
632 The operator implements the protocol behaviour for a class to perform a
633 method. When applied to an input command stream, the static definition may
634 be combined with others, as a sequence of filters. In those cases, processing
635 continues until some operator returns a true value.
636
637 NB. As this macro constructs and exports the operator names on-the-fly, any cross-references -
638 send-*, in particular must be coded as internal symbols for the first compilation to succeed."
639
640 (let* ((class-var (first lambda-list))
641 (qualified-lambda-list (cons 'channel lambda-list))
642 (response nil)
643 (response-op nil)
644 (qualified-response nil)
645 (qualified-response-op nil)
646 (request nil)
647 (request-op nil)
648 (qualified-request nil)
649 (qualified-request-op nil)
650 (send nil)
651 (send-op nil)
652 (doc nil)
653 (exports ()))
654
655 ;; collect the operator names, based on the clauses present
656 ;; if there is a respose definition, ensure a send.
657 (dolist (option options)
658 (destructuring-bind (keyword . option-value) option
659 (case keyword
660 (:documentation
661 (setf doc option))
662 (:send
663 (setf send option-value
664 send-op (or send-op (cons-symbol :amqp :send- name))))
665 (:request
666 (setf request option-value
667 request-op (cons-symbol :amqp :request- name)
668 qualified-request-op (cons-symbol :amqp.i :channel- request-op)
669 send-op (or send-op (cons-symbol :amqp :send- name))))
670 (:response
671 (setf response option-value
672 response-op (cons-symbol :amqp :respond-to- name)
673 qualified-response-op (cons-symbol :amqp.i :channel- response-op)))
674 (t
675 (error "Option not permitted in command definition: ~s, ~s."
676 keyword name)))))
677
678 (when send-op
679 (unless send
680 (setf send `((:method (,class-var &rest args)
681 (declare (dynamic-extent args))
682 (apply #'send-method ',name ,class-var args)))))
683 (unless (assoc :documentation send)
684 (push `(:documentation ,(format nil "A convenience send operator for ~a." name))
685 send)))
686
687 (when request-op
688 (unless (assoc :documentation request)
689 (push `(:documentation ,(format nil "The base protocol request operator for ~a." name))
690 request))
691 (setf qualified-request
692 (list* (first request) ; the documentation
693 `(:method :before ((channel t) (class t) &rest args)
694 "A before method logs the request-to-be and updates the class instance."
695 (declare (dynamic-extent args))
696 (amqp:log* ,request-op class args))
697 (mapcar #'(lambda (method)
698 (destructuring-bind (keyword parameters &rest body) method
699 `(,keyword ((amqp:channel amqp:channel) ,@parameters)
700 ,@body)))
701 (rest request)))))
702
703 (when response-op
704 (unless (assoc :documentation response)
705 (push `(:documentation ,(format nil "The base protocol response operator for ~a." name))
706 response))
707 (setf qualified-response
708 (list* (first response)
709 `(:method :before ((channel t) (class t) &rest args)
710 "A before method logs the response-to-be and updates the class instance."
711 (declare (dynamic-extent args))
712 (amqp:log* ,response-op class args))
713 (mapcar #'(lambda (method)
714 (destructuring-bind (keyword parameters &rest body) method
715 `(,keyword ((amqp:channel amqp:channel) ,@parameters)
716 ,@body)))
717 (rest response)))))
718
719 (setf exports (remove nil (list name send-op response-op request-op)))
720 (export exports :amqp)
721 `(progn (defclass ,name (amqp:method)
722 ((name :initform ',name :allocation :class)
723 (request-function :initform ',qualified-request-op :allocation :class)
724 (header :initform nil :allocation :class)
725 (data :initform nil :allocation :class))
726 ,@(when doc (list doc)))
727 (eval-when (:compile-toplevel :load-toplevel :execute)
728 (export ',exports :amqp))
729 ,@(when send-op
730 `((defgeneric ,send-op ,lambda-list
731 ,@(let ((rest (member '&rest lambda-list)))
732 (when rest `((declare (dynamic-extent ,(second rest))))))
733 ,@send)))
734 ,@(when response-op
735 `((defgeneric ,qualified-response-op ,qualified-lambda-list
736 ,@(let ((rest (member '&rest qualified-lambda-list)))
737 (when rest `((declare (dynamic-extent ,(second rest))))))
738 ,@qualified-response)
739
740 (defun ,response-op (class &rest args)
741 (declare (dynamic-extent args))
742 (apply #',qualified-response-op (object-channel class) class args))))
743 ,@(when request-op
744 `((defgeneric ,qualified-request-op ,qualified-lambda-list
745 ,@(let ((rest (member '&rest qualified-lambda-list)))
746 (when rest `((declare (dynamic-extent ,(second rest))))))
747 ,@qualified-request)
748 (defun ,request-op (class &rest args)
749 (declare (dynamic-extent args))
750 (apply #',qualified-request-op (object-channel class) class args))
751 ;; this claims the simple name for the request operator
752 ;; note that the approach precludes the simple constructor
753 (defgeneric ,name (class &rest args)
754 (declare (dynamic-extent args))
755 (:method ((object amqp:object) &rest args)
756 (declare (dynamic-extent args))
757 (apply ',request-op object args))))))))

  ViewVC Help
Powered by ViewVC 1.1.5