From 27048154e42befdf680be5411d11353fcd343785 Mon Sep 17 00:00:00 2001
From: Peter Feigl <address@hidden>
Date: Thu, 3 May 2012 09:58:44 +0200
Subject: [PATCH 6/6] Basic support for describing things in swank.

* Describing
Adding basic support for SWANK:DESCRIBE-FUNCTION and
SWANK:DESCRIBE-SYMBOL.
---
 src/runtime/swank.scm |   59 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 59 insertions(+)

diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm
index 191ebae..e3512ec 100644
--- a/src/runtime/swank.scm
+++ b/src/runtime/swank.scm
@@ -384,6 +384,65 @@ USA.
 (define (swank:set-default-directory socket directory)
   (->namestring (set-working-directory-pathname! directory)))

+;;;; Describe
+(define (swank:describe-symbol socket symbol)
+  (let* ((env (buffer-env))
+	 (package (env->pstring env))
+	 (symbol (string->symbol symbol))
+	 (type (environment-reference-type env symbol))
+	 (binding (if (eq? type 'normal) (environment-lookup env symbol) #f))
+	 (binding-type (if binding (get-object-type-name binding) #f))
+	 (params (if (and binding (procedure? binding)) (procedure-parameters symbol env) #f)))
+    (string-append
+     (format #f "~a in package ~a~a of type ~a.~%~%" (string-upcase (symbol->string symbol))
+	     package
+	     (if (and binding
+		      (procedure? binding))
+		 (format #f " [originally defined in package ~a]" (env->pstring (procedure-environment binding)))
+		 "")
+	     (if binding-type binding-type type))
+     (if binding
+	 (format #f "Bound to ~a.~%" binding)
+	 "")
+     (if params
+	 (format #f "~%Signature: ~a.~%~%" params)
+	 "")
+     (if binding
+	 (format #f "It is:~%~%~a~%" (with-output-to-string (lambda () (pp binding))))
+	 ""))))
+
+(define (swank:describe-function socket function)
+  (swank:describe-symbol socket function))
+
+(define (swank:describe-definition-for-emacs socket name type)
+  type
+  (swank:describe-symbol socket name))
+
+(define (get-object-type-name obj)
+  (cond ((boolean? obj) "boolean")
+	((string? obj) "string")
+	((char? obj) "char")
+	((fixnum? obj) "fixnum")
+	((integer? obj) "integer")
+	((rational? obj) "rational")
+	((real? obj) "real")
+	((complex? obj) "complex")
+	((vector? obj) "vector")
+	((pair? obj) "pair")
+	((null? obj) "empty list")
+	((bit-string? obj) "bit-string")
+	((cell? obj) "cell")
+	((condition? obj) "condition")
+	((environment? obj) "environment")
+	((port? obj) "port")
+	((procedure? obj) "procedure")
+	((promise? obj) "promise")
+	((symbol? obj) "symbol")
+	((weak-pair? obj) "weak-pair")
+	((record-type? obj) "record-type")
+	((wide-string? obj) "wide-string")
+	(else (user-object-type obj))))
+
 ;;;; Miscellaneous
 
 (define (swank:set-package socket pstring)
-- 
1.7.10