Add ability to import a library into an existing environment.

diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm
index 7f284a4e13a37afb86e5011c7b2e98a7d42b95d9..7f0d2197c2c57ba3c50d4474d6d956cb41a1f2ad 100644 (file)
--- a/src/runtime/library-loader.scm
+++ b/src/runtime/library-loader.scm
@@ -85,31 +85,49 @@ USA.
   (let ((env
         (make-root-top-level-environment
          (delete-duplicates (map library-import-to imports) eq?))))
+    (add-imports-to-env! imports env db)
+    env))
+
+(define (add-imports-to-env! imports env db)
+  (for-each
+   (lambda (group)
+     (for-each (let ((exporter
+                     (library-exporter
+                      (registered-library
+                       (library-import-from-library (car group))
+                       db))))
+                (lambda (import)
+                  (let ((value (exporter (library-import-from import)))
+                        (name (library-import-to import)))
+                    (if (or (not (environment-bound? env name))
+                            (let ((value* (environment-safe-lookup env name)))
+                              (and (not (values-equivalent? value value*))
+                                   (or (unassigned-reference-trap? value*)
+                                       (error "Conflicting imports:"
+                                              name value* value)))))
+                        (cond ((macro-reference-trap? value)
+                               (environment-define-macro
+                                env name
+                                (macro-reference-trap-transformer value)))
+                              ((unassigned-reference-trap? value)
+                               ;; nothing to do
+                               )
+                              (else
+                               (environment-define env name value)))))))
+              group))
+   (group-imports-by-source imports)))
+
+(define (group-imports-by-source imports)
+  (let ((table (make-equal-hash-table)))
     (for-each (lambda (import)
-               (let ((value
-                      ((library-exporter
-                        (registered-library
-                         (library-import-from-library import)
-                         db))
-                       (library-import-from import)))
-                     (name (library-import-to import)))
-                 (if (or (not (environment-bound? env name))
-                         (let ((value* (environment-safe-lookup env name)))
-                           (and (not (values-equivalent? value value*))
-                                (or (unassigned-reference-trap? value*)
-                                    (error "Conflicting imports:"
-                                           name value* value)))))
-                     (cond ((macro-reference-trap? value)
-                            (environment-define-macro
-                             env name
-                             (macro-reference-trap-transformer value)))
-                           ((unassigned-reference-trap? value)
-                            ;; nothing to do
-                            )
-                           (else
-                            (environment-define env name value))))))
+               (hash-table-update! table
+                                   (library-import-from-library import)
+                                   (lambda (imports)
+                                     (cons import imports))
+                                   (lambda ()
+                                     '())))
              imports)
-    env))
+    (hash-table-values table)))
 
 (define (values-equivalent? v1 v2)
   (cond ((unassigned-reference-trap? v1)
@@ -128,17 +146,28 @@ USA.
   make-environment-from-imports)
 \f
 (define (environment . import-sets)
-  (let ((parsed (map parse-import-set import-sets))
-       (db host-library-db))
-    (let ((imports (expand-parsed-imports parsed db)))
-      (let ((unavailable
-            (remove (lambda (import)
-                      (import-environment-available? import db))
-                    imports)))
-       (if (pair? unavailable)
-           (error "Imported libraries unavailable:"
-                  (library-imports-from unavailable))))
-      (make-environment-from-imports imports db))))
+  (let ((db (current-library-db)))
+    (make-environment-from-imports (import-sets->imports import-sets db)
+                                  db)))
+
+(define (import! import-set #!optional env)
+  (let ((db (current-library-db)))
+    (add-imports-to-env! (import-sets->imports (list import-set) db)
+                        (if (default-object? env)
+                            (nearest-repl/environment)
+                            (guarantee environment? env 'import!))
+                        db)))
+
+(define (import-sets->imports import-sets db)
+  (let ((imports (expand-parsed-imports (map parse-import-set import-sets) db)))
+    (let ((unavailable
+          (remove (lambda (import)
+                    (import-environment-available? import db))
+                  imports)))
+      (if (pair? unavailable)
+         (error "Imported libraries unavailable:"
+                (library-imports-from unavailable))))
+    imports))
 
 (define (scheme-report-environment version)
   (if (not (eqv? version 5))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2d6e16c9a52a385d94802d8a9a69fb4a69a377cd..1a6a577ac2f5fb7930352b7aa7be229d2cb792ee 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -6117,6 +6117,7 @@ USA.
   (export ()
          environment                   ;R7RS
          find-scheme-libraries!
+         import!
          null-environment              ;R7RS
          scheme-report-environment     ;R7RS
          )