ice-9/session.scm

   1 ;;;;    Copyright (C) 1997, 2000 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, Inc., 59 Temple Place, Suite 330,
  16 ;;;; Boston, MA 02111-1307 USA
  17 ;;;;
  18 \f
  19
  20 (define-module (ice-9 session)
  21   :use-module (ice-9 doc)
  22   :no-backtrace)
  23
  24 \f
  25
  26 ;;; Documentation
  27 ;;;
  28 (define-public help
  29   (procedure->syntax
  30     (lambda (exp env)
  31       "(help [NAME])
  32 Prints useful information.  Try `(help)'."
  33       (if (not (= (length exp) 2))
  34           (help-usage)
  35           (let* ((sym (cadr exp))
  36                  (obj (catch #t
  37                              (lambda ()
  38                                (local-eval sym env))
  39                              (lambda args
  40                                #f))))
  41             (cond ;; *fixme*: when we have GOOPS
  42                   ;;((or obj (not sym)) (describe obj))
  43                   ((and (or obj (not sym))
  44                         (cond ((procedure? obj)
  45                                (display (proc-doc obj))
  46                                (newline)
  47                                #t)
  48                               ((and (macro? obj) (macro-transformer obj))
  49                                (display (proc-doc (macro-transformer obj)))
  50                                (newline))
  51                               (else #f))))
  52                   ((symbol? sym)
  53                    (documentation sym))
  54                   (else
  55                    (display "No documentation for `")
  56                    (display sym)
  57                    (display "'\n")))
  58             *unspecified*)))))
  59
  60 (define (help-usage)
  61   (display "Usage: (help NAME) gives documentation about NAME
  62        (help) gives this text
  63
  64 Examples: (help help)
  65           (help cons)
  66
  67 Other useful sources of helpful information:
  68
  69 (apropos STRING)
  70 (arity PROCEDURE)
  71 (name PROCEDURE-OR-MACRO)
  72 (source PROCEDURE-OR-MACRO)
  73
  74 Tools:
  75
  76 (backtrace)                             ;show backtrace from last error
  77 (debug)                                 ;enter the debugger
  78 (trace [PROCEDURE])                     ;trace procedure (no arg => show)
  79 (untrace [PROCEDURE])                   ;untrace (no arg => untrace all)
  80
  81 (OPTIONSET-options 'full)               ;display option information
  82 (OPTIONSET-enable 'OPTION)
  83 (OPTIONSET-disable 'OPTION)
  84 (OPTIONSET-set! OPTION VALUE)
  85
  86 where OPTIONSET is one of debug, read, eval, print
  87
  88 "))
  89
  90 ;;; {Apropos}
  91 ;;;
  92 ;;; Author: Roland Orre <orre@nada.kth.se>
  93 ;;;
  94
  95 (define (id x) x)
  96
  97 (define-public (apropos rgx . options)
  98   "Search for bindings: apropos regexp {options= 'full 'shadow 'value}"
  99   (if (zero? (string-length rgx))
 100       "Empty string not allowed"
 101       (let* ((match (make-regexp rgx))
 102              (modules (cons (current-module)
 103                             (module-uses (current-module))))
 104              (separator #\tab)
 105              (shadow (member 'shadow options))
 106              (value (member 'value options)))
 107         (cond ((member 'full options)
 108                (set! shadow #t)
 109                (set! value #t)))
 110         (for-each
 111          (lambda (module)
 112            (let* ((builtin (or (eq? module the-scm-module)
 113                                (eq? module the-root-module)))
 114                   (name (module-name module))
 115                   (obarrays (if builtin
 116                                 (list (builtin-weak-bindings)
 117                                       (builtin-bindings))
 118                                 (list (module-obarray module))))
 119                   (get-refs (if builtin
 120                                 (list id id)
 121                                 (list variable-ref)))
 122                   )
 123              (for-each
 124               (lambda (obarray get-ref)
 125                 (array-for-each
 126                  (lambda (oblist)
 127                    (for-each
 128                     (lambda (x)
 129                       (cond ((regexp-exec match (car x))
 130                              (display name)
 131                              (display ": ")
 132                              (display (car x))
 133                              (cond ((procedure? (get-ref (cdr x)))
 134                                     (display separator)
 135                                     (display (get-ref (cdr x))))
 136                                    (value
 137                                     (display separator)
 138                                     (display (get-ref (cdr x)))))
 139                              (if (and shadow
 140                                       (not (eq? (module-ref module
 141                                                             (car x))
 142                                                 (module-ref (current-module)
 143                                                             (car x)))))
 144                                  (display " shadowed"))
 145                              (newline)
 146                              )))
 147                     oblist))
 148                  obarray))
 149               obarrays get-refs)))
 150          modules))))
 151
 152 (define-public (apropos-internal rgx)
 153   "Return a list of accessible variable names."
 154   (letrec ((match (make-regexp rgx))
 155            (recorded (make-vector 61 '()))
 156            (obarray-names
 157             (lambda (obarray names)
 158               (hash-fold (lambda (name var vars)
 159                            (if (and (regexp-exec match name)
 160                                     (not (hashq-get-handle recorded name)))
 161                                (begin
 162                                  (hashq-set! recorded name #t)
 163                                  (cons name vars))
 164                                vars))
 165                          names
 166                          obarray))))
 167     (do ((modules (cons (current-module) (module-uses (current-module)))
 168                   (cdr modules))
 169          (names '()
 170                 (if (or (eq? (car modules) the-scm-module)
 171                         (eq? (car modules) the-root-module))
 172                     (obarray-names (builtin-weak-bindings)
 173                                    (obarray-names (builtin-bindings)
 174                                                   names))
 175                     (obarray-names (module-obarray (car modules))
 176                                    names))))
 177         ((null? modules) names))))
 178
 179 (define-public (name obj)
 180   (cond ((procedure? obj) (procedure-name obj))
 181         ((macro? obj) (macro-name obj))
 182         (else #f)))
 183
 184 (define-public (source obj)
 185   (cond ((procedure? obj) (procedure-source obj))
 186         ((macro? obj) (procedure-source (macro-transformer obj)))
 187         (else #f)))
 188
 189 (define-public (arity obj)
 190   (let ((arity (procedure-property obj 'arity)))
 191     (display (car arity))
 192     (cond ((caddr arity)
 193            (display " or more"))
 194           ((not (zero? (cadr arity)))
 195            (display " required and ")
 196            (display (cadr arity))
 197            (display " optional")))
 198     (if (and (not (caddr arity))
 199              (= (car arity) 1)
 200              (<= (cadr arity) 1))
 201         (display " argument")
 202         (display " arguments"))
 203     (if (closure? obj)
 204         (let ((formals (cadr (procedure-source obj))))
 205           (if (pair? formals)
 206               (begin
 207                 (display ": `")
 208                 (display (car formals))
 209                 (let loop ((ls (cdr formals)))
 210                   (cond ((null? ls)
 211                          (display #\'))
 212                         ((not (pair? ls))
 213                          (display "', the rest in `")
 214                          (display ls)
 215                          (display #\'))
 216                         (else
 217                          (if (pair? (cdr ls))
 218                              (display "', `")
 219                              (display "' and `"))
 220                          (display (car ls))
 221                          (loop (cdr ls))))))
 222               (begin
 223                 (display " in `")
 224                 (display formals)
 225                 (display #\')))))
 226     (display ".\n")))
 227
 228 (define-public system-module
 229   (procedure->syntax
 230    (lambda (exp env)
 231      (let* ((m (nested-ref the-root-module
 232                            (append '(app modules) (cadr exp)))))
 233        (if (not m)
 234            (error "Couldn't find any module named" (cadr exp)))
 235        (let ((s (not (procedure-property (module-eval-closure m)
 236                                          'system-module))))
 237          (set-system-module! m s)
 238          (string-append "Module " (symbol->string (module-name m))
 239                         " is now a " (if s "system" "user") " module."))))))