Fix library bugs for existing test cases.

It remains to write tests that exercise the new functionality.

diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm
index e6a05f8f53229c9d8ae20020b702b9619b8538e2..bdb7dde69f64ed51a2bf5d84af5e4bc2becd6f67 100644 (file)
--- a/src/runtime/library-database.scm
+++ b/src/runtime/library-database.scm
@@ -256,20 +256,27 @@ USA.
   (library-name export-group-library-name)
   (exports export-group-exports))
 
-(define (library-exports library #!optional importing-library-name)
+(define-print-method export-group?
+  (standard-print-method 'export-group
+    (lambda (group)
+      (list (export-group-library-name group)))))
+
+(define (library-exports library #!optional importing-library)
   (let ((groups (library-export-groups library)))
-    (if (default-object? importing-library-name)
+    (if (or (not importing-library)
+           (default-object? importing-library))
        (let ((public
               (find (lambda (group)
                       (not (export-group-library-name group)))
                     groups)))
          (if public
-             (export-group-exports (car public))
+             (export-group-exports public)
              '()))
        (fold (lambda (group exports)
-               (let ((export-to (export-group-library-name group)))
+               (let ((export-to (export-group-library-name group))
+                     (importing-name (library-name importing-library)))
                  (if (or (not export-to)
-                         (library-name=? export-to importing-library-name))
+                         (library-name=? export-to importing-name))
                      (append (export-group-exports group) exports)
                      exports)))
              '()

diff --git a/src/runtime/library-ixports.scm b/src/runtime/library-ixports.scm
index 459afc1b380db9b474f95317c4e258ae951754e9..3298ad417a4c8483940c281de749ca8235761acd 100644 (file)
--- a/src/runtime/library-ixports.scm
+++ b/src/runtime/library-ixports.scm
@@ -159,17 +159,21 @@ USA.
    parsed-export library libraries))
 
 (define (merge-parsed-exports parsed-exports)
-  (let ((tag (caar parsed-exports))
-       (amap (make-amap (make-equal-comparator) 'alist)))
-    (for-each (lambda (parsed-export)
-               (amap-update!/default amap
-                                     (cadr parsed-export)
-                                     (lambda (names)
-                                       (lset-union (cddr parsed-export) names))
-                                     '()))
-             parsed-exports)
-    (map (lambda (p) (cons tag p))
-        (amap->alist amap))))
+  (if (pair? parsed-exports)
+      (let ((tag (caar parsed-exports))
+           (amap (make-amap (make-equal-comparator) 'alist)))
+       (for-each (lambda (parsed-export)
+                   (amap-update!/default amap
+                                         (cadr parsed-export)
+                                         (lambda (names)
+                                           (lset-union eq?
+                                                       (cddr parsed-export)
+                                                       names))
+                                         '()))
+                 parsed-exports)
+       (map (lambda (p) (cons tag p))
+            (amap->alist amap)))
+      parsed-exports))
 \f
 (define (check-missing-exports groups names)
   (let ((missing
@@ -198,7 +202,7 @@ USA.
                                 (lset-adjoin eq?
                                              froms
                                              (library-ixport-from export)))
-                              (if public
+                              (if base-names
                                   (append (export-group-exports private)
                                           base-names)
                                   (export-group-exports private))))
@@ -254,5 +258,4 @@ USA.
            (symbol<? (car a) (car b))))))
 
 (define (get-exports library db importing-library)
-  (library-exports (registered-library library db)
-                  (and importing-library (library-name importing-library))))
\ No newline at end of file
+  (library-exports (registered-library library db) importing-library))
\ No newline at end of file

diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm
index 7f7d179c1eadc461d8ce2d18449a12ca25664538..9002a4971da0ae8d9f0d78430ce42a33c4504c35 100644 (file)
--- a/src/runtime/library-loader.scm
+++ b/src/runtime/library-loader.scm
@@ -44,7 +44,7 @@ USA.
     (syntax-library-forms (expand-contents parsed-contents) env)))
 
 (define-automatic-property 'imports-used
-    '(imports export-groups free-names bound-names name)
+    '(imports export-groups free-names bound-names)
   #f
   (lambda (imports groups free-names bound-names)
     (let ((imports-to
@@ -98,24 +98,23 @@ USA.
     (and (registered-library? name db)
         (library-has? 'environment (registered-library name db)))))
 
-(define (make-environment-from-imports imports db #!optional sealed?
-                                      importing-library-name)
+(define (make-environment-from-imports imports db importing-library sealed?)
   (let ((env
         ((if sealed?
              make-root-top-level-environment
              make-top-level-environment)
          (delete-duplicates (map library-ixport-to imports) eq?))))
-    (add-imports-to-env! imports env db importing-library-name)
+    (add-imports-to-env! imports env db importing-library)
     env))
 
-(define (add-imports-to-env! imports env db #!optional importing-library-name)
+(define (add-imports-to-env! imports env db importing-library)
   (let ((grouped
         (let ((table (make-strong-eq-hash-table)))
           (for-each (lambda (import)
                       (let-values
                           (((senv sname)
                             (library-import-source import db
-                                                   importing-library-name)))
+                                                   importing-library)))
                         (hash-table-update! table (library-ixport-to import)
                           (lambda (sources) (cons (cons senv sname) sources))
                           (lambda () '()))))
@@ -156,37 +155,36 @@ USA.
                             (environment-define env tname value))))))
                other))))
 
-(define (library-import-source import db importing-library-name)
+(define (library-import-source import db importing-library)
   (let ((name (library-ixport-from import))
        (library (registered-library (library-ixport-from-library import) db)))
     (let ((export
           (find (lambda (export)
                   (eq? name (library-ixport-to export)))
-                (library-exports library importing-library-name))))
+                (library-exports library importing-library))))
       (if (not export)
          (error "Not an exported name:" name))
       (values (library-environment library)
              (library-ixport-from export)))))
 \f
-(define-automatic-property 'imports-environment '(imports db name)
-  (lambda (imports db name)
-    (declare (ignore name))
+(define-automatic-property 'imports-environment '(imports db library)
+  (lambda (imports db library)
+    (declare (ignore library))
     (every (lambda (import)
             (environment-available? import db))
           imports))
-  (lambda (imports db name)
-    (make-environment-from-imports imports db #t name)))
+  (lambda (imports db library)
+    (make-environment-from-imports imports db library #t)))
 
 (define (environment . import-sets)
   (let ((db (current-library-db)))
     (make-environment-from-imports (import-sets->imports import-sets db)
-                                  db)))
+                                  db #f #t)))
 
 (define (top-level-environment . import-sets)
   (let ((db (current-library-db)))
     (make-environment-from-imports (import-sets->imports import-sets db)
-                                  db
-                                  #f)))
+                                  db #f #f)))
 
 (define (scheme-report-environment version)
   (if (not (eqv? version 5))
@@ -205,7 +203,8 @@ USA.
   (let ((db (current-library-db)))
     (add-imports-to-env! (import-sets->imports import-sets db)
                         (nearest-repl/environment)
-                        db)))
+                        db
+                        #f)))
 \f
 (define (import-sets->imports import-sets db)
   (parsed-imports->imports (map parse-import-set import-sets) db))
@@ -213,7 +212,7 @@ USA.
 (define (make-environment-from-parsed-imports parsed-imports)
   (let ((db (current-library-db)))
     (make-environment-from-imports (parsed-imports->imports parsed-imports db)
-                                  db)))
+                                  db #f #t)))
 
 (define (parsed-imports->imports parsed-imports db)
   (let ((imports (expand-parsed-imports parsed-imports db)))

diff --git a/src/runtime/library-parser.scm b/src/runtime/library-parser.scm
index 51a717e46c0a50f896b5ca748e8daa12292136e5..109a810a1b74237ac18a7ecdd4a9d00055715f5a 100644 (file)
--- a/src/runtime/library-parser.scm
+++ b/src/runtime/library-parser.scm
@@ -262,6 +262,7 @@ USA.
     (encapsulate list
       (list 'define-library
            (match-if library-name?)
+
            (* (object r7rs-declaration-parser))))))
 
 (define r7rs-declaration-parser
@@ -277,7 +278,7 @@ USA.
   (object-parser
    (encapsulate list
      (list 'export
-          (values 'r7rs-export)
+          (values 'r7rs-export #f)
            (* (object r7rs-export-spec-parser))))))
 
 (define r7rs-export-spec-parser

diff --git a/src/runtime/library-scode.scm b/src/runtime/library-scode.scm
index b67c453490c25ca007320880251bea373351753d..1065fc173bb85fc000ba9410aacfa15721ad2ed1 100644 (file)
--- a/src/runtime/library-scode.scm
+++ b/src/runtime/library-scode.scm
@@ -107,9 +107,10 @@ USA.
 
 (define (scode-library-export-groups library)
   (if (= 2 (scode-library-version library))
-      (make-export-group
-       #f
-       (map list->library-ixport (scode-library-property 'exports library)))
+      (list
+       (make-export-group
+       #f
+       (map list->library-ixport (scode-library-property 'exports library))))
       (map list->export-group (scode-library-property 'export-groups library))))
 
 (define (singleton-list? object)

diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm
index f6cfd7b8cee6b8f89a85493544db7f8e1f2ab191..13d63ede79e455bfa808f7aa5c7380db691e9f3b 100644 (file)
--- a/src/runtime/library-standard.scm
+++ b/src/runtime/library-standard.scm
@@ -47,7 +47,8 @@ USA.
         (let ((library (car p))
               (exports (cdr p)))
           (make-library library
-                        'exports (convert-exports exports)
+                        'export-groups
+                        (list (make-export-group #f (convert-exports exports)))
                         'environment system-global-environment)))
        standard-libraries))
 
@@ -1181,7 +1182,8 @@ USA.
 
 (define (make-synthetic-library library exports environment)
   (register-library! (make-library library
-                                  'exports exports
+                                  'export-groups
+                                  (list (make-export-group #f exports))
                                   'environment environment)
                     host-library-db))
 

diff --git a/tests/runtime/test-library-parser.scm b/tests/runtime/test-library-parser.scm
index 28433b8d0b57a74a6fe0c3a95014a64c4c29aa93..fd932820f0c2b87a3aeb3aa4acb7f56755a68e0f 100644 (file)
--- a/tests/runtime/test-library-parser.scm
+++ b/tests/runtime/test-library-parser.scm
@@ -52,7 +52,7 @@ USA.
       (assert-equal (library-parsed-imports library)
                    `((r7rs-import ,@ex1-imports)))
       (assert-equal (library-parsed-exports library)
-                   `((r7rs-export ,@ex1-exports)))
+                   `((r7rs-export #f ,@ex1-exports)))
       (assert-equal (library-parsed-contents library)
                    (append-map convert-content ex1-contents))
       (assert-string= (library-filename library)
@@ -67,8 +67,8 @@ USA.
                    `((r7rs-import ,@ex1-imports)
                      (r7rs-import ,@ex2-extra-imports)))
       (assert-equal (library-parsed-exports library)
-                   `((r7rs-export ,@ex1-exports)
-                     (r7rs-export ,@ex2-extra-exports)))
+                   `((r7rs-export #f ,@ex1-exports)
+                     (r7rs-export #f ,@ex2-extra-exports)))
       (assert-equal (library-parsed-contents library)
                    (append-map convert-content
                                (append ex2-extra-contents ex1-contents)))