[slime-cvs] CVS slime

[heller]

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv17292

Modified Files:
	ChangeLog swank-lispworks.lisp 
Log Message:
For Lispworks, parse the $LWHOME/lwdoc file.

* swank-lispworks.lisp (lwdoc, lookup-lwdoc, parse-lwdoc-record):
New functions.
(describe-symbol-for-emacs): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/12 15:51:02	1.1503
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/12 18:55:42	1.1504
@@ -1,3 +1,11 @@
+2008-09-12  Helmut Eller  <heller at common-lisp.net>
+
+	For Lispworks, parse the $LWHOME/lwdoc file.
+
+	* swank-lispworks.lisp (lwdoc, lookup-lwdoc, parse-lwdoc-record):
+	New functions.
+	(describe-symbol-for-emacs): Use it.
+
 2008-09-12  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	In an SLDB buffer, `C-c C-c' will now recompile the source behind
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/09/12 12:27:38	1.114
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/09/12 18:55:42	1.115
@@ -154,7 +154,12 @@
                (let ((pos (position #\newline string)))
                  (if (null pos) string (subseq string 0 pos))))
              (doc (kind &optional (sym symbol))
-               (let ((string (documentation sym kind)))
+               (let ((string (or
+                              (documentation sym kind)
+                              (lwdoc (symbol-name sym)
+                                     (package-name (symbol-package sym))
+                                     kind))))
+                     
                  (if string 
                      (first-line string)
                      :not-documented)))
@@ -208,6 +213,66 @@
   (when (fboundp sym)
     (describe-function sym)))
 
+(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)))))
+
 ;;; Debugging
 
 (defclass slime-env (env:environment)