1 files changed, 361 insertions, 0 deletions
diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm
new file mode 100644
index 000000000..cb7d3b60e
--- /dev/null
+++ b/module/system/repl/describe.scm
@@ -0,0 +1,361 @@
+;;; Describe objects
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system repl describe)
+  :use-module (oop goops)
+  :use-module (ice-9 regex)
+  :use-module (ice-9 format)
+  :use-module (ice-9 and-let-star)
+  :export (describe))
+
+(define-method (describe (symbol <symbol>))
+  (format #t "`~s' is " symbol)
+  (if (not (defined? symbol))
+      (display "not defined in the current module.\n")
+      (describe-object (module-ref (current-module) symbol))))
+
+
+;;;
+;;; Display functions
+;;;
+
+(define (safe-class-name class)
+  (if (slot-bound? class 'name)
+      (class-name class)
+      class))
+
+(define-method (display-class class . args)
+  (let* ((name (safe-class-name class))
+	 (desc (if (pair? args) (car args) name)))
+    (if (eq? *describe-format* 'tag)
+	(format #t "@class{~a}{~a}" name desc)
+	(format #t "~a" desc))))
+
+(define (display-list title list)
+  (if title (begin (display title) (display ":\n\n")))
+  (if (null? list)
+      (display "(not defined)\n")
+      (for-each display-summary list)))
+
+(define (display-slot-list title instance list)
+  (if title (begin (display title) (display ":\n\n")))
+  (if (null? list)
+      (display "(not defined)\n")
+      (for-each (lambda (slot)
+		  (let ((name (slot-definition-name slot)))
+		    (display "Slot: ")
+		    (display name)
+		    (if (and instance (slot-bound? instance name))
+			(begin
+			  (display " = ")
+			  (display (slot-ref instance name))))
+		    (newline)))
+		list)))
+
+(define (display-file location)
+  (display "Defined in ")
+  (if (eq? *describe-format* 'tag)
+      (format #t "@location{~a}.\n" location)
+      (format #t "`~a'.\n" location)))
+
+(define (format-documentation doc)
+  (with-current-buffer (make-buffer #:text doc)
+    (lambda ()
+      (let ((regexp (make-regexp "@([a-z]*)(\\{([^}]*)\\})?")))
+	(do-while (match (re-search-forward regexp))
+	  (let ((key (string->symbol (match:substring match 1)))
+		(value (match:substring match 3)))
+	    (case key
+	      ((deffnx)
+	       (delete-region! (match:start match)
+			       (begin (forward-line) (point))))
+	      ((var)
+	       (replace-match! match 0 (string-upcase value)))
+	      ((code)
+	       (replace-match! match 0 (string-append "`" value "'")))))))
+      (display (string (current-buffer)))
+      (newline))))
+
+
+;;;
+;;; Top
+;;;
+
+(define description-table
+  (list
+   (cons <boolean>   "a boolean")
+   (cons <null>      "an empty list")
+   (cons <integer>   "an integer")
+   (cons <real>      "a real number")
+   (cons <complex>   "a complex number")
+   (cons <char>      "a character")
+   (cons <symbol>    "a symbol")
+   (cons <keyword>   "a keyword")
+   (cons <promise>   "a promise")
+   (cons <hook>      "a hook")
+   (cons <fluid>     "a fluid")
+   (cons <stack>     "a stack")
+   (cons <variable>  "a variable")
+   (cons <regexp>    "a regexp object")
+   (cons <module>    "a module object")
+   (cons <unknown>   "an unknown object")))
+
+(define-generic describe-object)
+(export describe-object)
+
+(define-method (describe-object (obj <top>))
+  (display-type obj)
+  (display-location obj)
+  (newline)
+  (display-value obj)
+  (newline)
+  (display-documentation obj))
+
+(define-generic display-object)
+(define-generic display-summary)
+(define-generic display-type)
+(define-generic display-value)
+(define-generic display-location)
+(define-generic display-description)
+(define-generic display-documentation)
+(export display-object display-summary display-type display-value
+	display-location display-description display-documentation)
+
+(define-method (display-object (obj <top>))
+  (write obj))
+
+(define-method (display-summary (obj <top>))
+  (display "Value: ")
+  (display-object obj)
+  (newline))
+
+(define-method (display-type (obj <top>))
+  (cond
+   ((eof-object? obj) (display "the end-of-file object"))
+   ((unspecified? obj) (display "unspecified"))
+   (else (let ((class (class-of obj)))
+	   (display-class class (or (assq-ref description-table class)
+				    (safe-class-name class))))))
+  (display ".\n"))
+
+(define-method (display-value (obj <top>))
+  (if (not (unspecified? obj))
+      (begin (display-object obj) (newline))))
+
+(define-method (display-location (obj <top>))
+  *unspecified*)
+
+(define-method (display-description (obj <top>))
+  (let* ((doc (with-output-to-string (lambda () (display-documentation obj))))
+	 (index (string-index doc #\newline)))
+    (display (make-shared-substring doc 0 (1+ index)))))
+
+(define-method (display-documentation (obj <top>))
+  (display "Not documented.\n"))
+
+
+;;;
+;;; Pairs
+;;;
+
+(define-method (display-type (obj <pair>))
+  (cond
+   ((list? obj) (display-class <list> "a list"))
+   ((pair? (cdr obj)) (display "an improper list"))
+   (else (display-class <pair> "a pair")))
+  (display ".\n"))
+
+
+;;;
+;;; Strings
+;;;
+
+(define-method (display-type (obj <string>))
+  (if (read-only-string? 'obj)
+      (display "a read-only string")
+      (display-class <string> "a string"))
+  (display ".\n"))
+
+
+;;;
+;;; Procedures
+;;;
+
+(define-method (display-object (obj <procedure>))
+  (cond
+   ((closure? obj)
+    ;; Construct output from the source.
+    (display "(")
+    (display (procedure-name obj))
+    (let ((args (cadr (procedure-source obj))))
+      (cond ((null? args) (display ")"))
+	    ((pair? args)
+	     (let ((str (with-output-to-string (lambda () (display args)))))
+	       (format #t " ~a" (string-upcase! (substring str 1)))))
+	    (else
+	     (format #t " . ~a)" (string-upcase! (symbol->string args)))))))
+   (else
+    ;; Primitive procedure.  Let's lookup the dictionary.
+    (and-let* ((entry (lookup-procedure obj)))
+      (let ((name (entry-property entry 'name))
+	    (print-arg (lambda (arg)
+			 (display " ")
+			 (display (string-upcase (symbol->string arg))))))
+	(display "(")
+	(display name)
+	(and-let* ((args (entry-property entry 'args)))
+	  (for-each print-arg args))
+	(and-let* ((opts (entry-property entry 'opts)))
+	  (display " &optional")
+	  (for-each print-arg opts))
+	(and-let* ((rest (entry-property entry 'rest)))
+	  (display " &rest")
+	  (print-arg rest))
+	(display ")"))))))
+
+(define-method (display-summary (obj <procedure>))
+  (display "Procedure: ")
+  (display-object obj)
+  (newline)
+  (display "  ")
+  (display-description obj))
+
+(define-method (display-type (obj <procedure>))
+  (cond
+   ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
+   ((closure? obj) (display-class <procedure> "a procedure"))
+   ((procedure-with-setter? obj)
+    (display-class <procedure-with-setter> "a procedure with setter"))
+   ((not (struct? obj)) (display "a primitive procedure"))
+   (else (display-class <procedure> "a procedure")))
+  (display ".\n"))
+
+(define-method (display-location (obj <procedure>))
+  (and-let* ((entry (lookup-procedure obj)))
+    (display-file (entry-file entry))))
+
+(define-method (display-documentation (obj <procedure>))
+  (cond ((cond ((closure? obj) (procedure-documentation obj))
+	       ((lookup-procedure obj) => entry-text)
+	       (else #f))
+	 => format-documentation)
+	(else (next-method))))
+
+
+;;;
+;;; Classes
+;;;
+
+(define-method (describe-object (obj <class>))
+  (display-type obj)
+  (display-location obj)
+  (newline)
+  (display-documentation obj)
+  (newline)
+  (display-value obj))
+
+(define-method (display-summary (obj <class>))
+  (display "Class: ")
+  (display-class obj)
+  (newline)
+  (display "  ")
+  (display-description obj))
+
+(define-method (display-type (obj <class>))
+  (display-class <class> "a class")
+  (if (not (eq? (class-of obj) <class>))
+      (begin (display " of ") (display-class (class-of obj))))
+  (display ".\n"))
+
+(define-method (display-value (obj <class>))
+  (display-list "Class precedence list" (class-precedence-list obj))
+  (newline)
+  (display-list "Direct superclasses" (class-direct-supers obj))
+  (newline)
+  (display-list "Direct subclasses" (class-direct-subclasses obj))
+  (newline)
+  (display-slot-list "Direct slots" #f (class-direct-slots obj))
+  (newline)
+  (display-list "Direct methods" (class-direct-methods obj)))
+
+
+;;;
+;;; Instances
+;;;
+
+(define-method (display-type (obj <object>))
+  (display-class <object> "an instance")
+  (display " of class ")
+  (display-class (class-of obj))
+  (display ".\n"))
+
+(define-method (display-value (obj <object>))
+  (display-slot-list #f obj (class-slots (class-of obj))))
+
+
+;;;
+;;; Generic functions
+;;;
+
+(define-method (display-type (obj <generic>))
+  (display-class <generic> "a generic function")
+  (display " of class ")
+  (display-class (class-of obj))
+  (display ".\n"))
+
+(define-method (display-value (obj <generic>))
+  (display-list #f (generic-function-methods obj)))
+
+
+;;;
+;;; Methods
+;;;
+
+(define-method (display-object (obj <method>))
+  (display "(")
+  (let ((gf (method-generic-function obj)))
+    (display (if gf (generic-function-name gf) "#<anonymous>")))
+  (let loop ((args (method-specializers obj)))
+    (cond
+     ((null? args))
+     ((pair? args)
+      (display " ")
+      (display-class (car args))
+      (loop (cdr args)))
+     (else (display " . ") (display-class args))))
+  (display ")"))
+
+(define-method (display-summary (obj <method>))
+  (display "Method: ")
+  (display-object obj)
+  (newline)
+  (display "  ")
+  (display-description obj))
+
+(define-method (display-type (obj <method>))
+  (display-class <method> "a method")
+  (display " of class ")
+  (display-class (class-of obj))
+  (display ".\n"))
+
+(define-method (display-documentation (obj <method>))
+  (let ((doc (procedure-documentation (method-procedure obj))))
+    (if doc (format-documentation doc) (next-method))))