Mercurial > hg > xemacs-beta

comparison lisp/help.el @ 464:5aa1854ad537 r21-2-47

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-47
author cvs
date Mon, 13 Aug 2007 11:45:51 +0200
parents 0784d089fdc9
children 7039e6323819
comparison
equal deleted inserted replaced
463:a158004111cd 464:5aa1854ad537
1073 (void-function "")))) 1073 (void-function ""))))
1074 (if (and strip-arglist 1074 (if (and strip-arglist
1075 (string-match "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" doc)) 1075 (string-match "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" doc))
1076 (setq doc (substring doc 0 (match-beginning 0)))) 1076 (setq doc (substring doc 0 (match-beginning 0))))
1077 doc)) 1077 doc))
1078 ; (let ((name-char "[-+a-zA-Z0-9_*]") (sym-char "[-+a-zA-Z0-9_:*]"))
1079 ; (list
1080 ; ;;
1081 ; ;; The symbol itself.
1082 ; (list (concat "\\`\\(" name-char "+\\)\\(:\\)?")
1083 ; '(1 (if (match-beginning 2)
1084 ; 'font-lock-function-name-face
1085 ; 'font-lock-variable-name-face)
1086 ; nil t))
1087 ; ;;
1088 ; ;; Words inside `' which tend to be symbol names.
1089 ; (list (concat "`\\(" sym-char sym-char "+\\)'")
1090 ; 1 '(prog1
1091 ; 'font-lock-reference-face
1092 ; (add-list-mode-item (match-beginning 1)
1093 ; (match-end 1)
1094 ; nil
1095 ; 'help-follow-reference))
1096 ; t)
1097 ; ;;
1098 ; ;; CLisp `:' keywords as references.
1099 ; (list (concat "\\<:" sym-char "+\\>") 0 'font-lock-reference-face t)))
1100 1078
1101 ;; replacement for `princ' that puts the text in the specified face, 1079 ;; replacement for `princ' that puts the text in the specified face,
1102 ;; if possible 1080 ;; if possible
1103 (defun Help-princ-face (object face) 1081 (defun Help-princ-face (object face)
1104 (cond ((bufferp standard-output) 1082 (cond ((bufferp standard-output)
1105 (let ((opoint (point standard-output))) 1083 (let ((opoint (point standard-output)))
1106 (princ object) 1084 (princ object)
1107 (put-nonduplicable-text-property opoint (point standard-output) 1085 (put-nonduplicable-text-property opoint (point standard-output)
1108 'face face standard-output))) 1086 'face face standard-output)))
1109 ((markerp standard-output) 1087 ((markerp standard-output)
1110 (let ((buf (marker-buffer standard-output)) 1088 (let ((buf (marker-buffer standard-output))
1111 (pos (marker-position standard-output))) 1089 (pos (marker-position standard-output)))
1112 (princ object) 1090 (princ object)
1113 (put-nonduplicable-text-property 1091 (put-nonduplicable-text-property
1114 pos (marker-position standard-output) 'face face buf))) 1092 pos (marker-position standard-output) 'face face buf)))
1115 (t princ object))) 1093 (t princ object)))
1116 1094
1117 ;; replacement for `prin1' that puts the text in the specified face, 1095 ;; replacement for `prin1' that puts the text in the specified face,
1118 ;; if possible 1096 ;; if possible
1119 (defun Help-prin1-face (object face) 1097 (defun Help-prin1-face (object face)
1120 (cond ((bufferp standard-output) 1098 (cond ((bufferp standard-output)
1121 (let ((opoint (point standard-output))) 1099 (let ((opoint (point standard-output)))
1122 (prin1 object) 1100 (prin1 object)
1123 (put-nonduplicable-text-property opoint (point standard-output) 1101 (put-nonduplicable-text-property opoint (point standard-output)
1124 'face face standard-output))) 1102 'face face standard-output)))
1125 ((markerp standard-output) 1103 ((markerp standard-output)
1126 (let ((buf (marker-buffer standard-output)) 1104 (let ((buf (marker-buffer standard-output))
1127 (pos (marker-position standard-output))) 1105 (pos (marker-position standard-output)))
1128 (prin1 object) 1106 (prin1 object)
1129 (put-nonduplicable-text-property 1107 (put-nonduplicable-text-property
1130 pos (marker-position standard-output) 'face face buf))) 1108 pos (marker-position standard-output) 'face face buf)))
1131 (t prin1 object))) 1109 (t prin1 object)))
1132 1110
1133 (defvar help-symbol-regexp 1111 (defvar help-symbol-regexp
1134 (let ((sym-char "[+a-zA-Z0-9_:*]") 1112 (let ((sym-char "[+a-zA-Z0-9_:*]")
1135 (sym-char-no-dash "[-+a-zA-Z0-9_:*]")) 1113 (sym-char-no-dash "[-+a-zA-Z0-9_:*]"))
1136 (concat "\\(" 1114 (concat "\\("
1183 ;; till end of file, and find documented functions and variables. 1161 ;; till end of file, and find documented functions and variables.
1184 ;; any such symbol found is tagged with an extent, that sets up these 1162 ;; any such symbol found is tagged with an extent, that sets up these
1185 ;; properties: 1163 ;; properties:
1186 ;; 1. mouse-face is 'highlight (so the extent gets highlighted on mouse over) 1164 ;; 1. mouse-face is 'highlight (so the extent gets highlighted on mouse over)
1187 ;; 2. help-symbol is the name of the symbol. 1165 ;; 2. help-symbol is the name of the symbol.
1188 ;; 3. face is 'font-lock-reference-face. 1166 ;; 3. face is 'hyper-apropos-hyperlink.
1189 ;; 4. context-menu is a list of context menu items, specific to whether 1167 ;; 4. context-menu is a list of context menu items, specific to whether
1190 ;; the symbol is a function, variable, or both. 1168 ;; the symbol is a function, variable, or both.
1191 ;; 5. activate-function will cause the function or variable to be described, 1169 ;; 5. activate-function will cause the function or variable to be described,
1192 ;; replacing the existing help contents. 1170 ;; replacing the existing help contents.
1193 (save-excursion 1171 (save-excursion
1205 (documentation sym t)))) 1183 (documentation sym t))))
1206 (when (or var fun) 1184 (when (or var fun)
1207 (let ((ex (make-extent b e))) 1185 (let ((ex (make-extent b e)))
1208 (set-extent-property ex 'mouse-face 'highlight) 1186 (set-extent-property ex 'mouse-face 'highlight)
1209 (set-extent-property ex 'help-symbol sym) 1187 (set-extent-property ex 'help-symbol sym)
1210 (set-extent-property ex 'face 'font-lock-reference-face) 1188 (set-extent-property ex 'face 'hyper-apropos-hyperlink)
1211 (set-extent-property 1189 (set-extent-property
1212 ex 'context-menu 1190 ex 'context-menu
1213 (cond ((and var fun) 1191 (cond ((and var fun)
1214 help-symbol-function-and-variable-context-menu) 1192 help-symbol-function-and-variable-context-menu)
1215 (var help-symbol-variable-context-menu) 1193 (var help-symbol-variable-context-menu)
1290 (princ (format " -- loaded from \"%s\"\n" file-name))) 1268 (princ (format " -- loaded from \"%s\"\n" file-name)))
1291 ;; (terpri) 1269 ;; (terpri)
1292 (if describe-function-show-arglist 1270 (if describe-function-show-arglist
1293 (let ((arglist (function-arglist function))) 1271 (let ((arglist (function-arglist function)))
1294 (when arglist 1272 (when arglist
1295 (Help-princ-face arglist 'font-lock-comment-face) 1273 (require 'hyper-apropos)
1274 (Help-princ-face arglist 'hyper-apropos-documentation)
1296 (terpri)))) 1275 (terpri))))
1297 (terpri) 1276 (terpri)
1298 (cond (kbd-macro-p 1277 (cond (kbd-macro-p
1299 (princ "These characters are executed:\n\n\t") 1278 (princ "These characters are executed:\n\n\t")
1300 (princ (key-description def)) 1279 (princ (key-description def))
1432 (let ((origvar variable) 1411 (let ((origvar variable)
1433 aliases) 1412 aliases)
1434 (let ((print-escape-newlines t)) 1413 (let ((print-escape-newlines t))
1435 (princ "`") 1414 (princ "`")
1436 ;; (Help-princ-face (symbol-name variable) 1415 ;; (Help-princ-face (symbol-name variable)
1437 ;; 'font-lock-variable-name-face) overkill 1416 ;; 'font-lock-variable-name-face) overkill
1438 (princ (symbol-name variable)) 1417 (princ (symbol-name variable))
1439 (princ "' is ") 1418 (princ "' is ")
1440 (while (variable-alias variable) 1419 (while (variable-alias variable)
1441 (let ((newvar (variable-alias variable))) 1420 (let ((newvar (variable-alias variable)))
1442 (if aliases 1421 (if aliases
1455 (princ ".\n") 1434 (princ ".\n")
1456 (let ((file-name (describe-symbol-find-file variable))) 1435 (let ((file-name (describe-symbol-find-file variable)))
1457 (if file-name 1436 (if file-name
1458 (princ (format " -- loaded from \"%s\"\n" file-name)))) 1437 (princ (format " -- loaded from \"%s\"\n" file-name))))
1459 (princ "\nValue: ") 1438 (princ "\nValue: ")
1460 (if (not (boundp variable)) 1439 (require 'hyper-apropos)
1461 (Help-princ-face "void\n" 'font-lock-comment-face) 1440 (if (not (boundp variable))
1462 (Help-prin1-face (symbol-value variable) 'font-lock-comment-face) 1441 (Help-princ-face "void\n" 'hyper-apropos-documentation)
1442 (Help-prin1-face (symbol-value variable)
1443 'hyper-apropos-documentation)
1463 (terpri)) 1444 (terpri))
1464 (terpri) 1445 (terpri)
1465 (cond ((local-variable-p variable (current-buffer)) 1446 (cond ((local-variable-p variable (current-buffer))
1466 (let* ((void (cons nil nil)) 1447 (let* ((void (cons nil nil))
1467 (def (condition-case nil 1448 (def (condition-case nil