ice-9/session.scm

   1 ;;;;    Copyright (C) 1997 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This program is free software; you can redistribute it and/or modify
   4 ;;;; it under the terms of the GNU General Public License as published by
   5 ;;;; the Free Software Foundation; either version 2, or (at your option)
   6 ;;;; any later version.
   7 ;;;;
   8 ;;;; This program is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 ;;;; GNU General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU General Public License
  14 ;;;; along with this software; see the file COPYING.  If not, write to
  15 ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16 ;;;;
  17 \f
  18
  19 (define-module (ice-9 session))
  20
  21 \f
  22
  23 ;;; {Apropos}
  24 ;;;
  25 ;;; Author: Roland Orre <orre@nada.kth.se>
  26 ;;;
  27
  28 (define (id x) x)
  29
  30 (define-public (apropos rgx . options)
  31   "Search for bindings: apropos regexp {options= 'full 'shadow 'value}"
  32   (if (zero? (string-length rgx))
  33       "Empty string not allowed"
  34       (let* ((match (make-regexp rgx))
  35              (modules (cons (current-module)
  36                             (module-uses (current-module))))
  37              (separator #\tab)
  38              (shadow (member 'shadow options))
  39              (value (member 'value options)))
  40         (cond ((member 'full options)
  41                (set! shadow #t)
  42                (set! value #t)))
  43         (for-each
  44          (lambda (module)
  45            (let* ((builtin (or (eq? module the-scm-module)
  46                                (eq? module the-root-module)))
  47                   (name (module-name module))
  48                   (obarrays (if builtin
  49                                 (list (builtin-weak-bindings)
  50                                       (builtin-bindings))
  51                                 (list (module-obarray module))))
  52                   (get-refs (if builtin
  53                                 (list id id)
  54                                 (list variable-ref)))
  55                   )
  56              (for-each
  57               (lambda (obarray get-ref)
  58                 (array-for-each
  59                  (lambda (oblist)
  60                    (for-each
  61                     (lambda (x)
  62                       (cond ((regexp-exec match (car x))
  63                              (display name)
  64                              (display ": ")
  65                              (display (car x))
  66                              (cond ((procedure? (get-ref (cdr x)))
  67                                     (display separator)
  68                                     (display (get-ref (cdr x))))
  69                                    (value
  70                                     (display separator)
  71                                     (display (get-ref (cdr x)))))
  72                              (if (and shadow
  73                                       (not (eq? (module-ref module
  74                                                             (car x))
  75                                                 (module-ref (current-module)
  76                                                             (car x)))))
  77                                  (display " shadowed"))
  78                              (newline)
  79                              )))
  80                     oblist))
  81                  obarray))
  82               obarrays get-refs)))
  83          modules))))
  84
  85 (define-public (apropos-internal rgx)
  86   "Return a list of accessible variable names."
  87   (let ((match (make-regexp rgx))
  88         (modules (cons (current-module)
  89                        (module-uses (current-module))))
  90         (recorded (make-vector 61 '()))
  91         (vars (cons '() '())))
  92     (let ((last vars))
  93       (for-each
  94        (lambda (module)
  95          (for-each
  96           (lambda (obarray)
  97             (array-for-each
  98              (lambda (oblist)
  99                (for-each
 100                 (lambda (x)
 101                   (if (and (regexp-exec match (car x))
 102                            (not (hashq-get-handle recorded (car x))))
 103                       (begin
 104                         (set-cdr! last (cons (car x) '()))
 105                         (set! last (cdr last))
 106                         (hashq-set! recorded (car x) #t))))
 107                 oblist))
 108              obarray))
 109           (if (or (eq? module the-scm-module)
 110                   (eq? module the-root-module))
 111               (list (builtin-weak-bindings)
 112                     (builtin-bindings))
 113               (list (module-obarray module)))))
 114        modules))
 115     (cdr vars)))
 116
 117 (define-public (name obj)
 118   (cond ((procedure? obj) (procedure-name obj))
 119         ((macro? obj) (macro-name obj))
 120         (else #f)))
 121
 122 (define-public (source obj)
 123   (cond ((procedure? obj) (procedure-source obj))
 124         ((macro? obj) (procedure-source (macro-transformer obj)))
 125         (else #f)))
 126
 127 (define-public (arity obj)
 128   (let ((arity (procedure-property obj 'arity)))
 129     (display (car arity))
 130     (cond ((caddr arity)
 131            (display " or more"))
 132           ((not (zero? (cadr arity)))
 133            (display " required and ")
 134            (display (cadr arity))
 135            (display " optional")))
 136     (if (and (not (caddr arity))
 137              (= (car arity) 1)
 138              (<= (cadr arity) 1))
 139         (display " argument")
 140         (display " arguments"))
 141     (if (closure? obj)
 142         (let ((formals (cadr (procedure-source obj))))
 143           (if (pair? formals)
 144               (begin
 145                 (display ": `")
 146                 (display (car formals))
 147                 (let loop ((ls (cdr formals)))
 148                   (cond ((null? ls)
 149                          (display #\'))
 150                         ((not (pair? ls))
 151                          (display "', the rest in `")
 152                          (display ls)
 153                          (display #\'))
 154                         (else
 155                          (if (pair? (cdr ls))
 156                              (display "', `")
 157                              (display "' and `"))
 158                          (display (car ls))
 159                          (loop (cdr ls))))))
 160               (begin
 161                 (display " in `")
 162                 (display formals)
 163                 (display #\')))))
 164     (display ".\n")))