Mercurial > hg > xemacs-beta

changeset 5070:b0f4adffca7d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
fix so that CL docstrings (with &key, etc.) handled properly -------------------- ChangeLog entries follow: -------------------- lisp/ChangeLog addition: 2010-02-23 Ben Wing <ben@xemacs.org> * autoload.el: * autoload.el (make-autoload): * cl-macs.el (cl-function-arglist): * cl-macs.el (cl-transform-lambda): Don't add argument list with the tag "Common Lisp lambda list:"; instead add in "standard" form using "arguments:" and omitting the function name. Add an arg to `cl-function-arglist' to omit the name and use it in autoload.el instead of just hacking it off. * help.el: * help.el (function-arglist): * help.el (function-documentation-1): New. Extract out common code to recognize and/or strip the arglist from documentation into `function-documentation-1'. Use in `function-arglist' and `function-documentation'. Modify `function-arglist' so it looks for the `arguments: ' stuff in all doc strings, not just subrs/autoloads, so that CL functions get recognized properly. Change the regexp used to match "arguments: " specs to allow nested parens inside the arg list (happens when you have a default value specified in a CL arglist).
author Ben Wing <ben@xemacs.org>
date Tue, 23 Feb 2010 01:12:13 -0600
parents 14f0dd1fabdb
children f28a4e9f0133
files lisp/ChangeLog lisp/autoload.el lisp/cl-macs.el lisp/help.el
diffstat 4 files changed, 77 insertions(+), 47 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Mon Feb 22 22:04:55 2010 -0600
+++ b/lisp/ChangeLog	Tue Feb 23 01:12:13 2010 -0600
@@ -1,3 +1,26 @@
+2010-02-23  Ben Wing  <ben@xemacs.org>
+
+	* autoload.el:
+	* autoload.el (make-autoload):
+	* cl-macs.el (cl-function-arglist):
+	* cl-macs.el (cl-transform-lambda):
+	Don't add argument list with the tag "Common Lisp lambda list:";
+	instead add in "standard" form using "arguments:" and omitting the
+	function name.  Add an arg to `cl-function-arglist' to omit the
+	name and use it in autoload.el instead of just hacking it off.
+	
+	* help.el:
+	* help.el (function-arglist):
+	* help.el (function-documentation-1): New.
+	Extract out common code to recognize and/or strip the arglist from
+	documentation into `function-documentation-1'.  Use in
+	`function-arglist' and `function-documentation'.  Modify
+	`function-arglist' so it looks for the `arguments: ' stuff in all
+	doc strings, not just subrs/autoloads, so that CL functions get
+	recognized properly.  Change the regexp used to match "arguments: "
+	specs to allow nested parens inside the arg list (happens when you
+	have a default value specified in a CL arglist).
+
 2010-02-22  Ben Wing  <ben@xemacs.org>
 
 	* test-harness.el:
--- a/lisp/autoload.el	Mon Feb 22 22:04:55 2010 -0600
+++ b/lisp/autoload.el	Tue Feb 23 01:12:13 2010 -0600
@@ -2,7 +2,7 @@
 
 ;; Copyright (C) 1991-1994, 1997, 2003 Free Software Foundation, Inc.
 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
-;; Copyright (C) 1996, 2000, 2002, 2003, 2004 Ben Wing.
+;; Copyright (C) 1996, 2000, 2002, 2003, 2004, 2010 Ben Wing.
 
 ;; Original Author: Roland McGrath <roland@gnu.ai.mit.edu>
 ;; Heavily Modified: XEmacs Maintainers
