Change ->environment to work with library names too.

diff --git a/src/runtime/environment.scm b/src/runtime/environment.scm
index 0944c13914872dcb4f1139d26bf662a9d6a1c9ee..9338264cb05e6469338a9fcf34a485d9b2675675 100644 (file)
--- a/src/runtime/environment.scm
+++ b/src/runtime/environment.scm
@@ -36,6 +36,14 @@ USA.
       (closure-ccenv? object)))
 (register-predicate! environment? 'environment)
 
+(define (->environment object #!optional caller)
+  (let ((caller (if (default-object? caller) '->environment caller)))
+    (cond ((environment? object) object)
+         ((library->environment-helper object) => library-environment)
+         ((name->package object) => package/environment)
+         ((procedure? object) (procedure-environment object))
+         (else (error:wrong-type-argument object "environment" caller)))))
+
 (define (environment-has-parent? environment)
   (cond ((system-global-environment? environment)
         #f)

diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm
index bfee0c2673b8e343c24143eb62afac7b893985f8..3fb06d10473f6f55a98fa48f5cd7e6ea978ec84d 100644 (file)
--- a/src/runtime/library-database.scm
+++ b/src/runtime/library-database.scm
@@ -331,4 +331,14 @@ USA.
 (define library-name (library-accessor 'name))
 (define library-parsed-contents (library-accessor 'parsed-contents))
 (define library-parsed-imports (library-accessor 'parsed-imports))
-(define library-syntaxed-contents (library-accessor 'syntaxed-contents))
\ No newline at end of file
+(define library-syntaxed-contents (library-accessor 'syntaxed-contents))
+
+(define (library->environment-helper name)
+  (if (library? name)
+      (and (name 'has? 'environment)
+          name)
+      (and (library-name? name)
+          (registered-library? name host-library-db)
+          (let ((library (registered-library name host-library-db)))
+            (and (library 'has? 'environment)
+                 library)))))
\ No newline at end of file

diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm
index f7b0ae5f40cc322f4055f719154cb624471ab268..1933dc7a7f5bd9aeea7d1430d2a8bdf27ac7f9a4 100644 (file)
--- a/src/runtime/packag.scm
+++ b/src/runtime/packag.scm
@@ -65,6 +65,13 @@ USA.
 (define (package-name? object)
   (list-of-type? object symbol?))
 
+(define (package-name=? name1 name2)
+  (or (and (null? name1) (null? name2))
+      (and (pair? name1)
+          (pair? name2)
+          (eq? (car name1) (car name2))
+          (package-name=? (cdr name1) (cdr name2)))))
+
 (define (package/reference package name)
   (lexical-reference (package/environment package) name))
 
@@ -103,19 +110,13 @@ USA.
 
 (define (find-package name #!optional error?)
   (let package-loop ((packages *packages*))
-    (if (null? packages)
-       (if error?
-           (error "Unable to find package:" name)
-           #f)
-       (if (let name-loop ((name1 name)
-                           (name2 (package/name (car packages))))
-             (cond ((and (null? name1) (null? name2)) #t)
-                   ((or (null? name1) (null? name2)) #f)
-                   ((eq? (car name1) (car name2))
-                    (name-loop (cdr name1) (cdr name2)))
-                   (else #f)))
+    (if (pair? packages)
+       (if (package-name=? name (package/name (car packages)))
            (car packages)
-           (package-loop (cdr packages))))))
+           (package-loop (cdr packages)))
+       (begin
+         (if error? (error "Unable to find package:" name))
+         #f))))
 
 (define (name-append name package)
   (let loop ((names (package/name package)))

diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index b45f47f6ee8ae7a00aaae101daf54ed3114fcd7a..5fefb54119a4466a0bc1e469c6fd08734cce973e 100644 (file)
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -127,6 +127,7 @@ USA.
                            (interaction-i/o-port #f)
                            (working-directory-pathname
                             (working-directory-pathname))
+                           (current-library-db (current-library-db))
                            (param:nearest-cmdl cmdl)
                            (param:standard-error-hook #f)
                            (param:standard-warning-hook #f)
@@ -792,23 +793,6 @@ USA.
     (set-repl/environment! (nearest-repl) environment)
     environment))
 
-(define (->environment object #!optional caller)
-  (let ((caller (if (default-object? caller) '->environment caller)))
-    (cond ((environment? object) object)
-         ((package? object) (package/environment object))
-         ((procedure? object) (procedure-environment object))
-         (else
-          (let ((package
-                 (let ((package-name
-                        (cond ((symbol? object) (list object))
-                              ((list? object) object)
-                              (else #f))))
-                   (and package-name
-                        (name->package package-name)))))
-            (if (not package)
-                (error:wrong-type-argument object "environment" caller))
-            (package/environment package))))))
-
 (define (re #!optional index)
   (repl-eval (repl-history/read (repl/reader-history (nearest-repl))
                                (if (default-object? index) 1 index))))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index b13e34014456c7e5a2650a88714081e4c3f36e02..4edba5cb7544934958567bbb37bd2b547405c476 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1957,6 +1957,7 @@ USA.
   (files "environment")
   (parent (runtime))
   (export ()
+         ->environment
          compiled-procedure/environment
          environment-arguments
          environment-assign!
@@ -3866,7 +3867,6 @@ USA.
   (parent (runtime))
   (export ()
          (interaction-environment nearest-repl/environment) ;R7RS
-         ->environment
          abort->nearest
          abort->previous
          abort->top-level
@@ -5852,6 +5852,13 @@ USA.
   (parent (runtime library))
   (export (runtime)
          copy-library-db
+         library-bound-names
+         library-contents
+         library-db?
+         library-environment
+         library-imports-used
+         library-imports
+         library-name
          library-export-from
          library-export-to
          library-export=?
@@ -5860,27 +5867,27 @@ USA.
          library-import-from-library
          library-import-to
          library-import=?
-         library-import?)
+         library-import?
+         library?
+         registered-libraries
+         registered-library
+         registered-library?)
+  (export (runtime environment)
+         library->environment-helper)
   (export (runtime library)
          define-automatic-property
          library-contents
-         library-db?
-         library-environment
          library-eval-result
          library-exporter
          library-export->list
          library-exports
          library-filename
          library-imports-from
-         library-imports-used
          library-import->list
-         library-imports
          library-imports-environment
-         library-name
          library-parsed-contents
          library-parsed-imports
          library-syntaxed-contents
-         library?
          list->library-export
          list->library-import
          make-library
@@ -5888,10 +5895,7 @@ USA.
          make-library-export
          make-library-import
          register-libraries!
-         register-library!
-         registered-libraries
-         registered-library
-         registered-library?))
+         register-library!))
 
 (define-package (runtime library parser)
   (files "library-parser")