pretty-print: allow max-expr-width to be set; recognize more keywords

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

diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index 70708c3..fbb03d2 100644 (file)
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -1,4 +1,4 @@
-;;;;   Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
+;;;;   Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -17,16 +17,17 @@
 \f
 
 (define-module (ice-9 session)
-  :use-module (ice-9 documentation)
-  :use-module (ice-9 regex)
-  :use-module (ice-9 rdelim)
-  :export (help
-           add-value-help-handler! remove-value-help-handler!
-           add-name-help-handler! remove-name-help-handler!
-           apropos apropos-internal apropos-fold apropos-fold-accessible
-           apropos-fold-exported apropos-fold-all source arity
-           procedure-arguments
-           module-commentary))
+  #:use-module (ice-9 documentation)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 rdelim)
+  #:export (help
+            add-value-help-handler! remove-value-help-handler!
+            add-name-help-handler! remove-name-help-handler!
+            apropos-hook
+            apropos apropos-internal apropos-fold apropos-fold-accessible
+            apropos-fold-exported apropos-fold-all source arity
+            procedure-arguments
+            module-commentary))
 
 \f
 
@@ -163,10 +164,8 @@ You don't seem to have regular expressions installed.\n")
                                 (cons (list module
                                             name
                                             (try-value-help name object)
-                                            (cond ((closure? object)
+                                            (cond ((procedure? object)
                                                    "a procedure")
-                                                  ((procedure? object)
-                                                   "a primitive procedure")
                                                   (else
                                                    "an object")))
                                       data))
@@ -286,8 +285,13 @@ where OPTIONSET is one of debug, read, eval, print
 ;;; Author: Roland Orre <orre@nada.kth.se>
 ;;;
 
+;; Two arguments: the module, and the pattern, as a string.
+;;
+(define apropos-hook (make-hook 2))
+
 (define (apropos rgx . options)
   "Search for bindings: apropos regexp {options= 'full 'shadow 'value}"
+  (run-hook apropos-hook (current-module) rgx)
   (if (zero? (string-length rgx))
       "Empty string not allowed"
       (let* ((match (make-regexp rgx))
@@ -356,8 +360,9 @@ Fourth arg FOLDER is one of
   (apropos-fold-accessible MODULE) ;fold over bindings accessible in MODULE
   apropos-fold-exported                   ;fold over all exported bindings
   apropos-fold-all                ;fold over all bindings"
+  (run-hook apropos-hook (current-module) rgx)
   (let ((match (make-regexp rgx))
-       (recorded (make-vector 61 '())))
+       (recorded (make-hash-table)))
     (let ((fold-module
           (lambda (module data)
             (let* ((obarray-filter
@@ -406,18 +411,10 @@ It is an image under the mapping EXTRACT."
                     identity))
 
 (define (root-modules)
-  (cons the-root-module
-       (submodules (nested-ref the-root-module '(app modules)))))
-
-(define (submodules m)
-  (hash-fold (lambda (name var data)
-              (let ((obj (and (variable-bound? var) (variable-ref var))))
-                (if (and (module? obj)
-                         (eq? (module-kind obj) 'directory))
-                    (cons obj data)
-                    data)))
-            '()
-            (module-obarray m)))
+  (submodules (resolve-module '() #f)))
+
+(define (submodules mod)
+  (hash-map->list (lambda (k v) v) (module-submodules mod)))
 
 (define apropos-fold-exported
   (make-fold-modules root-modules submodules module-public-interface))
@@ -486,7 +483,7 @@ It is an image under the mapping EXTRACT."
                  (display rest-arg)
                  (display "'"))))))
    (else
-    (let ((arity (procedure-property obj 'arity)))
+    (let ((arity (procedure-minimum-arity obj)))
       (display (car arity))
       (cond ((caddr arity)
             (display " or more"))
@@ -498,17 +495,7 @@ It is an image under the mapping EXTRACT."
               (= (car arity) 1)
               (<= (cadr arity) 1))
          (display " argument")
-         (display " arguments"))
-      (if (closure? obj)
-         (let ((formals (cadr (procedure-source obj))))
-           (cond
-            ((pair? formals)
-             (display ": ")
-             (display-arg-list formals))
-            (else
-             (display " in `")
-             (display formals)
-             (display #\'))))))))
+         (display " arguments")))))
   (display ".\n"))
 
 
@@ -528,7 +515,7 @@ The alist keys that are currently defined are `required', `optional',
    ((procedure-source proc)
     => cadr)
    (((@ (system vm program) program?) proc)
-    ((@ (system vm program) program-arguments) proc))
+    ((@ (system vm program) program-arguments-alist) proc))
    (else #f)))