diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 80581235f..1ff4a3d23 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +Mon Aug 18 21:58:25 1997 Mikael Djurfeldt + +* * session.scm: New file: Session support. + (apropos): New procedure: List bindings given regexp. + Sat Aug 16 18:44:24 1997 Gary Houston * boot-9.scm: define tms accessors: clock, utime, stime, cutime, diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index a8e0d75af..1e0888b7d 100644 --- 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 879303478..ec44653b0 100644 --- 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 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 +;;; + +(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))))