Mercurial > hg > xemacs-beta

comparison lisp/help.el @ 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 d6368048cd8c
children f28a4e9f0133
comparison
equal deleted inserted replaced
5069:14f0dd1fabdb 5070:b0f4adffca7d
1 ;; help.el --- help commands for XEmacs. 1 ;; help.el --- help commands for XEmacs.
2 2
3 ;; Copyright (C) 1985, 1986, 1992-4, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1985, 1986, 1992-4, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 2001, 2002, 2003 Ben Wing. 4 ;; Copyright (C) 2001, 2002, 2003, 2010 Ben Wing.
5 5
6 ;; Maintainer: FSF 6 ;; Maintainer: FSF
7 ;; Keywords: help, internal, dumped 7 ;; Keywords: help, internal, dumped
8 8
9 ;; This file is part of XEmacs. 9 ;; This file is part of XEmacs.
1180 arguments in the standard Lisp style." 1180 arguments in the standard Lisp style."
1181 (let* ((fnc (indirect-function function)) 1181 (let* ((fnc (indirect-function function))
1182 (fndef (if (eq (car-safe fnc) 'macro) 1182 (fndef (if (eq (car-safe fnc) 'macro)
1183 (cdr fnc) 1183 (cdr fnc)
1184 fnc)) 1184 fnc))
1185 (args (cdr (function-documentation-1 function t)))
1185 (arglist 1186 (arglist
1186 (cond ((compiled-function-p fndef) 1187 (or args
1187 (compiled-function-arglist fndef)) 1188 (cond ((compiled-function-p fndef)
1188 ((eq (car-safe fndef) 'lambda) 1189 (compiled-function-arglist fndef))
1189 (nth 1 fndef)) 1190 ((eq (car-safe fndef) 'lambda)
1190 ((or (subrp fndef) (eq 'autoload (car-safe fndef))) 1191 (nth 1 fndef))
1191 (let* ((doc (documentation function)) 1192 ((or (subrp fndef) (eq 'autoload (car-safe fndef)))
1192 (args (and doc 1193
1193 (string-match 1194 ;; If there are no arguments documented for the
1194 "[\n\t ]*\narguments: ?(\\([^)]*\\))\n?\\'" 1195 ;; subr, rather don't print anything.
1195 doc) 1196 (cond ((null args) t)
1196 (match-string 1 doc))) 1197 ((equal args "") nil)
1197 (args (and args (replace-in-string args 1198 (args)))
1198 "[ ]*\\\\\n[ \t]*" 1199 (t t))))
1199 " " t))))
1200 ;; If there are no arguments documented for the
1201 ;; subr, rather don't print anything.
1202 (cond ((null args) t)
1203 ((equal args "") nil)
1204 (args))))
1205 (t t)))
1206 (print-gensym nil)) 1200 (print-gensym nil))
1207 (cond ((listp arglist) 1201 (cond ((listp arglist)
1208 (prin1-to-string 1202 (prin1-to-string
1209 (cons function (loop 1203 (cons function (loop
1210 for arg in arglist 1204 for arg in arglist
1215 1209
1216 t)) 1210 t))
1217 ((stringp arglist) 1211 ((stringp arglist)
1218 (format "(%s %s)" function arglist))))) 1212 (format "(%s %s)" function arglist)))))
1219 1213
1220 (defun function-documentation (function &optional strip-arglist) 1214 ;; If STRIP-ARGLIST is true, return a cons (DOC . ARGS) of the documentation
1221 "Return a string giving the documentation for FUNCTION, if any. 1215 ;; with any embedded arglist stripped out, and the arglist that was stripped
1222 If the optional argument STRIP-ARGLIST is non-nil, remove the arglist 1216 ;; out. If STIRP-ARGLIST is false, the cons will be (FULL-DOC . nil),
1223 part of the documentation of internal subroutines." 1217 ;; where FULL-DOC is the full documentation without the embedded arglist
1218 ;; stripped out.
1219 (defun function-documentation-1 (function &optional strip-arglist)
1224 (let ((doc (condition-case nil 1220 (let ((doc (condition-case nil
1225 (or (documentation function) 1221 (or (documentation function)
1226 (gettext "not documented")) 1222 (gettext "not documented"))
1227 (void-function "(alias for undefined function)") 1223 (void-function "(alias for undefined function)")
1228 (error "(unexpected error from `documention')")))) 1224 (error "(unexpected error from `documentation')")))
1225 args)
1229 (when (and strip-arglist 1226 (when (and strip-arglist
1230 (string-match "[\n\t ]*\narguments: ?(\\([^)]*\\))\n?\\'" doc)) 1227 (string-match "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" doc))
1228 (setq args (match-string 1 doc))
1231 (setq doc (substring doc 0 (match-beginning 0))) 1229 (setq doc (substring doc 0 (match-beginning 0)))
1230 (and args (setq args (replace-in-string args "[ ]*\\\\\n[ \t]*" " " t)))
1232 (and (zerop (length doc)) (setq doc (gettext "not documented")))) 1231 (and (zerop (length doc)) (setq doc (gettext "not documented"))))
1233 doc)) 1232 (cons doc args)))
1233
1234 (defun function-documentation (function &optional strip-arglist)
1235 "Return a string giving the documentation for FUNCTION, if any.
1236 If the optional argument STRIP-ARGLIST is non-nil, remove the arglist
1237 part of the documentation of internal subroutines, CL lambda forms, etc."
1238 (car (function-documentation-1 function strip-arglist)))
1234 1239
1235 ;; replacement for `princ' that puts the text in the specified face, 1240 ;; replacement for `princ' that puts the text in the specified face,
1236 ;; if possible 1241 ;; if possible
1237 (defun Help-princ-face (object face) 1242 (defun Help-princ-face (object face)
1238 (cond ((bufferp standard-output) 1243 (cond ((bufferp standard-output)