Provide uniform mechanism to for environment names.

Previously we called environment->package and used the name of the returned
package, if any.  Now there is environment-name and some other procedures that
get the name, whether it's a package or a library.

diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm
index 0efd89b785cff464664ff3256a995c018da3e4dc..24a02190d5d6574f41c06a4e59a9424f8f1879da 100644 (file)
--- a/src/edwin/debug.scm
+++ b/src/edwin/debug.scm
@@ -1534,7 +1534,7 @@ once it has been renamed, it will not be deleted automatically.")
   (debugger-newline port)
   (debugger-newline port)
   (let ((names (environment-bound-names environment))
-       (package (environment->package environment))
+       (name? (environment-has-name? environment))
        (finish
         (lambda (names)
           (debugger-newline port)
@@ -1546,7 +1546,7 @@ once it has been renamed, it will not be deleted automatically.")
             names))))
     (cond ((null? names)
           (write-string " has no bindings" port))
-         ((and package
+         ((and name?
                (let ((limit (ref-variable environment-package-limit)))
                  (and limit
                       (let ((n (length names)))
@@ -1561,7 +1561,7 @@ once it has been renamed, it will not be deleted automatically.")
                                #t)))))))
          (else
           (write-string "  BINDINGS:" port)
-          (finish (if package (sort names symbol<?) names)))))
+          (finish (if name? (sort names symbol<?) names)))))
   (debugger-newline port)
   (debugger-newline port)
   (write-string
@@ -1696,11 +1696,11 @@ once it has been renamed, it will not be deleted automatically.")
 
 (define (show-environment-name environment port)
   (write-string "ENVIRONMENT " port)
-  (let ((package (environment->package environment)))
-    (if package
+  (let ((name (environment-name environment)))
+    (if name
        (begin
          (write-string "named: " port)
-         (write (package/name package) port))
+         (write name port))
        (begin
          (write-string "created by " port)
          (print-user-friendly-name environment port)))))
@@ -1739,7 +1739,7 @@ once it has been renamed, it will not be deleted automatically.")
                          ind
                          port))
                       names))))
