Update copyright.

[bpt/guile.git] / ice-9 / session.scm

diff --git a/ice-9/session.scm b/ice-9/session.scm
index 2082309..1148bbc 100644 (file)
--- a/ice-9/session.scm
+++ b/ice-9/session.scm
@@ -63,14 +63,21 @@ You don't seem to have regular expressions installed.\n"))
   (let ((entries (apropos-fold (lambda (module name object data)
                                 (cons (list module
                                             name
-                                            (object-documentation object))
+                                            (object-documentation object)
+                                            (cond ((closure? object)
+                                                   "a procedure")
+                                                  ((procedure? object)
+                                                   "a primitive procedure")
+                                                  (else
+                                                   "an object")))
                                       data))
                               '()
                               regexp
                               apropos-fold-exported))
        (module car)
        (name cadr)
-       (doc caddr))
+       (doc caddr)
+       (type cadddr))
     (if (null? entries)
        ;; no matches
        (begin
@@ -80,32 +87,55 @@ You don't seem to have regular expressions installed.\n"))
                             "named `~A'\n"
                             "matching regexp \"~A\"\n")
                         term))
-       (let ((first? #t))
-         (if (or-map doc entries)
-             ;; entries with documentation
-             (for-each (lambda (entry)
-                         ;; *fixme*: Use `describe' when we have GOOPS?
-                         (if (doc entry)
-                             (begin
-                               (if first?
-                                   (set! first? #f)
-                                   (newline))
-                               (simple-format #t "~S: ~S\n~A\n"
-                                              (module-name (module entry))
-                                              (name entry)
-                                              (doc entry)))))
-                       entries))
-         (if (or-map (lambda (x) (not (doc x))) entries)
-             ;; entries without documentation
+       (let ((first? #t)
+             (undocumented-entries '())
+             (documented-entries '())
+             (documentations '()))
+
+         (for-each (lambda (entry)
+                     (let ((entry-summary (simple-format #f
+                                                         "~S: ~S\n"
+                                                         (module-name (module entry))
+                                                         (name entry))))
+                       (if (doc entry)
+                           (begin
+                             (set! documented-entries
+                                   (cons entry-summary documented-entries))
+                             ;; *fixme*: Use `describe' when we have GOOPS?
+                             (set! documentations
+                                   (cons (simple-format #f
+                                                        "`~S' is ~A in the ~S module.\n\n~A\n"
+                                                        (name entry)
+                                                        (type entry)
+                                                        (module-name (module entry))
+                                                        (doc entry))
+                                         documentations)))
+                           (set! undocumented-entries
+                                 (cons entry-summary undocumented-entries)))))
+                   entries)
+
+         (if (and (not (null? documented-entries))
+                  (or (> (length documented-entries) 1)
+                      (not (null? undocumented-entries))))
              (begin
-               (if (not first?)
-                   (display "\nNo documentation found for:\n"))
-               (for-each (lambda (entry)
-                           (if (not (doc entry))
-                               (simple-format #t "~S: ~S\n"
-                                              (module-name (module entry))
-                                              (name entry))))
-                         entries)))))))
+               (display "Documentation found for:\n")
+               (for-each (lambda (entry) (display entry)) documented-entries)
+               (set! first? #f)))
+
+         (for-each (lambda (entry)
+                     (if first?
+                         (set! first? #f)
+                         (newline))
+                     (display entry))
+                   documentations)
+
+         (if (not (null? undocumented-entries))
+             (begin
+               (if first?
+                   (set! first? #f)
+                   (newline))
+               (display "No documentation found for:\n")
+               (for-each (lambda (entry) (display entry)) undocumented-entries)))))))
 
 (define (help-usage)
   (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol)
@@ -168,41 +198,36 @@ where OPTIONSET is one of debug, read, eval, print
           (let* ((builtin (or (eq? module the-scm-module)
                               (eq? module the-root-module)))
                  (name (module-name module))
-                 (obarrays (if builtin
-                               (list (builtin-weak-bindings)
-                                     (builtin-bindings))
-                               (list (module-obarray module))))
-                 (get-refs (if builtin
-                               (list id id)
-                               (list variable-ref)))
-                 )
-            (for-each
-             (lambda (obarray get-ref)
-               (array-for-each
-                (lambda (oblist)
-                  (for-each
-                   (lambda (x)
-                     (cond ((regexp-exec match (car x))
-                            (display name)
-                            (display ": ")
-                            (display (car x))
-                            (cond ((procedure? (get-ref (cdr x)))
-                                   (display separator)
-                                   (display (get-ref (cdr x))))
-                                  (value
-                                   (display separator)
-                                   (display (get-ref (cdr x)))))
-                            (if (and shadow
-                                     (not (eq? (module-ref module
-                                                           (car x))
-                                               (module-ref (current-module)
-                                                           (car x)))))
-                                (display " shadowed"))
-                            (newline)
-                            )))
-                   oblist))
-                obarray))
-             obarrays get-refs)))
+                 (obarray (if builtin
+                              (builtin-bindings)
+                              (module-obarray module)))
+                 (get-ref (if builtin
+                              id
+                              variable-ref)))
+            (array-for-each
+             (lambda (oblist)
+               (for-each
+                (lambda (x)
+                  (cond ((regexp-exec match (symbol->string (car x)))
+                         (display name)
+                         (display ": ")
+                         (display (car x))
+                         (cond ((procedure? (get-ref (cdr x)))
+                                (display separator)
+                                (display (get-ref (cdr x))))
+                               (value
+                                (display separator)
+                                (display (get-ref (cdr x)))))
+                         (if (and shadow
+                                  (not (eq? (module-ref module
+                                                        (car x))
+                                            (module-ref (current-module)
+                                                        (car x)))))
+                             (display " shadowed"))
+                         (newline)
+                         )))
+                oblist))
+             obarray)))
         modules))))
 
 (define-public (apropos-internal rgx)
@@ -236,7 +261,7 @@ Fourth arg FOLDER is one of
           (lambda (module data)
             (let* ((obarray-filter
                     (lambda (name val data)
-                      (if (and (regexp-exec match name)
+                      (if (and (regexp-exec match (symbol->string name))
                                (not (hashq-get-handle recorded name)))
                           (begin
                             (hashq-set! recorded name #t)
@@ -248,10 +273,8 @@ Fourth arg FOLDER is one of
               (cond ((or (eq? module the-scm-module)
                          (eq? module the-root-module))
                      (hash-fold obarray-filter
-                                (hash-fold obarray-filter
-                                           data
-                                           (builtin-bindings))
-                                (builtin-weak-bindings)))
+                                data
+                                (builtin-bindings)))
                     (module (hash-fold module-filter
                                        data
                                        (module-obarray module)))
@@ -266,8 +289,10 @@ It is an image under the mapping EXTRACT."
   (lambda (fold-module init)
     (let* ((table (make-hash-table 31))
           (first? (lambda (obj)
-                    (and (not (hash-ref table obj))
-                         (hash-create-handle! table obj #t)))))
+                    (let* ((handle (hash-create-handle! table obj #t))
+                           (first? (cdr handle)))
+                      (set-cdr! handle #f)
+                      first?))))
       (let rec ((data init)
                (modules (init-thunk)))
        (do ((modules modules (cdr modules))