Arrange for runtime packages to be importable as libraries.

diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm
index a8e3b5cbe1ecfe9ee961fbdf351d7977bf929366..2156ba5a6b36b44a6d6a1a976604f6364fac6518 100644 (file)
--- a/src/runtime/library-standard.scm
+++ b/src/runtime/library-standard.scm
@@ -973,4 +973,32 @@ USA.
     string-hash))
 
 (define-standard-library '(srfi 131)
-  '(define-record-type))
\ No newline at end of file
+  '(define-record-type))
+\f
+;;;; Legacy packages
+
+(define legacy-libraries)
+
+(define (initialize-legacy-libraries! package-file)
+  (set! legacy-libraries
+       (filter-map (lambda (pd)
+                     (and (let ((name (package-description/name pd)))
+                            (and (pair? name)
+                                 (eq? (car name) 'runtime)))
+                          (create-legacy-library pd)))
+                   (vector->list (package-file/descriptions package-file))))
+  (register-libraries! legacy-libraries host-library-db))
+
+(define (create-legacy-library pd)
+  (make-library (cons* 'mit 'legacy (package-description/name pd))
+               'parsed-imports '()
+               'exports (package-exports pd)
+               'parsed-contents '()
+               'filename #f
+               'environment system-global-environment))
+
+(define (package-exports pd)
+  (filter-map (lambda (link)
+               (and (null? (link-description/package link))
+                    (make-library-export (link-description/outer-name link))))
+             (vector->list (package-description/exports pd))))
\ No newline at end of file

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index a0b9d9ce96e17f1e145985a8b66236028116df50..7a09f410e44da0d7cc3263b3dbeba15171b55c50 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -570,8 +570,22 @@ USA.
   (if obj
       (eval obj system-global-environment)))
 
-(link-variables (->environment '(runtime environment)) 'package-name-tag
-               (->environment '(package)) 'package-name-tag)
+(let* ((package-env (->environment '(package)))
+       (export
+       (lambda (target-package names)
+         (let ((target-env (->environment target-package)))
+           (for-each (lambda (name)
+                       (link-variables target-env name package-env name))
+                     names)))))
+  (export '(runtime environment)
+         '(package-name-tag))
+  (export '(runtime library standard)
+         '(link-description/inner-name
+           link-description/outer-name
+           link-description/package
+           package-description/exports
+           package-description/name
+           package-file/descriptions)))
 
 (let ((roots
        (list->vector
@@ -603,6 +617,10 @@ USA.
   (purify roots #t #f)
   (write-string "done" (console-i/o-port)))
 
+((lexical-reference (->environment '(runtime library standard))
+                   'initialize-legacy-libraries!)
+ packages-file)
+
 )
 
 (package/add-child! (find-package '()) 'user user-initial-environment)

diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm
index 1933dc7a7f5bd9aeea7d1430d2a8bdf27ac7f9a4..308f688c3fa6ef7c83fd1951f6c62e58fdab23f4 100644 (file)
--- a/src/runtime/packag.scm
+++ b/src/runtime/packag.scm
@@ -200,31 +200,6 @@ USA.
 (define-integrable (make-package-file tag version descriptions loads)
   (vector tag version descriptions loads))
 
-(define-integrable (package-file/tag pf) (vector-ref pf 0))
-(define-integrable (package-file/version pf) (vector-ref pf 1))
-(define-integrable (package-file/descriptions pf) (vector-ref pf 2))
-(define-integrable (package-file/loads pf) (vector-ref pf 3))
-
-(define-integrable (make-package-description name ancestors internal-names
-                                            exports imports extension?)
-  (vector name ancestors internal-names exports imports extension?))
-
-(define-integrable (package-description/name pd) (vector-ref pd 0))
-(define-integrable (package-description/ancestors pd) (vector-ref pd 1))
-(define-integrable (package-description/internal-names pd) (vector-ref pd 2))
-(define-integrable (package-description/exports pd) (vector-ref pd 3))
-(define-integrable (package-description/imports pd) (vector-ref pd 4))
-(define-integrable (package-description/extension? pd) (vector-ref pd 5))
-
-(define-integrable (make-load-description name file-cases initializations
-                                         finalizations)
-  (vector name file-cases initializations finalizations))
-
-(define-integrable (load-description/name pd) (vector-ref pd 0))
-(define-integrable (load-description/file-cases pd) (vector-ref pd 1))
-(define-integrable (load-description/initializations pd) (vector-ref pd 2))
-(define-integrable (load-description/finalizations pd) (vector-ref pd 3))
-
 (define (package-file? object)
   (and (vector? object)
        (fix:= (vector-length object) 4)
@@ -236,6 +211,15 @@ USA.
        (vector-of-type? (package-file/loads object)
                        load-description?)))
 
+(define-integrable (package-file/tag pf) (vector-ref pf 0))
+(define-integrable (package-file/version pf) (vector-ref pf 1))
+(define-integrable (package-file/descriptions pf) (vector-ref pf 2))
+(define-integrable (package-file/loads pf) (vector-ref pf 3))
+
+(define-integrable (make-package-description name ancestors internal-names
+                                            exports imports extension?)
+  (vector name ancestors internal-names exports imports extension?))
+
 (define (package-description? object)
   (and (vector? object)
        (fix:= (vector-length object) 6)
@@ -246,22 +230,16 @@ USA.
        (vector-of-type? (package-description/imports object) link-description?)
        (boolean? (package-description/extension? object))))
 
-(define (link-description? object)
-  (and (vector? object)
-       (cond ((fix:= (vector-length object) 2)
-             (and (symbol? (vector-ref object 0))
-                  (package-name? (vector-ref object 1))))
-            ((fix:= (vector-length object) 3)
-             (and (symbol? (vector-ref object 0))
-                  (package-name? (vector-ref object 1))
-                  (symbol? (vector-ref object 2))))
-            ((fix:= (vector-length object) 4)
-             (and (symbol? (vector-ref object 0))
-                  (package-name? (vector-ref object 1))
-                  (symbol? (vector-ref object 2))
-                  (or (eq? #f (vector-ref object 3))
-                      (eq? 'deprecated (vector-ref object 3)))))
-            (else #f))))
+(define-integrable (package-description/name pd) (vector-ref pd 0))
+(define-integrable (package-description/ancestors pd) (vector-ref pd 1))
+(define-integrable (package-description/internal-names pd) (vector-ref pd 2))
+(define-integrable (package-description/exports pd) (vector-ref pd 3))
+(define-integrable (package-description/imports pd) (vector-ref pd 4))
+(define-integrable (package-description/extension? pd) (vector-ref pd 5))
+
+(define-integrable (make-load-description name file-cases initializations
+                                         finalizations)
+  (vector name file-cases initializations finalizations))
 
 (define (load-description? object)
   (and (vector? object)
@@ -280,6 +258,34 @@ USA.
               (vector-of-type? file-case string?))))
        (vector? (load-description/initializations object))
        (vector? (load-description/finalizations object))))
+
+(define-integrable (load-description/name pd) (vector-ref pd 0))
+(define-integrable (load-description/file-cases pd) (vector-ref pd 1))
+(define-integrable (load-description/initializations pd) (vector-ref pd 2))
+(define-integrable (load-description/finalizations pd) (vector-ref pd 3))
+\f
+(define (link-description? object)
+  (and (vector? object)
+       (memv (vector-length object) '(2 3 4))
+       (symbol? (link-description/inner-name object))
+       (package-name? (link-description/package object))
+       (symbol? (link-description/outer-name object))
+       (memq (link-description/status object) '(#f deprecated))))
+
+(define-integrable (link-description/inner-name link)
+  (vector-ref link 0))
+
+(define-integrable (link-description/package link)
+  (vector-ref link 1))
+
+(define-integrable (link-description/outer-name link)
+  (if (fix:>= (vector-length link) 3)
+      (vector-ref link 2)
+      (vector-ref link 0)))
+
+(define-integrable (link-description/status link)
+  (and (fix:>= (vector-length link) 4)
+       (vector-ref link 3)))
 \f
 ;; CONSTRUCT-PACKAGES-FROM-FILE is called from the cold load before
 ;; the runtime system is loaded.  Thus it must only call procedures
@@ -343,25 +349,22 @@ USA.
        (do ((i 0 (fix:+ i 1)))
            ((fix:= i n))
          (let ((binding (vector-ref bindings i)))
-           (link-variables (find-package-environment (vector-ref binding 1))
-                           (if (fix:>= (vector-length binding) 3)
-                               (vector-ref binding 2)
-                               (vector-ref binding 0))
+           (link-variables (find-package-environment
+                            (link-description/package binding))
+                           (link-description/outer-name binding)
                            environment
-                           (vector-ref binding 0))))))
+                           (link-description/inner-name binding))))))
     (let ((bindings (package-description/imports description)))
       (let ((n (vector-length bindings)))
        (do ((i 0 (fix:+ i 1)))
            ((fix:= i n))
          (let ((binding (vector-ref bindings i)))
            (let ((source-environment
-                  (find-package-environment (vector-ref binding 1)))
-                 (source-name
-                  (if (fix:>= (vector-length binding) 3)
-                      (vector-ref binding 2)
-                      (vector-ref binding 0))))
+                  (find-package-environment
+                   (link-description/package binding)))
+                 (source-name (link-description/outer-name binding)))
              (guarantee-binding source-environment source-name)
-             (link-variables environment (vector-ref binding 0)
+             (link-variables environment (link-description/inner-name binding)
                              source-environment source-name))))))))
 \f
 (define (extend-package-environment environment . name-sources)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 16d53848e0d3b197040ad25df0ca05c6761dfdb0..211a8a788a96d2bc3a93c87c3bf0b219ae861a91 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -52,6 +52,13 @@ USA.
          package/reference
          package?
          all-packages)
+  (export (runtime library standard)
+         link-description/inner-name
+         link-description/outer-name
+         link-description/package
+         package-description/exports
+         package-description/name
+         package-file/descriptions)
   (export (runtime environment)
          package-name-tag)
   (initialization (initialize-package!)))