[bpt/guile.git] / module / ice-9 / r6rs-libraries.scm

;;; r6rs-libraries.scm --- Support for the R6RS `library' and `import' forms

;;      Copyright (C) 2010 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;; 
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
\f

;; This file is included from boot-9.scm and assumes the existence of (and 
;; expands into) procedures and syntactic forms defined therein.

(define (resolve-r6rs-interface import-spec)
  (define (make-custom-interface mod)
    (let ((iface (make-module)))
      (set-module-kind! iface 'custom-interface)
      (set-module-name! iface (module-name mod))
      iface))
  (define (sym? x) (symbol? (syntax->datum x)))

  (syntax-case import-spec (library only except prefix rename srfi)
    ;; (srfi :n ...) -> (srfi srfi-n ...)
    ((library (srfi colon-n rest ... (version ...)))
     (and (and-map sym? #'(srfi rest ...))
          (symbol? (syntax->datum #'colon-n))
          (eqv? (string-ref (symbol->string (syntax->datum #'colon-n)) 0) #\:))
     (let ((srfi-n (string->symbol
                    (string-append
                     "srfi-"
                     (substring (symbol->string (syntax->datum #'colon-n))
                                1)))))
       (resolve-r6rs-interface
        (syntax-case #'(rest ...) ()
          (()
           #`(library (srfi #,srfi-n (version ...))))
          ((name rest ...)
           ;; SRFI 97 says that the first identifier after the colon-n
           ;; is used for the libraries name, so it must be ignored.
           #`(library (srfi #,srfi-n rest ... (version ...))))))))
    
    ((library (name name* ... (version ...)))
     (and-map sym? #'(name name* ...))
     (resolve-interface (syntax->datum #'(name name* ...))
                        #:version (syntax->datum #'(version ...))))

    ((library (name name* ...))
     (and-map sym? #'(name name* ...))
     (resolve-r6rs-interface #'(library (name name* ... ()))))
    
    ((only import-set identifier ...)
     (and-map sym? #'(identifier ...))
     (let* ((mod (resolve-r6rs-interface #'import-set))
            (iface (make-custom-interface mod)))
       (for-each (lambda (sym)
                   (module-add! iface sym
                                (or (module-local-variable mod sym)
                                    (error "no binding `~A' in module ~A"
                                           sym mod))))
                 (syntax->datum #'(identifier ...)))
       iface))
    
    ((except import-set identifier ...)
     (and-map sym? #'(identifier ...))
     (let* ((mod (resolve-r6rs-interface #'import-set))
            (iface (make-custom-interface mod)))
       (module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
       (for-each (lambda (sym)
                   (if (module-local-variable iface sym)
                       (module-remove! iface sym)
                       (error "no binding `~A' in module ~A" sym mod)))
                 (syntax->datum #'(identifier ...)))
       iface))

    ((prefix import-set identifier)
     (sym? #'identifier)
     (let* ((mod (resolve-r6rs-interface #'import-set))
            (iface (make-custom-interface mod))
            (pre (syntax->datum #'identifier)))
       (module-for-each (lambda (sym var)
                          (module-add! iface (symbol-append pre sym) var))
                        mod)
       iface))

    ((rename import-set (from to) ...)
     (and (and-map sym? #'(from ...)) (and-map sym? #'(to ...)))
     (let* ((mod (resolve-r6rs-interface #'import-set))
            (iface (make-custom-interface mod)))
       (module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
       (let lp ((in (syntax->datum #'((from . to) ...))) (out '()))
         (cond
          ((null? in)
           (for-each
            (lambda (pair)
              (if (module-local-variable iface (car pair))
                  (error "duplicate binding for `~A' in module ~A"
                         (car pair) mod)
                  (module-add! iface (car pair) (cdr pair))))
            out)
           iface)
          (else
           (let ((var (or (module-local-variable mod (caar in))
                          (error "no binding `~A' in module ~A"
                                 (caar in) mod))))
             (module-remove! iface (caar in))
             (lp (cdr in) (acons (cdar in) var out))))))))
    
    ((name name* ... (version ...))
     (and-map sym? #'(name name* ...))
     (resolve-r6rs-interface #'(library (name name* ... (version ...)))))

    ((name name* ...) 
     (and-map sym? #'(name name* ...))
     (resolve-r6rs-interface #'(library (name name* ... ()))))))

(define-syntax library
  (lambda (stx)
    (define (compute-exports ifaces specs)
      (define (re-export? sym)
        (or-map (lambda (iface) (module-local-variable iface sym)) ifaces))
      (define (replace? sym)
        (module-local-variable the-scm-module sym))
      
      (let lp ((specs specs) (e '()) (r '()) (x '()))
        (syntax-case specs (rename)
          (() (values e r x))
          (((rename (from to) ...) . rest)
           (and (and-map identifier? #'(from ...))
                (and-map identifier? #'(to ...)))
           (let lp2 ((in #'((from . to) ...)) (e e) (r r) (x x))
             (syntax-case in ()
               (() (lp #'rest e r x))
               (((from . to) . in)
                (cond
                 ((re-export? (syntax->datum #'from))
                  (lp2 #'in e (cons #'(from . to) r) x))
                 ((replace? (syntax->datum #'from))
                  (lp2 #'in e r (cons #'(from . to) x)))
                 (else
                  (lp2 #'in (cons #'(from . to) e) r x)))))))
          ((id . rest)
           (identifier? #'id)
           (let ((sym (syntax->datum #'id)))
             (cond
              ((re-export? sym)
               (lp #'rest e (cons #'id r) x))
              ((replace? sym)
               (lp #'rest e r (cons #'id x)))
              (else
               (lp #'rest (cons #'id e) r x))))))))

    (syntax-case stx (export import)
      ((_ (name name* ...)
          (export espec ...)
          (import ispec ...)
          body ...)
       (and-map identifier? #'(name name* ...))
       ;; Add () as the version.
       #'(library (name name* ... ())
           (export espec ...)
           (import ispec ...)
           body ...))

      ((_ (name name* ... (version ...))
          (export espec ...)
          (import ispec ...)
	  body ...)
       (and-map identifier? #'(name name* ...))
       (call-with-values
           (lambda ()
             (compute-exports 
              (map (lambda (im)
                     (syntax-case im (for)
                       ((for import-set import-level ...)
                        (resolve-r6rs-interface #'import-set))
                       (import-set (resolve-r6rs-interface #'import-set))))
                   #'(ispec ...))
              #'(espec ...)))
         (lambda (exports re-exports replacements)
           (with-syntax (((e ...) exports)
                         ((r ...) re-exports)
                         ((x ...) replacements))
             ;; It would be nice to push the module that was current before the
             ;; definition, and pop it after the library definition, but I
             ;; actually can't see a way to do that. Helper procedures perhaps,
             ;; around a fluid that is rebound in save-module-excursion? Patches
             ;; welcome!
             #'(begin
                 (define-module (name name* ...)
                   #:pure
                   #:version (version ...))
                 (import ispec)
                 ...
                 (export e ...)
                 (re-export r ...)
                 (export! x ...)
                 (@@ @@ (name name* ...) body)
                 ...))))))))
    
(define-syntax import
  (lambda (stx)
    (define (strip-for import-set)
      (syntax-case import-set (for)
        ((for import-set import-level ...)
         #'import-set)
        (import-set
         #'import-set)))
    (syntax-case stx ()
      ((_ import-set ...)
       (with-syntax (((library-reference ...) (map strip-for #'(import-set ...))))
         #'(eval-when (expand load eval)
             (let ((iface (resolve-r6rs-interface 'library-reference)))
               (call-with-deferred-observers
                 (lambda ()
                   (module-use-interfaces! (current-module) (list iface)))))
             ...
             (if #f #f)))))))
Commit	Line	Data
b1e4c7cc JG	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)
acc1d8e3	32	;; (srfi :n ...) -> (srfi srfi-n ...)
b1e4c7cc JG	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
5d7c55bd IP	43	(syntax-case #'(rest ...) ()
	44	(()
	45	#`(library (srfi #,srfi-n (version ...))))
	46	((name rest ...)
	47	;; SRFI 97 says that the first identifier after the colon-n
	48	;; is used for the libraries name, so it must be ignored.
	49	#`(library (srfi #,srfi-n rest ... (version ...))))))))
b1e4c7cc JG	50
	51	((library (name name* ... (version ...)))
	52	(and-map sym? #'(name name* ...))
	53	(resolve-interface (syntax->datum #'(name name* ...))
	54	#:version (syntax->datum #'(version ...))))
	55
	56	((library (name name* ...))
	57	(and-map sym? #'(name name* ...))
	58	(resolve-r6rs-interface #'(library (name name* ... ()))))
	59
	60	((only import-set identifier ...)
	61	(and-map sym? #'(identifier ...))
	62	(let* ((mod (resolve-r6rs-interface #'import-set))
	63	(iface (make-custom-interface mod)))
	64	(for-each (lambda (sym)
	65	(module-add! iface sym
	66	(or (module-local-variable mod sym)
	67	(error "no binding `~A' in module ~A"
	68	sym mod))))
	69	(syntax->datum #'(identifier ...)))
	70	iface))
	71
	72	((except import-set identifier ...)
	73	(and-map sym? #'(identifier ...))
	74	(let* ((mod (resolve-r6rs-interface #'import-set))
	75	(iface (make-custom-interface mod)))
	76	(module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
	77	(for-each (lambda (sym)
	78	(if (module-local-variable iface sym)
	79	(module-remove! iface sym)
	80	(error "no binding `~A' in module ~A" sym mod)))
	81	(syntax->datum #'(identifier ...)))
	82	iface))
	83
	84	((prefix import-set identifier)
	85	(sym? #'identifier)
	86	(let* ((mod (resolve-r6rs-interface #'import-set))
	87	(iface (make-custom-interface mod))
	88	(pre (syntax->datum #'identifier)))
	89	(module-for-each (lambda (sym var)
	90	(module-add! iface (symbol-append pre sym) var))
	91	mod)
	92	iface))
	93
	94	((rename import-set (from to) ...)
	95	(and (and-map sym? #'(from ...)) (and-map sym? #'(to ...)))
	96	(let* ((mod (resolve-r6rs-interface #'import-set))
	97	(iface (make-custom-interface mod)))
	98	(module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
	99	(let lp ((in (syntax->datum #'((from . to) ...))) (out '()))
	100	(cond
	101	((null? in)
	102	(for-each
	103	(lambda (pair)
	104	(if (module-local-variable iface (car pair))
	105	(error "duplicate binding for `~A' in module ~A"
	106	(car pair) mod)
	107	(module-add! iface (car pair) (cdr pair))))
	108	out)
	109	iface)
	110	(else
	111	(let ((var (or (module-local-variable mod (caar in))
	112	(error "no binding `~A' in module ~A"
	113	(caar in) mod))))
114	(module-remove! iface (caar in))
115	(lp (cdr in) (acons (cdar in) var out))))))))
116
117	((name name* ... (version ...))
118	(and-map sym? #'(name name* ...))
119	(resolve-r6rs-interface #'(library (name name* ... (version ...)))))
120
121	((name name* ...)
122	(and-map sym? #'(name name* ...))
123	(resolve-r6rs-interface #'(library (name name* ... ()))))))
124
125	(define-syntax library
126	(lambda (stx)
127	(define (compute-exports ifaces specs)
128	(define (re-export? sym)
129	(or-map (lambda (iface) (module-local-variable iface sym)) ifaces))
1052739b AW	130	(define (replace? sym)
1052739b AW	131	(module-local-variable the-scm-module sym))
b1e4c7cc	132
1052739b	133	(let lp ((specs specs) (e '()) (r '()) (x '()))
b1e4c7cc	134	(syntax-case specs (rename)
1052739b	135	(() (values e r x))
b1e4c7cc JG	136	(((rename (from to) ...) . rest)
	137	(and (and-map identifier? #'(from ...))
	138	(and-map identifier? #'(to ...)))
1052739b	139	(let lp2 ((in #'((from . to) ...)) (e e) (r r) (x x))
b1e4c7cc	140	(syntax-case in ()
1052739b	141	(() (lp #'rest e r x))
b1e4c7cc	142	(((from . to) . in)
1052739b AW	143	(cond
	144	((re-export? (syntax->datum #'from))
	145	(lp2 #'in e (cons #'(from . to) r) x))
	146	((replace? (syntax->datum #'from))
	147	(lp2 #'in e r (cons #'(from . to) x)))
	148	(else
	149	(lp2 #'in (cons #'(from . to) e) r x)))))))
b1e4c7cc JG	150	((id . rest)
	151	(identifier? #'id)
	152	(let ((sym (syntax->datum #'id)))
1052739b AW	153	(cond
	154	((re-export? sym)
	155	(lp #'rest e (cons #'id r) x))
	156	((replace? sym)
	157	(lp #'rest e r (cons #'id x)))
	158	(else
	159	(lp #'rest (cons #'id e) r x))))))))
b1e4c7cc JG	160
	161	(syntax-case stx (export import)
	162	((_ (name name* ...)
	163	(export espec ...)
	164	(import ispec ...)
	165	body ...)
	166	(and-map identifier? #'(name name* ...))
	167	;; Add () as the version.
	168	#'(library (name name* ... ())
	169	(export espec ...)
	170	(import ispec ...)
	171	body ...))
	172
	173	((_ (name name* ... (version ...))
	174	(export espec ...)
	175	(import ispec ...)
	176	body ...)
	177	(and-map identifier? #'(name name* ...))
	178	(call-with-values
	179	(lambda ()
04186f20 JG	180	(compute-exports
	181	(map (lambda (im)
	182	(syntax-case im (for)
	183	((for import-set import-level ...)
	184	(resolve-r6rs-interface #'import-set))
	185	(import-set (resolve-r6rs-interface #'import-set))))
	186	#'(ispec ...))
	187	#'(espec ...)))
1052739b	188	(lambda (exports re-exports replacements)
b1e4c7cc	189	(with-syntax (((e ...) exports)
1052739b AW	190	((r ...) re-exports)
1052739b AW	191	((x ...) replacements))
b1e4c7cc JG	192	;; It would be nice to push the module that was current before the
	193	;; definition, and pop it after the library definition, but I
	194	;; actually can't see a way to do that. Helper procedures perhaps,
	195	;; around a fluid that is rebound in save-module-excursion? Patches
	196	;; welcome!
	197	#'(begin
	198	(define-module (name name* ...)
e6c7e9ed	199	#:pure
b1e4c7cc JG	200	#:version (version ...))
	201	(import ispec)
	202	...
b1e4c7cc	203	(export e ...)
1052739b AW	204	(re-export r ...)
1052739b AW	205	(export! x ...)
8210c853	206	(@@ @@ (name name* ...) body)
d9b1c71a	207	...))))))))
b1e4c7cc JG	208
	209	(define-syntax import
	210	(lambda (stx)
ffd48603 AW	211	(define (strip-for import-set)
	212	(syntax-case import-set (for)
	213	((for import-set import-level ...)
	214	#'import-set)
	215	(import-set
	216	#'import-set)))
	217	(syntax-case stx ()
	218	((_ import-set ...)
	219	(with-syntax (((library-reference ...) (map strip-for #'(import-set ...))))
f6ddf827	220	#'(eval-when (expand load eval)
ffd48603 AW	221	(let ((iface (resolve-r6rs-interface 'library-reference)))
	222	(call-with-deferred-observers
	223	(lambda ()
	224	(module-use-interfaces! (current-module) (list iface)))))
	225	...
b1e4c7cc	226	(if #f #f)))))))