@@ -290,10 +290,8 @@
 		  (placeholder (eval-when-compile (gensym))))
 	      (setq doc (concat (or doc "")
 				"\n\narguments: "
-				(replace-in-string
-				 (cl-function-arglist placeholder arglist)
-				 (format "^(%s ?" placeholder)
-				 "(") "\n"))))
+				(cl-function-arglist placeholder arglist t)
+				"\n"))))
 	;; `define-generic-mode' quotes the name, so take care of that
 	(list 'autoload (if (listp name) name (list 'quote name)) file doc
 	      (or (and (memq car '(define-skeleton define-derived-mode
--- a/lisp/cl-macs.el	Mon Feb 22 22:04:55 2010 -0600
+++ b/lisp/cl-macs.el	Tue Feb 23 01:12:13 2010 -0600
@@ -299,29 +299,33 @@
 
 ;; npak@ispras.ru
 ;;;###autoload
-(defun cl-function-arglist (name arglist)
+(defun cl-function-arglist (name arglist &optional omit-name)
   "Returns string with printed representation of arguments list.
 Supports Common Lisp lambda lists."
+  ;; #### I would just change this so that OMIT-NAME is always true and
+  ;; eliminate the argument, but this function is autoloaded, which means
+  ;; someone might be using it somewhere.
   (if (not (or (listp arglist) (symbolp arglist)))
       "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")))))
+	   (let ((args (cond ((null arglist) nil)
+			     ((listp arglist) (cl-upcase-arg arglist))
+			     ((symbolp arglist)
+			      (cl-upcase-arg (list '&rest arglist)))
+			     (t (wrong-type-argument 'listp arglist)))))
+	     (if omit-name args
+	       (cons (if (eq name 'cl-none) 'lambda name) args))))
+	(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))
+         (complex-arglist (cl-function-arglist bind-block args t))
          (doc ""))
     (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
       (push (pop body) header))
@@ -348,12 +352,12 @@
     ;; 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))
+                   (cl-function-arglist bind-block simple-args t))
       (and (stringp (car header)) (setq doc (pop header)))
-      (push (concat doc
-                    "\n\nCommon Lisp lambda list:\n" 
-                    "  " complex-arglist "\n\n")
-	  header))
+      ;; Stick the arguments onto the end of the doc string in a way that
+      ;; will be recognized specially by `function-arglist'.
+      (push (concat doc "\n\narguments: " complex-arglist "\n")
+	    header))
     (if (null args)
 	(list* nil simple-args (nconc header body))
       (if (memq '&optional simple-args) (push '&optional args))
--- a/lisp/help.el	Mon Feb 22 22:04:55 2010 -0600
+++ b/lisp/help.el	Tue Feb 23 01:12:13 2010 -0600
@@ -1,7 +1,7 @@
 ;; help.el --- help commands for XEmacs.
 
 ;; Copyright (C) 1985, 1986, 1992-4, 1997 Free Software Foundation, Inc.
-;; Copyright (C) 2001, 2002, 2003 Ben Wing.
+;; Copyright (C) 2001, 2002, 2003, 2010 Ben Wing.
 
 ;; Maintainer: FSF
 ;; Keywords: help, internal, dumped
@@ -1182,27 +1182,21 @@
 	 (fndef (if (eq (car-safe fnc) 'macro)
 		    (cdr fnc)
 		  fnc))
+	 (args (cdr (function-documentation-1 function t)))
 	 (arglist
-	  (cond ((compiled-function-p fndef)
-		 (compiled-function-arglist fndef))
-		((eq (car-safe fndef) 'lambda)
-		 (nth 1 fndef))
-		((or (subrp fndef) (eq 'autoload (car-safe fndef)))
-		 (let* ((doc (documentation function))
-			(args (and doc
-				   (string-match
-				    "[\n\t ]*\narguments: ?(\\([^)]*\\))\n?\\'"
-				    doc)
-				   (match-string 1 doc)))
-                        (args (and args (replace-in-string args
-                                                           "[ ]*\\\\\n[ \t]*"
-                                                           " " t))))
-		   ;; If there are no arguments documented for the
-		   ;; subr, rather don't print anything.
-		   (cond ((null args) t)
-			 ((equal args "") nil)
-			 (args))))
-		(t t)))
+	  (or args
+	      (cond ((compiled-function-p fndef)
+		     (compiled-function-arglist fndef))
+		    ((eq (car-safe fndef) 'lambda)
+		     (nth 1 fndef))
+		    ((or (subrp fndef) (eq 'autoload (car-safe fndef)))
+		 
+		     ;; If there are no arguments documented for the
+		     ;; subr, rather don't print anything.
+		     (cond ((null args) t)
+			   ((equal args "") nil)
+			   (args)))
+		    (t t))))
          (print-gensym nil))
     (cond ((listp arglist)
 	   (prin1-to-string
@@ -1217,20 +1211,31 @@
 	  ((stringp arglist)
 	   (format "(%s %s)" function arglist)))))
 
-(defun function-documentation (function &optional strip-arglist)
-  "Return a string giving the documentation for FUNCTION, if any.
-If the optional argument STRIP-ARGLIST is non-nil, remove the arglist
-part of the documentation of internal subroutines."
+;; If STRIP-ARGLIST is true, return a cons (DOC . ARGS) of the documentation
+;; with any embedded arglist stripped out, and the arglist that was stripped
+;; out.  If STIRP-ARGLIST is false, the cons will be (FULL-DOC . nil),
+;; where FULL-DOC is the full documentation without the embedded arglist
+;; stripped out.
+(defun function-documentation-1 (function &optional strip-arglist)
   (let ((doc (condition-case nil
 		 (or (documentation function)
 		     (gettext "not documented"))
 	       (void-function "(alias for undefined function)")
-	       (error "(unexpected error from `documention')"))))
+	       (error "(unexpected error from `documentation')")))
+	args)
     (when (and strip-arglist
-               (string-match "[\n\t ]*\narguments: ?(\\([^)]*\\))\n?\\'" doc))
+               (string-match "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" doc))
+      (setq args (match-string 1 doc))
       (setq doc (substring doc 0 (match-beginning 0)))
+      (and args (setq args (replace-in-string args "[ ]*\\\\\n[ \t]*" " " t)))
       (and (zerop (length doc)) (setq doc (gettext "not documented"))))
-    doc))
+    (cons doc args)))
+
+(defun function-documentation (function &optional strip-arglist)
+  "Return a string giving the documentation for FUNCTION, if any.
+If the optional argument STRIP-ARGLIST is non-nil, remove the arglist
+part of the documentation of internal subroutines, CL lambda forms, etc."
+  (car (function-documentation-1 function strip-arglist)))
 
 ;; replacement for `princ' that puts the text in the specified face,
 ;; if possible