1;;;
2;;; module related utility functions.  to be autoloaded.
3;;;
4;;;   Copyright (c) 2000-2020  Shiro Kawai  <shiro@acm.org>
5;;;
6;;;   Redistribution and use in source and binary forms, with or without
7;;;   modification, are permitted provided that the following conditions
8;;;   are met:
9;;;
10;;;   1. Redistributions of source code must retain the above copyright
11;;;      notice, this list of conditions and the following disclaimer.
12;;;
13;;;   2. Redistributions in binary form must reproduce the above copyright
14;;;      notice, this list of conditions and the following disclaimer in the
15;;;      documentation and/or other materials provided with the distribution.
16;;;
17;;;   3. Neither the name of the authors nor the names of its contributors
18;;;      may be used to endorse or promote products derived from this
19;;;      software without specific prior written permission.
20;;;
21;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32;;;
33
34(define-module gauche.modutil
35  (export export-if-defined use-version describe-symbol-bindings)
36  )
37(select-module gauche.modutil)
38
39(define-macro (export-if-defined . symbols)
40  ;; CAVEAT: this form sees whether the given symbols are defined or not
41  ;; _at_compile_time_.  So the definitions of symbols have to appear
42  ;; before this form.   Furthermore, the semantics of this form is ambigous
43  ;; when used except top-level.  It's not very nice, so you should
44  ;; avoid this form unless you really need it.
45  ;; NB: filter is in srfi-1, and we don't want to load it here.  Ugh.
46  `(export
47    ,@(let loop ([syms symbols] [r '()])
48        (cond [(null? syms) (reverse! r)]
49              [(not (symbol? (car syms)))
50               (error "non-symbol in export-if-defined form:" (car syms))]
51              [(global-variable-bound? #f (car syms))
52               (loop (cdr syms) (cons (car syms) r))]
53              [else (loop (cdr syms) r)]))))
54
55;; Inter-version compatibility.
56(define-macro (use-version version)
57  (let1 compat (string-append "gauche/compat/" version)
58    (unless (provided? compat)
59      (let1 path (string-append (gauche-library-directory) "/" compat ".scm")
60        (when (file-exists? path)
61          (let1 module (string->symbol (string-append "gauche-" version))
62            `(begin
63               (require ,compat)
64               (import ,module))))))))
65
66;; Called when you describe a symbol in REPL.  Look for the symbol
67;; in all named modules.
68(define (describe-symbol-bindings sym)
69  (define const?     (with-module gauche.internal gloc-const?))
70  (define inlinable? (with-module gauche.internal gloc-inlinable?))
71  (define find-b     (with-module gauche.internal find-binding))
72  (define (describe-binding mod gloc val)
73    (let1 attrs (cond-list [(const? gloc) 'const]
74                           [(inlinable? gloc) 'inlinable])
75      (format #t "  In module `~s'" (module-name mod))
76      (unless (null? attrs) (format #t " ~s" attrs))
77      (format #t ":\n    ~a\n"
78              (guard [e (else "#<unprintable>")]
79                (format "~,,,,50:a" val)))))
80  (let1 bindings (filter-map (^m (and-let* ([g (find-b m sym #t)]
81                                            [ (global-variable-bound? m sym) ])
82                                   (list m g (global-variable-ref m sym))))
83                             (all-modules))
84    (if (null? bindings)
85      (format #t "No known bindings for variable ~a.\n" sym)
86      (begin (format #t "Known binding~a for variable ~a:\n"
87                     (if (null? (cdr bindings)) "" "s") sym)
88             (for-each (cut apply describe-binding <>) bindings))))
89  (values))
90