[Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1-9-7-48-g9db67bc

[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=9db67bccd9414bd9c4a2d4edf0c8173a46562ac3

The branch, wip-r6rs-libraries has been updated
       via  9db67bccd9414bd9c4a2d4edf0c8173a46562ac3 (commit)
      from  69f90b0b051e77257a753f1ee7ae6a18a1147c78 (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 9db67bccd9414bd9c4a2d4edf0c8173a46562ac3
Author: Julian Graham <address@hidden>
Date:   Sat Feb 6 12:33:20 2010 -0500

    Move R6RS library support into boot-9.
    
    * module/ice-9/boot-9.scm (library, import): New syntax.

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

Summary of changes:
 module/ice-9/boot-9.scm |   98 +++++++++++++++++++++++++++++++++++++++++++++++
 1 files changed, 98 insertions(+), 0 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index af09be8..6208264 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3050,6 +3050,104 @@ 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)))
+        #`(begin
+            (define-module #,(datum->syntax stx name) #:version #,version)
+            #,@(datum->syntax stx (map (lambda (i) (list 'import i)) imports))
+            (let ((ob (module-obarray (current-module))))
+              (module-export! 
+               (current-module) 
+               (filter (lambda (s) (hashq-ref ob (if (pair? s) (car s) s)))
+                       #,(datum->syntax stx (list 'quote exports))))
+              (module-re-export! 
+               (current-module)
+               (filter (lambda (s)
+                         (not (hashq-ref ob (if (pair? s) (car s) s))))
+                       #,(datum->syntax stx (list 'quote exports)))))
+            (purify-module! (current-module))
+            #,@(datum->syntax stx body)))))))
+    
+(define-syntax import
+  (lambda (stx)
+    (define transform-import-set
+      (lambda (stx)
+       (define (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 (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 ident)
+            (let ((inner (f #'import-set))
+                  (prefix-string (symbol->string (syntax->datum #'ident))))
+              (cons (car inner)
+                    (map (lambda (s)
+                           (cons s (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))))))
+
 (define-syntax define-private
   (syntax-rules ()
     ((_ foo bar)


hooks/post-receive
-- 
GNU Guile