module/ice-9/r6rs-libraries.scm

   1 ;;; r6rs-libraries.scm --- Support for the R6RS `library' and `import' forms
   2
   3 ;;      Copyright (C) 2010 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 \f
  19
  20 ;; This file is included from boot-9.scm and assumes the existence of (and
  21 ;; expands into) procedures and syntactic forms defined therein.
  22
  23 (define (resolve-r6rs-interface import-spec)
  24   (define (make-custom-interface mod)
  25     (let ((iface (make-module)))
  26       (set-module-kind! iface 'custom-interface)
  27       (set-module-name! iface (module-name mod))
  28       iface))
  29   (define (sym? x) (symbol? (syntax->datum x)))
  30
  31   (syntax-case import-spec (library only except prefix rename srfi)
  32     ;; (srfi :n ...) -> (srfi srfi-n ...)
  33     ((library (srfi colon-n rest ... (version ...)))
  34      (and (and-map sym? #'(srfi rest ...))
  35           (symbol? (syntax->datum #'colon-n))
  36           (eqv? (string-ref (symbol->string (syntax->datum #'colon-n)) 0) #\:))
  37      (let ((srfi-n (string->symbol
  38                     (string-append
  39                      "srfi-"
  40                      (substring (symbol->string (syntax->datum #'colon-n))
  41                                 1)))))
  42        (resolve-r6rs-interface
  43         #`(library (srfi #,srfi-n rest ... (version ...))))))
  44
  45     ((library (name name* ... (version ...)))
  46      (and-map sym? #'(name name* ...))
  47      (resolve-interface (syntax->datum #'(name name* ...))
  48                         #:version (syntax->datum #'(version ...))))
  49
  50     ((library (name name* ...))
  51      (and-map sym? #'(name name* ...))
  52      (resolve-r6rs-interface #'(library (name name* ... ()))))
  53
  54     ((only import-set identifier ...)
  55      (and-map sym? #'(identifier ...))
  56      (let* ((mod (resolve-r6rs-interface #'import-set))
  57             (iface (make-custom-interface mod)))
  58        (for-each (lambda (sym)
  59                    (module-add! iface sym
  60                                 (or (module-local-variable mod sym)
  61                                     (error "no binding `~A' in module ~A"
  62                                            sym mod))))
  63                  (syntax->datum #'(identifier ...)))
  64        iface))
  65
  66     ((except import-set identifier ...)
  67      (and-map sym? #'(identifier ...))
  68      (let* ((mod (resolve-r6rs-interface #'import-set))
  69             (iface (make-custom-interface mod)))
  70        (module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
  71        (for-each (lambda (sym)
  72                    (if (module-local-variable iface sym)
  73                        (module-remove! iface sym)
  74                        (error "no binding `~A' in module ~A" sym mod)))
  75                  (syntax->datum #'(identifier ...)))
  76        iface))
  77
  78     ((prefix import-set identifier)
  79      (sym? #'identifier)
  80      (let* ((mod (resolve-r6rs-interface #'import-set))
  81             (iface (make-custom-interface mod))
  82             (pre (syntax->datum #'identifier)))
  83        (module-for-each (lambda (sym var)
  84                           (module-add! iface (symbol-append pre sym) var))
  85                         mod)
  86        iface))
  87
  88     ((rename import-set (from to) ...)
  89      (and (and-map sym? #'(from ...)) (and-map sym? #'(to ...)))
  90      (let* ((mod (resolve-r6rs-interface #'import-set))
  91             (iface (make-custom-interface mod)))
  92        (module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
  93        (let lp ((in (syntax->datum #'((from . to) ...))) (out '()))
  94          (cond
  95           ((null? in)
  96            (for-each
  97             (lambda (pair)
  98               (if (module-local-variable iface (car pair))
  99                   (error "duplicate binding for `~A' in module ~A"
 100                          (car pair) mod)
 101                   (module-add! iface (car pair) (cdr pair))))
 102             out)
 103            iface)
 104           (else
 105            (let ((var (or (module-local-variable mod (caar in))
 106                           (error "no binding `~A' in module ~A"
 107                                  (caar in) mod))))
 108              (module-remove! iface (caar in))
 109              (lp (cdr in) (acons (cdar in) var out))))))))
 110
 111     ((name name* ... (version ...))
 112      (and-map sym? #'(name name* ...))
 113      (resolve-r6rs-interface #'(library (name name* ... (version ...)))))
 114
 115     ((name name* ...)
 116      (and-map sym? #'(name name* ...))
 117      (resolve-r6rs-interface #'(library (name name* ... ()))))))
 118
 119 (define-syntax library
 120   (lambda (stx)
 121     (define (compute-exports ifaces specs)
 122       (define (re-export? sym)
 123         (or-map (lambda (iface) (module-local-variable iface sym)) ifaces))
 124       (define (replace? sym)
 125         (module-local-variable the-scm-module sym))
 126
 127       (let lp ((specs specs) (e '()) (r '()) (x '()))
 128         (syntax-case specs (rename)
 129           (() (values e r x))
 130           (((rename (from to) ...) . rest)
 131            (and (and-map identifier? #'(from ...))
 132                 (and-map identifier? #'(to ...)))
 133            (let lp2 ((in #'((from . to) ...)) (e e) (r r) (x x))
 134              (syntax-case in ()
 135                (() (lp #'rest e r x))
 136                (((from . to) . in)
 137                 (cond
 138                  ((re-export? (syntax->datum #'from))
 139                   (lp2 #'in e (cons #'(from . to) r) x))
 140                  ((replace? (syntax->datum #'from))
 141                   (lp2 #'in e r (cons #'(from . to) x)))
 142                  (else
 143                   (lp2 #'in (cons #'(from . to) e) r x)))))))
 144           ((id . rest)
 145            (identifier? #'id)
 146            (let ((sym (syntax->datum #'id)))
 147              (cond
 148               ((re-export? sym)
 149                (lp #'rest e (cons #'id r) x))
 150               ((replace? sym)
 151                (lp #'rest e r (cons #'id x)))
 152               (else
 153                (lp #'rest (cons #'id e) r x))))))))
 154
 155     (syntax-case stx (export import)
 156       ((_ (name name* ...)
 157           (export espec ...)
 158           (import ispec ...)
 159           body ...)
 160        (and-map identifier? #'(name name* ...))
 161        ;; Add () as the version.
 162        #'(library (name name* ... ())
 163            (export espec ...)
 164            (import ispec ...)
 165            body ...))
 166
 167       ((_ (name name* ... (version ...))
 168           (export espec ...)
 169           (import ispec ...)
 170           body ...)
 171        (and-map identifier? #'(name name* ...))
 172        (call-with-values
 173            (lambda ()
 174              (compute-exports
 175               (map (lambda (im)
 176                      (syntax-case im (for)
 177                        ((for import-set import-level ...)
 178                         (resolve-r6rs-interface #'import-set))
 179                        (import-set (resolve-r6rs-interface #'import-set))))
 180                    #'(ispec ...))
 181               #'(espec ...)))
 182          (lambda (exports re-exports replacements)
 183            (with-syntax (((e ...) exports)
 184                          ((r ...) re-exports)
 185                          ((x ...) replacements))
 186              ;; It would be nice to push the module that was current before the
 187              ;; definition, and pop it after the library definition, but I
 188              ;; actually can't see a way to do that. Helper procedures perhaps,
 189              ;; around a fluid that is rebound in save-module-excursion? Patches
 190              ;; welcome!
 191              #'(begin
 192                  (define-module (name name* ...)
 193                    #:pure
 194                    #:version (version ...))
 195                  (import ispec)
 196                  ...
 197                  (export e ...)
 198                  (re-export r ...)
 199                  (export! x ...)
 200                  (@@ @@ (name name* ...) body)
 201                  ...))))))))
 202
 203 (define-syntax import
 204   (lambda (stx)
 205     (define (strip-for import-set)
 206       (syntax-case import-set (for)
 207         ((for import-set import-level ...)
 208          #'import-set)
 209         (import-set
 210          #'import-set)))
 211     (syntax-case stx ()
 212       ((_ import-set ...)
 213        (with-syntax (((library-reference ...) (map strip-for #'(import-set ...))))
 214          #'(eval-when (eval load compile expand)
 215              (let ((iface (resolve-r6rs-interface 'library-reference)))
 216                (call-with-deferred-observers
 217                  (lambda ()
 218                    (module-use-interfaces! (current-module) (list iface)))))
 219              ...
 220              (if #f #f)))))))