--- a/lisp/ChangeLog	Sun Sep 20 21:29:00 2009 +0100
+++ b/lisp/ChangeLog	Sun Sep 20 21:41:22 2009 +0100
@@ -1,3 +1,21 @@
+2009-09-20  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* help.el (function-arglist): 
+	Show the double-quotes in the sample output, correctly. 
+	Bind print-gensym to nil, now we're using uninterned symbols. 
+	Don't #'mapcar + #'intern to create uppercase symbols, use #'loop
+	and #'make-symbol instead.
+	* cl-macs.el (cl-upcase-arg): 
+	Don't intern the upcased symbols we're using for cosmetic reasons.
+	Trust #'true-list-p in #'cl-function-arglist to detect
+	circularity.
+	(cl-function-arglist): Bind print-gensym to nil, now we're
+	printing uninterned symbols and would prefer to avoid the gensym
+	syntax.
+	(cl-transform-lambda): Only add the Common Lisp lambda list:
+	argument information when that differs frmo the normal argument
+	information.
+
 2009-09-20  Aidan Kehoe  <kehoea@parhasard.net>
 
 	* mule/make-coding-system.el (make-coding-system): 

--- a/lisp/cl-macs.el	Sun Sep 20 21:29:00 2009 +0100
+++ b/lisp/cl-macs.el	Sun Sep 20 21:41:22 2009 +0100
@@ -275,7 +275,6 @@
 (defvar cl-macro-environment nil)
 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
-(defvar arglist-visited)
 
 ;; npak@ispras.ru
 (defun cl-upcase-arg (arg)
@@ -284,11 +283,10 @@
   ;; ARG is either symbol or list of symbols or lists
   (cond ((symbolp arg)
 	 ;; Do not upcase &optional, &key etc.
-	 (if (memq arg lambda-list-keywords) arg
-	   (intern (upcase (symbol-name arg)))))
+	 (if (memq arg lambda-list-keywords)
+             arg
+	   (make-symbol (upcase (symbol-name arg)))))
 	((listp arg)
-	 (if (memq arg arglist-visited) (error 'circular-list '(arg)))
-	 (push arg arglist-visited)
 	 (let ((arg (copy-list arg)) junk)
 	   ;; Clean the list
 	   (let ((p (last arg))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
@@ -305,34 +303,25 @@
 Supports Common Lisp lambda lists."
   (if (not (or (listp arglist) (symbolp arglist)))
       "Not available"
-    (setq arglist-visited nil)
-    (condition-case nil
-	(prin1-to-string
-	 (cons (if (eq name 'cl-none) 'lambda name)
-	       (cond ((null arglist) nil)
-		     ((listp arglist) (cl-upcase-arg arglist))
-		     ((symbolp arglist)
-		      (cl-upcase-arg (list '&rest arglist)))
-		     (t (wrong-type-argument 'listp arglist)))))
-      (t "Not available"))))
-
+    (check-argument-type #'true-list-p arglist)
+    (let ((print-gensym nil))
+      (condition-case nil
+          (prin1-to-string
+           (cons (if (eq name 'cl-none) 'lambda name)
+                 (cond ((null arglist) nil)
+                       ((listp arglist) (cl-upcase-arg arglist))
+                       ((symbolp arglist)
+                        (cl-upcase-arg (list '&rest arglist)))
+                       (t (wrong-type-argument 'listp arglist)))))
+      (t "Not available")))))
 
 (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)
+         (complex-arglist (cl-function-arglist bind-block args))
          (doc ""))
-    ;; Add CL lambda list to documentation. npak@ispras.ru
-    (if (and (stringp (car body))
-	     (cdr body))
-        (setq doc (pop body)))
-    (push (concat doc
-		  "\nCommon Lisp lambda list:\n" 
-		  "  " (cl-function-arglist bind-block args) 
-		  "\n\n")
-	  header)
-
     (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
       (push (pop body) header))
     (setq args (if (listp args) (copy-list args) (list '&rest args)))
@@ -353,19 +342,30 @@
       (push (pop args) simple-args))
     (or (eq bind-block 'cl-none)
 	(setq body (list (list* 'block bind-block body))))
+    (setq simple-args (nreverse simple-args)
+          header (nreverse header))
+    ;; Add CL lambda list to documentation, if the CL lambda list differs
+    ;; from the non-CL lambda list. npak@ispras.ru
+    (unless (equal complex-arglist
+                   (cl-function-arglist bind-block simple-args))
+      (and (stringp (car header)) (setq doc (pop header)))
+      (push (concat doc
+                    "\n\nCommon Lisp lambda list:\n" 
+                    "  " complex-arglist "\n\n")
+	  header))
     (if (null args)
-	(list* nil (nreverse simple-args) (nconc (nreverse header) body))
+	(list* nil simple-args (nconc header body))
       (if (memq '&optional simple-args) (push '&optional args))
       (cl-do-arglist args nil (- (length simple-args)
 				 (if (memq '&optional simple-args) 1 0)))
       (setq bind-lets (nreverse bind-lets))
       (list* (and bind-inits (list* 'eval-when '(compile load eval)
 				    (nreverse bind-inits)))
-	     (nconc (nreverse simple-args)
+	     (nconc simple-args
 		    (list '&rest (car (pop bind-lets))))
 	     ;; XEmacs change: we add usage information using Nickolay's
 	     ;; approach above
-	     (nconc (nreverse header)
+	     (nconc header
 		    (list (nconc (list 'let* bind-lets)
 				 (nreverse bind-forms) body)))))))
 

--- a/lisp/help.el	Sun Sep 20 21:29:00 2009 +0100
+++ b/lisp/help.el	Sun Sep 20 21:41:22 2009 +0100
@@ -1175,7 +1175,7 @@
 For example:
 
 	(function-arglist 'function-arglist)
-	=> (function-arglist FUNCTION)
+	=> \"(function-arglist FUNCTION)\"
 
 This function is used by `describe-function-1' to list function
 arguments in the standard Lisp style."
@@ -1203,14 +1203,17 @@
 		   (cond ((null args) t)
 			 ((equal args "") nil)
 			 (args))))
-		(t t))))
+		(t t)))
+         (print-gensym nil))
     (cond ((listp arglist)
 	   (prin1-to-string
-	    (cons function (mapcar (lambda (arg)
-				     (if (memq arg '(&optional &rest))
-					 arg
-				       (intern (upcase (symbol-name arg)))))
-				   arglist))
+	    (cons function (loop
+                             for arg in arglist
+                             collect (if (memq arg '(&optional &rest))
+                                         arg
+                                       (make-symbol (upcase (symbol-name
+                                                             arg))))))
+
 	    t))
 	  ((stringp arglist)
 	   (format "(%s %s)" function arglist)))))