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

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

diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
index 8058123..1ff4a3d 100644 (file)
--- a/ice-9/ChangeLog
+++ b/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,

diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am
index a8e0d75..1e0888b 100644 (file)
--- a/ice-9/Makefile.am
+++ b/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

diff --git a/ice-9/Makefile.in b/ice-9/Makefile.in
index 8793034..ec44653 100644 (file)
--- a/ice-9/Makefile.in
+++ b/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
 

diff --git a/ice-9/session.scm b/ice-9/session.scm
new file mode 100644 (file)
index 0000000..f60e345
--- /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.
+;;;; 
+\f
+
+(define-module (ice-9 session))
+
+\f
+
+;;; {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))))