source: CGBLisp/contrib/user_man/user-manual.lisp@ 1

Last change on this file since 1 was 1, checked in by Marek Rychlik, 15 years ago

First import of a version circa 1997.
File size: 49.9 KB
Line 
1;;; $Id: user-manual.lisp,v 1.28 1997/12/03 02:38:33 marek Exp $
2;;; ****************************************************************
3;;; CHANGE LOG:
4;;; * Added package stuff
5;;; * Modified by M. Rychlik (rychlik@math.arizona.edu)
6;;; so that create-manuals accepts a directory prefix
7;;; ****************************************************************
8
9(defpackage "USER-MANUAL"
10 (:export create-user-manual create-manuals text scribe latex))
11(in-package "USER-MANUAL")
12
13;;; Thu Oct 20 20:18:29 1994 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU>
14;;; user-manual.lisp -- 48831 bytes
15
16;;; ****************************************************************
17;;; Automatic User Manual Creation *********************************
18;;; ****************************************************************
19;;;
20;;; The Automatic User Manual Creation system is a common lisp portable
21;;; system for automatically generating user's guides from the
22;;; source definitions and their documentation strings. It uses several
23;;; heuristics for formatting the documentation segments nicely.
24;;; If Waters' XP pretty printer is available, it uses that instead to
25;;; format the argument lists.
26;;;
27;;; The user guide for this file was created using this program and
28;;; provides a good example of its capabilities. It was created by
29;;; evaluating (create-user-manual "user-manual.lisp").
30;;;
31;;; Written by Mark Kantrowitz, December 1990.
32;;;
33;;; Address: Carnegie Mellon University
34;;; School of Computer Science
35;;; Pittsburgh, PA 15213
36;;;
37;;; Copyright (c) 1990. All rights reserved.
38;;;
39;;; See general license below.
40;;;
41
42
43;;; ****************************************************************
44;;; General License Agreement and Lack of Warranty *****************
45;;; ****************************************************************
46;;;
47;;; This software is distributed in the hope that it will be useful (both
48;;; in and of itself and as an example of lisp programming), but WITHOUT
49;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for
50;;; the consequences of using it or for whether it serves any particular
51;;; purpose or works at all. No warranty is made about the software or its
52;;; performance.
53;;;
54;;; Use and copying of this software and the preparation of derivative
55;;; works based on this software are permitted, so long as the following
56;;; conditions are met:
57;;; o The copyright notice and this entire notice are included intact
58;;; and prominently carried on all copies and supporting documentation.
59;;; o No fees or compensation are charged for use, copies, or
60;;; access to this software. You may charge a nominal
61;;; distribution fee for the physical act of transferring a
62;;; copy, but you may not charge for the program itself.
63;;; o If you modify this software, you must cause the modified
64;;; file(s) to carry prominent notices (a Change Log)
65;;; describing the changes, who made the changes, and the date
66;;; of those changes.
67;;; o Any work distributed or published that in whole or in part
68;;; contains or is a derivative of this software or any part
69;;; thereof is subject to the terms of this agreement. The
70;;; aggregation of another unrelated program with this software
71;;; or its derivative on a volume of storage or distribution
72;;; medium does not bring the other program under the scope
73;;; of these terms.
74;;; o Permission is granted to manufacturers and distributors of
75;;; lisp compilers and interpreters to include this software
76;;; with their distribution.
77;;;
78;;; This software is made available AS IS, and is distributed without
79;;; warranty of any kind, either expressed or implied.
80;;;
81;;; In no event will the author(s) or their institutions be liable to you
82;;; for damages, including lost profits, lost monies, or other special,
83;;; incidental or consequential damages arising out of or in connection
84;;; with the use or inability to use (including but not limited to loss of
85;;; data or data being rendered inaccurate or losses sustained by third
86;;; parties or a failure of the program to operate as documented) the
87;;; program, even if you have been advised of the possibility of such
88;;; damanges, or for any claim by any other party, whether in an action of
89;;; contract, negligence, or other tortious action.
90;;;
91;;; The current version of this software and a variety of related
92;;; utilities may be obtained by anonymous ftp from ftp.cs.cmu.edu
93;;; (128.2.206.173) or any other CS machine in the directory
94;;; user/ai/lang/lisp/code/tools/user_man/
95;;;
96;;; Please send bug reports, comments, questions and suggestions to
97;;; mkant@cs.cmu.edu. We would also appreciate receiving any changes
98;;; or improvements you may make.
99;;;
100;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list,
101;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email
102;;; address, and affiliation. This mailing list is primarily for
103;;; notification about major updates, bug fixes, and additions to the lisp
104;;; utilities collection. The mailing list is intended to have low traffic.
105;;;
106
107
108;;; ********************************
109;;; Change Log *********************
110;;; ********************************
111;;;
112;;; mk = Mark Kantrowitz <mkant@cs.cmu.edu>
113;;; duff = David A. Duff <duff@starbase.MITRE.ORG>
114;;; rit = Jean-Francois Rit <rit@cs.stanford.edu>
115;;; wds = William D Smith <smithwd@kona.crd.ge.com>
116;;; dick = Dick Jackson <jackson@ciitip.ciit.nrc.ca>
117;;; ma = Marco Antoniotti <marcoxa@image.cs.nyu.edu>
118;;; fdmm = Fernando D. Mato Mira <matomira@epfl.ch>
119;;;
120;;; 24-JAN-91 duff Fixed bug in documentation handler for defstructs.
121;;; 24-JAN-91 duff Documentation-handlers for Lucid.
122;;; 28-JAN-91 rit Changed format clauses with @: to :@ in handle-form-output.
123;;; Otherwise Franz Allegro CL barfs.
124;;; mk Note that CLtL2 specifies that either is OK, although
125;;; :@ is traditional.
126;;; 28-JAN-91 mk Added Scribe output format in addition to TEXT output
127;;; format.
128;;; 31-JAN-91 duff Doc-handler for define-condition.
129;;; 05-FEB-91 wds Added doc-handlers for defmethod, defgeneric, defclass,
130;;; deftype and defsetf.
131;;; 05-FEB-91 mk Fixed handler for defmethod to handle qualifiers such
132;;; as :before, :after, and :around. Fixed defsetf handler
133;;; to include alternate format. Extended deftype handler.
134;;; 07-FEB-91 dick Doc-handlers for CLOS defclass. [This was better than
135;;; wds's. I've merged the capabilities of the two.
136;;; Also, I added :blank for use in leaving the args
137;;; position blank, and fixed split-string to not
138;;; trim whitespace in certain circumstances. --mk]
139;;; 08-FEB-91 wds Specialized the code using conditional read macros
140;;; in case XP package not present.
141;;; 05-JAN-93 ma Changed some of the inner working to add LaTeX
142;;; support: defvar, defconstant and defparameter have
143;;; their doc-handlers changed when they have nil as
144;;; default and support functions have bee added for
145;;; LaTeX. Also the structure of handle-form-output
146;;; has been slightly changed.
147;;; A LaTeX document including entries obtained via
148;;; create-user-manual must contain (e.g. by '\input')
149;;; the 'lisp:documentation' environment as defined in
150;;; the companion file 'lisp-documentation.tex'.
151;;; 03-MAR-93 fdmm Added doc-handler for ECLOS defconstraint.
152;;; 03-MAR-93 fdmm Added create-manuals.
153;;; 03-MAR-93 fdmm Enhanced defclass doc-handler to output metaclass, readers,
154;;; writers, initargs and slot type info.
155;;; 04-MAR-93 fdmm Fixed bug in handle-form-output (let --> let*).
156;;; 05-MAR-93 fdmm Added basic FrameMaker(tm) support.
157;;; 17-OCT-94 fdmm Added doc-handler for ECLOS defdaemon.
158;;; 17-OCT-94 fdmm Accepts now :latex, etc. keywords, to avoid package
159;;; problems, but still accepts `bad style' arguments for
160;;; backwards compatibility.
161;;; 20-OCT-94 mk Added *userman-version* parameter.
162
163
164;;; ********************************
165;;; To Do **************************
166;;; ********************************
167;;;
168;;; Generalize it to also use the definition's comments to create
169;;; even more documentation. Essentially, change the #\; macro
170;;; character so that instead of killing the remainder of the line,
171;;; it processes it for the documentation. By making this program
172;;; understand some sort of structured comments, we can have it
173;;; ignore comment stubs and only include the meaty stuff.
174;;;
175;;; Clean up use of XP pretty printer.
176;;;
177;;; Need 'latex output-format. In 'scribe mode, need to convert @ to @@.
178;;;
179;;; Note that using :output-format 'scribe and running scribe with
180;;; the -device FILE arguments should produce output similar to
181;;; :output-format 'text, except without semicolons in the left margin.
182;;;
183
184
185;;; ********************************
186;;; Documentation Types ************
187;;; ********************************
188;;;
189;;; This is a list of the documentation types currently supported:
190;;; + = things in user-manual.lisp
191;;; - = things still missing from user-manual.lisp
192;;;
193;;; COMMON-LISP forms:
194;;;
195;;; + (DEFCLASS name super-types slots &rest options )
196;;; + (DEFCONSTANT name initial-value &optional documentation )
197;;; + (DEFGENERIC name lambda-list &rest options )
198;;; + (DEFMACRO name lambda-list documentation ... )
199;;; + (DEFMETHOD name lambda-list documentation ... )
200;;; - defpackage
201;;; + (DEFPARAMETER name initial-value &optional documentation )
202;;; + (DEFSETF name function documentation )
203;;; + (DEFSTRUCT name+options documentation &rest slots )
204;;; + (DEFTYPE name lambda-list documentation ... )
205;;; + (DEFUN name lambda-list documentation ... )
206;;; + (DEFVAR name &optional initial-value documentation )
207;;;
208;;; ECLOS forms:
209;;;
210;;; + (DEFCONSTRAINT name super-types lambda-list documentation ...)
211;;; + (DEFDAEMON name super-types lambda-list documentation ...)
212;;;
213
214
215;;; ********************************
216;;; Notes **************************
217;;; ********************************
218;;;
219;;; USER-MANUAL has been tested (successfully) in the following lisps:
220;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
221;;; Macintosh Allegro Common Lisp (1.3.2)
222;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90)
223;;; Lucid CL (Version 2.1 6-DEC-87)
224;;;
225;;; USER-MANUAL needs to be tested in the following lisps:
226;;; Symbolics Common Lisp (8.0)
227;;; Lucid Common Lisp (3.0)
228;;; Lucid Common Lisp (4.0)
229;;; KCL (June 3, 1987 or later)
230;;; AKCL (1.86, June 30, 1987 or later)
231;;; TI (Release 4.1 or later)
232;;; Ibuki Common Lisp (01/01, October 15, 1987)
233;;; Golden Common Lisp (3.1 IBM-PC)
234;;; VAXLisp (2.0, 3.1)
235;;; HP Common Lisp (same as Lucid?)
236;;; Procyon Common Lisp
237
238
239
240;;; ********************************
241;;; User Guide *********************
242;;; ********************************
243;;;
244;;; EXTRACT-DOCUMENTATION (body) [MACRO]
245;;;
246;;; ATOM-OR-CAR (list-or-atom) [FUNCTION]
247;;;
248;;; *DOCUMENTATION-HANDLERS* (make-hash-table :test [VARIABLE]
249;;; (function equal))
250;;; Hash table of entries of the form (handler description),
251;;; where definer is the car of the definition form handled (for
252;;; example, DEFUN or DEFMACRO), handler is a function which takes the
253;;; form as input and value-returns the name, argument-list and
254;;; documentation string, and description is a one-word equivalent of
255;;; definer (for example, FUNCTION or MACRO).
256;;;
257;;; DEFINE-DOC-HANDLER (definer arglist description &body body) [MACRO]
258;;; Defines a new documentation handler. DEFINER is the car of the
259;;; definition form handled (e.g., defun), DESCRIPTION is a one-word
260;;; string equivalent of definer (e.g., "function"), and ARGLIST
261;;; and BODY together define a function that takes the form as input
262;;; and value-returns the name, argument-list, documentation string,
263;;; and a list of any qualifiers of the form.
264;;;
265;;; FIND-DOC-HANDLER (definer) [FUNCTION]
266;;; Given the car of a form, finds the appropriate documentation
267;;; handler for the form if one exists.
268;;;
269;;; DEFINE-DOC-HANDLER (form) [DOC-HANDLER]
270;;; Documentation handler for doc-handlers.
271;;;
272;;; DEFVAR (form) [DOC-HANDLER]
273;;; Documentation handler for variables.
274;;;
275;;; DEFCONSTANT (form) [DOC-HANDLER]
276;;; Documentation handler for constants.
277;;;
278;;; DEFPARAMETER (form) [DOC-HANDLER]
279;;; Documentation handler for parameters.
280;;;
281;;; DEFUN (form) [DOC-HANDLER]
282;;; Documentation handler for functions.
283;;;
284;;; DEFMACRO (form) [DOC-HANDLER]
285;;; Documentation handler for macros.
286;;;
287;;; DEFSTRUCT (form) [DOC-HANDLER]
288;;; Documentation handler for structures.
289;;;
290;;; DEFINE-CONDITION (form) [DOC-HANDLER]
291;;; Documentation handler for conditions.
292;;;
293;;; DEFTYPE (form) [DOC-HANDLER]
294;;; Documentation handler for types.
295;;;
296;;; DEFSETF (form) [DOC-HANDLER]
297;;; Documentation handler for setf mappings.
298;;;
299;;; DEFMETHOD (form) [DOC-HANDLER]
300;;; Documentation handler for methods.
301;;;
302;;; DEFGENERIC (form) [DOC-HANDLER]
303;;; Documentation handler for generic functions.
304;;;
305;;; DEFCLASS (form) [DOC-HANDLER]
306;;; Documentation handler for classs.
307;;;
308;;; DEFCONSTRAINT (form) [DOC-HANDLER]
309;;; Documentation handler for constraints.
310;;;
311;;; DEFDAEMON (form) [DOC-HANDLER]
312;;; Documentation handler for daemons.
313;;;
314;;; *FAILED-DEFINITION-TYPES* "()" [VARIABLE]
315;;; List of definition types that create-user-manual couldn't handle.
316;;;
317;;; CREATE-USER-MANUAL (filename &key (output-format (quote text)) [FUNCTION]
318;;; (output-stream *standard-output*))
319;;; Automatically creates a user manual for the functions in a file by
320;;; collecting the documentation strings and argument lists of the
321;;; functions and formatting the output nicely. Returns a list of the
322;;; definition types of the forms it couldn't handle. Output-format
323;;; may be either 'TEXT or 'SCRIBE.
324;;;
325;;; HANDLE-FORM-OUTPUT (form &optional (output-format (quote text)) [FUNCTION]
326;;; (stream *standard-output*))
327;;; This function takes a form as input and outputs its documentation
328;;; segment to the output stream.
329;;;
330;;; OUTPUT-TEXT-DOCUMENTATION (name type args documentation [FUNCTION]
331;;; args-tab-pos type-pos
332;;; &optional (stream *standard-output*))
333;;; Prints out the user guide entry for a form in TEXT mode.
334;;;
335;;; OUTPUT-SCRIBE-DOCUMENTATION (name type args documentation [FUNCTION]
336;;; &optional
337;;; (stream *standard-output*))
338;;; Prints out the user guide entry for a form in SCRIBE mode.
339;;;
340;;; XP-SPLIT-STRING (arglist width) [FUNCTION]
341;;; PPrints the arglist into a string of specified width. Assumes
342;;; that we're running the XP pretty printer.
343;;;
344;;; SPLIT-STRING (string width &optional arglistp filled [FUNCTION]
345;;; (trim-whitespace t))
346;;; Splits a string into a list of strings, each of which is shorter
347;;; than the specified width. Tries to be intelligent about where to
348;;; split the string if it is an argument list. If filled is T,
349;;; tries to fill out the strings as much as possible. This function
350;;; is used to break up long argument lists nicely, and to break up
351;;; wide lines of documentation nicely.
352;;;
353;;; SPLIT-POINT (string max-length &optional arglistp filled) [FUNCTION]
354;;; Finds an appropriate point to break the string at given a target
355;;; length. If arglistp is T, tries to find an intelligent position to
356;;; break the string. If filled is T, tries to fill out the string as
357;;; much as possible.
358;;;
359;;; LAMBDA-LIST-KEYWORD-POSITION (string [FUNCTION]
360;;; &optional end trailer-only)
361;;; If the previous symbol is a lambda-list keyword, returns
362;;; its position. Otherwise returns end.
363;;;
364;;; BALANCED-PARENTHESIS-POSITION (string &optional end) [FUNCTION]
365;;; Finds the position of the left parenthesis which is closest to END
366;;; but leaves the prefix of the string with balanced parentheses or
367;;; at most 1 unbalanced left parenthesis.
368;;;
369;;; PARSE-WITH-DELIMITER (line &optional (delim #\newline)) [FUNCTION]
370;;; Breaks LINE into a list of strings, using DELIM as a
371;;; breaking point.
372;;;
373
374
375;;; ********************************
376;;; Version Information ************
377;;; ********************************
378
379(defparameter *userman-version* "2.0 20-OCT-94"
380 "Current verison number/date for User-Manual.")
381
382(defun userman-copyright (&optional (stream *standard-output*))
383 "Prints a User Manual copyright notice and header upon startup."
384 (format stream "~%;;; ~V,,,'*A" 73 "*")
385 (format stream "~%;;; UserMan: Automatic User Manual Creation.")
386 (format stream "~%;;; Version ~A." *userman-version*)
387 (format stream "~%;;; Written by Mark Kantrowitz, CMU School of Computer Science.")
388 (format stream "~%;;; Copyright (c) 1990-94. All rights reserved.")
389 (format stream "~%;;; Use, copying, modification, and distribution permitted.")
390 (format stream "~%;;; See the copyright notice in the source for details.")
391 (format stream "~%;;; ~V,,,'*A~%" 73 "*")
392 (force-output stream))
393
394(userman-copyright)
395
396;;; ********************************
397;;; Check for XP *******************
398;;; ********************************
399
400;; If the XP package is available, add :XP to *features* so that
401;; the conditional read macros will work.
402(when (find-package "XP") (push :XP *FEATURES*))
403
404;;; ********************************
405;;; Utilities **********************
406;;; ********************************
407
408(defmacro extract-documentation (body)
409 `(when (and (stringp (car ,body))
410 (cdr ,body))
411 (pop ,body)))
412
413(defun atom-or-car (list-or-atom)
414 (if (listp list-or-atom)
415 (first list-or-atom)
416 list-or-atom))
417
418;;; ********************************
419;;; Documentation Handlers *********
420;;; ********************************
421(defvar *documentation-handlers* (make-hash-table :test #'equal)
422 "Hash table of entries of the form (handler description),
423 where definer is the car of the definition form handled (for example,
424 DEFUN or DEFMACRO), handler is a function which takes the form as input
425 and value-returns the name, argument-list and documentation string,
426 and description is a one-word equivalent of definer (for example,
427 FUNCTION or MACRO).")
428
429(defmacro define-doc-handler (definer arglist description &body body)
430 "Defines a new documentation handler. DEFINER is the car of the
431 definition form handled (e.g., defun), DESCRIPTION is a one-word
432 string equivalent of definer (e.g., \"function\"), and ARGLIST
433 and BODY together define a function that takes the form as input
434 and value-returns the name, argument-list, documentation string,
435 and a list of any qualifiers of the form."
436 `(setf (gethash ',definer *documentation-handlers*)
437 (list #'(lambda ,arglist
438 ,@body)
439 ,description)))
440
441(defun find-doc-handler (definer)
442 "Given the car of a form, finds the appropriate documentation
443 handler for the form if one exists."
444 (gethash definer *documentation-handlers*))
445
446(define-doc-handler define-doc-handler (form)
447 "doc-handler"
448 ;; name arglist documentation-string
449 (values (second form)
450 (third form)
451 (format nil "Documentation handler for ~A~P."
452 (fourth form) 2)))
453
454;;; Changed the return form for the arguments in defvar, defconstant
455;;; and defparameter (basically 'listified' them).
456
457(define-doc-handler defvar (form)
458 "variable"
459 ;; name arglist documentation-string
460 (values (second form)
461 (list (third form))
462 (fourth form)))
463
464(define-doc-handler defconstant (form)
465 "constant"
466 ;; name arglist documentation-string
467 (values (second form)
468 (list (third form))
469 (fourth form)))
470
471(define-doc-handler defparameter (form)
472 "parameter"
473 ;; name arglist documentation-string
474 (values (second form)
475 (list (third form))
476 (fourth form)))
477
478(define-doc-handler defun (form)
479 "function"
480 ;; name arglist documentation-string
481 (values (second form)
482 (third form)
483 (when (stringp (fourth form)) (fourth form))))
484
485(define-doc-handler defconstraint (form)
486 "constraint"
487 ;; name super-types arglist documentation-string
488 (let ((superclass-names (third form)))
489 (values (second form)
490 (fourth form)
491 (format nil "~@[~A~]~%Superclasses~%~:[~:(~A~)~;~{~(~A~)~}~]"
492 (when (stringp (fifth form)) (fifth form))
493 superclass-names (or superclass-names "None."))))) ; super-types
494
495(define-doc-handler defdaemon (form)
496 "daemon"
497 ;; name super-types arglist documentation-string
498 (let ((superclass-names (third form)))
499 (values (second form)
500 (fourth form)
501 (format nil "~@[~A~]~%Superclasses~%~:[~:(~A~)~;~{~(~A~)~}~]"
502 (when (stringp (fifth form)) (fifth form))
503 superclass-names (or superclass-names "None."))))) ; super-types
504
505(define-doc-handler defmacro (form)
506 "macro"
507 ;; name arglist documentation-string
508 (values (second form)
509 (third form)
510 (when (stringp (fourth form)) (fourth form))))
511
512(define-doc-handler defstruct (form)
513 "structure"
514 ;; name arglist documentation-string
515 (values (atom-or-car (second form))
516 (mapcar #'atom-or-car
517 (if (stringp (third form))
518 (cdddr form)
519 (cddr form)))
520 (third form)))
521
522(define-doc-handler define-condition (form)
523 "condition"
524 (values (cadr form)
525 ;; handled here like defstruct.
526 ;; might want to skip this and return nil.
527 (mapcar #'atom-or-car (fourth form))
528 (cadr (find :documentation (nthcdr 4 form) :key #'car))))
529
530(define-doc-handler DEFTYPE (form)
531 "type"
532 (let ((name (second form))
533 (args (third form))
534 doc def)
535 (setq form (cdddr form))
536 (setq doc (extract-documentation form))
537 (when (null (cdr form))
538 (setq def (car form)))
539 ;; We give a try at the type definition if the body of the deftype
540 ;; form consists of a single form.
541 (if def
542 (values name def doc (list args))
543 (values name args doc))))
544
545#|
546(define-doc-handler DEFTYPE (form)
547 "type"
548 (values (second form)
549 (third form)
550 (fourth form)))
551|#
552
553(define-doc-handler DEFSETF (form)
554 "setf mapping"
555 ;; name args doc.
556 ;; defsetf has two formats:
557 ;; (defsetf name update-fn doc)
558 ;; (defsetf name lambda-list (store-variable) doc-string body)
559 (cond ((listp (third form))
560 ;; long format
561 (values `(setf ,(second form))
562 (fourth form) ; store variable
563 (fifth form)))
564 (t
565 ;; short format
566 (values `(setf ,(second form))
567 (third form)
568 (fourth form)))))
569
570;;; ********************************
571;;; CLOS Related *******************
572;;; ********************************
573
574(define-doc-handler DEFMETHOD (form)
575 "method"
576 ;; name arglist documentation-string
577 ;; (defmethod name {qualifiers}* lambda-list [ {decl}* || doc ] body)
578 (let (name quals args doc)
579 (setf name (second form))
580 (do ((form (cddr form) (cdr form)))
581 ((or (null form)
582 ;; qualifiers are non-nil atoms while lambda-list is a list.
583 (listp (car form)))
584 (setq quals (nreverse quals))
585 (setq args (car form))
586 (setq form (cdr form))
587 (setq doc (extract-documentation form))
588 (values name args doc quals))
589 (when (atom (car form))
590 (push (car form) quals)))))
591
592#|
593(define-doc-handler DEFMETHOD (form)
594 "method"
595 ;; name arglist documentation-string
596 (let* ((name (second form))
597 (qual (when (symbolp (third form)) (third form)))
598 (args (if qual
599 (cons qual (fourth form))
600 (third form)))
601 (doc (if qual (fifth form) (fourth form))))
602 (values name args doc)))
603
604;; Dick's version:
605(define-doc-handler defmethod (form)
606 "method"
607 ;; name arglist documentation-string
608 (if (listp (third form))
609 (values (second form)
610 (third form)
611 (format nil "Primary method~%~A"
612 (if (stringp (fourth form))
613 (fourth form)
614 "")))
615 (values (second form)
616 (fourth form)
617 (format nil ":~A method~%~A"
618 (third form)
619 (if (stringp (fifth form))
620 (fifth form)
621 "")))))
622
623|#
624
625;;; DEFGENERIC: misses many options (eg, compile optimizations, etc.)
626(define-doc-handler DEFGENERIC (form)
627 "generic function"
628 ;; name arglist documentation-string
629 (values (second form)
630 (third form)
631 ;; doc-string is embedded in body of DEFGENERIC:
632 (second (assoc :documentation (cdddr form)))))
633
634(defun listify (x)
635 (if (null x)
636 x
637 (if (atom x)
638 (list x)
639 x)))
640
641(defun null-or-cdr (l)
642 (if l
643 (cdr l)
644 l))
645
646(defun null-or-cadr (l)
647 (if l
648 (cadr l)
649 l))
650
651(define-doc-handler DEFCLASS (form)
652 "class"
653 ;; name super-types slots &rest options
654 (let ((class-options (nthcdr 4 form))
655 (class-name (second form))
656 (superclass-names (third form))
657 (slots (fourth form)))
658 (values class-name
659 :blank ; no args per se
660 (format nil "~@[~A~]~@[~%Metaclass~%~(~A~)~]~%Superclasses~%~:[~:(~A~)~;~{~(~A~)~}~]~
661 ~%Initialization Arguments~:[~%None.~;~@[~:{~@[~%The :~(~A~) argument is a ~@[~(~A~)~]~]~}~]~]~
662 ~%Readers~:[~%None.~;~@[~{~@[~{~@[~{~%~(~A~)~AGeneric Function~
663 ~%~A~(~A~)~
664 ~%Returns ~@[~A~]~
665 ~}~]~
666 ~}~]~
667 ~}~]~]~
668 ~%Writers~:[~%None.~;~@[~{~@[~{~@[~{~%setf (~(~A~) ~(~A~))~AGeneric Setf Form~
669 ~%~A~(~A~)~
670 ~%The ~(~A~) argument should be a ~
671 ~@[~A~]~
672 ~}~]~
673 ~}~]~
674 ~}~]~]"
675 ;; Class documentation
676 (second (assoc :documentation class-options))
677 ;; Metaclass
678 (second (assoc :metaclass class-options))
679 ;; Superclasses
680 superclass-names (or superclass-names "None.")
681 slots
682 (mapcar #'(lambda (slot)
683 (if (atom slot)
684 nil
685 (let ((key (null-or-cadr (member :initarg slot))))
686 (if key
687 (list key
688 (null-or-cadr (member :type slot)))
689 nil))))
690 slots)
691 slots
692 (mapcar #'(lambda (slot)
693 (if (atom slot)
694 nil
695 (mapcar #'(lambda (acc)
696 (list acc #\tab
697 #\tab class-name
698 (null-or-cadr (member :documentation slot))
699 ))
700 (append (listify (null-or-cadr (member :reader slot)))
701 (listify (null-or-cadr (member :accessor slot)))))))
702
703 slots)
704 slots
705 (mapcar #'(lambda (slot)
706 (if (atom slot)
707 nil
708 (mapcar #'(lambda (acc)
709 (list acc class-name #\tab
710 #\tab acc
711 acc
712 (null-or-cadr (member :documentation slot))
713 ))
714 (append (listify (null-or-cadr (member :writer slot)))
715 (listify (null-or-cadr (member :accessor slot)))))))
716
717 slots)
718 ))))
719
720
721;;; ********************************
722;;; Doc Handlers for Lucid's FFI ***
723;;; ********************************
724;;; Doc-handlers for Lucid's foreign function interface
725
726#+:lucid
727(define-doc-handler def-foreign-synonym-type (form)
728 "foreign synonym type"
729 (values (second form) (third form) nil))
730
731#+:lucid
732(define-doc-handler def-foreign-struct (form)
733 "foreign synonym type"
734 (values (second form)
735 (mapcar #'car
736 (cddr form))
737 nil))
738
739#+:lucid
740(define-doc-handler def-foreign-function (form)
741 "foreign function"
742 (values (atom-or-car (second form))
743 (if (stringp (third form))
744 (cddr form)
745 (cdddr form))
746 (third form)))
747
748
749
750
751;;; ********************************
752;;; Create User Manual *************
753;;; ********************************
754(defvar *failed-definition-types* nil
755 "List of definition types that create-user-manual couldn't handle.")
756
757(defun create-user-manual (filename &key
758 (output-format 'text)
759 (output-stream *standard-output*)
760 (purge-latex t)
761 (purge-latex-in-doc-strings t))
762 "Automatically creates a user manual for the functions in a file by
763 collecting the documentation strings and argument lists of the
764 functions and formatting the output nicely. Returns a list of the
765 definition types of the forms it couldn't handle. Output-format may
766 be either 'TEXT, 'SCRIBE or 'LATEX. In this last case the extra
767 keyword 'purge-latex' may be specified: if non nil the latex filter
768 will try to substitute possible dangerous characters like '&', '\\' and
769 '#'."
770 (setq *failed-definition-types* nil)
771 (with-open-file (stream filename :direction :input)
772 (let ((eof (gensym)))
773 (format t "~%;;; Formatting ")
774 (case output-format
775 ((text :text) (format t "text"))
776 ((scribe :scribe) (format t "SCRIBE"))
777 ((latex :latex) (format t "LaTeX")))
778 (format t " manual from Lisp file: ~a" filename)
779 (do ((form (read stream nil eof nil)
780 (read stream nil eof nil)))
781 ((eq form eof)
782 *failed-definition-types*)
783 (when (listp form)
784 (handle-form-output form
785 output-format
786 output-stream
787 purge-latex
788 purge-latex-in-doc-strings))))))
789
790(defun handle-form-output (form &optional (output-format 'text)
791 (stream *standard-output*)
792 (purge-latex t)
793 (purge-latex-in-doc-strings t))
794 "This function takes a form as input and outputs its documentation
795 segment to the output stream."
796 (let* ((key (first form))
797 (handler-entry (find-doc-handler key)))
798 (cond (handler-entry
799 (let ((handler (first handler-entry))
800 (type (second handler-entry))
801 )
802 (multiple-value-bind (name args documentation qualifiers)
803 (funcall handler form)
804 (let ((name-length 0)
805 (args (cond ((stringp args) ; variable
806 (format nil "~S" args))
807 ((null args)
808 "()")
809 ((eq args :blank) "")
810 (t args)))
811 (type-pos (- 80 1)) ; 1 for right margin
812 (args-list-form args)
813 )
814 (setq name (format nil "~:@(~A~)~@[~{ ~S~}~]" name qualifiers)
815 type (format nil "~:@(~A~)" type)
816 name-length (length name)
817 )
818 ;; subtract the width of [type]
819 (decf type-pos (+ (length type) 2))
820 (let ((width (- type-pos (+ 1 4 1 ) name-length)))
821 (unless (or (eq output-format 'text)
822 (eq output-format :text))
823 ;; Add in the width of ";;; " since we use it
824 ;; only in text mode.
825 (incf width 4))
826 (setq args
827 #+:XP(xp-split-string args width)
828 #-:XP(split-string (format nil "~(~S~)" args)
829 width t)))
830 (ccase output-format
831 ((text :text)
832 (output-text-documentation name type args documentation
833 name-length type-pos
834 stream))
835 ((scribe :scribe)
836 (output-scribe-documentation name type args documentation
837 stream))
838 ((latex :latex)
839 (output-latex-documentation name type
840 args-list-form
841 documentation
842 stream
843 purge-latex
844 purge-latex-in-doc-strings)))
845 ))))
846 ((eq key 'eval-when)
847 (dolist (f (cddr form))
848 (handle-form-output f output-format stream)))
849 (t
850 (pushnew key *failed-definition-types*)))))
851
852(defun find-keyword (sym)
853 (find-symbol (symbol-name sym) :keyword))
854
855(defun output-frame-documentation (name type args documentation
856 &optional (stream *standard-output*))
857 "Prints out the user guide entry for a form in FrameMaker(tm) mode."
858 (format stream "~%~A~A~A~%" name #\tab (string-capitalize (symbol-name type)))
859 (when (and args (not (equal args '(()))))
860 (format stream "Syntax~%")
861 (format stream "~A" name)
862 (format stream "~A" #\tab)
863 (let ((&rest-p nil)
864 (&key-p nil)
865 (&aux-p nil)
866 (&optional-p nil)
867 (first-&aux-p t)
868 (first-&key-p t)
869 (first-&optional-p t))
870 (dolist (arg args)
871 (case arg
872 (&rest (setf &rest-p t)
873 (setf &key-p nil)
874 (setf &optional-p nil)
875 (format stream "~%~A&rest~A" #\tab #\tab))
876 (&key (setf &key-p t)
877 (setf &rest-p nil)
878 (setf &optional-p nil)
879 (format stream "~%~A&key~A" #\tab #\tab))
880 (&optional (setf &optional-p t)
881 (setf &rest-p nil)
882 (setf &key-p nil)
883 (format stream "~%~A&optional~A" #\tab #\tab))
884 (&aux (setf &aux-p t)
885 (setf &rest-p nil)
886 (setf &key-p nil)
887 (setf &optional-p nil)
888 (format stream "~%~A&aux" #\tab))
889 (t (cond (&rest-p
890 (format stream "~(~A~)" arg))
891 (&aux-p
892 (unless first-&aux-p
893 (format stream "~%~%~A~A" #\tab #\tab)
894 (setf first-&aux-p nil))
895 (format stream "~(~A~)" arg))
896 (&key-p
897 (unless first-&key-p
898 (format stream "~%~%~A~A" #\tab #\tab)
899 (setf first-&key-p nil))
900 (if (listp arg)
901 (let ((key (car arg)))
902 (if (listp key)
903 (format stream "~((:~A ~A)~)"
904 (car key)
905 (second arg))
906 (format stream "(:~(~A~) ~(~A)~)"
907 key
908 (second arg))))
909 (format stream "~(~A~) " arg)))
910 (&optional-p
911 (unless first-&optional-p
912 (format stream "~%~%~A~A" #\tab #\tab)
913 (setf first-&optional-p nil))
914 (format stream "~(~A~) "
915 (if (listp arg)
916 (cons (car arg) (cadr arg))
917 arg)))
918 (t ;;(if (listp arg)
919 ;; (format stream "(~(~A~) ~(~A~))" (first arg) (second arg))
920 (format stream "~%~A~(~A~)" #\tab arg)))))))
921 (when args
922 (format stream "~%Arguments")
923 (let ((&rest-p nil)
924 (&key-p nil)
925 (&optional-p nil))
926 (dolist (arg args)
927 (case arg
928 (&rest (setf &rest-p t))
929 (&key (setf &key-p t)
930 (setf &rest-p nil)
931 (setf &optional-p nil))
932 (&optional (setf &optional-p t)
933 (setf &rest-p nil)
934 (setf &key-p nil))
935 (&aux (setf &rest-p nil)
936 (setf &key-p nil)
937 (setf &optional-p nil))
938 (&allow-other-keys (setf &rest-p nil))
939 (t (cond (&rest-p
940 (format stream "~%The ~(~A~) argument consists of " arg)
941 (setf &rest-p nil))
942 (t (format stream "~%The ")
943 (cond (&key-p
944 (if (listp arg)
945 (let ((key (car arg)))
946 (format stream ":~(~A~)"
947 (if (listp key)
948 (car key)
949 key)))
950 (format stream ":~(~A~)" arg)))
951 (&optional-p
952 (format stream "~(~A~)"
953 (if (listp arg)
954 (car arg)
955 arg)))
956 (t (if (listp arg)
957 (format stream "~(~A~)" (car arg))
958 (format stream "~(~A~)" arg))))
959 (format stream " argument is a "))))))))
960 (format stream "~%Values~%The result is ")
961 (format stream "~%Purpose"))
962 (when (stringp documentation)
963 (format stream "~%")
964 (format stream documentation)))
965
966(defun output-text-documentation (name type args documentation args-tab-pos
967 type-pos
968 &optional (stream *standard-output*))
969 "Prints out the user guide entry for a form in TEXT mode."
970 (format stream "~%;;; ~A ~A ~VT[~A]" name (first args) type-pos type)
971 (dolist (arg (rest args))
972 (format stream "~%;;; ~0,1,V,' @A"
973 (+ #+:XP 1 #-:XP 2 args-tab-pos)
974 arg))
975 (when (stringp documentation)
976 ;; We give a line width of 70 characters for documentation
977 ;; strings. This leaves us room for a left margin of
978 ;; ";;; " and a right margin of 3 spaces (2 chars left of []).
979 (dolist (string (split-string documentation 70 nil nil nil))
980 (format stream "~&;;; ~A" string)))
981 (format stream "~%;;;"))
982
983(defun output-scribe-documentation (name type args documentation
984 &optional (stream *standard-output*))
985 "Prints out the user guide entry for a form in SCRIBE mode."
986 (format stream "~%@begin(format,group)~%@tabclear()")
987 (format stream "~%@t[~(~A~)] @^~A@>[~:(~A~)]"
988 name (first args) type)
989 (dolist (arg (rest args))
990 (format stream #+:XP "~%@\\@ ~A" #-:XP "~%@\\~A"
991 arg))
992 (format stream "~%@tabclear()")
993 ;; (format stream "~%@hinge()")
994 (format stream "~%@begin(quotation,indent 0,size +0)")
995 (when (stringp documentation)
996 (dolist (string (split-string documentation 70 nil nil nil))
997 (format stream "~%~A" string)))
998 (format stream "~%@end(quotation)~%@end(format)~%"))
999
1000(defun output-latex-documentation (name type args documentation
1001 &optional
1002 (stream *standard-output*)
1003 (purge-documentation t)
1004 (purge-documentation-in-doc-strings t))
1005 "Prints out the user guide entry for a form in LaTeX mode."
1006 (format stream "\\begin{lisp:documentation}")
1007 (format stream "{~(~A~)}{~A}" (purge-string-for-latex name purge-documentation) type)
1008 (format stream "~:[{\\ }~;{~{~(~A~) ~}}~]~%"
1009 args (preprocess-lisp-latex-clashes args purge-documentation))
1010 (if (stringp documentation)
1011 (format stream "~{~A~%~}"
1012 (split-string (purge-string-for-latex documentation
1013 purge-documentation-in-doc-strings)
1014 70 nil nil nil))
1015 (format stream "{\\ } % NO DOCUMENTATION FOR ~A~%" name))
1016 (format stream "\\end{lisp:documentation}~2%"))
1017
1018(defun purge-string-for-latex (a-string purge-doc)
1019 "Tries to purge a string from characters that are potentially
1020 dangerous for LaTeX."
1021 (if purge-doc
1022 (with-input-from-string (a-str a-string)
1023 (with-output-to-string (result)
1024 (let ((eos (gensym)))
1025 (do ((c (read-char a-str nil eos nil)
1026 (read-char a-str nil eos nil)))
1027 ((eq c eos) result)
1028 (case c
1029 (#\& (format result "\\&"))
1030 (#\\ (format result "$\\backslash$")) ; I have to
1031 ; resort to math
1032 ; mode to do this.
1033 (#\# (format result "\\#"))
1034 (#\$ (format result "\\$"))
1035 (#\% (format result "\\%"))
1036 (#\{ (format result "\\{"))
1037 (#\} (format result "\\}"))
1038 (#\_ (format result "\\_}"))
1039 (#\> (format result "$>$")) ;how to do this right? (M.R)
1040 (#\< (format result "$<$"))
1041 (#\^ (format result "\\symbol{94}"))
1042 (#\~ (format result "\\symbol{126}"))
1043 (t (format result "~C" c)))))
1044 ))
1045 a-string
1046 ))
1047
1048(defun preprocess-lambda-keywords (args)
1049 "Unused"
1050 (mapcar #'(lambda (arg)
1051 (if (member arg lambda-list-keywords :test #'eq)
1052 (format nil "{\\sf \\~(~A~)}" arg)
1053 arg))
1054 args))
1055
1056(defun preprocess-lisp-latex-clashes (args purge-doc)
1057 "This function is used to make the strings for the arguments of the
1058 form digestible for LaTeX, e.g. by removing '#' and '&'."
1059 (if (stringp args)
1060 (list args)
1061 (mapcar #'(lambda (arg)
1062 (cond ((member arg lambda-list-keywords :test #'eq)
1063 (format nil "{\\sf \\~(~A~)}" arg))
1064 ((listp arg) ; OK OK I am missing cons cells!
1065 (preprocess-specials arg purge-doc))
1066 ((characterp arg)
1067 (preprocess-character arg))
1068 (t (purge-string-for-latex
1069 (format nil "~S" arg)
1070 purge-doc))))
1071 args)))
1072
1073(defun preprocess-character (c)
1074 "Low level processing of single characters, when passed as defaults
1075 to optional, key and aux parameters."
1076 ;; The stupid LaTeX manual does not tell be how to produce a single
1077 ;; '\' without being in math mode, so I have to trick it.
1078 (case c
1079 (#\newline "\\#$\\backslash${newline}")
1080 (#\space "\\#$\\backslash${space}")
1081 (#\rubout "\\#$\\backslash${rubout}")
1082 (#\page "\\#$\\backslash${page}")
1083 (#\backspace "\\#$\\backslash${backspace}")
1084 (#\return "\\#$\\backslash${return}")
1085 (#\linefeed "\\#$\\backslash${linefeed}")
1086 (t c)))
1087
1088(defun preprocess-specials (list-form purge-doc)
1089 "Processing of some 'special' forms. Only 'quote' and 'function' are
1090 treated for the time being."
1091 (case (first list-form)
1092 (function
1093 (format nil "\\#'~A"
1094 (purge-string-for-latex
1095 (format nil "~A" (second list-form))
1096 purge-doc)))
1097 (quote
1098 (format nil "'~A"
1099 (purge-string-for-latex
1100 (format nil "~A" (second list-form))
1101 purge-doc)))
1102 (t (preprocess-lisp-latex-clashes list-form purge-doc))))
1103
1104#+:XP
1105(defun xp-split-string (arglist width)
1106 "PPrints the arglist into a string of specified width. Assumes
1107 that we're running the XP pretty printer."
1108 (let ((xp::*default-right-margin* width)
1109 (xp::*print-miser-width* 30)
1110 string)
1111 (cond ((stringp arglist) (list arglist))
1112 (t
1113 (setq string
1114 (with-output-to-string (stream) (pprint arglist stream)))
1115 (setq string (format nil "~(~A~)" string))
1116 (setq string (remove-if #'(lambda (x) (string-equal x ""))
1117 (parse-with-delimiter string #\newline)))
1118 string))))
1119
1120(defun split-string (string width
1121 &optional arglistp filled (trim-whitespace t))
1122 "Splits a string into a list of strings, each of which is shorter
1123 than the specified width. Tries to be intelligent about where to
1124 split the string if it is an argument list. If filled is T,
1125 tries to fill out the strings as much as possible. This function
1126 is used to break up long argument lists nicely, and to break up
1127 wide lines of documentation nicely."
1128 (let ((string-list (parse-with-delimiter string #\newline))
1129 (result nil))
1130 (do* ((rest string-list (rest rest))
1131 (s (car rest) (car rest)))
1132 ((null rest)
1133 (nreverse result))
1134 (multiple-value-bind (first second) (split-point s width arglistp filled)
1135 (if trim-whitespace
1136 (setf first (string-trim '(#\space #\tab) first))
1137 (when (and (> (length first) 0)
1138 (char= (char first 0) #\space))
1139 (if (and (> (length first) 3)
1140 (char= (char first 1) #\space)
1141 (char= (char first 2) #\space)
1142 (not (char= (char first 3) #\space)))
1143 (setf first (string-trim '(#\space #\tab) first))
1144 (setf first (subseq first 1)))))
1145 (when (not (string-equal first ""))
1146 (push first result))
1147 (when (and second (not (string-equal second "")))
1148 (setf rest
1149 (list*
1150 nil
1151 (concatenate 'string
1152 (string-trim '(#\space #\tab) second)
1153 " "
1154 (and (cadr rest)
1155 (string-trim '(#\space #\tab)
1156 (cadr rest))))
1157 (cddr rest))))))))
1158
1159;;; need some way for the last line from an arglist to possibly
1160;;; be split, even if it has a perfect fit.
1161(defun split-point (string max-length &optional arglistp filled)
1162 "Finds an appropriate point to break the string at given a target length.
1163 If arglistp is T, tries to find an intelligent position to break the
1164 string. If filled is T, tries to fill out the string as much as possible."
1165 ;; we probably should split some strings that are short enough anyway
1166 ;; but need a base condition to prevent infinite loops.
1167 (cond ((< (length string) max-length)
1168 (let ((lambda (lambda-list-keyword-position string (length string)
1169 t)))
1170 (if (and arglistp lambda (not (zerop lambda)))
1171 (values (subseq string 0 lambda)
1172 (unless (= lambda (length string))
1173 (subseq string lambda)))
1174 string)))
1175 (t
1176 ;; Find the first space that breaks the arglist.
1177 ;; If parentheses are not balanced at this point,
1178 ;; go to the first balanced paren that isn't at position
1179 ;; zero (actually, the conditions are much more complex).
1180 ;; Then check if the previous "word" is a lambda-list keyword.
1181 ;; This gives it a preference for lambda-list keywords.
1182 (let* ((space-pos (position #\space string :from-end t
1183 :end max-length))
1184 (pos space-pos))
1185 (when arglistp
1186 (let* ((paren (balanced-parenthesis-position
1187 string (or space-pos max-length)))
1188 (lambda (lambda-list-keyword-position
1189 string (or paren max-length))))
1190 (cond ((and lambda paren space-pos arglistp
1191 (not (zerop lambda))
1192 (or (not filled)
1193 (< (- max-length 10) lambda max-length)))
1194 (setq pos lambda))
1195 ((and paren space-pos
1196 arglistp
1197 (not (zerop paren))
1198 (or (not filled)
1199 (< (- max-length 10) paren max-length)))
1200 (setq pos paren)))))
1201 (if pos
1202 (values (subseq string 0 pos)
1203 (unless (= pos (length string))
1204 (subseq string pos)))
1205 string)))))
1206
1207(defun lambda-list-keyword-position (string &optional end trailer-only)
1208 "If the previous symbol is a lambda-list keyword, returns
1209 its position. Otherwise returns end."
1210 ;; possibly extend this to also search for colons for keywords?
1211 (when (null end) (setf end (length string)))
1212 (let ((ampersand (position #\& string :from-end t :end end))
1213 (rightmost-space (position #\space string :from-end t :end end)))
1214 (if ampersand
1215 (cond ((find (string-trim '(#\space) (subseq string ampersand end))
1216 lambda-list-keywords
1217 :key #'symbol-name
1218 :test #'string-equal)
1219 ampersand)
1220 ((and rightmost-space (not trailer-only)
1221 (< ampersand rightmost-space)
1222 (find (string-trim '(#\space)
1223 (subseq string
1224 ampersand rightmost-space))
1225 lambda-list-keywords
1226 :key #'symbol-name
1227 :test #'string-equal))
1228 ampersand)
1229 (t
1230 end))
1231 end)))
1232
1233(defun balanced-parenthesis-position (string &optional end)
1234 "Finds the position of the left parenthesis which is closest to END
1235 but leaves the prefix of the string with balanced parentheses or
1236 at most 1 unbalanced left parenthesis."
1237 (when (null end) (setf end (length string)))
1238 (let* ((num-left (count #\( string :end end))
1239 (num-right (count #\) string :end end))
1240 (imbalance (max 0 (- num-left num-right)))
1241 (leftmost-left-paren (position #\( string :end end))
1242 (leftmost-right-paren (position #\) string :end end))
1243 (rightmost-left-paren (position #\( string :end end :from-end t)))
1244 (cond ((and leftmost-left-paren leftmost-right-paren
1245 (< leftmost-right-paren leftmost-left-paren))
1246 ;; if we have ")(", break after the right paren.
1247 leftmost-left-paren)
1248 ((and leftmost-right-paren (not leftmost-left-paren))
1249 ;; we have a right paren but no left
1250 (1+ (position #\) string :from-end t :end end)))
1251 ((or (= imbalance 0)
1252 (and (or (char= (char string 0) #\()
1253 (char= (char string 0) #\&))
1254 (cond (leftmost-right-paren
1255 ;; there's a right paren and the left
1256 ;; parens before it account for the imbalance
1257 ;; actually, we need to do a fancier balancing
1258 ;; operation here to absorb balanced left
1259 ;; parentheses.
1260 (not (< (1- (count #\( string
1261 :end leftmost-right-paren))
1262 imbalance)))
1263 ((find #\space string :end rightmost-left-paren)
1264 nil)
1265 (t))))
1266 ;; either we're balanced, or the imbalance is due to
1267 ;; left-parens at the left edge.
1268 end)
1269 (t
1270 ;; let's try to reduce the imbalance
1271 (if (and rightmost-left-paren (not (zerop rightmost-left-paren)))
1272 (balanced-parenthesis-position string rightmost-left-paren)
1273 end)))))
1274
1275;;; This was a preliminary BUILD-SYMBOL.
1276;;; I've given a more complex implementation of this to Mark
1277;;; to include in EXTENSIONS or something like that. - fdmm
1278(defun um-build-symbol (symbol &key (prefix nil prefix-p)
1279 (suffix nil suffix-p)
1280 (package nil package-p))
1281 "Build a symbol concatenating prefix (if not null), symbol, and suffix (if not null).
1282 The newly generated symbol is interned in package, if not null, or in the SYMBOL-PACKAGE of symbol, otherwise."
1283 (let ((newname (symbol-name symbol)))
1284 (when prefix-p
1285 (setf newname (concatenate 'string (symbol-name prefix) newname)))
1286 (when suffix-p
1287 (setf newname (concatenate 'string newname (symbol-name suffix))))
1288 (if package-p
1289 (intern newname package)
1290 (intern newname (symbol-package symbol)))))
1291
1292(defun create-manuals (files &key (prefix nil)
1293 (extension '.cl)
1294 (output-format 'text)
1295 (purge-latex t)
1296 (purge-latex-in-doc-strings t))
1297 (format t "~%;;;~%;;; User manuals will be created in directory ~A~%;;;" (string-downcase prefix))
1298 (loop for file in files do
1299 (WITH-OPEN-FILE
1300 (STREAM (string-downcase
1301 (symbol-name
1302 (um-build-symbol file
1303 :prefix prefix
1304 :suffix (case output-format
1305 ((text :text) '.txt)
1306 ;What would be a `standard' extension for SCRIBE?
1307 ((scribe :scribe) '.scb)
1308 ((frame :frame) '.fm)
1309 ((latex :latex) '.tex)))))
1310 :DIRECTION :OUTPUT
1311 :if-does-not-exist :create
1312 :IF-EXISTS :new-version)
1313 (CREATE-USER-MANUAL (string-downcase (symbol-name
1314 (um-build-symbol file
1315 :suffix extension)))
1316 :OUTPUT-STREAM STREAM
1317 :output-format output-format
1318 :purge-latex purge-latex
1319 :purge-latex-in-doc-strings purge-latex-in-doc-strings)))
1320 (format t "~%;;;~%;;; END OF MANUAL PROCESSING.~%;;;"))
1321
1322(defun parse-with-delimiter (line &optional (delim #\newline))
1323 "Breaks LINE into a list of strings, using DELIM as a
1324 breaking point."
1325 ;; what about #\return instead of #\newline?
1326 (let ((pos (position delim line)))
1327 (cond (pos
1328 (cons (subseq line 0 pos)
1329 (parse-with-delimiter (subseq line (1+ pos)) delim)))
1330 (t
1331 (list line)))))
1332
1333;;; ********************************
1334;;; Dead Code **********************
1335;;; ********************************
1336
1337#|
1338;(split-string "the quick brown fox jumped over the lazy dogs" 20)
1339
1340(split-string "(((&OPTIONAL (NODE (QUOTE NODE)) (QUEUE (QUOTE QUEUE))
1341 (CHILDREN (QUOTE CHILDREN)) VISITED)
1342 INITIAL-QUEUE CHILDREN-FORM &OPTIONAL
1343 (DEQUEUE-FORM (QUOTE (POP QUEUE)))
1344 (MERGE-FORM (QUOTE (SETQ QUEUE (APPEND QUEUE PROGENY))))
1345 RESULT-FORM)
1346 &BODY BODY)" 30 t)
1347
1348;(BALANCED-PARENTHESIS-POSITION "foo the (bar baz) (biz" )
1349
1350|#
1351
Note: See TracBrowser for help on using the repository browser.