Tighten up testing of duplicate imports to ensure R7RS compatibility.

diff --git a/src/libraries/inline-testing.scm b/src/libraries/inline-testing.scm
index 700e6ea7a0f0e05bad1becf5ea06c06846b56e19..e5d170d10004a06567f1bb93b4da5bb45b6d1d26 100644 (file)
--- a/src/libraries/inline-testing.scm
+++ b/src/libraries/inline-testing.scm
@@ -54,8 +54,10 @@ USA.
          (scheme eval)
          (scheme read)
          (scheme write)
-         (srfi 1)
-         (srfi 6)
+         (only (srfi 1)
+               filter
+               filter-map
+               find-tail)
          (mit library)
          (only (mit legacy runtime)
                ->namestring

diff --git a/src/libraries/srfi-133.scm b/src/libraries/srfi-133.scm
index 7ed1f62cda9e3860c30ad52e865ba87808ba16ea..a18b22af9ce6ac93258e72d3708c15623b6a9573 100644 (file)
--- a/src/libraries/srfi-133.scm
+++ b/src/libraries/srfi-133.scm
@@ -31,7 +31,8 @@ USA.
 (define-library (srfi 133)
   (import (scheme base)
          (scheme cxr)
-         (srfi 8)
+         (only (srfi 8)
+               receive)
          (only (mit legacy runtime)
                error:bad-range-argument
                fix:+

diff --git a/src/runtime/library-imports.scm b/src/runtime/library-imports.scm
index b5970fb61630b350e308a8fe9439169f889efd4c..df03cc825b3417d777baa0d8c9113c73963ab3c3 100644 (file)
--- a/src/runtime/library-imports.scm
+++ b/src/runtime/library-imports.scm
@@ -29,20 +29,45 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (expand-parsed-imports imports db)
+(define (expand-parsed-imports import-sets db)
   (let ((unusable
-        (remove (lambda (import)
-                  (let ((name (parsed-import-library import)))
+        (remove (lambda (import-set)
+                  (let ((name (parsed-import-library import-set)))
                     (and (registered-library? name db)
                          ((registered-library name db) 'has? 'exports))))
-                imports)))
+                import-sets)))
     (if (pair? unusable)
        (error "Unknown imports:" (map parsed-import-library unusable))))
-  (reduce-right append!
-               '()
-               (map (lambda (import)
-                      (expand-parsed-import import db))
-                    imports)))
+  (let ((imports
+        (reduce-right append!
+                      '()
+                      (map (lambda (import-set)
+                             (expand-parsed-import import-set db))
+                           import-sets))))
+    (let ((dupes (find-duplicate-imports imports)))
+      (if (pair? dupes)
+         (error "Duplicate imports:"
+                (sort dupes
+                      (lambda (a b)
+                        (symbol<? (car a) (car b)))))))
+    imports))
+
+(define (find-duplicate-imports imports)
+  (let ((table (make-strong-eq-hash-table)))
+    (for-each
+     (lambda (import)
+       (hash-table-update! table
+                          (library-import-to import)
+                          (lambda (libraries)
+                            (lset-adjoin library-name=?
+                                         libraries
+                                         (library-import-from-library import)))
+                          (lambda ()
+                            '())))
+     imports)
+    (filter (lambda (p)
+             (pair? (cddr p)))
+           (hash-table->alist table))))
 
 (define-automatic-property 'imports '(parsed-imports db)
   #f
@@ -50,54 +75,43 @@ USA.
 
 ;;; Returns a list of library-import elements.
 (define (expand-parsed-import import-set db)
-  (let ((converted-set
-        (let loop ((import-set import-set) (filter (lambda (name) name)))
-          (case (car import-set)
-            ((only)
-             (loop (cadr import-set)
-                   (let ((names (cddr import-set)))
-                     (lambda (name)
-                       (and (memq name names)
-                            (filter name))))))
-            ((except)
-             (loop (cadr import-set)
-                   (let ((names (cddr import-set)))
-                     (lambda (name)
-                       (and (not (memq name names))
-                            (filter name))))))
-            ((prefix)
-             (loop (cadr import-set)
-                   (let ((prefix (caddr import-set)))
-                     (lambda (name)
-                       (filter (symbol prefix name))))))
-            ((rename)
-             (loop (cadr import-set)
-                   (let ((renames (cddr import-set)))
-                     (lambda (name)
-                       (filter
-                        (let ((p (assq name renames)))
-                          (if p
-                              (cadr p)
-                              name)))))))
-            (else
-             (if (not (library-name? import-set))
-                 (error "Unrecognized import set:" import-set))
-             (filter-map (lambda (export)
-                           (let* ((to (library-export-to export))
-                                  (filtered (filter to)))
-                             (and filtered
-                                  (make-library-import import-set
-                                                       to
-                                                       filtered))))
-                         ((registered-library import-set db)
-                          'get 'exports)))))))
-    (if (duplicate-names? (map library-import-to converted-set))
-       (error "Import set has duplicate names:" import-set))
-    converted-set))
-
-(define (duplicate-names? names)
-  (and (pair? names)
-       (let loop ((names (sort names symbol<?)))
-        (and (pair? (cdr names))
-             (or (eq? (car names) (cadr names))
-                 (loop (cdr names)))))))
\ No newline at end of file
+  (let loop ((import-set import-set) (filter (lambda (name) name)))
+    (case (car import-set)
+      ((only)
+       (loop (cadr import-set)
+            (let ((names (cddr import-set)))
+              (lambda (name)
+                (and (memq name names)
+                     (filter name))))))
+      ((except)
+       (loop (cadr import-set)
+            (let ((names (cddr import-set)))
+              (lambda (name)
+                (and (not (memq name names))
+                     (filter name))))))
+      ((prefix)
+       (loop (cadr import-set)
+            (let ((prefix (caddr import-set)))
+              (lambda (name)
+                (filter (symbol prefix name))))))
+      ((rename)
+       (loop (cadr import-set)
+            (let ((renames (cddr import-set)))
+              (lambda (name)
+                (filter
+                 (let ((p (assq name renames)))
+                   (if p
+                       (cadr p)
+                       name)))))))
+      (else
+       (if (not (library-name? import-set))
+          (error "Unrecognized import set:" import-set))
+       (filter-map (lambda (export)
+                    (let* ((to (library-export-to export))
+                           (filtered (filter to)))
+                      (and filtered
+                           (make-library-import import-set
+                                                to
+                                                filtered))))
+                  ((registered-library import-set db)
+                   'get 'exports))))))
\ No newline at end of file