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)) - ,@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)