[1] | 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 |
|
---|