[Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1-9-8-99-g80c3b20

[Julian Graham]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=80c3b20dad2f5129021b35d81ae37098a74f4ab3

The branch, wip-r6rs-libraries has been updated
       via  80c3b20dad2f5129021b35d81ae37098a74f4ab3 (commit)
      from  4b4da0fb47c7dd056d241e67cacb1112cd831b86 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 80c3b20dad2f5129021b35d81ae37098a74f4ab3
Author: Julian Graham <address@hidden>
Date:   Sun Apr 4 22:58:56 2010 -0400

    Move `library' and `import' forms into separate file.
    
    * module/ice-9/boot-9.scm: Replace `library' and `import' form definitions
      with `include' form referencing r6rs-libraries.scm.
    * module/ice-9/r6rs-libraries.scm: New file.

-----------------------------------------------------------------------

Summary of changes:
 module/ice-9/boot-9.scm         |  126 +---------------------------------
 module/ice-9/r6rs-libraries.scm |  147 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 148 insertions(+), 125 deletions(-)
 create mode 100644 module/ice-9/r6rs-libraries.scm

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 2a9ed4e..36170c5 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3200,131 +3200,7 @@ module '(ice-9 q) '(make-q q-length))}."
     (process-use-modules (list (list ,@(compile-interface-spec spec))))
     *unspecified*))
 
-(define-syntax library
-  (lambda (stx)
-    (syntax-case stx (export import)
-      ((_ (identifier-1 identifier-2 ... . ((version-1 ...)))
-         (export . exports)
-         (import . imports)
-         . body)
-       (let* ((name (syntax->datum #'(identifier-1 identifier-2 ...)))
-             (version (syntax->datum #'(version-1 ...)))
-             (exports (syntax->datum #'exports))
-             (imports (syntax->datum #'imports))
-             (body (syntax->datum #'body))
-             (import-exprs (map (lambda (i) (list 'import i)) imports))
-             (needs-purify (not (member '(guile) imports))))
-
-        ;; Until the imports have actually been resolved, it's actually
-        ;; somewhat difficult to figure out which exports are truly exports
-        ;; and which ones are re-exports of imported symbols.  So at expansion
-        ;; time, we import everything into a "staging" module and use its
-        ;; environment to determine the types of the exports.
-
-        (let ((import-environment (make-module 0)))
-          (beautify-user-module! import-environment)
-          (eval (cons 'begin import-exprs) import-environment)
-          (if needs-purify
-              (set-module-uses! import-environment 
-                                (cdr (module-uses import-environment))))
-
-          (let f ((local-exports '()) (re-exports '()) (el exports))
-            (if (null? el)
-                #`(begin
-                    (define-module #,(datum->syntax stx name) 
-                      #:version #,version)
-                    #,@(datum->syntax stx import-exprs)
-
-                    (module-export! 
-                     (current-module)
-                     #,(datum->syntax stx (list 'quote local-exports)))
-                    (module-re-export! 
-                     (current-module)
-                     #,(datum->syntax stx (list 'quote re-exports)))
-
-                    (eval-when (eval load compile)
-                      (if #,needs-purify
-                          (set-module-uses! 
-                           (current-module)
-                           (delq the-scm-module
-                                 (module-uses (current-module))))))
-                    #,@(datum->syntax stx body))
-                (let ((ce (car el)))
-                  (if (module-bound? import-environment
-                                     (if (pair? ce) (car ce) ce))
-                      (f local-exports (cons ce re-exports) (cdr el))
-                      (f (cons ce local-exports) re-exports (cdr el))))))))))))
-    
-(define-syntax import
-  (lambda (stx)
-    (define transform-import-set
-      (lambda (stx)
-       (define (add-prefix pre str) (string->symbol (string-append pre str)))
-       (define (load-library name version)
-         (define (transform-library-name name)
-           (define (make-srfi n) (cons 'srfi (list (add-prefix "srfi-" n))))
-           (or (and (>= (length name) 2)
-                    (eq? (car name) 'srfi)
-                    (let* ((str (symbol->string (cadr name)))
-                           (chars (string->list str)))
-                      (and (eqv? (car chars) #\:)
-                           (make-srfi (list->string (cdr chars))))))
-               name))
-         (let ((l (resolve-interface (transform-library-name name) 
-                                     #:version version)))
-           `((,(module-name l) ,version) 
-             ,@(hash-map->list (lambda (x y) x) (module-obarray l)))))
-       (let f ((i stx))
-         (syntax-case i (library only except prefix rename)
-           ((library (id-1 id-2 ... . ((v-1 ...))))
-            (load-library (syntax->datum #'(id-1 id-2 ...))
-                          (syntax->datum #'(v-1 ...))))
-           ((library (id-1 id-2 ...))
-            (load-library (syntax->datum #'(id-1 id-2 ...)) '()))
-           ((only import-set identifier ...)
-            (let ((inner (f #'import-set))
-                  (only-set (syntax->datum #'(identifier ...))))
-              (cons (car inner) (filter (lambda (s) (memq s only-set)) 
-                                        (cdr inner)))))
-           ((except import-set identifier ...)
-            (let ((inner (f #'import-set))
-                  (except-set (syntax->datum #'(identifier ...))))            
-              (cons (car inner) (filter (lambda (s) (not (memq s except-set))) 
-                                        (cdr inner)))))
-           ((prefix import-set identifier)
-            (let ((inner (f #'import-set))
-                  (prefix-string (symbol->string 
-                                  (syntax->datum #'identifier))))
-              (cons (car inner)
-                    (map (lambda (s) (cons s (add-prefix prefix-string 
-                                                         (symbol->string s))))
-                         (cdr inner)))))
-           ((rename import-set (id-1 id-2) ...)
-            (let* ((inner (f #'import-set))
-                   (rename-hash (make-hash-table)))
-              (for-each (lambda (r) (hashq-set! rename-hash (car r) (cadr r)))
-                        (syntax->datum #'((id-1 id-2) ...)))
-              (cons (car inner)
-                    (map (lambda (s) 
-                           (let ((r (hashq-ref rename-hash 
-                                               (if (list? s) (cadr s) s))))
-                             (if r (cons (if (pair? s) (car s) s) r) s)))
-                         (cdr inner)))))
-           ((id-1 id-2 ... . ((v-1 ...)))
-            (load-library (syntax->datum #'(id-1 id-2 ...))
-                          (syntax->datum #'(v-1 ...))))
-           ((id-1 id-2 ...) 
-            (load-library (syntax->datum #'(id-1 id-2 ...)) '()))))))
-
-    (define (emit-use-modules i)      
-      #`(use-modules (#,(datum->syntax stx (caar i))
-                     #:version #,(datum->syntax stx (cadar i))
-                     #:select #,(datum->syntax stx (cdr i)))))
-           
-    (syntax-case stx (for)
-      ((_ import-set) (emit-use-modules (transform-import-set #'import-set)))
-      ((_ (for import-set import-level ...))
-       (emit-use-modules (transform-import-set #'import-set))))))
+(include-from-path "ice-9/r6rs-libraries")
 
 (define-syntax define-private
   (syntax-rules ()
diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm
new file mode 100644
index 0000000..bc96859
--- /dev/null
+++ b/module/ice-9/r6rs-libraries.scm
@@ -0,0 +1,147 @@
+;;; 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
+
+
+;; This file is included from boot-9.scm and assumes the existence of (and 
+;; expands into) procedures and syntactic forms defined therein.
+
+(define-syntax library
+  (lambda (stx)
+    (syntax-case stx (export import)
+      ((_ (identifier-1 identifier-2 ... . ((version-1 ...)))
+         (export . exports)
+         (import . imports)
+         . body)
+       (let* ((name (syntax->datum #'(identifier-1 identifier-2 ...)))
+             (version (syntax->datum #'(version-1 ...)))
+             (exports (syntax->datum #'exports))
+             (imports (syntax->datum #'imports))
+             (body (syntax->datum #'body))
+             (import-exprs (map (lambda (i) (list 'import i)) imports))
+             (needs-purify (not (member '(guile) imports))))
+
+        ;; Until the imports have actually been resolved, it's actually
+        ;; somewhat difficult to figure out which exports are truly exports
+        ;; and which ones are re-exports of imported symbols.  So at expansion
+        ;; time, we import everything into a "staging" module and use its
+        ;; environment to determine the types of the exports.
+
+        (let ((import-environment (make-module 0)))
+          (beautify-user-module! import-environment)
+          (eval (cons 'begin import-exprs) import-environment)
+          (if needs-purify
+              (set-module-uses! import-environment 
+                                (cdr (module-uses import-environment))))
+
+          (let f ((local-exports '()) (re-exports '()) (el exports))
+            (if (null? el)
+                #`(begin
+                    (define-module #,(datum->syntax stx name) 
+                      #:version #,version)
+                    #,@(datum->syntax stx import-exprs)
+
+                    (module-export! 
+                     (current-module)
+                     #,(datum->syntax stx (list 'quote local-exports)))
+                    (module-re-export! 
+                     (current-module)
+                     #,(datum->syntax stx (list 'quote re-exports)))
+
+                    (eval-when (eval load compile)
+                      (if #,needs-purify
+                          (set-module-uses! 
+                           (current-module)
+                           (delq the-scm-module
+                                 (module-uses (current-module))))))
+                    #,@(datum->syntax stx body))
+                (let ((ce (car el)))
+                  (if (module-bound? import-environment
+                                     (if (pair? ce) (car ce) ce))
+                      (f local-exports (cons ce re-exports) (cdr el))
+                      (f (cons ce local-exports) re-exports (cdr el))))))))))))
+    
+(define-syntax import
+  (lambda (stx)
+    (define transform-import-set
+      (lambda (stx)
+       (define (add-prefix pre str) (string->symbol (string-append pre str)))
+       (define (load-library name version)
+         (define (transform-library-name name)
+           (define (make-srfi n) (cons 'srfi (list (add-prefix "srfi-" n))))
+           (or (and (>= (length name) 2)
+                    (eq? (car name) 'srfi)
+                    (let* ((str (symbol->string (cadr name)))
+                           (chars (string->list str)))
+                      (and (eqv? (car chars) #\:)
+                           (make-srfi (list->string (cdr chars))))))
+               name))
+         (let ((l (resolve-interface (transform-library-name name) 
+                                     #:version version)))
+           `((,(module-name l) ,version) 
+             ,@(hash-map->list (lambda (x y) x) (module-obarray l)))))
+       (let f ((i stx))
+         (syntax-case i (library only except prefix rename)
+           ((library (id-1 id-2 ... . ((v-1 ...))))
+            (load-library (syntax->datum #'(id-1 id-2 ...))
+                          (syntax->datum #'(v-1 ...))))
+           ((library (id-1 id-2 ...))
+            (load-library (syntax->datum #'(id-1 id-2 ...)) '()))
+           ((only import-set identifier ...)
+            (let ((inner (f #'import-set))
+                  (only-set (syntax->datum #'(identifier ...))))
+              (cons (car inner) (filter (lambda (s) (memq s only-set)) 
+                                        (cdr inner)))))
+           ((except import-set identifier ...)
+            (let ((inner (f #'import-set))
+                  (except-set (syntax->datum #'(identifier ...))))            
+              (cons (car inner) (filter (lambda (s) (not (memq s except-set))) 
+                                        (cdr inner)))))
+           ((prefix import-set identifier)
+            (let ((inner (f #'import-set))
+                  (prefix-string (symbol->string 
+                                  (syntax->datum #'identifier))))
+              (cons (car inner)
+                    (map (lambda (s) (cons s (add-prefix prefix-string 
+                                                         (symbol->string s))))
+                         (cdr inner)))))
+           ((rename import-set (id-1 id-2) ...)
+            (let* ((inner (f #'import-set))
+                   (rename-hash (make-hash-table)))
+              (for-each (lambda (r) (hashq-set! rename-hash (car r) (cadr r)))
+                        (syntax->datum #'((id-1 id-2) ...)))
+              (cons (car inner)
+                    (map (lambda (s) 
+                           (let ((r (hashq-ref rename-hash 
+                                               (if (list? s) (cadr s) s))))
+                             (if r (cons (if (pair? s) (car s) s) r) s)))
+                         (cdr inner)))))
+           ((id-1 id-2 ... . ((v-1 ...)))
+            (load-library (syntax->datum #'(id-1 id-2 ...))
+                          (syntax->datum #'(v-1 ...))))
+           ((id-1 id-2 ...) 
+            (load-library (syntax->datum #'(id-1 id-2 ...)) '()))))))
+
+    (define (emit-use-modules i)      
+      #`(use-modules (#,(datum->syntax stx (caar i))
+                     #:version #,(datum->syntax stx (cadar i))
+                     #:select #,(datum->syntax stx (cdr i)))))
+           
+    (syntax-case stx (for)
+      ((_ import-set) (emit-use-modules (transform-import-set #'import-set)))
+      ((_ (for import-set import-level ...))
+       (emit-use-modules (transform-import-set #'import-set))))))


hooks/post-receive
-- 
GNU Guile