home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / apropos.scm < prev    next >
Text File  |  1999-07-31  |  3KB  |  76 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: apropos.scm,v 1.5 1999/07/31 18:39:59 cph Exp $
  4.  
  5. Copyright (c) 1993, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Apropos command
  23. ;;; package: (runtime apropos)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (apropos text #!optional package/env search-parents?)
  28.   (let* ((env
  29.       (if (or (default-object? package/env) (eq? #t package/env))
  30.           (nearest-repl/environment)
  31.           (->environment package/env)))
  32.      (search-parents?
  33.       (cond ((default-object? package/env) #t)
  34.         ((default-object? search-parents?) #f)
  35.         (else search-parents?))))
  36.     (aproposer text env search-parents?
  37.            apropos-describe-env apropos-describe)))
  38.  
  39. (define (apropos-list text #!optional package/env search-parents?)
  40.   (let* ((env
  41.       (if (or (default-object? package/env) (eq? #t package/env))
  42.           (nearest-repl/environment)
  43.           (->environment package/env)))
  44.      (search-parents?
  45.       (cond ((default-object? package/env) #t)
  46.         ((default-object? search-parents?) #f)
  47.         (else search-parents?))))
  48.     (let ((names '()))
  49.       (aproposer text env search-parents?
  50.          (lambda (env) env)
  51.          (lambda (name env)
  52.            env
  53.            (set! names (cons name names))
  54.            unspecific))
  55.       names)))
  56.  
  57. (define (aproposer text env search-parents? process-env process-symbol)
  58.   (let ((text (if (symbol? text) (symbol-name text) text)))
  59.     (process-env env)
  60.     (for-each (lambda (symbol)
  61.         (if (substring? text (symbol-name symbol))
  62.             (process-symbol symbol env)))
  63.           (sort (environment-bound-names env) symbol<?))
  64.     (if (and search-parents? (environment-has-parent? env))
  65.     (aproposer text (environment-parent env) search-parents?
  66.            process-env process-symbol))))
  67.  
  68. (define (apropos-describe symbol env)
  69.   env
  70.   (newline)
  71.   (write symbol))
  72.  
  73. (define (apropos-describe-env env)
  74.   (let ((package (environment->package env)))
  75.     (newline)
  76.     (write (or package env))))