From: Peter Feigl <craven@gmx.net>
Date: Thu, 3 May 2012 07:31:24 +0000 (+0200)
Subject: Add autodoc for procedures
X-Git-Tag: release-9.2.0~243^2~4
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cc4f3f33e4221cd9d151a3b0fb44c4ad8439f754;p=mit-scheme.git

Add autodoc for procedures

* Autodoc
Actually implement swank:autodoc. It is called with a list form that contains the special symbol swank::%cursor-marker% somewhere to show the position of the cursor.
The new procedure FIND-STRING-BEFORE-SWANK-CURSOR-MARKER returns the symbol that starts the expression which contains the cursor as a string.
The new procedure PROCEDURE-PARAMETERS returns a list containing the function name and the list of parameters (as printed by PA) if symbol is bound to a function.
The new variable SWANK-EXTRA-DOCUMENTATION contains an (incomplete) list of "parameters" to special forms and macros.

Now we have working autodoc in the REPL and in Scheme buffers.
---

diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm
index ddfeee3f8..02ff0b965 100644
--- a/src/runtime/swank.scm
+++ b/src/runtime/swank.scm
@@ -430,9 +430,55 @@ USA.
   packages
   '())
 
+(define swank-extra-documentation
+  '((let bindings . body)
+    (let* bindings . body)
+    (letrec bindings . body)
+    (receive bindings expression . body)
+    (define name . body)
+    (quote expression)
+    (quasiquote expression)
+    (unquote expression)
+    (unquote-splicing expression)
+    (if test then else)
+    (set! name value)))
+
+(define (procedure-parameters symbol env)
+  (let ((type (environment-reference-type env symbol)))
+    (let ((ans (if (eq? type 'normal)
+		   (let ((binding (environment-lookup env symbol)))
+		     (if (and binding
+			      (procedure? binding))
+			 (cons symbol (read-from-string (string-trim (with-output-to-string
+								       (lambda () (pa binding))))))
+			 #f))
+		   (let ((extra (assq symbol swank-extra-documentation)))
+		     (if extra
+			 extra
+			 #f)))))
+      ans)))
+
+(define (find-string-before-swank-cursor-marker expr)
+  (if (list? expr)
+      (if (member 'swank::%cursor-marker% expr)
+	  (if (string? (car expr))
+	      (car expr)
+	      #f)
+	  (any (lambda (ex)
+		 (find-string-before-swank-cursor-marker ex))
+	       expr))
+      #f))
+
 (define (swank:autodoc socket expr . params)
   socket params
-  (list ':not-available 't))
+  (let* ((op-string (find-string-before-swank-cursor-marker expr)))
+    (if op-string
+	(let* ((op (string->symbol op-string))
+	       (type (environment-reference-type (buffer-env) op)))
+	  (let ((ans (procedure-parameters op (buffer-env))))
+	    (let ((answer (if ans (with-output-to-string (lambda () (write ans))) ':not-available)))
+	      (list answer 't))))
+	(list ':not-available 't))))
 
 (define (swank:quit-lisp socket)
   socket