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

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

ice-9/ChangeLog

@@ -1,3 +1,8 @@
+Mon Aug 18 21:58:25 1997  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>
+
+*	* session.scm: New file: Session support.
+	(apropos): New procedure: List bindings given regexp.
+
 Sat Aug 16 18:44:24 1997  Gary Houston  <ghouston@actrix.gen.nz>
 
 	* boot-9.scm: define tms accessors: clock, utime, stime, cutime,

ice-9/Makefile.am

@@ -4,7 +4,8 @@ AUTOMAKE_OPTIONS = foreign
 
 # These should be installed and distributed.
 ice9_sources = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \
-mapping.scm poe.scm regex.scm slib.scm tags.scm threads.scm r4rs.scm
+mapping.scm poe.scm regex.scm slib.scm tags.scm threads.scm r4rs.scm \
+session.scm
 
 # These should be installed, but not distributed.
 ice9_generated = version.scm

ice-9/Makefile.in

@@ -65,6 +65,7 @@ GUILE_VERSION = @GUILE_VERSION@
 LD = @LD@
 LIBLOBJS = @LIBLOBJS@
 LIBTOOL = @LIBTOOL@
+LN_S = @LN_S@
 MAINT = @MAINT@
 MAKEINFO = @MAKEINFO@
 PACKAGE = @PACKAGE@
@@ -83,7 +84,8 @@ AUTOMAKE_OPTIONS = foreign
 
 # These should be installed and distributed.
 ice9_sources = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \
-mapping.scm poe.scm regex.scm slib.scm tags.scm threads.scm r4rs.scm
+mapping.scm poe.scm regex.scm slib.scm tags.scm threads.scm r4rs.scm \
+session.scm
 
 # These should be installed, but not distributed.
 ice9_generated = version.scm
@@ -103,7 +105,7 @@ DIST_COMMON =  COPYING ChangeLog Makefile.am Makefile.in version.scm.in
 
 DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
 
-TAR = tar
+TAR = gtar
 GZIP = --best
 default: all
 

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))))