-      (cond ((environment->package environment)
+      (cond ((environment-has-name? environment)
             (write-string (string-append ind "    has ") port)
             (write n-bindings port)
             (write-string

diff --git a/src/runtime/apropos.scm b/src/runtime/apropos.scm
index 4057cab1ffad1733d4ad4f1776a4ade73edd19d1..053c8e523d1006e69b642ef0350d400cb7a05eeb 100644 (file)
--- a/src/runtime/apropos.scm
+++ b/src/runtime/apropos.scm
@@ -77,6 +77,7 @@ USA.
   (write symbol))
 
 (define (apropos-describe-env env)
-  (let ((package (environment->package env)))
-    (newline)
-    (write (or package env))))
\ No newline at end of file
+  (newline)
+  (write (or (environment->package env)
+            (environment->library env)
+            env)))
\ No newline at end of file

diff --git a/src/runtime/dbgutl.scm b/src/runtime/dbgutl.scm
index a61c801159211a5b49b926d8b76f4e773b18302f..45008572653ce73cbb5a0e75e00c36f5d25a4f91 100644 (file)
--- a/src/runtime/dbgutl.scm
+++ b/src/runtime/dbgutl.scm
@@ -118,16 +118,16 @@ USA.
        (write-string "Depth (relative to initial environment): " port)
        (write depth port)
        (newline port)))
-  (if (not (and (environment->package environment) brief?))
+  (if (not (and (environment-has-name? environment) brief?))
       (show-environment-bindings environment brief? port)))
 \f
 (define (show-environment-name environment port)
   (write-string "Environment " port)
-  (let ((package (environment->package environment)))
-    (if package
+  (let ((name (environment-name environment)))
+    (if name
        (begin
          (write-string "named: " port)
-         (write (package/name package) port))
+         (write name port))
        (begin
          (write-string "created by " port)
          (print-user-friendly-name environment port))))

diff --git a/src/runtime/debug.scm b/src/runtime/debug.scm
index 9cbe0172e6511dbba21eacac319af168c9313619..4c872b013c8871e7d48f81d8545069f77efd5baf 100644 (file)
--- a/src/runtime/debug.scm
+++ b/src/runtime/debug.scm
@@ -403,7 +403,7 @@ USA.
 (define (print-environment environment port)
   (newline port)
   (show-environment-name environment port)
-  (if (not (environment->package environment))
+  (if (not (environment-has-name? environment))
       (begin
        (newline port)
        (let ((arguments (environment-arguments environment)))

diff --git a/src/runtime/environment.scm b/src/runtime/environment.scm
index 4d95070d2633b5fe166e74037427d88521c4faca..c7e760bf8c0ecd60afa7160f75b2b10bb036a328 100644 (file)
--- a/src/runtime/environment.scm
+++ b/src/runtime/environment.scm
@@ -265,7 +265,8 @@ USA.
     result))
 
 (define (special-unbound-name? name)
-  (eq? name package-name-tag))
+  (or (eq? name package-name-tag)
+      (eq? name environment-library-tag)))
 \f
 ;;;; Interpreter Environments
 

diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm
index 655a25229b29a2064dd85b6a3d820661b3f30903..12fa561cea5d69eb99718c0c48f05b4f09f5e6fd 100644 (file)
--- a/src/runtime/library-loader.scm
+++ b/src/runtime/library-loader.scm
@@ -106,6 +106,7 @@ USA.
              make-top-level-environment)
          (delete-duplicates (map library-ixport-to imports) eq?))))
     (add-imports-to-env! imports env db importing-library)
+    (if importing-library (set-environment->library! env importing-library))
     env))
 
 (define (add-imports-to-env! imports env db importing-library)
@@ -206,6 +207,39 @@ USA.
                         (nearest-repl/environment)
                         db
                         #f)))
+
+(define (environment->library env)
+  (let ((value
+        (and (eq? 'normal
+                  (environment-reference-type env environment-library-tag))
+             (environment-lookup env environment-library-tag))))
+    (and (library? value)
+        value)))
+
+(define (set-environment->library! env library)
+  (environment-define env environment-library-tag library))
+
+(define-integrable environment-library-tag
+  '|#[(library database)library-tag]|)
+
+(define (environment-name environment)
+  (cond ((environment->package environment) => package/name)
+       ((environment->library environment) => library-key)
+       (else #f)))
+
+(define (environment-name&type environment)
+  (cond ((environment->package environment)
+        => (lambda (package)
+             (values (package/name package) "package")))
+       ((environment->library environment)
+        => (lambda (library)
+             (values (library-key library) "library")))
+       (else
+        (values #f #f))))
+
+(define (environment-has-name? environment)
+  (or (environment->package environment)
+      (environment->library environment)))
 \f
 (define (import-sets->imports import-sets db)
   (parsed-imports->imports (map parse-import-set import-sets) db))

diff --git a/src/runtime/rep-ui.scm b/src/runtime/rep-ui.scm
index b5c24b1098dab487d3c178dbe4355443972d31c5..222994f7da13c0dd47cb984c76b2f2dc845b613b 100644 (file)
--- a/src/runtime/rep-ui.scm
+++ b/src/runtime/rep-ui.scm
@@ -277,10 +277,11 @@ Otherwise, shows all REPL environments."
         => (lambda (name)
              (write name port)
              (write-string " " port))))
-  (cond ((environment->package env)
-        => (lambda (package)
-             (write (package/name package) port)
-             (write-string " " port))))
+  (let ((name (environment-name env)))
+    (if name
+       (begin
+         (write name port)
+         (write-string " " port))))
   (write env port))
 \f
 (define-command 'name '(name)

diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index a8d75c915c70aecb394e6d4f25c7c3ad94d70f1a..b5be63c6cbdd614942be31ae5ba10c2fdfa5bca8 100644 (file)
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -578,12 +578,14 @@ USA.
 ; Assignments to most compiled-code bindings are prohibited,
 ; as are certain other environment operations."
               port)))
-       (let ((package (environment->package environment)))
-         (if package
+       (let-values (((name type) (environment-name&type environment)))
+         (if name
              (begin
                (fresh-line port)
-               (write-string ";Package: " port)
-               (write (package/name package) port))))))))
+               (write-string ";" port)
+               (write-string type port)
+               (write-string ": " port)
+               (write name port))))))))
 \f
 (define (restart #!optional n)
   (let ((condition (nearest-repl/condition)))
@@ -872,10 +874,7 @@ USA.
   (let ((env-mgr (repl/env-mgr (nearest-repl))))
     (let ((env (env-mgr 'current)))
       (or (env-mgr 'name-of env)
-         (let ((package (environment->package env)))
-           (if package
-               (package/name package)
-               env))))))
+         (or (environment-name env) env)))))
 
 (define (ge #!optional environment)
   ((repl/env-mgr (nearest-repl))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index db5e2bfce206c840ccd417d3a8b1c050ea822930..b110ed98c1cec643c1ba0d18ef0179250e390823 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -6470,6 +6470,7 @@ USA.
          library-imports
          library-imports-environment
          library-imports-used
+         library-key
          library-name
          library-parsed-contents
          library-parsed-exports
@@ -6593,6 +6594,10 @@ USA.
   (parent (runtime library))
   (export ()
          environment                   ;(scheme eval)
+         environment->library
+         environment-has-name?
+         environment-name
+         environment-name&type
          find-scheme-libraries!
          null-environment              ;(scheme r5rs)
          scheme-report-environment     ;(scheme r5rs)
@@ -6603,7 +6608,9 @@ USA.
          eval-r7rs-source
          make-environment-from-parsed-imports
          repl-import
-         syntax-r7rs-source))
+         syntax-r7rs-source)
+  (export (runtime environment)
+         environment-library-tag))
 
 (define-package (runtime directed-graph)
   (files "digraph")

diff --git a/src/runtime/stack-sample.scm b/src/runtime/stack-sample.scm
index 069a112b12ec76300726af9a019bde7dc1f03f58..95e9976fe34b216610020c8b0889f5244ff1abd8 100644 (file)
--- a/src/runtime/stack-sample.scm
+++ b/src/runtime/stack-sample.scm
@@ -312,9 +312,9 @@
 (define (environment-ancestry-names environment)
   (let recur ((environment environment))
     (if (environment? environment)      ;Idle paranoia?
-        (let ((package (environment->package environment)))
-          (if package
-              (list (package/name package))
+       (let ((name (environment-name environment)))
+          (if name
+              (list name)
               (let ((name (environment-procedure-name environment))
                     (names
                      (if (environment-has-parent? environment)

diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm
index 8594ff41e79ab6673e726ab66de14498f235e4e5..d088869f3ebb1da45953867fc29c4b2fcfa6e458 100644 (file)
--- a/src/runtime/swank.scm
+++ b/src/runtime/swank.scm
@@ -258,9 +258,9 @@ USA.
         (package/environment (find-package (read-from-string pstring) #t)))))
 
 (define (env->pstring env)
-  (let ((package (environment->package env)))
-    (if package
-       (write-to-string (package/name package))
+  (let ((name (environment-name env)))
+    (if name
+       (write-to-string name)
        (string anonymous-package-prefix (hash-object env)))))
 
 (define anonymous-package-prefix
@@ -1027,8 +1027,7 @@ swank:xref
              (iline "cdr" (cdr pair)))))
 \f
 (define (inspect-environment env)
-  (let ((package (environment->package env))
-       (tail
+  (let ((tail
         (let loop ((bindings (environment-bindings env)))
           (if (pair? bindings)
               (cons-stream (let ((binding (car bindings)))
@@ -1044,9 +1043,10 @@ swank:xref
               (if (environment-has-parent? env)
                   (stream (iline "(<parent>)" (environment-parent env)))
                   (stream))))))
-    (if package
-       (cons-stream (iline "(package)" package) tail)
-       tail)))
+    (let-values (((name type) (environment-name&type env)))
+      (if name
+         (cons-stream (iline (string-append "(" type ")") name) tail)
+         tail))))
 
 (define (inspect-vector o)
   (let ((len (vector-length o)))

diff --git a/tests/check.scm b/tests/check.scm
index 65c8e1f77b659f4ac3cbd48b04890e3a71b038dd..c8d124f4bfb4d6753a820b10e83de0131eb1669f 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -189,9 +189,8 @@ USA.
                          (if (not (default-object? environment))
                              (begin
                                (write-string " in environment " output-port)
-                               (write (cond ((environment->package environment)
-                                             => package/name)
-                                            (else environment))
+                               (write (or (environment-name environment)
+                                          environment)
                                       output-port))))
                      (lambda ()
                        (if inline?