Add "transient" intmap interface

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

diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index 10ce613..a6ab3ab 100644 (file)
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -1,4 +1,5 @@
-;;;;   Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010, 2011,
+;;;;    2012, 2013 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 +18,18 @@
 \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)
+  #:use-module (ice-9 match)
+  #: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
 
@@ -284,8 +287,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))
@@ -354,8 +362,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,15 +415,8 @@ It is an image under the mapping EXTRACT."
 (define (root-modules)
   (submodules (resolve-module '() #f)))
 
-(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)))
+(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))
@@ -504,14 +506,20 @@ It is an image under the mapping EXTRACT."
 if the information cannot be obtained.
 
 The alist keys that are currently defined are `required', `optional',
-`keyword', and `rest'."
+`keyword', `allow-other-keys?', and `rest'."
   (cond
    ((procedure-property proc 'arglist)
-    => (lambda (arglist)
-         `((required . ,(car arglist))
-           (optional . ,(cadr arglist))
-           (keyword . ,(caddr arglist))
-           (rest . ,(car (cddddr arglist))))))
+    => (match-lambda
+        ((req opt keyword aok? rest)
+         `((required . ,(if (number? req)
+                            (make-list req '_)
+                            req))
+           (optional . ,(if (number? opt)
+                            (make-list opt '_)
+                            opt))
+           (keyword . ,keyword)
+           (allow-other-keys? . ,aok?)
+           (rest . ,rest)))))
    ((procedure-source proc)
     => cadr)
    (((@ (system vm program) program?) proc)