--- a/lisp/cl-macs.el	Mon Aug 13 11:39:21 2007 +0200
+++ b/lisp/cl-macs.el	Mon Aug 13 11:40:21 2007 +0200
@@ -150,11 +150,41 @@
 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
 
+;; npak@ispras.ru
+(defun cl-upcase-arg (arg)
+  ;; Changes all non-keyword sysmbols in `arg' to symbols
+  ;; with name in upper case.
+  ;; arg is either symbol or list of symbols or lists
+  (cond ((symbolp arg)
+         (if (memq arg lambda-list-keywords)
+             ;; Do not upcase &optional, &key etc.
+             arg
+           (intern (upcase (symbol-name arg)))))
+        ((listp arg)
+         (mapcar 'cl-upcase-arg arg))))
+
+;; npak@ispras.ru
+(defun cl-function-arglist (function agrlist)
+  "Returns string with printed representation of arguments list.
+Supports Common Lisp lambda lists."
+  (prin1-to-string
+   (cons function (cl-upcase-arg agrlist))))
+
 (defun cl-transform-lambda (form bind-block)
   (let* ((args (car form)) (body (cdr form))
 	 (bind-defs nil) (bind-enquote nil)
 	 (bind-inits nil) (bind-lets nil) (bind-forms nil)
-	 (header nil) (simple-args nil))
+	 (header nil) (simple-args nil)
+         (doc ""))
+    ;; Add CL lambda list to documentation. npak@ispras.ru
+    (if (stringp (car body))
+        (setq doc (cl-pop body)))
+    (cl-push (concat "\nCommon Lisp lambda list:\n" 
+                     "  " (cl-function-arglist bind-block args) 
+                     "\n\n"
+                     doc)
+             header)
+
     (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
       (cl-push (cl-pop body) header))
     (setq args (if (listp args) (copy-list args) (list '&rest args)))