[bknr-cvs] r2523 - branches/trunk-reorg/bknr/datastore/src/data

[hhubner at common-lisp.net]

Author: hhubner
Date: Sun Feb 17 16:27:25 2008
New Revision: 2523

Modified:
   branches/trunk-reorg/bknr/datastore/src/data/txn.lisp
Log:
Improve DEFTRANSACTION:

Define wrapper function with docstring, if supplied.  Use lambda list
specified in DEFTRANSACTION for the wrapper function.  Handle
docstrings correctly.  Insert IN-TRANSACTION-P check after
declarations and docstring in generated function.


Modified: branches/trunk-reorg/bknr/datastore/src/data/txn.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/data/txn.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/data/txn.lisp	Sun Feb 17 16:27:25 2008
@@ -240,26 +240,90 @@
 (defmethod execute-transaction ((executor transaction) transaction)
   (execute-unlogged transaction))
 
+(defun find-doc (body)
+  "Given a function definition BODY, extract the docstring, if any.
+Skips over any declarations that precede the docstring.  See also CLHS
+3.4.11"
+  (do ((body body (cdr body)))
+      ((or (not (listp (car body)))
+           (not (eq 'declare (caar body))))
+       (when (and (stringp (car body))
+                  (cdr body))
+         (car body)))))
+
+(defun insert-after-declarations (body forms-to-insert)
+  "Given a function definition body, insert FORMS-TO-INSERT after all
+declarations and documentation in BODY."
+  (loop for rest on body
+        for form = (car rest)
+        with decls
+        with doc
+        while (or (and (listp form) (eq 'declare (car form)))
+                  (and (not doc) (cdr rest) (stringp form)))
+        when (stringp form)
+        do (setf doc form)
+        do (push form decls)
+        finally (return-from insert-after-declarations (append (nreverse decls) forms-to-insert rest))))
+
+(defun make-args (args)
+  "Parse the lambda list ARGS, returning a list that contains the
+arguments in the lambda list prepared so that the list can be applied
+to a function accepting that lambda list.
+
+For example:
+
+ (MAKE-ARGS '(A B &OPTIONAL C &REST D &KEY E F)) => (A B C :E E :F F)
+
+It is used to forward arguments to a transaction wrapper generated by
+DEFTRANSACTION to the actual transaction so that the wrapper function
+can be declared with the lambda list of the transaction function
+itself,"
+  (do ((args args (cdr args))
+       result
+       in-keywords-p)
+      ((not args)
+       (nreverse result))
+    (let ((arg (funcall (if (listp (car args)) #'caar #'car) args)))
+      (cond
+        ((eql #\& (aref (symbol-name arg) 0))
+         (case arg
+           (&optional)
+           (&rest (setf args (cdr args))) ; skip argument, too
+           (&key (setf in-keywords-p t))
+           (otherwise (error "unsupported lambda list option ~A in DEFTRANSACTION" arg))))
+        (t
+         (when in-keywords-p
+           (push (intern (symbol-name arg) :keyword) result))
+         (push arg result))))))
+
 (defmacro deftransaction (name (&rest args) &rest body)
-  "Define a transaction function tx-NAME and a function NAME executing tx-NAME in the context
-of the current store. The arguments to NAME will be serialized to the transaction-log, and
-should must be supported by the binary encoder. tx-NAME will be called during a roll-forward."
-  (dolist (arg args)
-    (when (listp arg)
-      (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name)))
-  (let ((args-name (gensym))
-	(tx-name (intern (string-upcase (concatenate 'string "tx-" (symbol-name name)))
-			 (symbol-package name))))
-    `(progn
-      (defun ,tx-name ,args
-	(unless (in-transaction-p)
-	  (error 'not-in-transaction))
-	, at body)
-      (defun ,name (&rest ,args-name)
-	(execute (make-instance 'transaction
-				:function-symbol ',tx-name
-				:timestamp (get-universal-time)
-				:args ,args-name))))))
+  "Define a transaction function tx-NAME and a function NAME executing
+tx-NAME in the context of the current store. The arguments to NAME
+will be serialized to the transaction-log, and should must be
+supported by the binary encoder. tx-NAME will be called during a
+roll-forward."
+  (let ((name name)
+        (args args)
+        (body body))
+    (dolist (arg args)
+      (when (listp arg)
+        (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name)))
+    (let ((tx-name (intern (format nil "TX-~A" name)
+                           (symbol-package name))))
+      `(progn
+        (defun ,tx-name ,args
+          ,@(insert-after-declarations body
+                                       '((unless (in-transaction-p)
+                                           (error 'not-in-transaction)))))
+        (defun ,name ,args
+          ,@(let ((doc (find-doc body)))
+                 (when doc (list (format nil "[Transaction function wrapper ~A invokes a store transaction]~%~A" name doc))))
+          ,@(let ((rest (member '&rest args)))
+                 (when rest `((declare (ignore ,(second rest))))))
+          (execute (make-instance 'transaction
+                                  :function-symbol ',tx-name
+                                  :timestamp (get-universal-time)
+                                  :args (list ,@(make-args args)))))))))
 
 (defmethod encode-object ((object transaction) stream)
   (%write-char #\T stream)