/[slime]/slime/swank-lispworks.lisp
ViewVC logotype

Diff of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.115 by heller, Fri Sep 12 18:55:42 2008 UTC revision 1.116 by heller, Mon Sep 15 21:11:19 2008 UTC
# Line 154  Return NIL if the symbol is unbound." Line 154  Return NIL if the symbol is unbound."
154                 (let ((pos (position #\newline string)))                 (let ((pos (position #\newline string)))
155                   (if (null pos) string (subseq string 0 pos))))                   (if (null pos) string (subseq string 0 pos))))
156               (doc (kind &optional (sym symbol))               (doc (kind &optional (sym symbol))
157                 (let ((string (or                 (let ((string (or (documentation sym kind))))
                               (documentation sym kind)  
                               (lwdoc (symbol-name sym)  
                                      (package-name (symbol-package sym))  
                                      kind))))  
   
158                   (if string                   (if string
159                       (first-line string)                       (first-line string)
160                       :not-documented)))                       :not-documented)))
# Line 213  Return NIL if the symbol is unbound." Line 208  Return NIL if the symbol is unbound."
208    (when (fboundp sym)    (when (fboundp sym)
209      (describe-function sym)))      (describe-function sym)))
210    
 (defvar *lwdoc-types*  
   '(("%FUN-DOCUMENTATION" . function)  
     ("%VAR-DOCUMENTATION" . variable)  
     ("%SETF-DOCUMENTATION" . setf)  
     ("%STRUCT-DOCUMENTATION" . structure)))  
   
 ;; (lwdoc 'cons 'common-lisp 't)  
 (defun lwdoc (name package type)  
   "Search in $LWHOME/lwdoc for entries matching NAME and PACKAGE."  
   (lw:when-let (doc (lookup-lwdoc name package))  
     (destructuring-bind (kind description) doc  
       (when (or (eq type t)  
                 (eq (cdr (assoc kind *lwdoc-types* :test #'string-equal))  
                     type))  
         description))))  
   
 (defun lookup-lwdoc (name package)  
   (when (probe-file (sys:lispworks-file "lwdoc"))  
     (with-open-file (file (sys:lispworks-file "lwdoc"))  
       (lwdoc-search file 0 (file-length file) package name))))  
   
 ;; Use binary search, assuming that the entries are ordered alphabetically  
 (defun lwdoc-search (file min max package name)  
   (declare (optimize (sys:interruptable 3)))  
   (let ((pos (+ min (floor (- max min) 2))))  
     (and (< min (1- max))  
          (let ((record (parse-lwdoc-record file pos)))  
            (and record  
                 (destructuring-bind (rpackage rname kind doc) record  
                   ;;(format t "~d ~d ~a ~a~%" min max rpackage rname)  
                   (ecase (cond ((string-equal package rpackage)  
                                 (cond ((string-equal name rname) '=)  
                                       ((string-lessp name rname) '<)  
                                       (t '>)))  
                                ((string-lessp package rpackage) '<)  
                                (t '>))  
                     (= (list kind doc))  
                     (< (lwdoc-search file min pos package name))  
                     (> (lwdoc-search file pos max package name)))))))))  
   
 (defun parse-lwdoc-record (file position)  
   (declare (optimize (sys:interruptable 3)))  
   (file-position file position)  
   (when (peek-char #\null file nil nil)  
     ;; Search previous #\null or beginning of file  
     (do* ((end (file-position file))  
           (start end (max (- start 10) 0)))  
          (nil)  
       (file-position file start)  
       (when (= start 0) (return))  
       (peek-char #\null file)  
       (when (< (file-position file) end) (return)))  
     (peek-char #\" file)  
     (let ((key (read file))  
           (doc (read file)))  
       (peek-char #\null file)  
       (read-char file)  
       (append (lw:split-sequence ":" key :coalesce-separators t)  
               (list doc)))))  
   
211  ;;; Debugging  ;;; Debugging
212    
213  (defclass slime-env (env:environment)  (defclass slime-env (env:environment)

Legend:
Removed from v.1.115  
changed lines
  Added in v.1.116

  ViewVC Help
Powered by ViewVC 1.1.5