Changeset 2523

Timestamp:

02/17/08 22:27:25 (9 months ago)

Author:

hhubner

Message:

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.

Files:

• branches/trunk-reorg/bknr/datastore/src/data/txn.lisp (modified) (1 diff)

branches/trunk-reorg/bknr/datastore/src/data/txn.lisp

@@ -241 +241 @@
-  (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)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-(defmethod encode-object ((object transaction) stream)