/[cmucl]/src/hemlock/doccoms.lisp
ViewVC logotype

Contents of /src/hemlock/doccoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.3: +0 -2 lines
Fix headed boilerplate.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.3 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8     "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/doccoms.lisp,v 1.4 1994/10/31 04:50:12 ram Rel $")
9     ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Hemlock Documentation and Help commands.
13     ;;; Written by Rob MacLachlan and Bill Chiles.
14     ;;;
15    
16     (in-package "HEMLOCK")
17    
18    
19    
20     ;;;; Help.
21    
22     (defcommand "Help" (p)
23     "Give helpful information.
24     This command dispatches to a number of other documentation commands,
25     on the basis of a character command."
26     "Prompt for a single character command to dispatch to another helping
27     function."
28     (declare (ignore p))
29     (command-case (:prompt "Doc (Help for Help): "
30     :help "Type a Help option to say what kind of help you want:")
31 ram 1.2 (#\a "List all commands, variables and attributes Apropos a keyword."
32 ram 1.1 (apropos-command nil))
33 ram 1.2 (#\d "Describe a command, given its name."
34 ram 1.1 (describe-command-command nil))
35 ram 1.2 (#\g "Generic describe, any Hemlock thing (e.g., variables, keys, attributes)."
36 ram 1.1 (generic-describe-command nil))
37 ram 1.2 (#\v "Describe variable and show its values."
38 ram 1.1 (describe-and-show-variable-command nil))
39 ram 1.2 (#\c "Describe the command bound to a Character."
40 ram 1.1 (describe-key-command nil))
41 ram 1.2 (#\l "List the last 60 characters typed."
42 ram 1.1 (what-lossage-command nil))
43 ram 1.2 (#\m "Describe a mode."
44 ram 1.1 (describe-mode-command nil))
45 ram 1.2 (#\p "Describe commands with mouse/pointer bindings."
46 ram 1.1 (describe-pointer-command nil))
47 ram 1.2 (#\w "Find out Where a command is bound."
48 ram 1.1 (where-is-command nil))
49 ram 1.2 (#\t "Describe a Lisp object."
50 ram 1.1 (editor-describe-command nil))
51 ram 1.2 ((#\q :no) "Quits, You don't really want help.")))
52 ram 1.1
53     (defcommand "Where Is" (p)
54     "Find what key a command is bound to.
55     Prompts for the command to look for, and says what environment it is
56     available in."
57     "List places where a command is bound."
58     (declare (ignore p))
59     (multiple-value-bind (nam cmd)
60     (prompt-for-keyword (list *command-names*)
61     :prompt "Command: "
62     :help "Name of command to look for.")
63     (let ((bindings (command-bindings cmd)))
64     (with-pop-up-display (s)
65     (cond
66     ((null bindings)
67     (format s "~S may only be invoked as an extended command.~%" nam))
68     (t
69     (format s "~S may be invoked in the following ways:~%" nam)
70     (print-command-bindings bindings s)))))))
71    
72    
73    
74     ;;;; Apropos.
75    
76     (defcommand "Apropos" (p)
77     "List things whose names contain a keyword."
78     "List things whose names contain a keyword."
79     (declare (ignore p))
80     (let* ((str (prompt-for-string
81     :prompt "Apropos keyword: "
82     :help
83     "String to look for in command, variable and attribute names."))
84     (coms (find-containing str *command-names*))
85     (vars (mapcar #'(lambda (table)
86     (let ((res (find-containing str table)))
87     (if res (cons table res))))
88     (current-variable-tables)))
89     (attr (find-containing str *character-attribute-names*)))
90     (if (or coms vars attr)
91     (apropos-command-output str coms vars attr)
92     (with-pop-up-display (s :height 1)
93     (format s "No command, attribute or variable name contains ~S."
94     str)))))
95    
96     (defun apropos-command-output (str coms vars attr)
97     (declare (list coms vars attr))
98     (with-pop-up-display (s)
99     (when coms
100     (format s "Commands with ~S in their names:~%" str)
101     (dolist (com coms)
102     (let ((obj (getstring com *command-names*)))
103     (write-string com s)
104     (write-string " " s)
105     (print-command-bindings (command-bindings obj) s)
106     (terpri s)
107     (print-short-doc (command-documentation obj) s))))
108     (when vars
109     (when coms (terpri s))
110     (format s "Variables with ~S in their names:~%" str)
111     (dolist (stuff vars)
112     (let ((table (car stuff)))
113     (dolist (var (cdr stuff))
114     (let ((obj (getstring var table)))
115     (write-string var s)
116     (write-string " " s)
117     (let ((*print-level* 2) (*print-length* 3))
118     (prin1 (variable-value obj) s))
119     (terpri s)
120     (print-short-doc (variable-documentation obj) s))))))
121     (when attr
122     (when (or coms vars) (terpri s))
123     (format s "Attributes with ~S in their names:~%" str)
124     (dolist (att attr)
125     (let ((obj (getstring att *character-attribute-names*)))
126     (write-line att s)
127     (print-short-doc (character-attribute-documentation obj) s))))))
128    
129     ;;; PRINT-SHORT-DOC takes doc, a function or string, and gets it out on stream.
130     ;;; If doc is a string, this only outputs up to the first newline. All output
131     ;;; is preceded by two spaces.
132     ;;;
133     (defun print-short-doc (doc stream)
134     (let ((str (typecase doc
135     (function (funcall doc :short))
136     (simple-string
137     (let ((nl (position #\newline (the simple-string doc))))
138     (subseq doc 0 (or nl (length doc)))))
139     (t
140     (error "Bad documentation: ~S" doc)))))
141     (write-string " " stream)
142     (write-line str stream)))
143    
144    
145    
146     ;;;; Describe command, key, pointer.
147    
148     (defcommand "Describe Command" (p)
149     "Describe a command.
150     Prompts for a command and then prints out it's full documentation."
151     "Print out the command documentation for a command which is prompted for."
152     (declare (ignore p))
153     (multiple-value-bind (nam com)
154     (prompt-for-keyword
155     (list *command-names*)
156     :prompt "Describe command: "
157     :help "Name of a command to document.")
158     (let ((bindings (command-bindings com)))
159     (with-pop-up-display (s)
160     (format s "Documentation for ~S:~% ~A~%"
161     nam (command-documentation com))
162     (cond ((not bindings)
163     (write-line
164     "This can only be invoked as an extended command." s))
165     (t
166     (write-line
167     "This can be invoked in the following ways:" s)
168     (write-string " " s)
169     (print-command-bindings bindings s)
170     (terpri s)))))))
171    
172     (defcommand "Describe Key" (p)
173     "Prompt for a sequence of characters. When the first character is typed that
174     terminates a key binding in the current context, describe the command bound
175     to it. When the first character is typed that no longer allows a correct
176 ram 1.2 key to be entered, tell the user that this sequence is not bound to
177     anything."
178     "Print out the command documentation for a key
179     which is prompted for."
180 ram 1.1 (declare (ignore p))
181     (let ((old-window (current-window)))
182     (unwind-protect
183     (progn
184     (setf (current-window) hi::*echo-area-window*)
185     (hi::display-prompt-nicely "Describe key: " nil)
186     (setf (fill-pointer hi::*prompt-key*) 0)
187     (loop
188 ram 1.2 (let ((key-event (get-key-event hi::*editor-input*)))
189     (vector-push-extend key-event hi::*prompt-key*)
190 ram 1.1 (let ((res (get-command hi::*prompt-key* :current)))
191 ram 1.2 (ext:print-pretty-key-event key-event *echo-area-stream*)
192     (write-char #\space *echo-area-stream*)
193 ram 1.1 (cond ((commandp res)
194     (with-pop-up-display (s)
195 ram 1.2 (print-pretty-key (copy-seq hi::*prompt-key*) s)
196 ram 1.1 (format s " is bound to ~S.~%" (command-name res))
197     (format s "Documentation for this command:~% ~A"
198     (command-documentation res)))
199     (return))
200     ((not (eq res :prefix))
201     (with-pop-up-display (s :height 1)
202 ram 1.2 (print-pretty-key (copy-seq hi::*prompt-key*) s)
203 ram 1.1 (write-string " is not bound to anything." s))
204     (return)))))))
205     (setf (current-window) old-window))))
206    
207     (defcommand "Describe Pointer" (p)
208     "Describe commands with any key binding that contains a \"mouse\" character
209     (modified or not). Does not describe the command \"Illegal\"."
210     "Describe commands with any key binding that contains a \"mouse\" character
211     (modified or not). Does not describe the command \"Illegal\"."
212     (declare (ignore p))
213     (let ((illegal-command (getstring "Illegal" *command-names*)))
214     (with-pop-up-display (s)
215     (dolist (cmd (get-mouse-commands))
216     (unless (eq cmd illegal-command)
217     (format s "Documentation for ~S:~% ~A~%"
218     (command-name cmd)
219     (command-documentation cmd))
220     (write-line
221     "This can be invoked in the following ways:" s)
222     (write-string " " s)
223     (print-command-bindings (command-bindings cmd) s)
224     (terpri s) (terpri s))))))
225    
226     (defun get-mouse-commands ()
227     (let ((result nil))
228     (do-strings (name cmd *command-names* result)
229     (declare (ignore name))
230     (dolist (b (command-bindings cmd))
231     (let ((key (car b)))
232     (declare (simple-vector key))
233     (when (dotimes (i (length key) nil)
234 ram 1.2 (when (member (ext:make-key-event (svref key i))
235     (list #k"Leftdown" #k"Leftup" #k"Middledown"
236     #k"Middleup" #k"Rightdown" #k"Rightup"))
237 ram 1.1 (push cmd result)
238     (return t)))
239     (return)))))))
240    
241    
242    
243     ;;;; Generic describe variable, command, key, attribute.
244    
245     (defvar *generic-describe-kinds*
246     (list (make-string-table :initial-contents
247     '(("Variable" . :variable)
248     ("Command" . :command)
249     ("Key" . :key)
250     ("Attribute" . :attribute)))))
251    
252     (defcommand "Generic Describe" (p)
253     "Describe some Hemlock thing.
254     First prompt for the kind of thing, then prompt for the thing to describe.
255     Currently supported kinds of things are variables, commands, keys and
256     character attributes."
257     "Prompt for some Hemlock thing to describe."
258     (declare (ignore p))
259     (multiple-value-bind (ignore kwd)
260     (prompt-for-keyword *generic-describe-kinds*
261     :default "Variable"
262     :help "Kind of thing to describe."
263     :prompt "Kind: ")
264     (declare (ignore ignore))
265     (case kwd
266     (:variable
267     (describe-and-show-variable-command nil))
268     (:command (describe-command-command ()))
269     (:key (describe-key-command ()))
270     (:attribute
271     (multiple-value-bind (name attr)
272     (prompt-for-keyword
273     (list *character-attribute-names*)
274     :help "Name of character attribute to describe."
275     :prompt "Attribute: ")
276     (print-full-doc name (character-attribute-documentation attr)))))))
277    
278     ;;; PRINT-FULL-DOC displays whole documentation string in a pop-up window.
279     ;;; Doc may be a function that takes at least one arg, :short or :full.
280     ;;;
281     (defun print-full-doc (nam doc)
282     (typecase doc
283     (function (funcall doc :full))
284     (simple-string
285     (with-pop-up-display (s)
286     (format s "Documentation for ~S:~% ~A" nam doc)))
287     (t (error "Bad documentation: ~S" doc))))
288    
289    
290    
291     ;;;; Describing and show variables.
292    
293     (defcommand "Show Variable" (p)
294     "Display the values of a Hemlock variable."
295     "Display the values of a Hemlock variable."
296     (declare (ignore p))
297     (multiple-value-bind (name var)
298     (prompt-for-variable
299     :help "Name of variable to describe."
300     :prompt "Variable: ")
301     (with-pop-up-display (s)
302     (show-variable s name var))))
303    
304     (defcommand "Describe and Show Variable" (p)
305     "Describe in full and show all of variable's value.
306     Variable is prompted for."
307     "Describe in full and show all of variable's value."
308     (declare (ignore p))
309     (multiple-value-bind (name var)
310     (prompt-for-variable
311     :help "Name of variable to describe."
312     :prompt "Variable: ")
313     (with-pop-up-display (s)
314     (format s "Documentation for ~S:~% ~A~&~%"
315     name (variable-documentation var))
316     (show-variable s name var))))
317    
318     (defun show-variable (s name var)
319     (when (hemlock-bound-p var :global)
320     (format s "Global value of ~S:~% ~S~%"
321     name (variable-value var :global)))
322     (let ((buffer (current-buffer)))
323     (when (hemlock-bound-p var :buffer (current-buffer))
324     (format s "Value of ~S in buffer ~A:~% ~S~%"
325     name (buffer-name buffer)
326     (variable-value var :buffer buffer))))
327     (do-strings (mode-name val *mode-names*)
328     (declare (ignore val))
329     (when (hemlock-bound-p var :mode mode-name)
330     (format s "Value of ~S in ~S Mode:~% ~S~%"
331     name mode-name
332     (variable-value var :mode mode-name)))))
333    
334    
335    
336     ;;;; Describing modes.
337    
338     (defvar *describe-mode-ignore* (list "Illegal" "Do Nothing"))
339    
340     (defcommand "Describe Mode" (p &optional name)
341     "Describe a mode showing special bindings for that mode."
342     "Describe a mode showing special bindings for that mode."
343     (declare (ignore p))
344     (let ((name (or name
345     (prompt-for-keyword (list *mode-names*)
346     :prompt "Mode: "
347     :help "Enter mode to describe."
348     :default
349     (car (buffer-modes (current-buffer)))))))
350     (with-pop-up-display (s)
351     (format s "~A mode description:~%" name)
352     (let ((doc (mode-documentation name)))
353     (when doc
354     (write-line doc s)
355     (terpri s)))
356     (map-bindings
357     #'(lambda (key cmd)
358     (unless (member (command-name cmd)
359     *describe-mode-ignore*
360     :test #'string-equal)
361     (let ((str (key-to-string key)))
362     (cond ((= (length str) 1)
363     (write-string str s)
364     (write-string " - " s))
365     (t (write-line str s)
366     (write-string " - " s)))
367     (print-short-doc (command-documentation cmd) s))))
368     :mode name))))
369    
370     (defun key-to-string (key)
371     (with-output-to-string (s)
372 ram 1.2 (print-pretty-key key s)))
373 ram 1.1
374    
375    
376     ;;;; Printing bindings and last N characters typed.
377    
378     (defcommand "What Lossage" (p)
379     "Display the last 60 characters typed."
380     "Display the last 60 characters typed."
381     (declare (ignore p))
382     (with-pop-up-display (s :height 7)
383 ram 1.2 (let ((num (ring-length *key-event-history*)))
384 ram 1.1 (format s "The last ~D characters typed:~%" num)
385     (do ((i (1- num) (1- i)))
386     ((minusp i))
387 ram 1.2 (ext:print-pretty-key-event (ring-ref *key-event-history* i) s)
388 ram 1.1 (write-char #\space s)))))
389    
390     (defun print-command-bindings (bindings stream)
391     (let ((buffer ())
392     (mode ())
393     (global ()))
394     (dolist (b bindings)
395     (case (second b)
396     (:global (push (first b) global))
397     (:mode
398     (let ((m (assoc (third b) mode :test #'string=)))
399     (if m
400     (push (first b) (cdr m))
401     (push (list (third b) (first b)) mode))))
402     (t
403     (let ((f (assq (third b) buffer)))
404     (if f
405     (push (first b) (cdr f))
406     (push (list (third b) (first b)) buffer))))))
407     (when global
408     (print-some-keys global stream)
409     (write-string "; " stream))
410     (dolist (b buffer)
411     (format stream "Buffer ~S: " (buffer-name (car b)))
412     (print-some-keys (cdr b) stream)
413     (write-string "; " stream))
414     (dolist (m mode)
415     (write-string (car m) stream)
416     (write-string ": " stream)
417     (print-some-keys (cdr m) stream)
418     (write-string "; " stream))))
419    
420     ;;; PRINT-SOME-KEYS prints the list of keys onto Stream.
421     ;;;
422     (defun print-some-keys (keys stream)
423     (do ((key keys (cdr key)))
424     ((null (cdr key))
425 ram 1.2 (print-pretty-key (car key) stream))
426     (print-pretty-key (car key) stream)
427 ram 1.1 (write-string ", " stream)))

  ViewVC Help
Powered by ViewVC 1.1.5