* * session.scm: New file: Session support.

	(apropos): New procedure: List bindings given regexp.

1 files changed, 88 insertions, 0 deletions

diff --git a/ice-9/session.scm b/ice-9/session.scm
new file mode 100644
index 000000000..f60e3453a
--- /dev/null
+++ b/ice-9/session.scm
@@ -0,0 +1,88 @@
+;;;; 	Copyright (C) 1997 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 software; see the file COPYING.  If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;; 
+
+
+(define-module (ice-9 session))
+
+
+
+;;; {Apropos}
+;;;
+;;; Author: Roland Orre <orre@nada.kth.se>
+;;;
+
+(define (id x) x)
+
+(define (vector-for-each proc vector)
+  (do ((i (+ -1 (vector-length vector)) (+ -1 i)))
+      ((negative? i))
+    (proc (vector-ref vector i))))
+
+(define-public (apropos rgx . options)
+  "Search for bindings: apropos regexp {options= 'full 'shadow 'value}"
+  (if (zero? (string-length rgx))
+      "Empty string not allowed"
+      (let* ((match (regcomp rgx))
+	     (modules (cons (current-module)
+			    (module-uses (current-module))))
+	     (separator #\tab)
+	     (shadow (member 'shadow options))
+	     (value (member 'value options)))
+	(cond ((member 'full options)
+	       (set! shadow #t)
+	       (set! value #t)))
+	(for-each
+	 (lambda (module)
+	   (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)
+		(vector-for-each
+		 (lambda (oblist)
+		   (for-each
+		    (lambda (x)
+		      (cond ((regexec match (car x) #f)
+			     (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)))
+	 modules))))