/[cmucl]/src/docs/doc-diff.lisp
ViewVC logotype

Contents of /src/docs/doc-diff.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Tue Jun 10 16:52:37 2003 UTC (10 years, 10 months ago) by toy
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, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, 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, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, 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, 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, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, 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, 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, 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, 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, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, 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, 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.1: +1 -1 lines
Some changes from Paul Foley:

o Fix a number of spelling errors.
o Add EXT:PURGE-FILES (hmm, should that be renamed to
  purge-backup-files?) to delete old versions of files.
o Opening a file with :if-exists :append shouldn't set the Unix append
  flag, else you can't seek back to a point before you started
  appending. (Actually from Rudi Schlatte.)
o Fix a bug in logical pathname parsing.
o Fix FASL-file versioning so we don't create versioned fasl files.
1 ;;; -*- Package: Hemlock -*-
2 ;;;
3 ;;; A hack to compare the functions and variables defined by the hemlock
4 ;;; documents with the ones defined in the core.
5 ;;;
6 ;;; Use GROVEL-LABELS.
7 ;;;
8
9 (in-package "HEMLOCK")
10
11
12 (defvar *defined-labels* (make-hash-table :test #'equal))
13
14 ;;; Ignore these because they would be internal (not for the user) if Hemlock
15 ;;; had that kind of definition power.
16 ;;;
17 (defvar *hvars-to-ignore*
18 '(auto-save-state current-package draft-information headers-buffer
19 headers-information message-buffer message-information spell-information
20 default-message-modeline-fields current-compile-server current-eval-server))
21
22 (defvar *cmds-to-ignore*
23 '("Beginning Of Parse" "Echo Area Backward Character"
24 "Echo Area Backward Word" "Echo Area Delete Previous Character"
25 "Echo Area Kill Previous Word" "Do Nothing" "Illegal" "Insert Parse Default"
26 "Italic Comment Mode" "Kill Parse" "Lisp Insert )" "Next Parse"
27 "Previous Parse" "Start Italic Comment" "Insert ()" "Move over )"
28 "Current Compile Server" "Current Eval Server" "Defhvar" "Defindent"))
29
30 ;;; These do not get removed from *defined-labels* because they are not
31 ;;; command names, variable names, or "HI" function names. These are now
32 ;;; documented in the Command Implementor's Manual, but we don't want to call
33 ;;; FIND-UNDOCUMENTED-SYMBOLS on these packages due to all the uninteresting
34 ;;; symbols they hold. In the case of routines defined in the "ED" package,
35 ;;; they aren't exported anyway.
36 ;;;
37 ;;; Do not add names to this list that occur in the ED package and have
38 ;;; asterisks (e.g., specials like *kill-ring* and *last-search-string*). Use
39 ;;; the variable below, *unimplemented-strings-to-ignore*.
40 ;;;
41 (defvar *unimplemented-to-ignore*
42 '(spell:spell-try-word spell:maybe-read-spell-dictionary spell:spell-root-word
43 spell:max-entry-length spell:spell-read-dictionary
44 spell:spell-collect-close-words spell:correct-spelling
45 spell:spell-add-entry spell:spell-remove-entry spell:spell-root-flags
46
47 ext:translate-character ext:define-keyboard-modifier
48 ext:define-mouse-code ext:translate-mouse-character ext:define-keysym
49
50 dired:find-file dired:make-directory dired:delete-file
51 dired:pathnames-from-pattern dired:copy-file dired:rename-file
52
53 get-search-pattern current-mark file-compile kill-characters
54 indent-region-for-commands display-page-directory previous-buffer
55 sentence-offset interactive buffer-default-pathname
56 add-definition-dir-translation push-buffer-mark do-active-group
57 paragraph-offset word-offset create-slave make-region-undo
58 process-file-options pre-command-parse-check top-level-offset fill-region
59 pop-buffer-mark region-eval get-current-compile-server mark-top-level-form
60 ed page-directory find-file-buffer deactivate-region valid-spot
61 buffer-history kill-region string-eval backward-up-list
62 define-file-type-hook buffer-history check-region-query-size
63 change-to-buffer region-compile current-region mark-paragraph form-offset
64 check-region-active read-buffer-file fill-region-by-paragraphs
65 forward-up-list define-file-option buffer-mark region-active-p
66 inside-defun-p activate-region start-defun-p delete-buffer-if-possible
67 get-current-eval-server goto-page write-buffer-file save-for-undo
68 eval-form-in-server indent-region in-lisp pathname-to-buffer-name
69 page-offset defun-region delete-definition-dir-translation
70 delete-horizontal-space supply-generic-pointer-up-function))
71
72 ;;; This is just like *unimplemented-to-ignore*, but these names are hard to
73 ;;; deal with in *unimplemented-to-ignore* due to one of the following reasons:
74 ;;; Scribe,
75 ;;; The name is an example and truly unimplemented, or
76 ;;; The name has asterisks in core but not in the Scribe label name.
77 ;;;
78 (defvar *unimplemented-strings-to-ignore*
79 '("SAMPLECOMMAND" "SAMPLEVARIABLE"
80
81 "MARK-GTR" "MARK-NEQ" "MARK-LSS" "MARK-LEQ" "MARK-GEQ" "MARK-EQL"
82 "LINE-GEQ" "LINE-LSS" "LINE-GTR" "LINE-LEQ"
83
84 "KILL-RING" "LAST-SEARCH-STRING" "EPHEMERALLY-ACTIVE-COMMAND-TYPES"
85 "HEMLOCK-BEEP" "LAST-SEARCH-PATTERN" "ACTIVE-FILE-GROUP"
86
87 "ERROR-FUNCTION" "REPORT-FUNCTION" "UPDATE-DEFAULT" "YESP-FUNCTION"
88 "CLOBBER-DEFAULT" "RECURSIVE-DEFAULT"))
89
90
91 (defun grovel-labels (aux-files output-file)
92 "Read each of the files in the list Aux-Files to find what commands are
93 documented, then compare it with the commands defined in core. We write
94 documentation forms to the output-file for things defined but not documented,
95 and we put a list of things documented but not implemented in a comment."
96 (clrhash *defined-labels*)
97 (dolist (labels-file aux-files)
98 (with-open-file (s labels-file :direction :input)
99 (loop
100 (let ((l (read-line s nil nil)))
101 (unless l (return))
102 (multiple-value-bind (kind label)
103 (parse-label l)
104 (when kind
105 (let ((old (gethash label *defined-labels*)))
106 (when (and old
107 (not (eq old :hemlock-variable))
108 (not (eq kind :hemlock-variable)))
109 (format t "~S multiply defined as ~S and ~S.~%"
110 label old kind))
111 (setf (gethash label *defined-labels*) kind))))))))
112 (with-open-file (s output-file :direction :output
113 :if-exists :rename-and-delete)
114 (map-undocumented-hemlock-things *command-names* :command s
115 #'document-command *cmds-to-ignore*)
116 (terpri s)
117 (map-undocumented-hemlock-things *global-variable-names* :hemlock-variable s
118 #'document-variable *hvars-to-ignore*)
119 (terpri s)
120 (find-undocumented-symbols "HEMLOCK-INTERNALS" s)
121 (terpri s)
122 (write-line "@begin[comment]" s)
123 (let ((ignored-symbols (copy-list *unimplemented-to-ignore*))
124 (ignored-strings (copy-list *unimplemented-strings-to-ignore*)))
125 (maphash #'(lambda (name type)
126 (cond ((member name ignored-symbols
127 :test #'string= :key #'symbol-name)
128 (setf ignored-symbols
129 (delete name ignored-symbols
130 :test #'string= :key #'symbol-name)))
131 ((member name ignored-strings :test #'string=)
132 (setf ignored-strings
133 (delete name ignored-strings :test #'string=)))
134 (t
135 (format s "~A ~S is not implemented.~%" type name))))
136 *defined-labels*)
137 (when ignored-symbols
138 (format s
139 "~&******************* These ignored \"unimplemented\" symbols ~
140 were not used.~%~S~%********************~2%"
141 ignored-symbols))
142 (when ignored-strings
143 (format s
144 "~&******************* These ignored \"unimplemented\" strings ~
145 were not used.~%~S~%********************~2%"
146 ignored-strings)))
147 (write-line "@end[comment]" s)
148 (values)))
149
150
151 ;;; Iterate over a string table, checking that each thing has a corresponding
152 ;;; label of the specified kind. If there is no label, then call the function
153 ;;; with the value and stream. If the label is the wrong kind, print a comment
154 ;;; on Stream before calling the function. We also blast the label so we will
155 ;;; know that it was defined.
156 ;;;
157 (defun map-undocumented-hemlock-things (table kind stream function ignore-stuff)
158 (do-strings (string value table)
159 (let* ((lab (nstring-upcase (remove #\space string)))
160 (lkind (gethash lab *defined-labels*)))
161 (cond ((and (eq kind :command)
162 (member (command-name value) ignore-stuff
163 :test #'string-equal))
164 (setf ignore-stuff
165 (remove (command-name value) ignore-stuff
166 :test #'string-equal)))
167 ((member value ignore-stuff)
168 (setf ignore-stuff (remove value ignore-stuff)))
169 (t
170 (unless (eq lkind kind)
171 (when lkind
172 (format stream
173 "@comment{~S documented as a ~A, ~
174 but defined as a ~A.}~2%"
175 string lkind kind))
176 (funcall function value stream))))
177 (remhash lab *defined-labels*)))
178 (when ignore-stuff
179 (format stream
180 "~&******************** These ignored ~Ss were not used.~%~
181 ~S~%********************~2%"
182 kind ignore-stuff)))
183
184
185
186 (defvar *undocumented-symbols-to-ignore*
187 '(make-xwindow-like-hwindow mark/= default-font input-waiting mark=
188 modify-kbdmac-stream delete-line-font-marks font-mark hemlock-output-stream
189 command reprompt store-cut-string make-kbdmac-stream window window-font
190 delete-font-mark fetch-cut-string fun-defined-from-pathname
191 hemlock-region-stream line< buffer mark< move-font-mark
192 editor-describe-function enter-window-autoraise ring mark<= search-pattern
193 *print-region* mark>= string-table line mark> line> line>= line<=
194 after-editor-initializations *invoke-hook* defhvar))
195
196 (defun find-undocumented-symbols (package stream)
197 (let ((ignore-symbols *undocumented-symbols-to-ignore*))
198 (do-external-symbols (sym package)
199 (let* ((name (string-trim "*" (symbol-name sym)))
200 (kind (gethash name *defined-labels*)))
201 (ecase kind
202 ((nil)
203 (if (member sym ignore-symbols)
204 (setf ignore-symbols (remove sym ignore-symbols))
205 (let ((*standard-output* stream))
206 ;; Bind this to squelch CLOS/DESCRIBE bad interaction.
207 (describe sym)
208 (terpri)
209 (terpri))))
210 ((:function :macro :special-form)
211 (let ((def (cond ((macro-function sym) :macro)
212 ((special-form-p sym) :special-form)
213 ((fboundp sym) :function))))
214 (unless (eq kind def)
215 (format stream
216 "@comment{~S is ~:[not defined~;~:*defined as a ~A~]~
217 , but is documented as a ~A}~%" sym def kind))))
218 (:constant
219 (unless (constantp sym)
220 (format stream
221 "@comment{~S is documented as a constant, but isn't ~
222 defined.}~%"
223 sym)))
224 (:variable
225 (unless (or (get sym 'lisp::globally-special)
226 (string= name (symbol-name sym)))
227 (format stream
228 "@comment{~S is documented as a special, but isn't ~
229 declared.}~%"
230 sym))))
231 (remhash name *defined-labels*)))
232 (when ignore-symbols
233 (format stream
234 "~&******************** These ignored symbols were not used.~%~
235 ~S~%********************~2%"
236 ignore-symbols))))
237
238
239 (defvar *suffix-codes* (make-hash-table :test #'equal))
240 (setf (gethash "COM" *suffix-codes*) :command)
241 (setf (gethash "HVAR" *suffix-codes*) :hemlock-variable)
242 (setf (gethash "FUN" *suffix-codes*) :function)
243 (setf (gethash "MAC" *suffix-codes*) :macro)
244 (setf (gethash "SPEC" *suffix-codes*) :special-form)
245 (setf (gethash "VAR" *suffix-codes*) :variable)
246 (setf (gethash "CON" *suffix-codes*) :constant)
247
248
249 ;;; Parse a line from a Scribe .Aux file, returning the kind of the thing
250 ;;; documented and its name.
251 ;;;
252 (defun parse-label (entry)
253 (let* ((end (search "), Value" entry :start2 28))
254 (hpos (position #\- entry :start 28 :end end :from-end t)))
255 (if hpos
256 (let* ((suffix (subseq entry (1+ hpos) end))
257 (found (gethash suffix *suffix-codes*)))
258 (if found
259 (values found (subseq entry 28 hpos))
260 (values nil nil)))
261 (values nil nil))))
262
263
264 (defun document-command (command stream)
265 (format stream "@defcom[com ~S" (command-name command))
266 (let ((binds (command-bindings command)))
267 (when binds
268 (format stream ", bind (")
269 (print-command-bindings binds stream)
270 (format stream ")"))
271 (format stream "]~%~A~%@enddefcom~2%"
272 (command-documentation command))))
273
274
275 (defun document-variable (var stream)
276 (let* ((name (variable-name var :global))
277 (len (length name)))
278 (unless (string= name "Mode Hook" :start1 (- len 9))
279 (format stream "@defhvar[var ~S~@[, val {~(~S~)}~]]~%~A~%@enddefhvar~2%"
280 name (variable-value var :global)
281 (variable-documentation var :global)))))
282
283
284 (defvar *definition-pattern*
285 (new-search-pattern :string-insensitive :forward "
286 @def"))
287
288 (defvar *insert-pattern*
289 (new-search-pattern :string-insensitive :backward "
290
291 "))
292
293 (defvar *definition-macros* (make-hash-table :test #'equal))
294 (setf (gethash "COM" *definition-macros*) :command)
295 (setf (gethash "HVAR" *definition-macros*) :hemlock-variable)
296 (setf (gethash "UN" *definition-macros*) :function)
297 (setf (gethash "MAC" *definition-macros*) :macro)
298 (setf (gethash "SPEC" *definition-macros*) :special-form)
299 (setf (gethash "VAR" *definition-macros*) :variable)
300 (setf (gethash "CON" *definition-macros*) :constant)
301 (setf (gethash "COM1" *definition-macros*) :command)
302 (setf (gethash "HVAR1" *definition-macros*) :hemlock-variable)
303 (setf (gethash "UN1" *definition-macros*) :function)
304 (setf (gethash "MAC1" *definition-macros*) :macro)
305 (setf (gethash "SPEC1" *definition-macros*) :special-form)
306 (setf (gethash "VAR1" *definition-macros*) :variable)
307 (setf (gethash "CON1" *definition-macros*) :constant)
308
309 (defun parse-doc-macro (line)
310 (let* ((bracket (or (position #\[ line)
311 (error "No opening #\[ ???")))
312 (name (nstring-upcase (subseq line 4 bracket)))
313 (kind (gethash name *definition-macros*))
314 (nend (case (char line (+ bracket 5))
315 (#\"
316 (position #\" line :start (+ bracket 6)))
317 (#\{
318 (position #\} line :start (+ bracket 6)))
319 (t nil))))
320 (cond ((not kind)
321 (format t "Unknown definition macro:~%~A~%" line)
322 (values nil nil))
323 ((not nend)
324 (format t "Can't parse name:~%~A~%" line)
325 (values nil nil))
326 (t
327 (values kind (subseq line (+ bracket 6) nend))))))
328
329
330 (defun annotate-with-online-documentation (input-file output-file)
331 "Take a Scribe input file and produce a Scribe output file with the online
332 documentation for each thing inserted before the offline documentation."
333 (let* ((temp-buffer (make-buffer "Annotate Temporary"))
334 (point (buffer-point temp-buffer)))
335 (unwind-protect
336 (progn
337 (read-file input-file point)
338 (buffer-start point)
339 (loop
340 (unless (find-pattern point *definition-pattern*)
341 (return))
342 (line-offset point 1)
343 (multiple-value-bind
344 (kind name)
345 (parse-doc-macro (line-string (mark-line point)))
346 (when kind
347 (with-mark ((insert point :left-inserting))
348 (unless (find-pattern insert *insert-pattern*)
349 (buffer-start insert))
350 (line-offset insert 2 0)
351 (with-output-to-mark (stream insert :full)
352 (ecase kind
353 ((:function :macro :special-form :constant)
354 (format stream "@begin[format]~%")
355 (let ((*standard-output* stream))
356 (describe (intern (string-upcase name))))
357 (format stream "~&@end[format]~2%"))
358 (:variable
359 (format stream "@begin[format]~%")
360 (let ((*standard-output* stream))
361 (describe (intern (concatenate 'string "*"
362 (string-upcase name)
363 "*"))))
364 (format stream "~&@end[format]~2%"))
365 (:command
366 (let ((command (getstring name *command-names*)))
367 (when command
368 (format stream "@begin[verse]~%Command @hid[~A]: ("
369 (command-name command))
370 (print-command-bindings (command-bindings command)
371 stream)
372 (format stream ")~%@end[verse]~%~A~2&"
373 (command-documentation command)))))
374 (:hemlock-variable
375 (let ((var (getstring name *global-variable-names*)))
376 (when var
377 (format stream "@begin[verse]~%Variable @hid[~A]: ~
378 (~(~S~))~%@end[verse]~%~A~2&"
379 (variable-name var :global)
380 (variable-value var :global)
381 (variable-documentation var :global))))))
382 )))))
383 (write-file (buffer-region temp-buffer) output-file))
384 (delete-buffer temp-buffer))))

  ViewVC Help
Powered by ViewVC 1.1.5