home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / GLOS.LSP < prev    next >
Lisp/Scheme  |  1995-12-27  |  5KB  |  151 lines
  1. ; This is an XLISP-PLUS glossary lookup package.
  2. ; It requires the package facility to work, and uses a file called
  3. ; glos.txt which is the glossary portion of the XLISP documentation file
  4. ; When loaded for the first time, it adds a *glossary* property to all
  5. ; functions which are defined in glos.txt and are in the XLISP package.
  6. ; This property is the displacement into the file. When a glossary lookup
  7. ; occurs the file itself is referenced. By operating this way, very little
  8. ; space is taken for this feature.
  9.  
  10. ; There are two user-accessable symbols. tools:*glospaging* is a variable
  11. ; which causes the output to "page" (pause for user response) at every
  12. ; screenful. Set it to NIL to defeat this feature or to the number of lines
  13. ; per page to enable.
  14.  
  15. ; The main entry point is the function tools:glos. When given an argument that
  16. ; is a function symbol, it will look up the glossary definition. If the
  17. ; symbol is not in the XLISP package, or if a second non-nil argument is
  18. ; supplied, the name will be passed to APROPOS, and the glossary definitions
  19. ; for all matching symbols will be displayed
  20.  
  21. ; For instance (glos :car) or (glos 'car) or (glos "car") will show the
  22. ; definition for the CAR function, while (glos 'car t) will show that of
  23. ; MAPCAR as well. (glos "X") will give the glossary listing of all functions
  24. ; with names containing an X character, since there is no external symbol
  25. ; named X in the XLISP package.
  26.  
  27. ; It would not be that difficult to modifify this program for environments
  28. ; where packages are not compiled in, however operation would not be quite
  29. ; as sophisticated.
  30.  
  31. ;Tom Almy
  32. ;10/93
  33.  
  34. ; Revised 2/94, improving operation and clarifying some loading messages
  35.  
  36. #-:packages
  37. (error "This utility was written asuming the package facility is in use")
  38. #-:common
  39. (load "common")
  40.  
  41. (unless (find-package "TOOLS")
  42.     (make-package "TOOLS" :use '("XLISP")))
  43.  
  44. (in-package "TOOLS")
  45.  
  46. (export '(glos *glospaging*))
  47.  
  48. (defvar *glosfilename*)
  49.  
  50. ; We will look things up while loading
  51. ; so we can toss all the code when done
  52.  
  53. (unless *glosfilename*
  54.     (format t "~&Building glossary references---")
  55.     (let ((lpar #\()
  56.           (rpar #\))
  57.           (dot #\.)
  58.           (*pos* 0)
  59.           symbol)
  60.          (labels (
  61.           
  62.  
  63. (xposition (chr str &aux (pos (position chr str)))
  64.        (if pos pos (length str)))
  65.  
  66. (seek-next-fcn (strm)
  67.        (do ((thispos *pos* (file-position strm))
  68.         (text (read-line strm nil) (read-line strm nil)))
  69.        ((null text) nil)
  70.        (when (and (> (length text) 3)
  71.               (or (char= lpar (char text 0))
  72.               (char= dot (char text 0))))
  73.          (setf *pos* thispos)
  74.          (return-from seek-next-fcn
  75.                   (subseq text 1 (min (xposition rpar text)
  76.                           (xposition #\space text))))))))
  77.  
  78. ;; The body of the code that does the work:           
  79.            (unless (open "glos.txt" :direction :probe)
  80.                (error "Could not find glossary file glos.txt"))
  81.            (with-open-file
  82.             (strm "glos.txt")
  83.             (setq *glosfilename* (truename strm))
  84.             (do ((name (seek-next-fcn strm) (seek-next-fcn strm)))
  85.             ((null name) nil)
  86.             (setq symbol (find-symbol (string-upcase name) :xlisp))
  87.             (unless symbol
  88.                 (if (string-equal name "nil")
  89.                     (setf (get nil '*glossary*) *pos*)
  90.                     (format t
  91.                         "~&Documented symbol ~s not found in XLISP.~%"
  92.                         name)))
  93.             (when symbol
  94. ;                  (format t "~s " symbol)
  95.                   (setf (get symbol '*glossary*) *pos*))))
  96. ;; Check for functions & vars in package XLISP that aren't documented
  97.            (format t "~&Not documented, but found in XLISP:")
  98.            (do-external-symbols
  99.             (x :xlisp)
  100.             (when (and (or (fboundp x) (specialp x))
  101.                    (not (get x '*glossary*)))
  102.               (format t "~s " x)))
  103.            (format t "~&")
  104.  
  105. ))) ;; Ends the Flet, let, and unless
  106.  
  107. (defvar *linecount*)
  108. (defvar *glospaging* 23)
  109.  
  110. (defun linechk ()
  111.        (when (and *glospaging*
  112.           (> (incf *linecount*) *glospaging*))
  113.          (setq *linecount* 0)
  114.          (if (y-or-n-p "--PAUSED--  Continue?")
  115.          (fresh-line)
  116.          (throw 'getoutahere))))
  117.        
  118. (defun glos2 (val)
  119.        (with-open-file
  120.     (strm *glosfilename*)
  121.     (file-position strm val)
  122.     (do ((line (read-line strm nil) (read-line strm nil)))
  123.         ((zerop (length line))
  124.          (linechk)
  125.          (format t "~%"))
  126.         (linechk)
  127.         (format t "~a~%" line))))
  128.  
  129.  
  130. (defun glos (symbol &optional matchall &aux val (sym (string symbol)))
  131.        (catch
  132.     'getoutahere
  133.     (setq *linecount* 0)
  134.     (if (and (null matchall) (setq val (find-symbol sym)))
  135.         (if (setq val (get val '*glossary*))
  136.         (glos2 val)
  137.         (format t"No information on ~a~%" sym))
  138.         (progn
  139.          (setq val
  140.            (do ((list (apropos-list sym :xlisp) (cdr list))
  141.             (result nil result))
  142.                ((null list) result)
  143.                (when (setq val (get (car list) '*glossary*))
  144.                  (pushnew val result))))
  145.          (if (zerop (length val))
  146.          (format t "No matches for ~a~%" symbol)
  147.          (map nil #'glos2 val)))))
  148. #+:mulvals (values)
  149. #-:mulvals nil
  150. )
  151.