xlisponly/lsp/document.lsp

   1 ;;;; This file provide various documentation functions, taking some existing
   2 ;;;; XLISP-PLUS functionality and merging it with new Common Lisp functions.
   3
   4 ; Author -- Tom Almy,  10/96
   5
   6 ;;; It supercedes glos.lsp.  Do not load glos.lsp if this file is used!
   7
   8 ;;; This file adds these new functions:
   9
  10 ;;; DOCUMENTATION -- get/set documentation string.
  11 ;;; This function will fetch glossary info
  12 ;;; for functions and variables defined in glos.txt (see description of GLOS
  13 ;;; below) as well provided via DOCUMENTATION used with SETF or with
  14 ;;; the DEF* macros listed below.
  15
  16 ;;; The documentation types variable, function, structure, and setf are stored
  17 ;;; in properties named %doc-function, %doc-structure, %doc-variable, and
  18 ;;; %doc-setf. In addition, documentation type type with property %doc-type
  19 ;;; is provided for completeness.
  20
  21 ;;; DEFCONSTANT, DEFPARAMETER, DEFVAR, DEFUN, DEFMACRO, DEFSTRUCT, and DEFSETF
  22 ;;; are modified to have the documentation arguments functional.
  23
  24 ;;; GLOS -- glossary function
  25
  26 ; GLOS requires the package and multiple value return facilities to
  27 ; work, and uses a file called glos.txt which is the glossary portion
  28 ; of the XLISP documentation file When loaded for the first time, it
  29 ; adds documentation marks for all functions which are defined in
  30 ; glos.txt and are in the XLISP package.  This property is the
  31 ; displacement into the file. When a glossary lookup occurs (or the
  32 ; DOCUMENTATION function is used) the file itself is referenced. By
  33 ; operating this way, very little space is taken for this feature.
  34
  35 ; There are two user-accessable symbols. tools:*glospaging* is a variable
  36 ; which causes the output to "page" (pause for user response) at every
  37 ; screenful. Set it to NIL to defeat this feature or to the number of lines
  38 ; per page to enable.
  39
  40 ; The main entry point is the function tools:glos. When given an
  41 ; argument that is a function symbol, it will look up the glossary
  42 ; definition. If the symbol is not visible, or if a second non-nil
  43 ; argument is supplied, the name will be passed to APROPOS, and the
  44 ; glossary definitions for all matching symbols will be displayed
  45
  46 ; For instance (glos :car) or (glos 'car) will show the definition for
  47 ; the CAR function, while (glos 'car t) or (glos "car") will show that
  48 ; of MAPCAR as well. (glos "X") will give the glossary listing of all
  49 ; functions with names containing an X character.
  50
  51
  52 #-:packages
  53 (error "This utility was written asuming the package facility is in use")
  54
  55 #-:mulvals
  56 (error "This utility was written asuming multiple value return is in use")
  57
  58 #-:common
  59 (load "common")       ;; make sure these are defined first
  60
  61 (in-package "XLISP")
  62
  63 (export '(documentation variable function structure setf))
  64
  65 (in-package "TOOLS")
  66
  67
  68 ; This is the glos.lsp package, modified to be integrated with
  69 ; DOCUMENTATION. Glos.lsp should not be loaded if this file is used!
  70 ;
  71
  72 (export '(glos *glospaging*))
  73
  74 (import '(xlisp::%doc-function xlisp::%doc-variable))
  75
  76 (defvar *glosfilename*)
  77
  78 (setq *glosfilename* nil)
  79
  80 ; We will look things up while loading
  81 ; so we can toss all the code when done
  82
  83 (unless *glosfilename*
  84         (format t "~&Building glossary references---")
  85         (let ((lpar #\()
  86               (rpar #\))
  87               (dot #\.)
  88               (*pos* 0)
  89               symbol)
  90              (labels
  91 (
  92
  93
  94 (xposition (chr str &aux (pos (position chr str)))
  95        (if pos pos (length str)))
  96
  97 (seek-next-fcn (strm)
  98        (do ((thispos *pos* (file-position strm))
  99             (text (read-line strm nil) (read-line strm nil)))
 100            ((null text) nil)
 101            (when (and (> (length text) 1)
 102                       (or (char= lpar (char text 0))
 103                           (char= dot (char text 0))))
 104                  (setf *pos* thispos)
 105                  (return-from seek-next-fcn
 106                               (cons (char= dot (char text 0))
 107                                     (subseq text 1 (min (xposition rpar text)
 108                                                   (xposition #\space text)))))))))
 109
 110 ;; The body of the code that does the work:
 111               (unless (open "glos.txt" :direction :probe)
 112                       (error "Could not find glossary file glos.txt"))
 113               (with-open-file
 114                (strm "glos.txt")
 115                (setq *glosfilename* (truename strm))
 116                (do ((name (seek-next-fcn strm) (seek-next-fcn strm)))
 117                    ((null name) nil)
 118                    (setq symbol (find-symbol (string-upcase (cdr name))))
 119                    (unless symbol
 120                            (if (string-equal (cdr name) "nil")
 121                                (setf (get nil '%doc-variable) (abs *pos*))
 122                                (format t
 123                                        "~&Documented symbol ~s not found in XLISP.~%"
 124                                        (cdr name))))
 125                    (when symbol
 126 ;;                       (format t "~s ~s" symbol *pos*)
 127                          (setf (get symbol (if (car name)
 128                                                '%doc-variable
 129                                                '%doc-function))
 130                                (abs *pos*)))))
 131 ;; Check for functions & vars in package XLISP that aren't documented
 132               (format t "~&Not documented, but found in XLISP:")
 133               (do-external-symbols
 134                (x :xlisp)
 135                (when (or (and (fboundp x) (not (get x '%doc-function)))
 136                          (and (specialp x) (not (get x '%doc-variable))))
 137                      (format t "~s " x)))
 138               (format t "~&")
 139
 140 ))) ;; Ends the Flet, let, and unless
 141
 142 (defvar *linecount*)
 143 (defvar *glospaging* 23)
 144
 145 (defun linechk ()
 146        (when (and *glospaging*
 147                   (> (incf *linecount*) *glospaging*))
 148              (setq *linecount* 0)
 149              (if (y-or-n-p "--PAUSED--  Continue?")
 150                  (fresh-line)
 151                  (throw 'getoutahere))))
 152
 153 (defun ppstring (string &aux (strm (make-string-input-stream string)))
 154        (do ((line (read-line strm nil) (read-line strm nil)))
 155            ((zerop (length line))
 156             (linechk)
 157             (format t "~%"))
 158            (linechk)
 159            (format t "~a~%" line)))
 160
 161 (defun glosx (val &aux (ostrm (make-string-output-stream)))
 162        (with-open-file
 163         (strm *glosfilename*)
 164         (file-position strm (abs val))
 165         (do ((line (read-line strm nil) (read-line strm nil)))
 166             ((zerop (length line))
 167              (format ostrm "~%"))
 168             (if (eq #\. (char line 0))
 169                 (format ostrm "~a~%" (subseq line 1))
 170                 (format ostrm "~a~%" line))))
 171        (get-output-stream-string ostrm))
 172
 173 (defun glos (symbol &optional matchall
 174                     &aux val val2 val3 (sym (string symbol)))
 175        (catch
 176         'getoutahere
 177         (setq *linecount* 0)
 178         (if (and (null matchall) (setq val (find-symbol sym)))
 179             (progn (when (setq val2 (documentation val 'function))
 180                          (ppstring val2))
 181                    (when (setq val3 (documentation val 'variable))
 182                          (ppstring val3))
 183                    (unless (or val2 val3)
 184                            (format t "No information on ~a~%" sym)))
 185             (progn
 186              (setq val
 187                    (do ((list (apropos-list sym) (cdr list))
 188                         (result nil result))
 189                        ((null list) result)
 190                        (when (setq val2 (documentation (car list) 'function))
 191                              (when (not (member val2 result :test #'string-equal))
 192                                    (push val2 result)))
 193                        (when (setq val2 (documentation (car list) 'variable))
 194                              (when (not (member val2 result :test #'string-equal))
 195                                    (push val2 result)))))
 196
 197              (if (zerop (length val))
 198                  (format t "No matches for ~a~%" symbol)
 199                  (map nil #'ppstring val)))))
 200        (values)
 201 )
 202
 203 (in-package "XLISP")
 204 (defun documentation (sym type &aux value)
 205        (unless (symbolp sym) (error "bad argument type - ~s" sym))
 206        (setq
 207         value
 208         (case type
 209               (variable (get sym '%doc-variable))
 210               (function (get sym '%doc-function))
 211               (structure (get sym '%doc-structure))
 212               (setf (get sym '%doc-setf))
 213               (type (get syp '%doc-type))
 214               (t (error "invalid documentation type - ~s" type))))
 215        (if (numberp value)
 216            (tools::glosx value)
 217            value))
 218
 219 (defsetf documentation (sym type) (val)
 220          (case (eval type)
 221                (variable `(setf (get ,sym '%doc-variable) ,val))
 222                (function `(setf (get ,sym '%doc-function) ,val))
 223                (structure `(setf (get ,sym '%doc-structure) ,val))
 224                (setf `(setf (get ,sym '%doc-setf) ,val))
 225                (type `(type (get ,sym '%doc-type) ,val))
 226                (t (error "invalid documentation type - ~s" type))))
 227
 228 ;; If we haven't done it before, save function binding of defining words
 229
 230 (unless (fboundp 'old-defun)
 231         (setf (symbol-function 'old-defun)
 232               (symbol-function 'defun)))
 233 (unless (fboundp 'old-defmacro)
 234         (setf (symbol-function 'old-defmacro)
 235               (symbol-function 'defmacro)))
 236 (unless (fboundp 'old-defvar)
 237         (setf (symbol-function 'old-defvar)
 238               (symbol-function 'defvar)))
 239 (unless (fboundp 'old-defparameter)
 240         (setf (symbol-function 'old-defparameter)
 241               (symbol-function 'defparameter)))
 242 (unless (fboundp 'old-defconstant)
 243         (setf (symbol-function 'old-defconstant)
 244               (symbol-function 'defconstant)))
 245 (unless (fboundp 'old-defstruct)
 246         (setf (symbol-function 'old-defstruct)
 247               (symbol-function 'defstruct)))
 248
 249 ;; Redefine defun, defmacro, defvar, defconstant, defparameter, and defstruct
 250 ;; to update the property list and then do the original function.
 251 ;; In the case of defmacro and defvar, the documentation string is removed
 252 ;; from the definition.
 253
 254 (defmacro defun (&rest arglist)
 255           (if (and (stringp (third arglist)) (cdddr arglist))
 256               (progn
 257                (unless (symbolp (first arglist))
 258                        (error "bad argument type - ~s" (first arglist)))
 259                (setf (get (first arglist) '%doc-function) (third arglist))
 260                `(old-defun ,(first arglist)
 261                            ,(second arglist)
 262                            ,@(cdddr arglist)))
 263               `(old-defun ,@arglist)))
 264
 265 (defmacro defmacro (&rest arglist)
 266           (if (and (stringp (third arglist)) (cdddr arglist))
 267               (progn
 268                (unless (symbolp (first arglist))
 269                        (error "bad argument type - ~s" (first arglist)))
 270                (setf (get (first arglist) '%doc-function) (third arglist))
 271                `(old-defmacro ,(first arglist)
 272                            ,(second arglist)
 273                            ,@(cdddr arglist)))
 274               `(old-defmacro ,@arglist)))
 275
 276 (defmacro defvar (&rest arglist)
 277           (when (stringp (third arglist))
 278                 (progn
 279                  (unless (symbolp (first arglist))
 280                          (error "bad argument type - ~s" (first arglist)))
 281                  (setf (get (first arglist) '%doc-variable) (third arglist))))
 282           `(old-defvar ,@arglist))
 283
 284
 285 (defmacro defparameter (&rest arglist)
 286           (when (stringp (third arglist))
 287                 (progn
 288                  (unless (symbolp (first arglist))
 289                          (error "bad argument type - ~s" (first arglist)))
 290                  (setf (get (first arglist) '%doc-variable) (third arglist))))
 291           `(old-defparameter ,@arglist))
 292
 293
 294 (defmacro defconstant (&rest arglist)
 295           (when (stringp (third arglist))
 296                 (progn
 297                  (unless (symbolp (first arglist))
 298                          (error "bad argument type - ~s" (first arglist)))
 299                  (setf (get (first arglist) '%doc-variable) (third arglist))))
 300           `(old-defconstant ,@arglist))
 301
 302 (defmacro defstruct (&rest arglist)
 303           (when (stringp (second arglist))
 304                 (let ((sym (if (consp (first arglist))
 305                                (caar arglist)
 306                                (first arglist))))
 307                      (unless (symbolp sym)
 308                              (error "bad argument type - ~s" (first arglist)))
 309                      (setf (get sym '%doc-structure) (second arglist))))
 310           `(old-defstruct ,@arglist))
 311