home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast2.iso / xlisp / xl21freq.zip / GLOS.LSP < prev    next >
Lisp/Scheme  |  1993-12-17  |  5KB  |  143 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. #-:packages
  35. (error "This utility was written asuming the package facility is in use")
  36. #-:common
  37. (load "common")
  38.  
  39. (unless (find-package "TOOLS")
  40.     (make-package "TOOLS" :use '("XLISP")))
  41.  
  42. (in-package "TOOLS")
  43.  
  44. (export '(glos *glospaging*))
  45.  
  46. (defvar *glosfilename*)
  47.  
  48. ; We will look things up while loading
  49. ; so we can toss all the code when done
  50.  
  51. (unless *glosfilename*
  52.     (format t "~&Building glossary references---")
  53.     (let ((lpar #\()
  54.           (rpar #\))
  55.           (dot #\.)
  56.           (*pos* 0)
  57.           symbol)
  58.          (labels (
  59.           
  60.  
  61. (xposition (chr str &aux (pos (position chr str)))
  62.        (if pos pos (length str)))
  63.  
  64. (seek-next-fcn (strm)
  65.        (do ((thispos *pos* (file-position strm))
  66.         (text (read-line strm nil) (read-line strm nil)))
  67.        ((null text) nil)
  68.        (when (and (> (length text) 3)
  69.               (or (char= lpar (char text 0))
  70.               (char= dot (char text 0))))
  71.          (setf *pos* thispos)
  72.          (return-from seek-next-fcn
  73.                   (subseq text 1 (min (xposition rpar text)
  74.                           (xposition #\space text))))))))
  75.  
  76. ;; The body of the code that does the work:           
  77.            (unless (open "glos.txt" :direction :probe)
  78.                (error "Could not find glossary file glos.txt"))
  79.            (with-open-file
  80.             (strm "glos.txt")
  81.             (setq *glosfilename* (truename strm))
  82.             (do ((name (seek-next-fcn strm) (seek-next-fcn strm)))
  83.             ((null name) nil)
  84.             (setq symbol (find-symbol (string-upcase name) :xlisp))
  85.             (unless symbol (format t "~&Symbol ~s not found.~%" name))
  86.             (when symbol
  87. ;                  (format t "~s " symbol)
  88.                   (setf (get symbol '*glossary*) *pos*))))
  89. ;; Check for functions & vars in package XLISP that aren't documented
  90.            (format t "~&Not documented:")
  91.            (do-external-symbols
  92.             (x :xlisp)
  93.             (when (and (or (fboundp x) (specialp x))
  94.                    (not (get x '*glossary*)))
  95.               (format t "~s " x)))
  96.            (format t "~&")
  97.  
  98. ))) ;; Ends the Flet, let, and unless
  99.  
  100. (defvar *linecount*)
  101. (defvar *glospaging* 23)
  102.  
  103. (defun linechk ()
  104.        (when (and *glospaging*
  105.           (> (incf *linecount*) *glospaging*))
  106.          (setq *linecount* 0)
  107.          (unless (y-or-n-p "--PAUSED--  Continue?")
  108.              (throw 'getoutahere))))
  109.        
  110.  
  111. (defun glos2 (sym &aux (val (get sym '*glossary*)))
  112.        (when val
  113.        (with-open-file
  114.         (strm *glosfilename*)
  115.         (file-position strm val)
  116.         (do ((line (read-line strm) (read-line strm)))
  117.         ((zerop (length line))
  118.          (linechk)
  119.          (format t "~%"))
  120.         (linechk)
  121.         (format t "~a~%" line)))))
  122.  
  123. (defun glos (symbol &optional matchall &aux val (sym (string symbol)))
  124.        (catch
  125.     'getoutahere
  126.     (setq *linecount* 0)
  127.     (if (and (null matchall) (setq val (find-symbol sym)))
  128.         (glos2 val)
  129.         (progn
  130.          (setq val (mapcan
  131.             #'(lambda (x)
  132.                   (when (eq (symbol-package x)
  133.                         (find-package :xlisp))
  134.                     (list x)))
  135.             (apropos-list sym)))
  136.          (if (zerop (length val))
  137.          (format t "No matches for ~a~%" symbol)
  138.          (map nil #'glos2 val)))))
  139. #+:mulvals (values)
  140. #-:mulvals nil
  141.        )
  142.  
  143.