#| -*-Scheme-*-
-$Id: apropos.scm,v 1.3 1999/01/02 06:11:34 cph Exp $
+$Id: apropos.scm,v 1.4 1999/07/06 15:08:44 cph Exp $
Copyright (c) 1993, 1999 Massachusetts Institute of Technology
;;;; Apropos command
;;; package: (runtime apropos)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(declare (usual-integrations))
\f
(define (apropos text #!optional package/env search-parents?)
(let* ((env
- (cond ((default-object? package/env) (nearest-repl/environment))
- ((eq? package/env #t) (nearest-repl/environment))
- (else (->environment package/env))))
+ (if (or (default-object? package/env) (eq? #t package/env))
+ (nearest-repl/environment)
+ (->environment package/env)))
(search-parents?
- (or (default-object? package/env)
- (and (not (default-object? search-parents?))
- search-parents?))))
+ (cond ((default-object? package/env) #t)
+ ((default-object? search-parents?) #f)
+ (else search-parents?))))
(aproposer text env search-parents?
apropos-describe-env apropos-describe)))
-
(define (apropos-list text #!optional package/env search-parents?)
(let* ((env
- (cond ((default-object? package/env) (nearest-repl/environment))
- ((eq? package/env #t) (nearest-repl/environment))
- (else (->environment package/env))))
+ (if (or (default-object? package/env) (eq? #t package/env))
+ (nearest-repl/environment)
+ (->environment package/env)))
(search-parents?
- (or (default-object? package/env)
- (and (not (default-object? search-parents?))
- search-parents?))))
+ (cond ((default-object? package/env) #t)
+ ((default-object? search-parents?) #f)
+ (else search-parents?))))
(let ((names '()))
- (define (add-name name env)
- env
- (set! names (cons name names))
- unspecific)
- (aproposer text env search-parents? (lambda (env) env) add-name)
+ (aproposer text env search-parents?
+ (lambda (env) env)
+ (lambda (name env)
+ env
+ (set! names (cons name names))
+ unspecific))
names)))
-
(define (aproposer text env search-parents? process-env process-symbol)
- (let* ((text (if (symbol? text) (symbol-name text) text)))
+ (let ((text (if (symbol? text) (symbol-name text) text)))
(process-env env)
(for-each (lambda (symbol)
- (if (substring? text (symbol-name symbol))
+ (if (substring? (symbol-name symbol) text)
(process-symbol symbol env)))
(sort (environment-bound-names env) symbol<?))
(if (and search-parents? (environment-has-parent? env))
(aproposer text (environment-parent env) search-parents?
process-env process-symbol))))
-
(define (apropos-describe symbol env)
env
(newline)
- (display symbol))
+ (write symbol))
(define (apropos-describe-env env)
(let ((package (environment->package env)))
(newline)
- (display (or package env))))
\ No newline at end of file
+ (write (or package env))))
\ No newline at end of file