From e84c8b718ecf73ad00d0fbd47605007360df8510 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 22 Nov 2018 00:23:53 -0800 Subject: [PATCH] Arrange for runtime packages to be importable as libraries. --- src/runtime/library-standard.scm | 30 ++++++++- src/runtime/make.scm | 22 ++++++- src/runtime/packag.scm | 107 ++++++++++++++++--------------- src/runtime/runtime.pkg | 7 ++ 4 files changed, 111 insertions(+), 55 deletions(-) diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm index a8e3b5cbe..2156ba5a6 100644 --- 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)) + +;;;; 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 a0b9d9ce9..7a09f410e 100644 --- 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 1933dc7a7..308f688c3 100644 --- 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)) + +(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))) ;; 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)))))))) (define (extend-package-environment environment . name-sources) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 16d53848e..211a8a788 100644 --- 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!))) -- 2.25.1